| blob | 2d275a9bc8033814d517675dc9b1a42e37e1da5e |
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-2008, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
80 -- Performs validity checks for a binary operator
82 procedure Build_Boolean_Array_Proc_Call
86 -- If a boolean array assignment can be done in place, build call to
87 -- corresponding library procedure.
90 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
91 -- Expand_Allocator_Expression. Allocating class-wide interface objects
92 -- this routine displaces the pointer to the allocated object to reference
93 -- the component referencing the corresponding secondary dispatch table.
96 -- Subsidiary to Expand_N_Allocator, for the case when the expression
97 -- is a qualified expression or an aggregate.
100 -- This routine handles expansion of the comparison operators (N_Op_Lt,
101 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
102 -- code for these operators is similar, differing only in the details of
103 -- the actual comparison call that is made. Special processing (call a
104 -- run-time routine)
106 function Expand_Array_Equality
112 -- Expand an array equality into a call to a function implementing this
113 -- equality, and a call to it. Loc is the location for the generated nodes.
114 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
115 -- on which to attach bodies of local functions that are created in the
116 -- process. It is the responsibility of the caller to insert those bodies
117 -- at the right place. Nod provides the Sloc value for the generated code.
118 -- Normally the types used for the generated equality routine are taken
119 -- from Lhs and Rhs. However, in some situations of generated code, the
120 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
121 -- the type to be used for the formal parameters.
124 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
125 -- case of array type arguments.
127 function Expand_Composite_Equality
133 -- Local recursive function used to expand equality for nested composite
134 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
135 -- to attach bodies of local functions that are created in the process.
136 -- This is the responsibility of the caller to insert those bodies at the
137 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
138 -- are the left and right sides for the comparison, and Typ is the type of
139 -- the arrays to compare.
142 -- This routine handles expansion of concatenation operations, where N is
143 -- the N_Op_Concat node being expanded and Operands is the list of operands
144 -- (at least two are present). The caller has dealt with converting any
145 -- singleton operands into singleton aggregates.
148 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
149 -- and replace node Cnode with the result of the concatenation. If there
150 -- are two operands, they can be string or character. If there are more
151 -- than two operands, then are always of type string (i.e. the caller has
152 -- already converted character operands to strings in this case).
155 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
156 -- fixed. We do not have such a type at runtime, so the purpose of this
157 -- routine is to find the real type by looking up the tree. We also
158 -- determine if the operation must be rounded.
160 function Get_Allocator_Final_List
164 -- If the designated type is controlled, build final_list expression for
165 -- created object. If context is an access parameter, create a local access
166 -- type to have a usable finalization list.
169 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
170 -- discriminants if it has a constrained nominal type, unless the object
171 -- is a component of an enclosing Unchecked_Union object that is subject
172 -- to a per-object constraint and the enclosing object lacks inferable
173 -- discriminants.
174 --
175 -- An expression of an Unchecked_Union type has inferable discriminants
176 -- if it is either a name of an object with inferable discriminants or a
177 -- qualified expression whose subtype mark denotes a constrained subtype.
180 -- N is an expression whose type is an access. When the type of the
181 -- associated storage pool is derived from Checked_Pool, generate a
182 -- call to the 'Dereference' primitive operation.
184 function Make_Array_Comparison_Op
187 -- Comparisons between arrays are expanded in line. This function produces
188 -- the body of the implementation of (a > b), where a and b are one-
189 -- dimensional arrays of some discrete type. The original node is then
190 -- expanded into the appropriate call to this function. Nod provides the
191 -- Sloc value for the generated code.
193 function Make_Boolean_Array_Op
196 -- Boolean operations on boolean arrays are expanded in line. This function
197 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
198 -- b). It is used only the normal case and not the packed case. The type
199 -- involved, Typ, is the Boolean array type, and the logical operations in
200 -- the body are simple boolean operations. Note that Typ is always a
201 -- constrained type (the caller has ensured this by using
202 -- Convert_To_Actual_Subtype if necessary).
205 -- If N is the node for a comparison whose outcome can be determined at
206 -- compile time, then the node N can be rewritten with True or False. If
207 -- the outcome cannot be determined at compile time, the call has no
208 -- effect. If N is a type conversion, then this processing is applied to
209 -- its expression. If N is neither comparison nor a type conversion, the
210 -- call has no effect.
213 -- Construct the expression corresponding to the tagged membership test.
214 -- Deals with a second operand being (or not) a class-wide type.
216 function Safe_In_Place_Array_Op
220 -- In the context of an assignment, where the right-hand side is a boolean
221 -- operation on arrays, check whether operation can be performed in place.
225 -- Performs validity checks for a unary operator
227 -------------------------------
228 -- Binary_Op_Validity_Checks --
229 -------------------------------
232 begin
239 ------------------------------------
240 -- Build_Boolean_Array_Proc_Call --
241 ------------------------------------
243 procedure Build_Boolean_Array_Proc_Call
247 is
260 begin
264 -- Use negated version of the binary operators
276 Call_Node :=
281 Target,
294 else
297 Call_Node :=
301 Target,
312 else
313 -- We use the following equivalences:
315 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
316 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
317 -- (not X) xor (not Y) = X xor Y
318 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
327 else
331 else
342 else
347 Call_Node :=
351 Target,
366 exception
371 --------------------------------
372 -- Displace_Allocator_Pointer --
373 --------------------------------
382 begin
383 -- Do nothing in case of VM targets: the virtual machine will handle
384 -- interfaces directly.
399 then
400 -- If the type of the allocator expression is not an interface type
401 -- we can generate code to reference the record component containing
402 -- the pointer to the secondary dispatch table.
405 declare
408 begin
409 -- 1) Get access to the allocated object
417 -- 2) Add the conversion to displace the pointer to reference
418 -- the secondary dispatch table.
423 -- 3) The 'access to the secondary dispatch table will be used
424 -- as the value returned by the allocator.
434 -- If the type of the allocator expression is an interface type we
435 -- generate a run-time call to displace "this" to reference the
436 -- component containing the pointer to the secondary dispatch table
437 -- or else raise Constraint_Error if the actual object does not
438 -- implement the target interface. This case corresponds with the
439 -- following example:
441 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
442 -- begin
443 -- return new Iface_2'Class'(Obj);
444 -- end Op;
446 else
455 New_Occurrence_Of
457 (First_Elmt
459 Loc)))));
465 ---------------------------------
466 -- Expand_Allocator_Expression --
467 ---------------------------------
475 procedure Apply_Accessibility_Check
478 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
479 -- type, generate an accessibility check to verify that the level of the
480 -- type of the created object is not deeper than the level of the access
481 -- type. If the type of the qualified expression is class- wide, then
482 -- always generate the check (except in the case where it is known to be
483 -- unnecessary, see comment below). Otherwise, only generate the check
484 -- if the level of the qualified expression type is statically deeper
485 -- than the access type.
486 --
487 -- Although the static accessibility will generally have been performed
488 -- as a legality check, it won't have been done in cases where the
489 -- allocator appears in generic body, so a run-time check is needed in
490 -- general. One special case is when the access type is declared in the
491 -- same scope as the class-wide allocator, in which case the check can
492 -- never fail, so it need not be generated.
493 --
494 -- As an open issue, there seem to be cases where the static level
495 -- associated with the class-wide object's underlying type is not
496 -- sufficient to perform the proper accessibility check, such as for
497 -- allocators in nested subprograms or accept statements initialized by
498 -- class-wide formals when the actual originates outside at a deeper
499 -- static level. The nested subprogram case might require passing
500 -- accessibility levels along with class-wide parameters, and the task
501 -- case seems to be an actual gap in the language rules that needs to
502 -- be fixed by the ARG. ???
504 -------------------------------
505 -- Apply_Accessibility_Check --
506 -------------------------------
508 procedure Apply_Accessibility_Check
511 is
514 begin
515 -- Note: we skip the accessibility check for the VM case, since
516 -- there does not seem to be any practical way of implementing it.
522 and then
524 or else
527 then
528 -- If the allocator was built in place Ref is already a reference
529 -- to the access object initialized to the result of the allocator
530 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
531 -- it is the entity associated with the object containing the
532 -- address of the allocated object.
536 else
542 Condition =>
544 Left_Opnd =>
549 Right_Opnd =>
556 -- Local variables
565 -- Type used as source for tag assignment
568 -- Target reference for tag assignment
575 -- Start of processing for Expand_Allocator_Expression
577 begin
580 -- Ada 2005 (AI-318-02): If the initialization expression is a call
581 -- to a build-in-place function, then access to the allocated object
582 -- must be passed to the function. Currently we limit such functions
583 -- to those with constrained limited result subtypes, but eventually
584 -- we plan to expand the allowed forms of functions that are treated
585 -- as build-in-place.
589 then
595 -- Actions inserted before:
596 -- Temp : constant ptr_T := new T'(Expression);
597 -- <no CW> Temp._tag := T'tag;
598 -- <CTRL> Adjust (Finalizable (Temp.all));
599 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
601 -- We analyze by hand the new internal allocator to avoid
602 -- any recursion and inappropriate call to Initialize
604 -- We don't want to remove side effects when the expression must be
605 -- built in place. In the case of a build-in-place function call,
606 -- that could lead to a duplication of the call, which was already
607 -- substituted for the allocator.
613 Temp :=
616 -- For a class wide allocation generate the following code:
618 -- type Equiv_Record is record ... end record;
619 -- implicit subtype CW is <Class_Wide_Subytpe>;
620 -- temp : PtrT := new CW'(CW!(expr));
625 -- Ada 2005 (AI-251): If the expression is a class-wide interface
626 -- object we generate code to move up "this" to reference the
627 -- base of the object before allocating the new object.
629 -- Note that Exp'Address is recursively expanded into a call
630 -- to Base_Address (Exp.Tag)
635 then
636 Set_Expression
645 else
646 Set_Expression
654 -- Keep separate the management of allocators returning interfaces
658 Tmp_Node :=
662 Expression =>
666 Set_Comes_From_Source
674 then
675 -- Create local finalization list for access parameter
681 else
692 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
693 -- interface type. In this case we use the type of the qualified
694 -- expression to allocate the object.
696 else
697 declare
703 begin
704 New_Decl :=
707 Type_Definition =>
712 Subtype_Indication =>
717 -- Inherit the final chain to ensure that the expansion of the
718 -- aggregate is correct in case of controlled types
725 -- Declare the object using the previous type declaration
728 Tmp_Node :=
732 Expression =>
736 Set_Comes_From_Source
744 then
745 -- Create local finalization list for access parameter
747 Flist :=
752 else
763 -- Generate an additional object containing the address of the
764 -- returned object. The type of this second object declaration
765 -- is the correct type required for the common processing that
766 -- is still performed by this subprogram. The displacement of
767 -- this pointer to reference the component associated with the
768 -- interface type will be done at the end of common processing.
770 New_Decl :=
787 -- Generate the tag assignment
789 -- Suppress the tag assignment when VM_Target because VM tags are
790 -- represented implicitly in objects.
795 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
796 -- interface objects because in this case the tag does not change.
809 then
811 TagR :=
818 Tag_Assign :=
820 Name =>
823 Selector_Name =>
826 Expression =>
828 New_Reference_To
830 Loc)));
832 -- The previous assignment has to be done in any case
840 then
841 declare
846 begin
847 -- If it is an allocation on the secondary stack (i.e. a value
848 -- returned from a function), the object is attached on the
849 -- caller side as soon as the call is completed (see
850 -- Expand_Ctrl_Function_Call)
853 declare
857 begin
868 -- Normal case, not a secondary stack allocation
870 else
873 then
874 -- Create local finalization list for access parameter
876 Flist :=
878 else
885 -- Generate an Adjust call if the object will be moved. In Ada
886 -- 2005, the object may be inherently limited, in which case
887 -- there is no Adjust procedure, and the object is built in
888 -- place. In Ada 95, the object can be limited but not
889 -- inherently limited if this allocator came from a return
890 -- statement (we're allocating the result on the secondary
891 -- stack). In that case, the object will be moved, so we _do_
892 -- want to Adjust.
894 if not Aggr_In_Place
896 then
898 Make_Adjust_Call (
899 Ref =>
901 -- An unchecked conversion is needed in the classwide
902 -- case because the designated type can be an ancestor of
903 -- the subtype mark of the allocator.
920 -- Ada 2005 (AI-251): Displace the pointer to reference the record
921 -- component containing the secondary dispatch table of the interface
922 -- type.
929 Temp :=
931 Tmp_Node :=
938 Set_Comes_From_Source
950 then
951 -- Apply constraint to designated subtype indication
959 -- Propagate constraint_error to enclosing allocator
963 else
964 -- First check against the type of the qualified expression
965 --
966 -- NOTE: The commented call should be correct, but for some reason
967 -- causes the compiler to bomb (sigsegv) on ACVC test c34007g, so for
968 -- now we just perform the old (incorrect) test against the
969 -- designated subtype with no sliding in the else part of the if
970 -- statement below. ???
971 --
972 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
974 -- A check is also needed in cases where the designated subtype is
975 -- constrained and differs from the subtype given in the qualified
976 -- expression. Note that the check on the qualified expression does
977 -- not allow sliding, but this check does (a relaxation from Ada 83).
980 and then not Subtypes_Statically_Match
982 then
983 Apply_Constraint_Check
986 -- The nonsliding check should really be performed (unconditionally)
987 -- against the subtype of the qualified expression, but that causes a
988 -- problem with c34007g (see above), so for now we retain this.
990 else
991 Apply_Constraint_Check
995 -- For an access to unconstrained packed array, GIGI needs to see an
996 -- expression with a constrained subtype in order to compute the
997 -- proper size for the allocator.
1002 then
1003 declare
1008 begin
1012 Subtype_Indication =>
1019 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1020 -- to a build-in-place function, then access to the allocated object
1021 -- must be passed to the function. Currently we limit such functions
1022 -- to those with constrained limited result subtypes, but eventually
1023 -- we plan to expand the allowed forms of functions that are treated
1024 -- as build-in-place.
1028 then
1033 exception
1038 -----------------------------
1039 -- Expand_Array_Comparison --
1040 -----------------------------
1042 -- Expansion is only required in the case of array types. For the unpacked
1043 -- case, an appropriate runtime routine is called. For packed cases, and
1044 -- also in some other cases where a runtime routine cannot be called, the
1045 -- form of the expansion is:
1047 -- [body for greater_nn; boolean_expression]
1049 -- The body is built by Make_Array_Comparison_Op, and the form of the
1050 -- Boolean expression depends on the operator involved.
1066 -- True for byte addressable target
1069 -- Returns True if the length of the given operand is known to be less
1070 -- than 4. Returns False if this length is known to be four or greater
1071 -- or is not known at compile time.
1073 ------------------------
1074 -- Length_Less_Than_4 --
1075 ------------------------
1080 begin
1084 else
1085 declare
1092 begin
1095 else
1101 else
1110 -- Start of processing for Expand_Array_Comparison
1112 begin
1113 -- Deal first with unpacked case, where we can call a runtime routine
1114 -- except that we avoid this for targets for which are not addressable
1115 -- by bytes, and for the JVM/CIL, since they do not support direct
1116 -- addressing of array components.
1119 and then Byte_Addressable
1121 then
1122 -- The call we generate is:
1124 -- Compare_Array_xn[_Unaligned]
1125 -- (left'address, right'address, left'length, right'length) <op> 0
1127 -- x = U for unsigned, S for signed
1128 -- n = 8,16,32,64 for component size
1129 -- Add _Unaligned if length < 4 and component size is 8.
1130 -- <op> is the standard comparison operator
1134 or else
1136 then
1139 else
1143 else
1146 else
1154 else
1161 else
1168 else
1206 -- Cases where we cannot make runtime call
1208 -- For (a <= b) we convert to not (a > b)
1213 Right_Opnd =>
1220 -- For < the Boolean expression is
1221 -- greater__nn (op2, op1)
1226 -- Switch operands
1231 -- For (a >= b) we convert to not (a < b)
1236 Right_Opnd =>
1243 -- For > the Boolean expression is
1244 -- greater__nn (op1, op2)
1246 else
1252 Expr :=
1261 exception
1266 ---------------------------
1267 -- Expand_Array_Equality --
1268 ---------------------------
1270 -- Expand an equality function for multi-dimensional arrays. Here is an
1271 -- example of such a function for Nb_Dimension = 2
1273 -- function Enn (A : atyp; B : btyp) return boolean is
1274 -- begin
1275 -- if (A'length (1) = 0 or else A'length (2) = 0)
1276 -- and then
1277 -- (B'length (1) = 0 or else B'length (2) = 0)
1278 -- then
1279 -- return True; -- RM 4.5.2(22)
1280 -- end if;
1282 -- if A'length (1) /= B'length (1)
1283 -- or else
1284 -- A'length (2) /= B'length (2)
1285 -- then
1286 -- return False; -- RM 4.5.2(23)
1287 -- end if;
1289 -- declare
1290 -- A1 : Index_T1 := A'first (1);
1291 -- B1 : Index_T1 := B'first (1);
1292 -- begin
1293 -- loop
1294 -- declare
1295 -- A2 : Index_T2 := A'first (2);
1296 -- B2 : Index_T2 := B'first (2);
1297 -- begin
1298 -- loop
1299 -- if A (A1, A2) /= B (B1, B2) then
1300 -- return False;
1301 -- end if;
1303 -- exit when A2 = A'last (2);
1304 -- A2 := Index_T2'succ (A2);
1305 -- B2 := Index_T2'succ (B2);
1306 -- end loop;
1307 -- end;
1309 -- exit when A1 = A'last (1);
1310 -- A1 := Index_T1'succ (A1);
1311 -- B1 := Index_T1'succ (B1);
1312 -- end loop;
1313 -- end;
1315 -- return true;
1316 -- end Enn;
1318 -- Note on the formal types used (atyp and btyp). If either of the arrays
1319 -- is of a private type, we use the underlying type, and do an unchecked
1320 -- conversion of the actual. If either of the arrays has a bound depending
1321 -- on a discriminant, then we use the base type since otherwise we have an
1322 -- escaped discriminant in the function.
1324 -- If both arrays are constrained and have the same bounds, we can generate
1325 -- a loop with an explicit iteration scheme using a 'Range attribute over
1326 -- the first array.
1328 function Expand_Array_Equality
1334 is
1350 -- The parameter types to be used for the formals
1352 function Arr_Attr
1356 -- This builds the attribute reference Arr'Nam (Expr)
1359 -- Create one statement to compare corresponding components, designated
1360 -- by a full set of indices.
1363 -- Given one of the arguments, computes the appropriate type to be used
1364 -- for that argument in the corresponding function formal
1366 function Handle_One_Dimension
1369 -- This procedure returns the following code
1370 --
1371 -- declare
1372 -- Bn : Index_T := B'First (N);
1373 -- begin
1374 -- loop
1375 -- xxx
1376 -- exit when An = A'Last (N);
1377 -- An := Index_T'Succ (An)
1378 -- Bn := Index_T'Succ (Bn)
1379 -- end loop;
1380 -- end;
1381 --
1382 -- If both indices are constrained and identical, the procedure
1383 -- returns a simpler loop:
1384 --
1385 -- for An in A'Range (N) loop
1386 -- xxx
1387 -- end loop
1388 --
1389 -- N is the dimension for which we are generating a loop. Index is the
1390 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1391 -- xxx statement is either the loop or declare for the next dimension
1392 -- or if this is the last dimension the comparison of corresponding
1393 -- components of the arrays.
1394 --
1395 -- The actual way the code works is to return the comparison of
1396 -- corresponding components for the N+1 call. That's neater!
1399 -- This function constructs the test for both arrays being empty
1400 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1401 -- and then
1402 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1405 -- This function constructs the test for arrays having different lengths
1406 -- in at least one index position, in which case the resulting code is:
1408 -- A'length (1) /= B'length (1)
1409 -- or else
1410 -- A'length (2) /= B'length (2)
1411 -- or else
1412 -- ...
1414 --------------
1415 -- Arr_Attr --
1416 --------------
1418 function Arr_Attr
1422 is
1423 begin
1424 return
1431 ------------------------
1432 -- Component_Equality --
1433 ------------------------
1439 begin
1440 -- if a(i1...) /= b(j1...) then return false; end if;
1442 L :=
1447 R :=
1452 Test := Expand_Composite_Equality
1455 -- If some (sub)component is an unchecked_union, the whole operation
1456 -- will raise program error.
1460 -- This node is going to be inserted at a location where a
1461 -- statement is expected: clear its Etype so analysis will set
1462 -- it to the expected Standard_Void_Type.
1467 else
1468 return
1477 ------------------
1478 -- Get_Arg_Type --
1479 ------------------
1485 begin
1491 else
1497 or else
1499 then
1511 --------------------------
1512 -- Handle_One_Dimension --
1513 ---------------------------
1515 function Handle_One_Dimension
1518 is
1520 Ltyp /= Rtyp
1522 -- If the index types are identical, and we are working with
1523 -- constrained types, then we can use the same index for both
1524 -- of the arrays.
1534 begin
1539 -- Case where we generate a loop
1544 Bn :=
1547 else
1559 -- Generate guard for loop, followed by increments of indices
1563 Condition =>
1571 Expression =>
1580 Expression =>
1587 -- If separate indexes, we need a declare block for An and Bn, and a
1588 -- loop without an iteration scheme.
1591 Loop_Stm :=
1594 return
1607 Handled_Statement_Sequence =>
1611 -- If no separate indexes, return loop statement with explicit
1612 -- iteration scheme on its own
1614 else
1615 Loop_Stm :=
1618 Iteration_Scheme =>
1620 Loop_Parameter_Specification =>
1623 Discrete_Subtype_Definition =>
1629 -----------------------
1630 -- Test_Empty_Arrays --
1631 -----------------------
1640 begin
1644 Atest :=
1649 Btest :=
1658 else
1659 Alist :=
1664 Blist :=
1671 return
1677 -----------------------------
1678 -- Test_Lengths_Correspond --
1679 -----------------------------
1685 begin
1688 Rtest :=
1695 else
1696 Result :=
1706 -- Start of processing for Expand_Array_Equality
1708 begin
1712 -- For now, if the argument types are not the same, go to the base type,
1713 -- since the code assumes that the formals have the same type. This is
1714 -- fixable in future ???
1722 -- Build list of formals for function
1735 -- Build statement sequence for function
1737 Func_Body :=
1739 Specification =>
1747 Handled_Statement_Sequence =>
1755 Expression =>
1762 Expression =>
1773 -- If the array type is distinct from the type of the arguments, it
1774 -- is the full view of a private type. Apply an unchecked conversion
1775 -- to insure that analysis of the call succeeds.
1777 declare
1780 begin
1786 then
1792 then
1801 return
1807 -----------------------------
1808 -- Expand_Boolean_Operator --
1809 -----------------------------
1811 -- Note that we first get the actual subtypes of the operands, since we
1812 -- always want to deal with types that have bounds.
1817 begin
1818 -- Special case of bit packed array where both operands are known to be
1819 -- properly aligned. In this case we use an efficient run time routine
1820 -- to carry out the operation (see System.Bit_Ops).
1825 then
1830 -- For the normal non-packed case, the general expansion is to build
1831 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1832 -- and then inserting it into the tree. The original operator node is
1833 -- then rewritten as a call to this function. We also use this in the
1834 -- packed case if either operand is a possibly unaligned object.
1836 declare
1843 begin
1856 then
1861 and then
1863 then
1865 else
1871 -- Now rewrite the expression with a call
1876 Parameter_Associations =>
1877 New_List (
1878 L,
1879 Make_Type_Conversion
1887 -------------------------------
1888 -- Expand_Composite_Equality --
1889 -------------------------------
1891 -- This function is only called for comparing internal fields of composite
1892 -- types when these fields are themselves composites. This is a special
1893 -- case because it is not possible to respect normal Ada visibility rules.
1895 function Expand_Composite_Equality
1901 is
1907 begin
1910 else
1914 -- Defense against malformed private types with no completion the error
1915 -- will be diagnosed later by check_completion
1925 -- If the operand is an elementary type other than a floating-point
1926 -- type, then we can simply use the built-in block bitwise equality,
1927 -- since the predefined equality operators always apply and bitwise
1928 -- equality is fine for all these cases.
1932 then
1935 -- For composite component types, and floating-point types, use the
1936 -- expansion. This deals with tagged component types (where we use
1937 -- the applicable equality routine) and floating-point, (where we
1938 -- need to worry about negative zeroes), and also the case of any
1939 -- composite type recursively containing such fields.
1941 else
1947 -- Call the primitive operation "=" of this type
1953 -- If this is derived from an untagged private type completed with a
1954 -- tagged type, it does not have a full view, so we use the primitive
1955 -- operations of the private type. This check should no longer be
1956 -- necessary when these types receive their full views ???
1963 then
1965 else
1969 loop
1981 return
1984 Parameter_Associations =>
1985 New_List
1995 -- Inherited equality from parent type. Convert the actuals to
1996 -- match signature of operation.
1998 declare
2001 begin
2002 return
2005 Parameter_Associations =>
2010 else
2011 -- Comparison between Unchecked_Union components
2014 declare
2020 begin
2021 -- Lhs subtype
2027 -- Rhs subtype
2033 -- Lhs of the composite equality
2037 -- Since the enclosing record type can never be an
2038 -- Unchecked_Union (this code is executed for records
2039 -- that do not have variants), we may reference its
2040 -- discriminant(s).
2045 then
2046 Lhs_Discr_Val :=
2049 Selector_Name =>
2050 New_Copy (
2051 Get_Discriminant_Value (
2053 Lhs_Type,
2056 else
2058 Get_Discriminant_Value (
2060 Lhs_Type,
2064 else
2065 -- It is not possible to infer the discriminant since
2066 -- the subtype is not constrained.
2068 return
2073 -- Rhs of the composite equality
2079 then
2080 Rhs_Discr_Val :=
2083 Selector_Name =>
2084 New_Copy (
2085 Get_Discriminant_Value (
2087 Rhs_Type,
2090 else
2092 Get_Discriminant_Value (
2094 Rhs_Type,
2098 else
2099 return
2104 -- Call the TSS equality function with the inferred
2105 -- discriminant values.
2107 return
2111 Lhs,
2112 Rhs,
2113 Lhs_Discr_Val,
2114 Rhs_Discr_Val));
2118 -- Shouldn't this be an else, we can't fall through the above
2119 -- IF, right???
2121 return
2127 else
2131 else
2132 -- It can be a simple record or the full view of a scalar private
2138 ------------------------------
2139 -- Expand_Concatenate_Other --
2140 ------------------------------
2142 -- Let n be the number of array operands to be concatenated, Base_Typ their
2143 -- base type, Ind_Typ their index type, and Arr_Typ the original array type
2144 -- to which the concatenation operator applies, then the following
2145 -- subprogram is constructed:
2147 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
2148 -- L : Ind_Typ;
2149 -- begin
2150 -- if S1'Length /= 0 then
2151 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
2152 -- XXX = Arr_Typ'First otherwise
2153 -- elsif S2'Length /= 0 then
2154 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
2155 -- YYY = Arr_Typ'First otherwise
2156 -- ...
2157 -- elsif Sn-1'Length /= 0 then
2158 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
2159 -- ZZZ = Arr_Typ'First otherwise
2160 -- else
2161 -- return Sn;
2162 -- end if;
2164 -- declare
2165 -- P : Ind_Typ;
2166 -- H : Ind_Typ :=
2167 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
2168 -- + Ind_Typ'Pos (L));
2169 -- R : Base_Typ (L .. H);
2170 -- begin
2171 -- if S1'Length /= 0 then
2172 -- P := S1'First;
2173 -- loop
2174 -- R (L) := S1 (P);
2175 -- L := Ind_Typ'Succ (L);
2176 -- exit when P = S1'Last;
2177 -- P := Ind_Typ'Succ (P);
2178 -- end loop;
2179 -- end if;
2180 --
2181 -- if S2'Length /= 0 then
2182 -- L := Ind_Typ'Succ (L);
2183 -- loop
2184 -- R (L) := S2 (P);
2185 -- L := Ind_Typ'Succ (L);
2186 -- exit when P = S2'Last;
2187 -- P := Ind_Typ'Succ (P);
2188 -- end loop;
2189 -- end if;
2191 -- ...
2193 -- if Sn'Length /= 0 then
2194 -- P := Sn'First;
2195 -- loop
2196 -- R (L) := Sn (P);
2197 -- L := Ind_Typ'Succ (L);
2198 -- exit when P = Sn'Last;
2199 -- P := Ind_Typ'Succ (P);
2200 -- end loop;
2201 -- end if;
2203 -- return R;
2204 -- end;
2205 -- end Cnn;]
2244 -- Builds the sequence of statement:
2245 -- P := Si'First;
2246 -- loop
2247 -- R (L) := Si (P);
2248 -- L := Ind_Typ'Succ (L);
2249 -- exit when P = Si'Last;
2250 -- P := Ind_Typ'Succ (P);
2251 -- end loop;
2252 --
2253 -- where i is the input parameter I given.
2254 -- If the flag Last is true, the exit statement is emitted before
2255 -- incrementing the lower bound, to prevent the creation out of
2256 -- bound values.
2259 -- Builds the statement:
2260 -- L := Arr_Typ'First; If Arr_Typ is constrained
2261 -- L := Si'First; otherwise (where I is the input param given)
2264 -- Builds reference to identifier H
2267 -- Builds expression Ind_Typ'Val (E);
2270 -- Builds reference to identifier L
2273 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
2274 -- expression to avoid universal_integer computations whenever possible,
2275 -- in the expression for the upper bound H.
2278 -- Builds expression Ind_Typ'Succ (L)
2281 -- Builds integer literal one
2284 -- Builds reference to identifier P
2287 -- Builds expression Ind_Typ'Succ (P)
2290 -- Builds reference to identifier R
2293 -- Builds reference to identifier Si, where I is the value given
2296 -- Builds expression Si'First, where I is the value given
2299 -- Builds expression Si'Last, where I is the value given
2302 -- Builds expression Si'Length, where I is the value given
2305 -- Builds expression Si'Length /= 0, where I is the value given
2307 -------------------
2308 -- Copy_Into_R_S --
2309 -------------------
2320 begin
2321 -- First construct the initializations
2328 -- Then build the loop
2350 Loop_Stmt :=
2353 else
2354 Loop_Stmt :=
2364 -------
2365 -- H --
2366 -------
2369 begin
2373 -------------
2374 -- Ind_Val --
2375 -------------
2378 begin
2379 return
2386 ------------
2387 -- Init_L --
2388 ------------
2393 begin
2399 else
2406 -------
2407 -- L --
2408 -------
2411 begin
2415 -----------
2416 -- L_Pos --
2417 -----------
2422 begin
2423 -- If the index type is an enumeration type, the computation can be
2424 -- done in standard integer. Otherwise, choose a large enough integer
2425 -- type to accomodate the index type computation.
2432 then
2434 else
2438 return
2441 Expression =>
2448 ------------
2449 -- L_Succ --
2450 ------------
2453 begin
2454 return
2461 ---------
2462 -- One --
2463 ---------
2466 begin
2470 -------
2471 -- P --
2472 -------
2475 begin
2479 ------------
2480 -- P_Succ --
2481 ------------
2484 begin
2485 return
2492 -------
2493 -- R --
2494 -------
2497 begin
2501 -------
2502 -- S --
2503 -------
2506 begin
2510 -------------
2511 -- S_First --
2512 -------------
2515 begin
2521 ------------
2522 -- S_Last --
2523 ------------
2526 begin
2532 --------------
2533 -- S_Length --
2534 --------------
2537 begin
2543 -------------------
2544 -- S_Length_Test --
2545 -------------------
2548 begin
2549 return
2555 -- Start of processing for Expand_Concatenate_Other
2557 begin
2558 -- Construct the parameter specs and the overall function spec
2562 Append_To
2565 Defining_Identifier =>
2571 Func_Spec :=
2577 -- Construct L's object declaration
2579 L_Decl :=
2586 -- Construct the if-then-elsif statements
2595 If_Stmt :=
2603 -- Construct the declaration for H
2605 P_Decl :=
2615 -- If the index type is small modular type, we need to perform an
2616 -- additional check that the upper bound fits in the index type.
2617 -- Otherwise the computation of the upper bound can wrap around
2618 -- and yield meaningless results. The constraint check has to be
2619 -- explicit in the code, because the generated function is compiled
2620 -- with checks disabled, for efficiency.
2624 then
2625 I_Decl :=
2629 Expression =>
2634 H_Init :=
2635 Ind_Val (
2640 -- For other index types, computation is safe.
2642 else
2646 H_Decl :=
2652 -- Construct the declaration for R
2655 R_Constr :=
2659 R_Decl :=
2662 Object_Definition =>
2667 -- Construct the declarations for the declare block
2671 -- Add constraint check for the modular index case.
2675 then
2680 Condition =>
2682 Left_Opnd =>
2684 Right_Opnd =>
2693 -- Construct list of statements for the declare block
2703 Append_To
2706 -- Construct the declare block
2710 Handled_Statement_Sequence =>
2713 -- Construct the list of function statements
2717 -- Construct the function body
2719 Func_Body :=
2723 Handled_Statement_Sequence =>
2726 -- Insert the newly generated function in the code. This is analyzed
2727 -- with all checks off, since we have completed all the checks.
2729 -- Note that this does *not* fix the array concatenation bug when the
2730 -- low bound is Integer'first sibce that bug comes from the pointer
2731 -- dereferencing an unconstrained array. And there we need a constraint
2732 -- check to make sure the length of the concatenated array is ok. ???
2736 -- Construct list of arguments for the function call
2745 -- Insert the function call
2747 Rewrite
2755 -------------------------------
2756 -- Expand_Concatenate_String --
2757 -------------------------------
2767 -- RE_Id value for function to be called
2769 begin
2770 -- In all cases, we build a call to a routine giving the list of
2771 -- arguments as the parameter list to the routine.
2779 else
2788 else
2793 -- If we have anything other than Standard_Character or
2794 -- Standard_String, then we must have had a serious error
2795 -- earlier, so we just abandon the attempt at expansion.
2797 else
2816 -- Now generate the appropriate call
2825 exception
2830 ------------------------
2831 -- Expand_N_Allocator --
2832 ------------------------
2844 -- Generate finalization calls for all nested coextensions of N. This
2845 -- routine may allocate list controllers if necessary.
2848 -- Static coextensions have the same lifetime as the entity they
2849 -- constrain. Such occurrences can be rewritten as aliased objects
2850 -- and their unrestricted access used instead of the coextension.
2852 ---------------------------------------
2853 -- Complete_Coextension_Finalization --
2854 ---------------------------------------
2863 -- Determine whether node N is part of a return statement
2866 -- Determine whether node N is a subtype indicator allocator which
2867 -- acts a coextension. Such coextensions need initialization.
2869 -------------------------------
2870 -- Inside_A_Return_Statement --
2871 -------------------------------
2876 begin
2879 if Nkind_In
2881 then
2884 -- Stop the traversal when we reach a subprogram body
2896 -------------------------------
2897 -- Needs_Initialization_Call --
2898 -------------------------------
2903 begin
2907 N_Object_Declaration
2908 then
2911 return
2915 N_Qualified_Expression;
2921 -- Start of processing for Complete_Coextension_Finalization
2923 begin
2924 -- When a coextension root is inside a return statement, we need to
2925 -- use the finalization chain of the function's scope. This does not
2926 -- apply for controlled named access types because in those cases we
2927 -- can use the finalization chain of the type itself.
2930 and then
2932 or else
2935 then
2936 declare
2941 begin
2946 -- Retrieve the declaration of the body
2956 -- Push the scope of the function body since we are inserting
2957 -- the list before the body, but we are currently in the body
2958 -- itself. Override the finalization list of PtrT since the
2959 -- finalization context is now different.
2963 Pop_Scope;
2966 -- The root allocator may not be controlled, but it still needs a
2967 -- finalization list for all nested coextensions.
2973 Flist :=
2975 Prefix =>
2977 Selector_Name =>
2984 -- Generate:
2985 -- typ! (coext.all)
2988 Ref :=
2991 Expression =>
2994 else
2998 -- No initialization call if not allowed
3004 -- Generate:
3005 -- initialize (Ref)
3006 -- attach_to_final_list (Ref, Flist, 2)
3010 Make_Init_Call (
3016 -- Generate:
3017 -- attach_to_final_list (Ref, Flist, 2)
3019 else
3021 Make_Attach_Call (
3032 -------------------------
3033 -- Rewrite_Coextension --
3034 -------------------------
3041 -- Generate:
3042 -- Cnn : aliased Etyp;
3048 Object_Definition =>
3052 begin
3057 -- Find the proper insertion node for the declaration
3078 -- Start of processing for Expand_N_Allocator
3080 begin
3081 -- RM E.2.3(22). We enforce that the expected type of an allocator
3082 -- shall not be a remote access-to-class-wide-limited-private type
3084 -- Why is this being done at expansion time, seems clearly wrong ???
3088 -- Set the Storage Pool
3101 else
3107 -- Under certain circumstances we can replace an allocator by an access
3108 -- to statically allocated storage. The conditions, as noted in AARM
3109 -- 3.10 (10c) are as follows:
3111 -- Size and initial value is known at compile time
3112 -- Access type is access-to-constant
3114 -- The allocator is not part of a constraint on a record component,
3115 -- because in that case the inserted actions are delayed until the
3116 -- record declaration is fully analyzed, which is too late for the
3117 -- analysis of the rewritten allocator.
3125 then
3126 -- Here we can do the optimization. For the allocator
3128 -- new x'(y)
3130 -- We insert an object declaration
3132 -- Tnn : aliased x := y;
3134 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3135 -- marked as requiring static allocation.
3137 Temp :=
3142 -- If context is constrained, use constrained subtype directly,
3143 -- so that the constant is not labelled as having a nominally
3144 -- unconstrained subtype.
3165 -- We set the variable as statically allocated, since we don't want
3166 -- it going on the stack of the current procedure!
3172 -- Same if the allocator is an access discriminant for a local object:
3173 -- instead of an allocator we create a local value and constrain the
3174 -- the enclosing object with the corresponding access attribute.
3181 -- The current allocator creates an object which may contain nested
3182 -- coextensions. Use the current allocator's finalization list to
3183 -- generate finalization call for all nested coextensions.
3186 Complete_Coextension_Finalization;
3189 -- Handle case of qualified expression (other than optimization above)
3196 -- If the allocator is for a type which requires initialization, and
3197 -- there is no initial value (i.e. operand is a subtype indication
3198 -- rather than a qualified expression), then we must generate a call to
3199 -- the initialization routine using an expressions action node:
3201 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3203 -- Here ptr_T is the pointer type for the allocator, and T is the
3204 -- subtype of the allocator. A special case arises if the designated
3205 -- type of the access type is a task or contains tasks. In this case
3206 -- the call to Init (Temp.all ...) is replaced by code that ensures
3207 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3208 -- for details). In addition, if the type T is a task T, then the
3209 -- first argument to Init must be converted to the task record type.
3211 declare
3224 begin
3228 -- Case of no initialization procedure present
3232 -- Case of simple initialization required
3246 -- No initialization required
3248 else
3252 -- Case of initialization procedure present, must be called
3254 else
3262 -- Construct argument list for the initialization routine call
3264 Arg1 :=
3270 -- The initialization procedure expects a specific type. if the
3271 -- context is access to class wide, indicate that the object
3272 -- being allocated has the right specific type.
3278 -- If designated type is a concurrent type or if it is private
3279 -- type whose definition is a concurrent type, the first
3280 -- argument in the Init routine has to be unchecked conversion
3281 -- to the corresponding record type. If the designated type is
3282 -- a derived type, we also convert the argument to its root
3283 -- type.
3286 Arg1 :=
3292 then
3293 Arg1 :=
3294 Unchecked_Convert_To
3298 declare
3300 begin
3308 -- For the task case, pass the Master_Id of the access type as
3309 -- the value of the _Master parameter, and _Chain as the value
3310 -- of the _Chain parameter (_Chain will be defined as part of
3311 -- the generated code for the allocator).
3313 -- In Ada 2005, the context may be a function that returns an
3314 -- anonymous access type. In that case the Master_Id has been
3315 -- created when expanding the function declaration.
3320 -- If we have a non-library level task with restriction
3321 -- No_Task_Hierarchy set, then no point in expanding.
3325 then
3329 -- The designated type was an incomplete type, and the
3330 -- access type did not get expanded. Salvage it now.
3333 Expand_N_Full_Type_Declaration
3337 -- If the context of the allocator is a declaration or an
3338 -- assignment, we can generate a meaningful image for it,
3339 -- even though subsequent assignments might remove the
3340 -- connection between task and entity. We build this image
3341 -- when the left-hand side is a simple variable, a simple
3342 -- indexed assignment or a simple selected component.
3345 declare
3348 begin
3350 Decls :=
3351 Build_Task_Image_Decls
3353 New_Occurrence_Of
3356 elsif Nkind_In
3359 then
3360 Decls :=
3361 Build_Task_Image_Decls
3363 else
3369 Decls :=
3370 Build_Task_Image_Decls
3373 else
3378 New_Reference_To
3386 -- Has_Task is false, Decls not used
3388 else
3392 -- Add discriminants if discriminated type
3394 declare
3398 begin
3406 then
3413 -- If the allocated object will be constrained by the
3414 -- default values for discriminants, then build a subtype
3415 -- with those defaults, and change the allocated subtype
3416 -- to that. Note that this happens in fewer cases in Ada
3417 -- 2005 (AI-363).
3423 or else
3425 then
3435 -- AI-416: when the discriminant constraint is an
3436 -- anonymous access type make sure an accessibility
3437 -- check is inserted if necessary (3.10.2(22.q/2))
3440 and then
3442 then
3451 -- We set the allocator as analyzed so that when we analyze the
3452 -- expression actions node, we do not get an unwanted recursive
3453 -- expansion of the allocator expression.
3458 -- Here is the transformation:
3459 -- input: new T
3460 -- output: Temp : constant ptr_T := new T;
3461 -- Init (Temp.all, ...);
3462 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
3463 -- <CTRL> Initialize (Finalizable (Temp.all));
3465 -- Here ptr_T is the pointer type for the allocator, and is the
3466 -- subtype of the allocator.
3468 Temp_Decl :=
3478 -- If the designated type is a task type or contains tasks,
3479 -- create block to activate created tasks, and insert
3480 -- declaration for Task_Image variable ahead of call.
3483 declare
3486 begin
3493 else
3502 -- Postpone the generation of a finalization call for the
3503 -- current allocator if it acts as a coextension.
3512 else
3513 Flist :=
3516 -- Anonymous access types created for access parameters
3517 -- are attached to an explicitly constructed controller,
3518 -- which ensures that they can be finalized properly,
3519 -- even if their deallocation might not happen. The list
3520 -- associated with the controller is doubly-linked. For
3521 -- other anonymous access types, the object may end up
3522 -- on the global final list which is singly-linked.
3523 -- Work needed for access discriminants in Ada 2005 ???
3526 and then
3528 not in N_Subprogram_Specification
3529 then
3531 else
3536 Make_Init_Call (
3551 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
3552 -- object that has been rewritten as a reference, we displace "this"
3553 -- to reference properly its secondary dispatch table.
3557 then
3561 exception
3566 -----------------------
3567 -- Expand_N_And_Then --
3568 -----------------------
3570 -- Expand into conditional expression if Actions present, and also deal
3571 -- with optimizing case of arguments being True or False.
3580 begin
3581 -- Deal with non-standard booleans
3589 -- Check for cases of left argument is True or False
3593 -- If left argument is True, change (True and then Right) to Right.
3594 -- Any actions associated with Right will be executed unconditionally
3595 -- and can thus be inserted into the tree unconditionally.
3606 -- If left argument is False, change (False and then Right) to False.
3607 -- In this case we can forget the actions associated with Right,
3608 -- since they will never be executed.
3619 -- If Actions are present, we expand
3621 -- left and then right
3623 -- into
3625 -- if left then right else false end
3627 -- with the actions becoming the Then_Actions of the conditional
3628 -- expression. This conditional expression is then further expanded
3629 -- (and will eventually disappear)
3636 Left,
3637 Right,
3646 -- No actions present, check for cases of right argument True/False
3650 -- Change (Left and then True) to Left. Note that we know there are
3651 -- no actions associated with the True operand, since we just checked
3652 -- for this case above.
3657 -- Change (Left and then False) to False, making sure to preserve any
3658 -- side effects associated with the Left operand.
3662 Rewrite
3670 -------------------------------------
3671 -- Expand_N_Conditional_Expression --
3672 -------------------------------------
3674 -- Expand into expression actions if then/else actions present
3685 begin
3686 -- If either then or else actions are present, then given:
3688 -- if cond then then-expr else else-expr end
3690 -- we insert the following sequence of actions (using Insert_Actions):
3692 -- Cnn : typ;
3693 -- if cond then
3694 -- <<then actions>>
3695 -- Cnn := then-expr;
3696 -- else
3697 -- <<else actions>>
3698 -- Cnn := else-expr
3699 -- end if;
3701 -- and replace the conditional expression by a reference to Cnn
3706 New_If :=
3724 Insert_List_Before
3729 Insert_List_Before
3745 -----------------------------------
3746 -- Expand_N_Explicit_Dereference --
3747 -----------------------------------
3750 begin
3751 -- Insert explicit dereference call for the checked storage pool case
3756 -----------------
3757 -- Expand_N_In --
3758 -----------------
3768 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3769 -- test for the left operand being in range of its subtype.
3771 ----------------------------
3772 -- Substitute_Valid_Check --
3773 ----------------------------
3776 begin
3789 -- Start of processing for Expand_N_In
3791 begin
3792 -- Check case of explicit test for an expression in range of its
3793 -- subtype. This is suspicious usage and we replace it with a 'Valid
3794 -- test and give a warning.
3801 then
3802 Substitute_Valid_Check;
3806 -- Do validity check on operands
3813 -- Case of explicit range
3816 declare
3829 Constant_Condition_Warnings
3831 -- This must be true for any of the optimization warnings, we
3832 -- clearly want to give them only for source with the flag on.
3835 Warn1
3838 -- For the case where only one bound warning is elided, we also
3839 -- insist on an explicit range and an integer type. The reason is
3840 -- that the use of enumeration ranges including an end point is
3841 -- common, as is the use of a subtype name, one of whose bounds
3842 -- is the same as the type of the expression.
3844 begin
3845 -- If test is explicit x'first .. x'last, replace by valid check
3858 then
3859 Substitute_Valid_Check;
3863 -- If bounds of type are known at compile time, and the end points
3864 -- are known at compile time and identical, this is another case
3865 -- for substituting a valid test. We only do this for discrete
3866 -- types, since it won't arise in practice for float types.
3876 then
3877 Substitute_Valid_Check;
3881 -- If we have an explicit range, do a bit of optimization based
3882 -- on range analysis (we may be able to kill one or both checks).
3884 -- If either check is known to fail, replace result by False since
3885 -- the other check does not matter. Preserve the static flag for
3886 -- legality checks, because we are constant-folding beyond RM 4.9.
3901 -- If both checks are known to succeed, replace result by True,
3902 -- since we know we are in range.
3917 -- If lower bound check succeeds and upper bound check is not
3918 -- known to succeed or fail, then replace the range check with
3919 -- a comparison against the upper bound.
3935 -- If upper bound check succeeds and lower bound check is not
3936 -- known to succeed or fail, then replace the range check with
3937 -- a comparison against the lower bound.
3955 -- For all other cases of an explicit range, nothing to be done
3959 -- Here right operand is a subtype mark
3961 else
3962 declare
3968 begin
3971 -- For tagged type, do tagged membership operation
3975 -- No expansion will be performed when VM_Target, as the VM
3976 -- back-ends will handle the membership tests directly (tags
3977 -- are not explicitly represented in Java objects, so the
3978 -- normal tagged membership expansion is not what we want).
3987 -- If type is scalar type, rewrite as x in t'first .. t'last.
3988 -- This reason we do this is that the bounds may have the wrong
3989 -- type if they come from the original type definition.
3994 Low_Bound =>
3999 High_Bound =>
4006 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4007 -- a membership test if the subtype mark denotes a constrained
4008 -- Unchecked_Union subtype and the expression lacks inferable
4009 -- discriminants.
4014 then
4019 -- Prevent Gigi from generating incorrect code by rewriting
4020 -- the test as a standard False.
4028 -- Here we have a non-scalar type
4039 -- For the constrained array case, we have to check the subscripts
4040 -- for an exact match if the lengths are non-zero (the lengths
4041 -- must match in any case).
4046 function Construct_Attribute_Reference
4050 -- Build attribute reference E'Nam(Dim)
4052 -----------------------------------
4053 -- Construct_Attribute_Reference --
4054 -----------------------------------
4056 function Construct_Attribute_Reference
4060 is
4061 begin
4062 return
4070 -- Start processing for Check_Subscripts
4072 begin
4076 Left_Opnd =>
4077 Construct_Attribute_Reference
4080 Right_Opnd =>
4081 Construct_Attribute_Reference
4086 Left_Opnd =>
4087 Construct_Attribute_Reference
4090 Right_Opnd =>
4091 Construct_Attribute_Reference
4096 Cond :=
4098 Left_Opnd =>
4109 -- These are the cases where constraint checks may be required,
4110 -- e.g. records with possible discriminants
4112 else
4113 -- Expand the test into a series of discriminant comparisons.
4114 -- The expression that is built is the negation of the one that
4115 -- is used for checking discriminant constraints.
4125 Left_Opnd =>
4132 else
4143 --------------------------------
4144 -- Expand_N_Indexed_Component --
4145 --------------------------------
4153 begin
4154 -- A special optimization, if we have an indexed component that is
4155 -- selecting from a slice, then we can eliminate the slice, since, for
4156 -- example, x (i .. j)(k) is identical to x(k). The only difference is
4157 -- the range check required by the slice. The range check for the slice
4158 -- itself has already been generated. The range check for the
4159 -- subscripting operation is ensured by converting the subject to
4160 -- the subtype of the slice.
4162 -- This optimization not only generates better code, avoiding slice
4163 -- messing especially in the packed case, but more importantly bypasses
4164 -- some problems in handling this peculiar case, for example, the issue
4165 -- of dealing specially with object renamings.
4172 Convert_To
4179 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4180 -- function, then additional actuals must be passed.
4184 then
4188 -- If the prefix is an access type, then we unconditionally rewrite if
4189 -- as an explicit deference. This simplifies processing for several
4190 -- cases, including packed array cases and certain cases in which checks
4191 -- must be generated. We used to try to do this only when it was
4192 -- necessary, but it cleans up the code to do it all the time.
4199 -- Generate index and validity checks
4207 -- All done for the non-packed case
4213 -- For packed arrays that are not bit-packed (i.e. the case of an array
4214 -- with one or more index types with a non-contiguous enumeration type),
4215 -- we can always use the normal packed element get circuit.
4222 -- For a reference to a component of a bit packed array, we have to
4223 -- convert it to a reference to the corresponding Packed_Array_Type.
4224 -- We only want to do this for simple references, and not for:
4226 -- Left side of assignment, or prefix of left side of assignment, or
4227 -- prefix of the prefix, to handle packed arrays of packed arrays,
4228 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4230 -- Renaming objects in renaming associations
4231 -- This case is handled when a use of the renamed variable occurs
4233 -- Actual parameters for a procedure call
4234 -- This case is handled in Exp_Ch6.Expand_Actuals
4236 -- The second expression in a 'Read attribute reference
4238 -- The prefix of an address or size attribute reference
4240 -- The following circuit detects these exceptions
4242 declare
4246 begin
4247 loop
4252 N_Procedure_Call_Statement)
4254 and then
4256 then
4261 or else
4264 then
4269 then
4272 -- If the expression is an index of an indexed component, it must
4273 -- be expanded regardless of context.
4277 then
4283 then
4289 then
4294 then
4297 else
4302 -- Keep looking up tree for unchecked expression, or if we are the
4303 -- prefix of a possible assignment left side.
4311 ---------------------
4312 -- Expand_N_Not_In --
4313 ---------------------
4315 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
4316 -- can be done. This avoids needing to duplicate this expansion code.
4323 begin
4326 Right_Opnd =>
4331 -- We want this to appear as coming from source if original does (see
4332 -- transformations in Expand_N_In).
4337 -- Now analyze transformed node
4342 -------------------
4343 -- Expand_N_Null --
4344 -------------------
4346 -- The only replacement required is for the case of a null of type that is
4347 -- an access to protected subprogram. We represent such access values as a
4348 -- record, and so we must replace the occurrence of null by the equivalent
4349 -- record (with a null address and a null pointer in it), so that the
4350 -- backend creates the proper value.
4357 begin
4359 Agg :=
4368 -- For subsequent semantic analysis, the node must retain its type.
4369 -- Gigi in any case replaces this type by the corresponding record
4370 -- type before processing the node.
4375 exception
4380 ---------------------
4381 -- Expand_N_Op_Abs --
4382 ---------------------
4388 begin
4391 -- Deal with software overflow checking
4393 if not Backend_Overflow_Checks_On_Target
4396 then
4397 -- The only case to worry about is when the argument is equal to the
4398 -- largest negative number, so what we do is to insert the check:
4400 -- [constraint_error when Expr = typ'Base'First]
4402 -- with the usual Duplicate_Subexpr use coding for expr
4406 Condition =>
4409 Right_Opnd =>
4411 Prefix =>
4417 -- Vax floating-point types case
4424 ---------------------
4425 -- Expand_N_Op_Add --
4426 ---------------------
4431 begin
4434 -- N + 0 = 0 + N = N for integer types
4439 then
4445 then
4451 -- Arithmetic overflow checks for signed integer/fixed point types
4455 then
4459 -- Vax floating-point types case
4466 ---------------------
4467 -- Expand_N_Op_And --
4468 ---------------------
4473 begin
4487 ------------------------
4488 -- Expand_N_Op_Concat --
4489 ------------------------
4492 -- This is initialized the first time this routine is called. It records
4493 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
4494 -- available in the run-time:
4495 --
4496 -- 0 None available
4497 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
4498 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
4499 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
4500 -- 5 All routines including RE_Str_Concat_5 available
4503 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
4504 -- all three are available, False if any one of these is unavailable.
4508 -- List of operands to be concatenated
4511 -- Single operand for concatenation
4514 -- Node which is to be replaced by the result of concatenating the nodes
4515 -- in the list Opnds.
4518 -- Array type of concatenation result type
4521 -- Component type of concatenation represented by Cnode
4523 begin
4524 -- Initialize global variables showing run-time status
4528 -- See what routines are available and set max operand count
4529 -- according to the highest count available in the run-time.
4543 else
4547 Char_Concat_Available :=
4549 and then
4551 and then
4555 -- Ensure validity of both operands
4559 -- If we are the left operand of a concatenation higher up the tree,
4560 -- then do nothing for now, since we want to deal with a series of
4561 -- concatenations as a unit.
4565 then
4569 -- We get here with a concatenation whose left operand may be a
4570 -- concatenation itself with a consistent type. We need to process
4571 -- these concatenation operands from left to right, which means
4572 -- from the deepest node in the tree to the highest node.
4579 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
4580 -- nodes above, so now we process bottom up, doing the operations. We
4581 -- gather a string that is as long as possible up to five operands
4583 -- The outer loop runs more than once if there are more than five
4584 -- concatenations of type Standard.String, the most we handle for
4585 -- this case, or if more than one concatenation type is involved.
4591 -- The inner loop gathers concatenation operands. We gather any
4592 -- number of these in the non-string case, or if no concatenation
4593 -- routines are available for string (since in that case we will
4594 -- treat string like any other non-string case). Otherwise we only
4595 -- gather as many operands as can be handled by the available
4596 -- procedures in the run-time library (normally 5, but may be
4597 -- less for the configurable run-time case).
4601 or else
4603 or else
4605 Max_Available_String_Operands)
4608 loop
4613 -- Here we process the collected operands. First we convert singleton
4614 -- operands to singleton aggregates. This is skipped however for the
4615 -- case of two operands of type String since we have special routines
4616 -- for these cases.
4622 or else not Char_Concat_Available
4623 then
4625 loop
4638 -- Now call appropriate continuation routine
4642 then
4644 else
4653 ------------------------
4654 -- Expand_N_Op_Divide --
4655 ------------------------
4665 and then
4669 begin
4676 -- N / 1 = N for integer types
4683 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4684 -- Is_Power_Of_2_For_Shift is set means that we know that our left
4685 -- operand is an unsigned integer, as required for this to work.
4690 -- We cannot do this transformation in configurable run time mode if we
4691 -- have 64-bit -- integers and long shifts are not available.
4693 and then
4696 then
4700 Right_Opnd =>
4706 -- Do required fixup of universal fixed operation
4713 -- Divisions with fixed-point results
4717 -- No special processing if Treat_Fixed_As_Integer is set, since
4718 -- from a semantic point of view such operations are simply integer
4719 -- operations and will be treated that way.
4724 else
4729 -- Other cases of division of fixed-point operands. Again we exclude the
4730 -- case where Treat_Fixed_As_Integer is set.
4735 then
4738 else
4743 -- Mixed-mode operations can appear in a non-static universal context,
4744 -- in which case the integer argument must be converted explicitly.
4748 then
4756 then
4762 -- Non-fixed point cases, do integer zero divide and overflow checks
4767 -- Check for 64-bit division available, or long shifts if the divisor
4768 -- is a small power of 2 (since such divides will be converted into
4769 -- long shifts.
4772 and then not Support_64_Bit_Divides_On_Target
4773 and then
4775 or else not Support_Long_Shifts_On_Target
4782 then
4786 -- Deal with Vax_Float
4794 --------------------
4795 -- Expand_N_Op_Eq --
4796 --------------------
4811 -- If a constructed equality exists for the type or for its parent,
4812 -- build and analyze call, adding conversions if the operation is
4813 -- inherited.
4816 -- Determines whether a type has a subcomponent of an unconstrained
4817 -- Unchecked_Union subtype. Typ is a record type.
4819 -------------------------
4820 -- Build_Equality_Call --
4821 -------------------------
4828 begin
4831 then
4836 -- If we have an Unchecked_Union, we need to add the inferred
4837 -- discriminant values as actuals in the function call. At this
4838 -- point, the expansion has determined that both operands have
4839 -- inferable discriminants.
4842 declare
4848 begin
4849 -- Per-object constrained selected components require special
4850 -- attention. If the enclosing scope of the component is an
4851 -- Unchecked_Union, we cannot reference its discriminants
4852 -- directly. This is why we use the two extra parameters of
4853 -- the equality function of the enclosing Unchecked_Union.
4855 -- type UU_Type (Discr : Integer := 0) is
4856 -- . . .
4857 -- end record;
4858 -- pragma Unchecked_Union (UU_Type);
4860 -- 1. Unchecked_Union enclosing record:
4862 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4863 -- . . .
4864 -- Comp : UU_Type (Discr);
4865 -- . . .
4866 -- end Enclosing_UU_Type;
4867 -- pragma Unchecked_Union (Enclosing_UU_Type);
4869 -- Obj1 : Enclosing_UU_Type;
4870 -- Obj2 : Enclosing_UU_Type (1);
4872 -- [. . .] Obj1 = Obj2 [. . .]
4874 -- Generated code:
4876 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4878 -- A and B are the formal parameters of the equality function
4879 -- of Enclosing_UU_Type. The function always has two extra
4880 -- formals to capture the inferred discriminant values.
4882 -- 2. Non-Unchecked_Union enclosing record:
4884 -- type
4885 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4886 -- is record
4887 -- . . .
4888 -- Comp : UU_Type (Discr);
4889 -- . . .
4890 -- end Enclosing_Non_UU_Type;
4892 -- Obj1 : Enclosing_Non_UU_Type;
4893 -- Obj2 : Enclosing_Non_UU_Type (1);
4895 -- ... Obj1 = Obj2 ...
4897 -- Generated code:
4899 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4900 -- obj1.discr, obj2.discr)) then
4902 -- In this case we can directly reference the discriminants of
4903 -- the enclosing record.
4905 -- Lhs of equality
4908 and then Has_Per_Object_Constraint
4910 then
4911 -- Enclosing record is an Unchecked_Union, use formal A
4915 then
4916 Lhs_Discr_Val :=
4920 -- Enclosing record is of a non-Unchecked_Union type, it is
4921 -- possible to reference the discriminant.
4923 else
4924 Lhs_Discr_Val :=
4927 Selector_Name =>
4928 New_Copy
4929 (Get_Discriminant_Value
4931 Lhs_Type,
4935 -- Comment needed here ???
4937 else
4938 -- Infer the discriminant value
4940 Lhs_Discr_Val :=
4941 New_Copy
4942 (Get_Discriminant_Value
4944 Lhs_Type,
4948 -- Rhs of equality
4951 and then Has_Per_Object_Constraint
4953 then
4954 if Is_Unchecked_Union
4956 then
4957 Rhs_Discr_Val :=
4961 else
4962 Rhs_Discr_Val :=
4965 Selector_Name =>
4968 Rhs_Type,
4972 else
4973 Rhs_Discr_Val :=
4976 Rhs_Type,
4985 L_Exp,
4986 R_Exp,
4987 Lhs_Discr_Val,
4988 Rhs_Discr_Val)));
4991 -- Normal case, not an unchecked union
4993 else
5003 ------------------------------------
5004 -- Has_Unconstrained_UU_Component --
5005 ------------------------------------
5007 function Has_Unconstrained_UU_Component
5009 is
5015 function Component_Is_Unconstrained_UU
5017 -- Determines whether the subtype of the component is an
5018 -- unconstrained Unchecked_Union.
5020 function Variant_Is_Unconstrained_UU
5022 -- Determines whether a component of the variant has an unconstrained
5023 -- Unchecked_Union subtype.
5025 -----------------------------------
5026 -- Component_Is_Unconstrained_UU --
5027 -----------------------------------
5029 function Component_Is_Unconstrained_UU
5031 is
5032 begin
5037 declare
5041 begin
5042 -- Unconstrained nominal type. In the case of a constraint
5043 -- present, the node kind would have been N_Subtype_Indication.
5053 ---------------------------------
5054 -- Variant_Is_Unconstrained_UU --
5055 ---------------------------------
5057 function Variant_Is_Unconstrained_UU
5059 is
5062 begin
5067 -- We only need to test one component
5069 declare
5072 begin
5082 -- None of the components withing the variant were of
5083 -- unconstrained Unchecked_Union type.
5088 -- Start of processing for Has_Unconstrained_UU_Component
5090 begin
5098 -- Inspect available components
5101 declare
5104 begin
5107 -- One component is sufficient
5118 -- Inspect available components withing variants
5121 declare
5124 begin
5127 -- One component within a variant is sufficient
5138 -- Neither the available components, nor the components inside the
5139 -- variant parts were of an unconstrained Unchecked_Union subtype.
5144 -- Start of processing for Expand_N_Op_Eq
5146 begin
5153 else
5157 -- It may happen in error situations that the underlying type is not
5158 -- set. The error will be detected later, here we just defend the
5159 -- expander code.
5167 -- Boolean types (requiring handling of non-standard case)
5175 -- Array types
5179 -- If we are doing full validity checking, and it is possible for the
5180 -- array elements to be invalid then expand out array comparisons to
5181 -- make sure that we check the array elements.
5183 if Validity_Check_Operands
5185 then
5186 declare
5188 Force_Validity_Checks;
5189 begin
5192 Expand_Array_Equality
5196 Bodies,
5197 Typl));
5203 -- Packed case where both operands are known aligned
5208 then
5211 -- Where the component type is elementary we can use a block bit
5212 -- comparison (if supported on the target) exception in the case
5213 -- of floating-point (negative zero issues require element by
5214 -- element comparison), and atomic types (where we must be sure
5215 -- to load elements independently) and possibly unaligned arrays.
5222 and then Support_Composite_Compare_On_Target
5223 then
5226 -- For composite and floating-point cases, expand equality loop to
5227 -- make sure of using proper comparisons for tagged types, and
5228 -- correctly handling the floating-point case.
5230 else
5232 Expand_Array_Equality
5236 Bodies,
5237 Typl));
5242 -- Record Types
5246 -- For tagged types, use the primitive "="
5250 -- No need to do anything else compiling under restriction
5251 -- No_Dispatching_Calls. During the semantic analysis we
5252 -- already notified such violation.
5258 -- If this is derived from an untagged private type completed with
5259 -- a tagged type, it does not have a full view, so we use the
5260 -- primitive operations of the private type. This check should no
5261 -- longer be necessary when these types get their full views???
5267 then
5268 -- Search for equality operation, checking that the operands
5269 -- have the same type. Note that we must find a matching entry,
5270 -- or something is very wrong!
5278 and then
5287 -- Find the type's predefined equality or an overriding
5288 -- user- defined equality. The reason for not simply calling
5289 -- Find_Prim_Op here is that there may be a user-defined
5290 -- overloaded equality op that precedes the equality that we want,
5291 -- so we have to explicitly search (e.g., there could be an
5292 -- equality with two different parameter types).
5294 else
5304 and then
5316 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
5317 -- predefined equality operator for a type which has a subcomponent
5318 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
5325 -- Prevent Gigi from generating incorrect code by rewriting the
5326 -- equality as a standard False.
5333 -- If we can infer the discriminants of the operands, we make a
5334 -- call to the TSS equality function.
5337 and then
5339 then
5340 Build_Equality_Call
5343 else
5344 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5345 -- the predefined equality operator for an Unchecked_Union type
5346 -- if either of the operands lack inferable discriminants.
5352 -- Prevent Gigi from generating incorrect code by rewriting
5353 -- the equality as a standard False.
5360 -- If a type support function is present (for complex cases), use it
5363 Build_Equality_Call
5366 -- Otherwise expand the component by component equality. Note that
5367 -- we never use block-bit comparisons for records, because of the
5368 -- problems with gaps. The backend will often be able to recombine
5369 -- the separate comparisons that we generate here.
5371 else
5382 -- Test if result is known at compile time
5386 -- If we still have comparison for Vax_Float, process it
5394 -----------------------
5395 -- Expand_N_Op_Expon --
5396 -----------------------
5414 begin
5417 -- If either operand is of a private type, then we have the use of an
5418 -- intrinsic operator, and we get rid of the privateness, by using root
5419 -- types of underlying types for the actual operation. Otherwise the
5420 -- private types will cause trouble if we expand multiplications or
5421 -- shifts etc. We also do this transformation if the result type is
5422 -- different from the base type.
5425 or else
5427 or else
5429 or else
5431 then
5432 declare
5436 begin
5447 -- Test for case of known right argument
5452 -- We only fold small non-negative exponents. You might think we
5453 -- could fold small negative exponents for the real case, but we
5454 -- can't because we are required to raise Constraint_Error for
5455 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
5456 -- See ACVC test C4A012B.
5460 -- X ** 0 = 1 (or 1.0)
5465 else
5469 -- X ** 1 = X
5474 -- X ** 2 = X * X
5477 Xnode :=
5482 -- X ** 3 = X * X * X
5485 Xnode :=
5487 Left_Opnd =>
5493 -- X ** 4 ->
5494 -- En : constant base'type := base * base;
5495 -- ...
5496 -- En * En
5499 Temp :=
5507 Expression =>
5512 Xnode :=
5524 -- Case of (2 ** expression) appearing as an argument of an integer
5525 -- multiplication, or as the right argument of a division of a non-
5526 -- negative integer. In such cases we leave the node untouched, setting
5527 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
5528 -- of the higher level node converts it into a shift.
5530 -- Note: this transformation is not applicable for a modular type with
5531 -- a non-binary modulus in the multiplication case, since we get a wrong
5532 -- result if the shift causes an overflow before the modular reduction.
5539 and then not Ovflo
5541 then
5542 declare
5547 begin
5550 and then
5552 or else
5556 or else
5562 then
5569 -- Fall through if exponentiation must be done using a runtime routine
5571 -- First deal with modular case
5575 -- Non-binary case, we call the special exponentiation routine for
5576 -- the non-binary case, converting the argument to Long_Long_Integer
5577 -- and passing the modulus value. Then the result is converted back
5578 -- to the base type.
5588 Exp))));
5590 -- Binary case, in this case, we call one of two routines, either the
5591 -- unsigned integer case, or the unsigned long long integer case,
5592 -- with a final "and" operation to do the required mod.
5594 else
5597 else
5604 Left_Opnd =>
5609 Exp)),
5610 Right_Opnd =>
5615 -- Common exit point for modular type case
5620 -- Signed integer cases, done using either Integer or Long_Long_Integer.
5621 -- It is not worth having routines for Short_[Short_]Integer, since for
5622 -- most machines it would not help, and it would generate more code that
5623 -- might need certification when a certified run time is required.
5625 -- In the integer cases, we have two routines, one for when overflow
5626 -- checks are required, and one when they are not required, since there
5627 -- is a real gain in omitting checks on many machines.
5631 and then
5634 then
5639 else
5648 else
5652 -- Floating-point cases, always done using Long_Long_Float. We do not
5653 -- need separate routines for the overflow case here, since in the case
5654 -- of floating-point, we generate infinities anyway as a rule (either
5655 -- that or we automatically trap overflow), and if there is an infinity
5656 -- generated and a range check is required, the check will fail anyway.
5658 else
5664 -- Common processing for integer cases and floating-point cases.
5665 -- If we are in the right type, we can call runtime routine directly
5670 then
5676 -- Otherwise we have to introduce conversions (conversions are also
5677 -- required in the universal cases, since the runtime routine is
5678 -- typed using one of the standard types.
5680 else
5687 Exp))));
5693 exception
5698 --------------------
5699 -- Expand_N_Op_Ge --
5700 --------------------
5708 begin
5725 -- If we still have comparison, and Vax_Float type, process it
5733 --------------------
5734 -- Expand_N_Op_Gt --
5735 --------------------
5743 begin
5760 -- If we still have comparison, and Vax_Float type, process it
5768 --------------------
5769 -- Expand_N_Op_Le --
5770 --------------------
5778 begin
5795 -- If we still have comparison, and Vax_Float type, process it
5803 --------------------
5804 -- Expand_N_Op_Lt --
5805 --------------------
5813 begin
5830 -- If we still have comparison, and Vax_Float type, process it
5838 -----------------------
5839 -- Expand_N_Op_Minus --
5840 -----------------------
5846 begin
5849 if not Backend_Overflow_Checks_On_Target
5852 then
5853 -- Software overflow checking expands -expr into (0 - expr)
5862 -- Vax floating-point types case
5869 ---------------------
5870 -- Expand_N_Op_Mod --
5871 ---------------------
5891 begin
5897 -- Convert mod to rem if operands are known non-negative. We do this
5898 -- since it is quite likely that this will improve the quality of code,
5899 -- (the operation now corresponds to the hardware remainder), and it
5900 -- does not seem likely that it could be harmful.
5903 and then
5905 then
5911 -- Instead of reanalyzing the node we do the analysis manually. This
5912 -- avoids anomalies when the replacement is done in an instance and
5913 -- is epsilon more efficient.
5922 -- Otherwise, normal mod processing
5924 else
5929 -- Apply optimization x mod 1 = 0. We don't really need that with
5930 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5931 -- certainly harmless.
5936 then
5942 -- Deal with annoying case of largest negative number remainder
5943 -- minus one. Gigi does not handle this case correctly, because
5944 -- it generates a divide instruction which may trap in this case.
5946 -- In fact the check is quite easy, if the right operand is -1, then
5947 -- the mod value is always 0, and we can just ignore the left operand
5948 -- completely in this case.
5950 -- The operand type may be private (e.g. in the expansion of an an
5951 -- intrinsic operation) so we must use the underlying type to get the
5952 -- bounds, and convert the literals explicitly.
5954 LLB :=
5955 Expr_Value
5959 and then
5961 then
5967 Right_Opnd =>
5980 --------------------------
5981 -- Expand_N_Op_Multiply --
5982 --------------------------
6001 begin
6004 -- Special optimizations for integer types
6008 -- N * 0 = 0 * N = 0 for integer types
6012 or else
6015 then
6021 -- N * 1 = 1 * N = N for integer types
6023 -- This optimisation is not done if we are going to
6024 -- rewrite the product 1 * 2 ** N to a shift.
6028 and then not Lp2
6029 then
6035 and then not Rp2
6036 then
6042 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
6043 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6044 -- operand is an integer, as required for this to work.
6049 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
6054 Right_Opnd =>
6061 else
6065 Right_Opnd =>
6071 -- Same processing for the operands the other way round
6077 Right_Opnd =>
6083 -- Do required fixup of universal fixed operation
6090 -- Multiplications with fixed-point results
6094 -- No special processing if Treat_Fixed_As_Integer is set, since from
6095 -- a semantic point of view such operations are simply integer
6096 -- operations and will be treated that way.
6100 -- Case of fixed * integer => fixed
6105 -- Case of integer * fixed => fixed
6110 -- Case of fixed * fixed => fixed
6112 else
6117 -- Other cases of multiplication of fixed-point operands. Again we
6118 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
6122 then
6125 else
6130 -- Mixed-mode operations can appear in a non-static universal context,
6131 -- in which case the integer argument must be converted explicitly.
6135 then
6142 then
6147 -- Non-fixed point cases, check software overflow checking required
6152 -- Deal with VAX float case
6160 --------------------
6161 -- Expand_N_Op_Ne --
6162 --------------------
6167 begin
6168 -- Case of elementary type with standard operator
6172 then
6175 -- Boolean types (requiring handling of non-standard case)
6186 -- If we still have comparison for Vax_Float, process it
6193 -- For all cases other than elementary types, we rewrite node as the
6194 -- negation of an equality operation, and reanalyze. The equality to be
6195 -- used is defined in the same scope and has the same signature. This
6196 -- signature must be set explicitly since in an instance it may not have
6197 -- the same visibility as in the generic unit. This avoids duplicating
6198 -- or factoring the complex code for record/array equality tests etc.
6200 else
6201 declare
6206 begin
6209 Neg :=
6211 Right_Opnd =>
6221 -- For navigation purposes, the inequality is treated as an
6222 -- implicit reference to the corresponding equality. Preserve the
6223 -- Comes_From_ source flag so that the proper Xref entry is
6224 -- generated.
6234 ---------------------
6235 -- Expand_N_Op_Not --
6236 ---------------------
6238 -- If the argument is other than a Boolean array type, there is no special
6239 -- expansion required.
6241 -- For the packed case, we call the special routine in Exp_Pakd, except
6242 -- that if the component size is greater than one, we use the standard
6243 -- routine generating a gruesome loop (it is so peculiar to have packed
6244 -- arrays with non-standard Boolean representations anyway, so it does not
6245 -- matter that we do not handle this case efficiently).
6247 -- For the unpacked case (and for the special packed case where we have non
6248 -- standard Booleans, as discussed above), we generate and insert into the
6249 -- tree the following function definition:
6251 -- function Nnnn (A : arr) is
6252 -- B : arr;
6253 -- begin
6254 -- for J in a'range loop
6255 -- B (J) := not A (J);
6256 -- end loop;
6257 -- return B;
6258 -- end Nnnn;
6260 -- Here arr is the actual subtype of the parameter (and hence always
6261 -- constrained). Then we replace the not with a call to this function.
6277 begin
6280 -- For boolean operand, deal with non-standard booleans
6289 -- Only array types need any other processing
6295 -- Case of array operand. If bit packed with a component size of 1,
6296 -- handle it in Exp_Pakd if the operand is known to be aligned.
6301 then
6306 -- Case of array operand which is not bit-packed. If the context is
6307 -- a safe assignment, call in-place operation, If context is a larger
6308 -- boolean expression in the context of a safe assignment, expansion is
6309 -- done by enclosing operation.
6322 -- Special case the negation of a binary operation
6325 and then Safe_In_Place_Array_Op
6327 then
6334 then
6335 declare
6340 begin
6344 then
6345 -- (not A) op (not B) can be reduced to a single call
6351 then
6352 -- A xor (not B) can also be special-cased
6364 A_J :=
6369 B_J :=
6374 Loop_Statement :=
6378 Iteration_Scheme =>
6380 Loop_Parameter_Specification =>
6383 Discrete_Subtype_Definition =>
6398 Specification =>
6412 Handled_Statement_Sequence =>
6415 Loop_Statement,
6417 Expression =>
6428 --------------------
6429 -- Expand_N_Op_Or --
6430 --------------------
6435 begin
6449 ----------------------
6450 -- Expand_N_Op_Plus --
6451 ----------------------
6454 begin
6458 ---------------------
6459 -- Expand_N_Op_Rem --
6460 ---------------------
6479 begin
6486 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
6487 -- but it is useful with other back ends (e.g. AAMP), and is certainly
6488 -- harmless.
6493 then
6499 -- Deal with annoying case of largest negative number remainder minus
6500 -- one. Gigi does not handle this case correctly, because it generates
6501 -- a divide instruction which may trap in this case.
6503 -- In fact the check is quite easy, if the right operand is -1, then
6504 -- the remainder is always 0, and we can just ignore the left operand
6505 -- completely in this case.
6510 -- The operand type may be private (e.g. in the expansion of an an
6511 -- intrinsic operation) so we must use the underlying type to get the
6512 -- bounds, and convert the literals explicitly.
6514 LLB :=
6515 Expr_Value
6518 -- Now perform the test, generating code only if needed
6521 and then
6523 then
6529 Right_Opnd =>
6543 -----------------------------
6544 -- Expand_N_Op_Rotate_Left --
6545 -----------------------------
6548 begin
6552 ------------------------------
6553 -- Expand_N_Op_Rotate_Right --
6554 ------------------------------
6557 begin
6561 ----------------------------
6562 -- Expand_N_Op_Shift_Left --
6563 ----------------------------
6566 begin
6570 -----------------------------
6571 -- Expand_N_Op_Shift_Right --
6572 -----------------------------
6575 begin
6579 ----------------------------------------
6580 -- Expand_N_Op_Shift_Right_Arithmetic --
6581 ----------------------------------------
6584 begin
6588 --------------------------
6589 -- Expand_N_Op_Subtract --
6590 --------------------------
6595 begin
6598 -- N - 0 = N for integer types
6603 then
6608 -- Arithmetic overflow checks for signed integer/fixed point types
6612 then
6615 -- Vax floating-point types case
6622 ---------------------
6623 -- Expand_N_Op_Xor --
6624 ---------------------
6629 begin
6643 ----------------------
6644 -- Expand_N_Or_Else --
6645 ----------------------
6647 -- Expand into conditional expression if Actions present, and also
6648 -- deal with optimizing case of arguments being True or False.
6657 begin
6658 -- Deal with non-standard booleans
6666 -- Check for cases of left argument is True or False
6670 -- If left argument is False, change (False or else Right) to Right.
6671 -- Any actions associated with Right will be executed unconditionally
6672 -- and can thus be inserted into the tree unconditionally.
6683 -- If left argument is True, change (True and then Right) to True. In
6684 -- this case we can forget the actions associated with Right, since
6685 -- they will never be executed.
6696 -- If Actions are present, we expand
6698 -- left or else right
6700 -- into
6702 -- if left then True else right end
6704 -- with the actions becoming the Else_Actions of the conditional
6705 -- expression. This conditional expression is then further expanded
6706 -- (and will eventually disappear)
6713 Left,
6715 Right)));
6723 -- No actions present, check for cases of right argument True/False
6727 -- Change (Left or else False) to Left. Note that we know there are
6728 -- no actions associated with the True operand, since we just checked
6729 -- for this case above.
6734 -- Change (Left or else True) to True, making sure to preserve any
6735 -- side effects associated with the Left operand.
6739 Rewrite
6747 -----------------------------------
6748 -- Expand_N_Qualified_Expression --
6749 -----------------------------------
6755 begin
6756 -- Do validity check if validity checking operands
6758 if Validity_Checks_On
6759 and then Validity_Check_Operands
6760 then
6764 -- Apply possible constraint check
6769 ---------------------------------
6770 -- Expand_N_Selected_Component --
6771 ---------------------------------
6773 -- If the selector is a discriminant of a concurrent object, rewrite the
6774 -- prefix to denote the corresponding record type.
6786 -- Gigi needs a temporary for prefixes that depend on a discriminant,
6787 -- unless the context of an assignment can provide size information.
6788 -- Don't we have a general routine that does this???
6790 -----------------------
6791 -- In_Left_Hand_Side --
6792 -----------------------
6795 begin
6803 -- Start of processing for Expand_N_Selected_Component
6805 begin
6806 -- Insert explicit dereference if required
6814 then
6821 -- Deal with discriminant check required
6825 -- Present the discriminant checking function to the backend, so that
6826 -- it can inline the call to the function.
6828 Add_Inlined_Body
6829 (Discriminant_Checking_Func
6832 -- Now reset the flag and generate the call
6838 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6839 -- function, then additional actuals must be passed.
6843 then
6847 -- Gigi cannot handle unchecked conversions that are the prefix of a
6848 -- selected component with discriminants. This must be checked during
6849 -- expansion, because during analysis the type of the selector is not
6850 -- known at the point the prefix is analyzed. If the conversion is the
6851 -- target of an assignment, then we cannot force the evaluation.
6856 then
6860 -- Remaining processing applies only if selector is a discriminant
6864 -- If the selector is a discriminant of a constrained record type,
6865 -- we may be able to rewrite the expression with the actual value
6866 -- of the discriminant, a useful optimization in some cases.
6871 then
6872 -- Do this optimization for discrete types only, and not for
6873 -- access types (access discriminants get us into trouble!)
6878 -- Don't do this on the left hand of an assignment statement.
6879 -- Normally one would think that references like this would
6880 -- not occur, but they do in generated code, and mean that
6881 -- we really do want to assign the discriminant!
6885 then
6888 -- Don't do this optimization for the prefix of an attribute or
6889 -- the operand of an object renaming declaration since these are
6890 -- contexts where we do not want the value anyway.
6895 then
6898 -- Don't do this optimization if we are within the code for a
6899 -- discriminant check, since the whole point of such a check may
6900 -- be to verify the condition on which the code below depends!
6905 -- Green light to see if we can do the optimization. There is
6906 -- still one condition that inhibits the optimization below but
6907 -- now is the time to check the particular discriminant.
6909 else
6910 -- Loop through discriminants to find the matching discriminant
6911 -- constraint to see if we can copy it.
6917 -- Check if this is the matching discriminant
6921 -- Here we have the matching discriminant. Check for
6922 -- the case of a discriminant of a component that is
6923 -- constrained by an outer discriminant, which cannot
6924 -- be optimized away.
6926 if
6927 Denotes_Discriminant
6929 then
6932 -- In the context of a case statement, the expression may
6933 -- have the base type of the discriminant, and we need to
6934 -- preserve the constraint to avoid spurious errors on
6935 -- missing cases.
6939 then
6942 Subtype_Mark =>
6944 Expression =>
6948 -- In case that comes out as a static expression,
6949 -- reset it (a selected component is never static).
6954 -- Otherwise we can just copy the constraint, but the
6955 -- result is certainly not static! In some cases the
6956 -- discriminant constraint has been analyzed in the
6957 -- context of the original subtype indication, but for
6958 -- itypes the constraint might not have been analyzed
6959 -- yet, and this must be done now.
6961 else
6973 -- Note: the above loop should always find a matching
6974 -- discriminant, but if it does not, we just missed an
6975 -- optimization due to some glitch (perhaps a previous error),
6976 -- so ignore.
6981 -- The only remaining processing is in the case of a discriminant of
6982 -- a concurrent object, where we rewrite the prefix to denote the
6983 -- corresponding record type. If the type is derived and has renamed
6984 -- discriminants, use corresponding discriminant, which is the one
6985 -- that appears in the corresponding record.
6995 then
6999 New_N :=
7001 Prefix =>
7011 --------------------
7012 -- Expand_N_Slice --
7013 --------------------
7022 -- Check whether the argument is an actual for a procedure call, in
7023 -- which case the expansion of a bit-packed slice is deferred until the
7024 -- call itself is expanded. The reason this is required is that we might
7025 -- have an IN OUT or OUT parameter, and the copy out is essential, and
7026 -- that copy out would be missed if we created a temporary here in
7027 -- Expand_N_Slice. Note that we don't bother to test specifically for an
7028 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
7029 -- is harmless to defer expansion in the IN case, since the call
7030 -- processing will still generate the appropriate copy in operation,
7031 -- which will take care of the slice.
7034 -- Create a named variable for the value of the slice, in cases where
7035 -- the back-end cannot handle it properly, e.g. when packed types or
7036 -- unaligned slices are involved.
7038 -------------------------
7039 -- Is_Procedure_Actual --
7040 -------------------------
7045 begin
7046 loop
7047 -- If our parent is a procedure call we can return
7052 -- If our parent is a type conversion, keep climbing the tree,
7053 -- since a type conversion can be a procedure actual. Also keep
7054 -- climbing if parameter association or a qualified expression,
7055 -- since these are additional cases that do can appear on
7056 -- procedure actuals.
7059 N_Parameter_Association,
7060 N_Qualified_Expression)
7061 then
7064 -- Any other case is not what we are looking for
7066 else
7072 --------------------
7073 -- Make_Temporary --
7074 --------------------
7080 begin
7081 Decl :=
7089 Decl,
7098 -- Start of processing for Expand_N_Slice
7100 begin
7101 -- Special handling for access types
7114 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7115 -- function, then additional actuals must be passed.
7119 then
7123 -- Range checks are potentially also needed for cases involving a slice
7124 -- indexed by a subtype indication, but Do_Range_Check can currently
7125 -- only be set for expressions ???
7132 -- Do not enable range check to nodes associated with the frontend
7133 -- expansion of the dispatch table. We first check if Ada.Tags is
7134 -- already loaded to avoid the addition of an undesired dependence
7135 -- on such run-time unit.
7137 and then
7139 or else not
7145 then
7149 -- The remaining case to be handled is packed slices. We can leave
7150 -- packed slices as they are in the following situations:
7152 -- 1. Right or left side of an assignment (we can handle this
7153 -- situation correctly in the assignment statement expansion).
7155 -- 2. Prefix of indexed component (the slide is optimized away in this
7156 -- case, see the start of Expand_N_Slice.)
7158 -- 3. Object renaming declaration, since we want the name of the
7159 -- slice, not the value.
7161 -- 4. Argument to procedure call, since copy-in/copy-out handling may
7162 -- be required, and this is handled in the expansion of call
7163 -- itself.
7165 -- 5. Prefix of an address attribute (this is an error which is caught
7166 -- elsewhere, and the expansion would interfere with generating the
7167 -- error message).
7171 -- Apply transformation for actuals of a function call, where
7172 -- Expand_Actuals is not used.
7176 then
7177 Make_Temporary;
7183 then
7189 then
7194 then
7197 else
7198 Make_Temporary;
7202 ------------------------------
7203 -- Expand_N_Type_Conversion --
7204 ------------------------------
7213 -- This is called in the case of record and array type conversions to
7214 -- see if there is a change of representation to be handled. Change of
7215 -- representation is actually handled at the assignment statement level,
7216 -- and what this procedure does is rewrite node N conversion as an
7217 -- assignment to temporary. If there is no change of representation,
7218 -- then the conversion node is unchanged.
7221 -- Handles generation of range check for real target value
7223 -----------------------------------
7224 -- Handle_Changed_Representation --
7225 -----------------------------------
7235 begin
7236 -- Nothing else to do if no change of representation
7241 -- The real change of representation work is done by the assignment
7242 -- statement processing. So if this type conversion is appearing as
7243 -- the expression of an assignment statement, nothing needs to be
7244 -- done to the conversion.
7249 -- Otherwise we need to generate a temporary variable, and do the
7250 -- change of representation assignment into that temporary variable.
7251 -- The conversion is then replaced by a reference to this variable.
7253 else
7256 -- If type is unconstrained we have to add a constraint, copied
7257 -- from the actual value of the left hand side.
7272 Selector_Name =>
7283 -- We convert the bounds explicitly. We use an unchecked
7284 -- conversion because bounds checks are done elsewhere.
7288 Low_Bound =>
7291 Prefix =>
7292 Duplicate_Subexpr_No_Checks
7298 High_Bound =>
7301 Prefix =>
7302 Duplicate_Subexpr_No_Checks
7316 Odef :=
7319 Constraint =>
7325 Decl :=
7332 -- Insert required actions. It is essential to suppress checks
7333 -- since we have suppressed default initialization, which means
7334 -- that the variable we create may have no discriminants.
7337 New_List (
7338 Decl,
7349 ----------------------
7350 -- Real_Range_Check --
7351 ----------------------
7353 -- Case of conversions to floating-point or fixed-point. If range checks
7354 -- are enabled and the target type has a range constraint, we convert:
7356 -- typ (x)
7358 -- to
7360 -- Tnn : typ'Base := typ'Base (x);
7361 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7362 -- Tnn
7364 -- This is necessary when there is a conversion of integer to float or
7365 -- to fixed-point to ensure that the correct checks are made. It is not
7366 -- necessary for float to float where it is enough to simply set the
7367 -- Do_Range_Check flag.
7377 begin
7378 -- Nothing to do if conversion was rewritten
7384 -- Nothing to do if range checks suppressed, or target has the same
7385 -- range as the base type (or is the base type).
7389 and then
7391 then
7395 -- Nothing to do if expression is an entity on which checks have been
7396 -- suppressed.
7400 then
7404 -- Nothing to do if bounds are all static and we can tell that the
7405 -- expression is within the bounds of the target. Note that if the
7406 -- operand is of an unconstrained floating-point type, then we do
7407 -- not trust it to be in range (might be infinite)
7409 declare
7413 begin
7420 then
7421 declare
7427 begin
7431 else
7439 then
7447 -- For float to float conversions, we are done
7450 and then
7452 then
7456 -- Otherwise rewrite the conversion as described above
7459 Rewrite
7463 -- Enable overflow except for case of integer to float conversions,
7464 -- where it is never required, since we can never have overflow in
7465 -- this case.
7471 Tnn :=
7482 Condition =>
7484 Left_Opnd =>
7487 Right_Opnd =>
7490 Prefix =>
7493 Right_Opnd =>
7496 Right_Opnd =>
7499 Prefix =>
7507 -- Start of processing for Expand_N_Type_Conversion
7509 begin
7510 -- Nothing at all to do if conversion is to the identical type so remove
7511 -- the conversion completely, it is useless.
7518 -- Nothing to do if this is the second argument of read. This is a
7519 -- "backwards" conversion that will be handled by the specialized code
7520 -- in attribute processing.
7525 then
7529 -- Here if we may need to expand conversion
7531 -- Do validity check if validity checking operands
7533 if Validity_Checks_On
7534 and then Validity_Check_Operands
7535 then
7539 -- Special case of converting from non-standard boolean type
7543 then
7549 -- Case of converting to an access type
7553 -- Apply an accessibility check when the conversion operand is an
7554 -- access parameter (or a renaming thereof), unless conversion was
7555 -- expanded from an unchecked or unrestricted access attribute. Note
7556 -- that other checks may still need to be applied below (such as
7557 -- tagged type checks).
7560 and then
7562 or else
7565 and then Is_Formal
7570 then
7573 -- If the level of the operand type is statically deeper then the
7574 -- level of the target type, then force Program_Error. Note that this
7575 -- can only occur for cases where the attribute is within the body of
7576 -- an instantiation (otherwise the conversion will already have been
7577 -- rejected as illegal). Note: warnings are issued by the analyzer
7578 -- for the instance cases.
7580 elsif In_Instance_Body
7583 then
7589 -- When the operand is a selected access discriminant the check needs
7590 -- to be made against the level of the object denoted by the prefix
7591 -- of the selected name. Force Program_Error for this case as well
7592 -- (this accessibility violation can only happen if within the body
7593 -- of an instantiation).
7595 elsif In_Instance_Body
7600 then
7608 -- Case of conversions of tagged types and access to tagged types
7610 -- When needed, that is to say when the expression is class-wide, Add
7611 -- runtime a tag check for (strict) downward conversion by using the
7612 -- membership test, generating:
7614 -- [constraint_error when Operand not in Target_Type'Class]
7616 -- or in the access type case
7618 -- [constraint_error
7619 -- when Operand /= null
7620 -- and then Operand.all not in
7621 -- Designated_Type (Target_Type)'Class]
7626 then
7627 -- Do not do any expansion in the access type case if the parent is a
7628 -- renaming, since this is an error situation which will be caught by
7629 -- Sem_Ch8, and the expansion can interfere with this error check.
7633 then
7637 -- Otherwise, proceed with processing tagged conversion
7639 declare
7646 -- Create a membership check to test whether Operand is a member
7647 -- of Targ_Typ. If the original Target_Type is an access, include
7648 -- a test for null value. The check is inserted at N.
7650 --------------------
7651 -- Make_Tag_Check --
7652 --------------------
7657 begin
7658 -- Generate:
7659 -- [Constraint_Error
7660 -- when Operand /= null
7661 -- and then Operand.all not in Targ_Typ]
7664 Cond :=
7666 Left_Opnd =>
7671 Right_Opnd =>
7673 Left_Opnd =>
7678 -- Generate:
7679 -- [Constraint_Error when Operand not in Targ_Typ]
7681 else
7682 Cond :=
7694 -- Start of processing
7696 begin
7701 else
7708 -- Ada 2005 (AI-251): Handle interface type conversion
7717 -- Create a runtime tag check for a downward class-wide type
7718 -- conversion.
7723 then
7728 -- AI05-0073: If the result subtype of the function is defined
7729 -- by an access_definition designating a specific tagged type
7730 -- T, a check is made that the result value is null or the tag
7731 -- of the object designated by the result value identifies T.
7732 -- Constraint_Error is raised if this check fails.
7735 declare
7739 begin
7740 -- Climb scope stack looking for the enclosing function
7745 loop
7749 -- The function's return subtype must be defined using
7750 -- an access definition.
7753 N_Access_Definition
7754 then
7757 -- The return subtype denotes a specific tagged type,
7758 -- in other words, a non class-wide type.
7762 then
7770 -- We have generated a tag check for either a class-wide type
7771 -- conversion or for AI05-0073.
7774 declare
7776 begin
7777 Conv :=
7788 -- Case of other access type conversions
7793 -- Case of conversions from a fixed-point type
7795 -- These conversions require special expansion and processing, found in
7796 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
7797 -- since from a semantic point of view, these are simple integer
7798 -- conversions, which do not need further processing.
7802 then
7803 -- We should never see universal fixed at this case, since the
7804 -- expansion of the constituent divide or multiply should have
7805 -- eliminated the explicit mention of universal fixed.
7809 -- Check for special case of the conversion to universal real that
7810 -- occurs as a result of the use of a round attribute. In this case,
7811 -- the real type for the conversion is taken from the target type of
7812 -- the Round attribute and the result must be marked as rounded.
7817 then
7822 -- Otherwise do correct fixed-conversion, but skip these if the
7823 -- Conversion_OK flag is set, because from a semantic point of
7824 -- view these are simple integer conversions needing no further
7825 -- processing (the backend will simply treat them as integers)
7830 Real_Range_Check;
7835 else
7838 Real_Range_Check;
7842 -- Case of conversions to a fixed-point type
7844 -- These conversions require special expansion and processing, found in
7845 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
7846 -- since from a semantic point of view, these are simple integer
7847 -- conversions, which do not need further processing.
7851 then
7854 Real_Range_Check;
7855 else
7858 Real_Range_Check;
7861 -- Case of float-to-integer conversions
7863 -- We also handle float-to-fixed conversions with Conversion_OK set
7864 -- since semantically the fixed-point target is treated as though it
7865 -- were an integer in such cases.
7868 and then
7870 or else
7872 then
7873 -- One more check here, gcc is still not able to do conversions of
7874 -- this type with proper overflow checking, and so gigi is doing an
7875 -- approximation of what is required by doing floating-point compares
7876 -- with the end-point. But that can lose precision in some cases, and
7877 -- give a wrong result. Converting the operand to Universal_Real is
7878 -- helpful, but still does not catch all cases with 64-bit integers
7879 -- on targets with only 64-bit floats
7881 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
7882 -- Can this code be removed ???
7887 Subtype_Mark =>
7889 Expression =>
7897 -- Case of array conversions
7899 -- Expansion of array conversions, add required length/range checks but
7900 -- only do this if there is no change of representation. For handling of
7901 -- this case, see Handle_Changed_Representation.
7907 else
7911 Handle_Changed_Representation;
7913 -- Case of conversions of discriminated types
7915 -- Add required discriminant checks if target is constrained. Again this
7916 -- change is skipped if we have a change of representation.
7920 then
7922 Handle_Changed_Representation;
7924 -- Case of all other record conversions. The only processing required
7925 -- is to check for a change of representation requiring the special
7926 -- assignment processing.
7930 -- Ada 2005 (AI-216): Program_Error is raised when converting from
7931 -- a derived Unchecked_Union type to an unconstrained type that is
7932 -- not Unchecked_Union if the operand lacks inferable discriminants.
7939 then
7940 -- To prevent Gigi from generating illegal code, we generate a
7941 -- Program_Error node, but we give it the target type of the
7942 -- conversion.
7944 declare
7948 begin
7953 else
7954 Handle_Changed_Representation;
7957 -- Case of conversions of enumeration types
7961 -- Special processing is required if there is a change of
7962 -- representation (from enumeration representation clauses)
7966 -- Convert: x(y) to x'val (ytyp'val (y))
7981 -- Case of conversions to floating-point
7984 Real_Range_Check;
7987 -- At this stage, either the conversion node has been transformed into
7988 -- some other equivalent expression, or left as a conversion that can
7989 -- be handled by Gigi. The conversions that Gigi can handle are the
7990 -- following:
7992 -- Conversions with no change of representation or type
7994 -- Numeric conversions involving integer, floating- and fixed-point
7995 -- values. Fixed-point values are allowed only if Conversion_OK is
7996 -- set, i.e. if the fixed-point values are to be treated as integers.
7998 -- No other conversions should be passed to Gigi
8000 -- Check: are these rules stated in sinfo??? if so, why restate here???
8002 -- The only remaining step is to generate a range check if we still have
8003 -- a type conversion at this stage and Do_Range_Check is set. For now we
8004 -- do this only for conversions of discrete types.
8008 then
8009 declare
8014 begin
8017 then
8020 -- Before we do a range check, we have to deal with treating a
8021 -- fixed-point operand as an integer. The way we do this is
8022 -- simply to do an unchecked conversion to an appropriate
8023 -- integer type large enough to hold the result.
8025 -- This code is not active yet, because we are only dealing
8026 -- with discrete types so far ???
8030 then
8035 else
8042 -- Reset overflow flag, since the range check will include
8043 -- dealing with possible overflow, and generate the check If
8044 -- Address is either a source type or target type, suppress
8045 -- range check to avoid typing anomalies when it is a visible
8046 -- integer type.
8051 then
8052 Generate_Range_Check
8059 -- Final step, if the result is a type conversion involving Vax_Float
8060 -- types, then it is subject for further special processing.
8064 then
8070 -----------------------------------
8071 -- Expand_N_Unchecked_Expression --
8072 -----------------------------------
8074 -- Remove the unchecked expression node from the tree. It's job was simply
8075 -- to make sure that its constituent expression was handled with checks
8076 -- off, and now that that is done, we can remove it from the tree, and
8077 -- indeed must, since gigi does not expect to see these nodes.
8082 begin
8087 ----------------------------------------
8088 -- Expand_N_Unchecked_Type_Conversion --
8089 ----------------------------------------
8091 -- If this cannot be handled by Gigi and we haven't already made a
8092 -- temporary for it, do it now.
8099 begin
8100 -- If we have a conversion of a compile time known value to a target
8101 -- type and the value is in range of the target type, then we can simply
8102 -- replace the construct by an integer literal of the correct type. We
8103 -- only apply this to integer types being converted. Possibly it may
8104 -- apply in other cases, but it is too much trouble to worry about.
8106 -- Note that we do not do this transformation if the Kill_Range_Check
8107 -- flag is set, since then the value may be outside the expected range.
8108 -- This happens in the Normalize_Scalars case.
8110 -- We also skip this if either the target or operand type is biased
8111 -- because in this case, the unchecked conversion is supposed to
8112 -- preserve the bit pattern, not the integer value.
8120 then
8121 declare
8124 begin
8126 and then
8128 and then
8130 and then
8132 then
8135 -- If Address is the target type, just set the type to avoid a
8136 -- spurious type error on the literal when Address is a visible
8137 -- integer type.
8141 else
8150 -- Nothing to do if conversion is safe
8156 -- Otherwise force evaluation unless Assignment_OK flag is set (this
8157 -- flag indicates ??? -- more comments needed here)
8161 else
8166 ----------------------------
8167 -- Expand_Record_Equality --
8168 ----------------------------
8170 -- For non-variant records, Equality is expanded when needed into:
8172 -- and then Lhs.Discr1 = Rhs.Discr1
8173 -- and then ...
8174 -- and then Lhs.Discrn = Rhs.Discrn
8175 -- and then Lhs.Cmp1 = Rhs.Cmp1
8176 -- and then ...
8177 -- and then Lhs.Cmpn = Rhs.Cmpn
8179 -- The expression is folded by the back-end for adjacent fields. This
8180 -- function is called for tagged record in only one occasion: for imple-
8181 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
8182 -- otherwise the primitive "=" is used directly.
8184 function Expand_Record_Equality
8190 is
8199 -- Return the first field to compare beginning with C, skipping the
8200 -- inherited components.
8202 ----------------------
8203 -- Suitable_Element --
8204 ----------------------
8207 begin
8213 then
8218 then
8223 then
8229 else
8234 -- Start of processing for Expand_Record_Equality
8236 begin
8237 -- Generates the following code: (assuming that Typ has one Discr and
8238 -- component C2 is also a record)
8240 -- True
8241 -- and then Lhs.Discr1 = Rhs.Discr1
8242 -- and then Lhs.C1 = Rhs.C1
8243 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8244 -- and then ...
8245 -- and then Lhs.Cmpn = Rhs.Cmpn
8251 declare
8256 begin
8261 else
8266 Check :=
8268 Lhs =>
8272 Rhs =>
8278 -- If some (sub)component is an unchecked_union, the whole
8279 -- operation will raise program error.
8285 else
8286 Result :=
8299 -------------------------------------
8300 -- Fixup_Universal_Fixed_Operation --
8301 -------------------------------------
8306 begin
8307 -- We must have a type conversion immediately above us
8311 -- Normally the type conversion gives our target type. The exception
8312 -- occurs in the case of the Round attribute, where the conversion
8313 -- will be to universal real, and our real type comes from the Round
8314 -- attribute (as well as an indication that we must round the result)
8318 then
8322 -- Normal case where type comes from conversion above us
8324 else
8329 ------------------------------
8330 -- Get_Allocator_Final_List --
8331 ------------------------------
8333 function Get_Allocator_Final_List
8337 is
8341 -- The entity whose finalization list must be used to attach the
8342 -- allocated object.
8344 begin
8347 -- If the context is an access parameter, we need to create a
8348 -- non-anonymous access type in order to have a usable final list,
8349 -- because there is otherwise no pool to which the allocated object
8350 -- can belong. We create both the type and the finalization chain
8351 -- here, because freezing an internal type does not create such a
8352 -- chain. The Final_Chain that is thus created is shared by the
8353 -- access parameter. The access type is tested against the result
8354 -- type of the function to exclude allocators whose type is an
8355 -- anonymous access result type.
8358 in N_Subprogram_Specification
8359 and then
8360 PtrT /=
8362 then
8367 Type_Definition =>
8369 Subtype_Indication =>
8375 -- Ada 2005 (AI-318-02): If the context is a return object
8376 -- declaration, then the anonymous return subtype is defined to have
8377 -- the same accessibility level as that of the function's result
8378 -- subtype, which means that we want the scope where the function is
8379 -- declared.
8383 then
8386 -- Case of an access discriminant, or (Ada 2005), of an anonymous
8387 -- access component or anonymous access function result: find the
8388 -- final list associated with the scope of the type. (In the
8389 -- anonymous access component kind, a list controller will have
8390 -- been allocated when freezing the record type, and PtrT has an
8391 -- Associated_Final_Chain attribute designating it.)
8401 ---------------------------------
8402 -- Has_Inferable_Discriminants --
8403 ---------------------------------
8408 -- Determines whether the left-most prefix of a selected component is a
8409 -- formal parameter in a subprogram. Assumes N is a selected component.
8411 --------------------------------
8412 -- Prefix_Is_Formal_Parameter --
8413 --------------------------------
8418 begin
8419 -- Move to the left-most prefix by climbing up the tree
8423 loop
8430 -- Start of processing for Has_Inferable_Discriminants
8432 begin
8433 -- For identifiers and indexed components, it is sufficient to have a
8434 -- constrained Unchecked_Union nominal subtype.
8438 and then
8441 -- For selected components, the subtype of the selector must be a
8442 -- constrained Unchecked_Union. If the component is subject to a
8443 -- per-object constraint, then the enclosing object must have inferable
8444 -- discriminants.
8449 -- A small hack. If we have a per-object constrained selected
8450 -- component of a formal parameter, return True since we do not
8451 -- know the actual parameter association yet.
8457 -- Otherwise, check the enclosing object and the selector
8460 and then
8464 -- The call to Has_Inferable_Discriminants will determine whether
8465 -- the selector has a constrained Unchecked_Union nominal type.
8469 -- A qualified expression has inferable discriminants if its subtype
8470 -- mark is a constrained Unchecked_Union subtype.
8474 and then
8482 -------------------------------
8483 -- Insert_Dereference_Action --
8484 -------------------------------
8493 -- Return true if type of P is derived from Checked_Pool;
8495 -----------------------------
8496 -- Is_Checked_Storage_Pool --
8497 -----------------------------
8502 begin
8511 else
8519 -- Start of processing for Insert_Dereference_Action
8521 begin
8526 then
8537 -- Pool
8541 -- Storage_Address. We use the attribute Pool_Address, which uses
8542 -- the pointer itself to find the address of the object, and which
8543 -- handles unconstrained arrays properly by computing the address
8544 -- of the template. i.e. the correct address of the corresponding
8545 -- allocation.
8551 -- Size_In_Storage_Elements
8554 Left_Opnd =>
8556 Prefix =>
8560 Right_Opnd =>
8563 -- Alignment
8566 Prefix =>
8571 exception
8576 ------------------------------
8577 -- Make_Array_Comparison_Op --
8578 ------------------------------
8580 -- This is a hand-coded expansion of the following generic function:
8582 -- generic
8583 -- type elem is (<>);
8584 -- type index is (<>);
8585 -- type a is array (index range <>) of elem;
8587 -- function Gnnn (X : a; Y: a) return boolean is
8588 -- J : index := Y'first;
8590 -- begin
8591 -- if X'length = 0 then
8592 -- return false;
8594 -- elsif Y'length = 0 then
8595 -- return true;
8597 -- else
8598 -- for I in X'range loop
8599 -- if X (I) = Y (J) then
8600 -- if J = Y'last then
8601 -- exit;
8602 -- else
8603 -- J := index'succ (J);
8604 -- end if;
8606 -- else
8607 -- return X (I) > Y (J);
8608 -- end if;
8609 -- end loop;
8611 -- return X'length > Y'length;
8612 -- end if;
8613 -- end Gnnn;
8615 -- Note that since we are essentially doing this expansion by hand, we
8616 -- do not need to generate an actual or formal generic part, just the
8617 -- instantiated function itself.
8619 function Make_Array_Comparison_Op
8622 is
8643 begin
8644 -- if J = Y'last then
8645 -- exit;
8646 -- else
8647 -- J := index'succ (J);
8648 -- end if;
8650 Inner_If :=
8652 Condition =>
8655 Right_Opnd =>
8663 Else_Statements =>
8664 New_List (
8667 Expression =>
8673 -- if X (I) = Y (J) then
8674 -- if ... end if;
8675 -- else
8676 -- return X (I) > Y (J);
8677 -- end if;
8679 Loop_Body :=
8681 Condition =>
8683 Left_Opnd =>
8688 Right_Opnd =>
8697 Expression =>
8699 Left_Opnd =>
8704 Right_Opnd =>
8710 -- for I in X'range loop
8711 -- if ... end if;
8712 -- end loop;
8714 Loop_Statement :=
8718 Iteration_Scheme =>
8720 Loop_Parameter_Specification =>
8723 Discrete_Subtype_Definition =>
8730 -- if X'length = 0 then
8731 -- return false;
8732 -- elsif Y'length = 0 then
8733 -- return true;
8734 -- else
8735 -- for ... loop ... end loop;
8736 -- return X'length > Y'length;
8737 -- end if;
8739 Length1 :=
8744 Length2 :=
8749 Final_Expr :=
8754 If_Stat :=
8756 Condition =>
8758 Left_Opnd =>
8762 Right_Opnd =>
8765 Then_Statements =>
8766 New_List (
8772 Condition =>
8774 Left_Opnd =>
8778 Right_Opnd =>
8781 Then_Statements =>
8782 New_List (
8787 Loop_Statement,
8791 -- (X : a; Y: a)
8802 -- function Gnnn (...) return boolean is
8803 -- J : index := Y'first;
8804 -- begin
8805 -- if ... end if;
8806 -- end Gnnn;
8810 Func_Body :=
8812 Specification =>
8822 Expression =>
8827 Handled_Statement_Sequence =>
8834 ---------------------------
8835 -- Make_Boolean_Array_Op --
8836 ---------------------------
8838 -- For logical operations on boolean arrays, expand in line the following,
8839 -- replacing 'and' with 'or' or 'xor' where needed:
8841 -- function Annn (A : typ; B: typ) return typ is
8842 -- C : typ;
8843 -- begin
8844 -- for J in A'range loop
8845 -- C (J) := A (J) op B (J);
8846 -- end loop;
8847 -- return C;
8848 -- end Annn;
8850 -- Here typ is the boolean array type
8852 function Make_Boolean_Array_Op
8855 is
8873 begin
8874 A_J :=
8879 B_J :=
8884 C_J :=
8890 Op :=
8896 Op :=
8901 else
8902 Op :=
8908 Loop_Statement :=
8912 Iteration_Scheme =>
8914 Loop_Parameter_Specification =>
8917 Discrete_Subtype_Definition =>
8936 Func_Name :=
8940 Func_Body :=
8942 Specification =>
8953 Handled_Statement_Sequence =>
8956 Loop_Statement,
8963 ------------------------
8964 -- Rewrite_Comparison --
8965 ------------------------
8968 begin
8977 declare
8983 -- Res indicates if compare outcome can be compile time determined
8988 begin
8999 and then Constant_Condition_Warnings
9002 and then not In_Instance
9005 then
9006 Error_Msg_N
9023 and then Constant_Condition_Warnings
9026 and then not In_Instance
9029 then
9030 Error_Msg_N
9056 ----------------------------
9057 -- Safe_In_Place_Array_Op --
9058 ----------------------------
9060 function Safe_In_Place_Array_Op
9064 is
9068 -- Operand is safe if it cannot overlap part of the target of the
9069 -- operation. If the operand and the target are identical, the operand
9070 -- is safe. The operand can be empty in the case of negation.
9073 -- Check that N is a stand-alone entity
9075 ------------------
9076 -- Is_Unaliased --
9077 ------------------
9080 begin
9081 return
9087 ---------------------
9088 -- Is_Safe_Operand --
9089 ---------------------
9092 begin
9103 return
9110 else
9115 -- Start of processing for Is_Safe_In_Place_Array_Op
9117 begin
9118 -- Skip this processing if the component size is different from system
9119 -- storage unit (since at least for NOT this would cause problems).
9124 -- Cannot do in place stuff on VM_Target since cannot pass addresses
9129 -- Cannot do in place stuff if non-standard Boolean representation
9136 else
9139 return
9145 -----------------------
9146 -- Tagged_Membership --
9147 -----------------------
9149 -- There are two different cases to consider depending on whether the right
9150 -- operand is a class-wide type or not. If not we just compare the actual
9151 -- tag of the left expr to the target type tag:
9152 --
9153 -- Left_Expr.Tag = Right_Type'Tag;
9154 --
9155 -- If it is a class-wide type we use the RT function CW_Membership which is
9156 -- usually implemented by looking in the ancestor tables contained in the
9157 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
9159 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9160 -- function IW_Membership which is usually implemented by looking in the
9161 -- table of abstract interface types plus the ancestor table contained in
9162 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9173 begin
9181 Obj_Tag :=
9184 Selector_Name =>
9189 -- No need to issue a run-time check if we statically know that the
9190 -- result of this membership test is always true. For example,
9191 -- considering the following declarations:
9193 -- type Iface is interface;
9194 -- type T is tagged null record;
9195 -- type DT is new T and Iface with null record;
9197 -- Obj1 : T;
9198 -- Obj2 : DT;
9200 -- These membership tests are always true:
9202 -- Obj1 in T'Class
9203 -- Obj2 in T'Class;
9204 -- Obj2 in Iface'Class;
9206 -- We do not need to handle cases where the membership is illegal.
9207 -- For example:
9209 -- Obj1 in DT'Class; -- Compile time error
9210 -- Obj1 in Iface'Class; -- Compile time error
9215 and then Interface_Present_In_Ancestor
9218 then
9222 -- Ada 2005 (AI-251): Class-wide applied to interfaces
9226 -- Support to: "Iface_CW_Typ in Typ'Class"
9229 then
9230 -- Issue error if IW_Membership operation not available in a
9231 -- configurable run time setting.
9234 Error_Msg_CRT
9239 return
9246 New_Reference_To (
9247 Node (First_Elmt
9249 Loc)));
9251 -- Ada 95: Normal case
9253 else
9254 return
9257 Typ_Tag_Node =>
9258 New_Reference_To (
9259 Node (First_Elmt
9261 Loc));
9264 -- Right_Type is not a class-wide type
9266 else
9267 -- No need to check the tag of the object if Right_Typ is abstract
9272 else
9273 return
9276 Right_Opnd =>
9277 New_Reference_To
9283 ------------------------------
9284 -- Unary_Op_Validity_Checks --
9285 ------------------------------
9288 begin