| blob | 9309c4850489519b9760c2e626e1a92735efa72d |
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
949 then
955 then
956 -- Apply constraint to designated subtype indication
964 -- Propagate constraint_error to enclosing allocator
968 else
969 -- First check against the type of the qualified expression
970 --
971 -- NOTE: The commented call should be correct, but for some reason
972 -- causes the compiler to bomb (sigsegv) on ACVC test c34007g, so for
973 -- now we just perform the old (incorrect) test against the
974 -- designated subtype with no sliding in the else part of the if
975 -- statement below. ???
976 --
977 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
979 -- A check is also needed in cases where the designated subtype is
980 -- constrained and differs from the subtype given in the qualified
981 -- expression. Note that the check on the qualified expression does
982 -- not allow sliding, but this check does (a relaxation from Ada 83).
986 then
987 Apply_Constraint_Check
990 -- The nonsliding check should really be performed (unconditionally)
991 -- against the subtype of the qualified expression, but that causes a
992 -- problem with c34007g (see above), so for now we retain this.
994 else
995 Apply_Constraint_Check
999 -- For an access to unconstrained packed array, GIGI needs to see an
1000 -- expression with a constrained subtype in order to compute the
1001 -- proper size for the allocator.
1006 then
1007 declare
1012 begin
1016 Subtype_Indication =>
1023 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1024 -- to a build-in-place function, then access to the allocated object
1025 -- must be passed to the function. Currently we limit such functions
1026 -- to those with constrained limited result subtypes, but eventually
1027 -- we plan to expand the allowed forms of functions that are treated
1028 -- as build-in-place.
1032 then
1037 exception
1042 -----------------------------
1043 -- Expand_Array_Comparison --
1044 -----------------------------
1046 -- Expansion is only required in the case of array types. For the unpacked
1047 -- case, an appropriate runtime routine is called. For packed cases, and
1048 -- also in some other cases where a runtime routine cannot be called, the
1049 -- form of the expansion is:
1051 -- [body for greater_nn; boolean_expression]
1053 -- The body is built by Make_Array_Comparison_Op, and the form of the
1054 -- Boolean expression depends on the operator involved.
1070 -- True for byte addressable target
1073 -- Returns True if the length of the given operand is known to be less
1074 -- than 4. Returns False if this length is known to be four or greater
1075 -- or is not known at compile time.
1077 ------------------------
1078 -- Length_Less_Than_4 --
1079 ------------------------
1084 begin
1088 else
1089 declare
1096 begin
1099 else
1105 else
1114 -- Start of processing for Expand_Array_Comparison
1116 begin
1117 -- Deal first with unpacked case, where we can call a runtime routine
1118 -- except that we avoid this for targets for which are not addressable
1119 -- by bytes, and for the JVM/CIL, since they do not support direct
1120 -- addressing of array components.
1123 and then Byte_Addressable
1125 then
1126 -- The call we generate is:
1128 -- Compare_Array_xn[_Unaligned]
1129 -- (left'address, right'address, left'length, right'length) <op> 0
1131 -- x = U for unsigned, S for signed
1132 -- n = 8,16,32,64 for component size
1133 -- Add _Unaligned if length < 4 and component size is 8.
1134 -- <op> is the standard comparison operator
1138 or else
1140 then
1143 else
1147 else
1150 else
1158 else
1165 else
1172 else
1210 -- Cases where we cannot make runtime call
1212 -- For (a <= b) we convert to not (a > b)
1217 Right_Opnd =>
1224 -- For < the Boolean expression is
1225 -- greater__nn (op2, op1)
1230 -- Switch operands
1235 -- For (a >= b) we convert to not (a < b)
1240 Right_Opnd =>
1247 -- For > the Boolean expression is
1248 -- greater__nn (op1, op2)
1250 else
1256 Expr :=
1265 exception
1270 ---------------------------
1271 -- Expand_Array_Equality --
1272 ---------------------------
1274 -- Expand an equality function for multi-dimensional arrays. Here is an
1275 -- example of such a function for Nb_Dimension = 2
1277 -- function Enn (A : atyp; B : btyp) return boolean is
1278 -- begin
1279 -- if (A'length (1) = 0 or else A'length (2) = 0)
1280 -- and then
1281 -- (B'length (1) = 0 or else B'length (2) = 0)
1282 -- then
1283 -- return True; -- RM 4.5.2(22)
1284 -- end if;
1286 -- if A'length (1) /= B'length (1)
1287 -- or else
1288 -- A'length (2) /= B'length (2)
1289 -- then
1290 -- return False; -- RM 4.5.2(23)
1291 -- end if;
1293 -- declare
1294 -- A1 : Index_T1 := A'first (1);
1295 -- B1 : Index_T1 := B'first (1);
1296 -- begin
1297 -- loop
1298 -- declare
1299 -- A2 : Index_T2 := A'first (2);
1300 -- B2 : Index_T2 := B'first (2);
1301 -- begin
1302 -- loop
1303 -- if A (A1, A2) /= B (B1, B2) then
1304 -- return False;
1305 -- end if;
1307 -- exit when A2 = A'last (2);
1308 -- A2 := Index_T2'succ (A2);
1309 -- B2 := Index_T2'succ (B2);
1310 -- end loop;
1311 -- end;
1313 -- exit when A1 = A'last (1);
1314 -- A1 := Index_T1'succ (A1);
1315 -- B1 := Index_T1'succ (B1);
1316 -- end loop;
1317 -- end;
1319 -- return true;
1320 -- end Enn;
1322 -- Note on the formal types used (atyp and btyp). If either of the arrays
1323 -- is of a private type, we use the underlying type, and do an unchecked
1324 -- conversion of the actual. If either of the arrays has a bound depending
1325 -- on a discriminant, then we use the base type since otherwise we have an
1326 -- escaped discriminant in the function.
1328 -- If both arrays are constrained and have the same bounds, we can generate
1329 -- a loop with an explicit iteration scheme using a 'Range attribute over
1330 -- the first array.
1332 function Expand_Array_Equality
1338 is
1354 -- The parameter types to be used for the formals
1356 function Arr_Attr
1360 -- This builds the attribute reference Arr'Nam (Expr)
1363 -- Create one statement to compare corresponding components, designated
1364 -- by a full set of indices.
1367 -- Given one of the arguments, computes the appropriate type to be used
1368 -- for that argument in the corresponding function formal
1370 function Handle_One_Dimension
1373 -- This procedure returns the following code
1374 --
1375 -- declare
1376 -- Bn : Index_T := B'First (N);
1377 -- begin
1378 -- loop
1379 -- xxx
1380 -- exit when An = A'Last (N);
1381 -- An := Index_T'Succ (An)
1382 -- Bn := Index_T'Succ (Bn)
1383 -- end loop;
1384 -- end;
1385 --
1386 -- If both indices are constrained and identical, the procedure
1387 -- returns a simpler loop:
1388 --
1389 -- for An in A'Range (N) loop
1390 -- xxx
1391 -- end loop
1392 --
1393 -- N is the dimension for which we are generating a loop. Index is the
1394 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1395 -- xxx statement is either the loop or declare for the next dimension
1396 -- or if this is the last dimension the comparison of corresponding
1397 -- components of the arrays.
1398 --
1399 -- The actual way the code works is to return the comparison of
1400 -- corresponding components for the N+1 call. That's neater!
1403 -- This function constructs the test for both arrays being empty
1404 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1405 -- and then
1406 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1409 -- This function constructs the test for arrays having different lengths
1410 -- in at least one index position, in which case the resulting code is:
1412 -- A'length (1) /= B'length (1)
1413 -- or else
1414 -- A'length (2) /= B'length (2)
1415 -- or else
1416 -- ...
1418 --------------
1419 -- Arr_Attr --
1420 --------------
1422 function Arr_Attr
1426 is
1427 begin
1428 return
1435 ------------------------
1436 -- Component_Equality --
1437 ------------------------
1443 begin
1444 -- if a(i1...) /= b(j1...) then return false; end if;
1446 L :=
1451 R :=
1456 Test := Expand_Composite_Equality
1459 -- If some (sub)component is an unchecked_union, the whole operation
1460 -- will raise program error.
1464 -- This node is going to be inserted at a location where a
1465 -- statement is expected: clear its Etype so analysis will set
1466 -- it to the expected Standard_Void_Type.
1471 else
1472 return
1481 ------------------
1482 -- Get_Arg_Type --
1483 ------------------
1489 begin
1495 else
1501 or else
1503 then
1515 --------------------------
1516 -- Handle_One_Dimension --
1517 ---------------------------
1519 function Handle_One_Dimension
1522 is
1524 Ltyp /= Rtyp
1526 -- If the index types are identical, and we are working with
1527 -- constrained types, then we can use the same index for both
1528 -- of the arrays.
1538 begin
1543 -- Case where we generate a loop
1548 Bn :=
1551 else
1563 -- Generate guard for loop, followed by increments of indices
1567 Condition =>
1575 Expression =>
1584 Expression =>
1591 -- If separate indexes, we need a declare block for An and Bn, and a
1592 -- loop without an iteration scheme.
1595 Loop_Stm :=
1598 return
1611 Handled_Statement_Sequence =>
1615 -- If no separate indexes, return loop statement with explicit
1616 -- iteration scheme on its own
1618 else
1619 Loop_Stm :=
1622 Iteration_Scheme =>
1624 Loop_Parameter_Specification =>
1627 Discrete_Subtype_Definition =>
1633 -----------------------
1634 -- Test_Empty_Arrays --
1635 -----------------------
1644 begin
1648 Atest :=
1653 Btest :=
1662 else
1663 Alist :=
1668 Blist :=
1675 return
1681 -----------------------------
1682 -- Test_Lengths_Correspond --
1683 -----------------------------
1689 begin
1692 Rtest :=
1699 else
1700 Result :=
1710 -- Start of processing for Expand_Array_Equality
1712 begin
1716 -- For now, if the argument types are not the same, go to the base type,
1717 -- since the code assumes that the formals have the same type. This is
1718 -- fixable in future ???
1726 -- Build list of formals for function
1739 -- Build statement sequence for function
1741 Func_Body :=
1743 Specification =>
1751 Handled_Statement_Sequence =>
1759 Expression =>
1766 Expression =>
1777 -- If the array type is distinct from the type of the arguments, it
1778 -- is the full view of a private type. Apply an unchecked conversion
1779 -- to insure that analysis of the call succeeds.
1781 declare
1784 begin
1790 then
1796 then
1805 return
1811 -----------------------------
1812 -- Expand_Boolean_Operator --
1813 -----------------------------
1815 -- Note that we first get the actual subtypes of the operands, since we
1816 -- always want to deal with types that have bounds.
1821 begin
1822 -- Special case of bit packed array where both operands are known to be
1823 -- properly aligned. In this case we use an efficient run time routine
1824 -- to carry out the operation (see System.Bit_Ops).
1829 then
1834 -- For the normal non-packed case, the general expansion is to build
1835 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1836 -- and then inserting it into the tree. The original operator node is
1837 -- then rewritten as a call to this function. We also use this in the
1838 -- packed case if either operand is a possibly unaligned object.
1840 declare
1847 begin
1860 then
1865 and then
1867 then
1869 else
1875 -- Now rewrite the expression with a call
1880 Parameter_Associations =>
1881 New_List (
1882 L,
1883 Make_Type_Conversion
1891 -------------------------------
1892 -- Expand_Composite_Equality --
1893 -------------------------------
1895 -- This function is only called for comparing internal fields of composite
1896 -- types when these fields are themselves composites. This is a special
1897 -- case because it is not possible to respect normal Ada visibility rules.
1899 function Expand_Composite_Equality
1905 is
1911 begin
1914 else
1918 -- Defense against malformed private types with no completion the error
1919 -- will be diagnosed later by check_completion
1929 -- If the operand is an elementary type other than a floating-point
1930 -- type, then we can simply use the built-in block bitwise equality,
1931 -- since the predefined equality operators always apply and bitwise
1932 -- equality is fine for all these cases.
1936 then
1939 -- For composite component types, and floating-point types, use the
1940 -- expansion. This deals with tagged component types (where we use
1941 -- the applicable equality routine) and floating-point, (where we
1942 -- need to worry about negative zeroes), and also the case of any
1943 -- composite type recursively containing such fields.
1945 else
1951 -- Call the primitive operation "=" of this type
1957 -- If this is derived from an untagged private type completed with a
1958 -- tagged type, it does not have a full view, so we use the primitive
1959 -- operations of the private type. This check should no longer be
1960 -- necessary when these types receive their full views ???
1967 then
1969 else
1973 loop
1985 return
1988 Parameter_Associations =>
1989 New_List
1999 -- Inherited equality from parent type. Convert the actuals to
2000 -- match signature of operation.
2002 declare
2005 begin
2006 return
2009 Parameter_Associations =>
2014 else
2015 -- Comparison between Unchecked_Union components
2018 declare
2024 begin
2025 -- Lhs subtype
2031 -- Rhs subtype
2037 -- Lhs of the composite equality
2041 -- Since the enclosing record type can never be an
2042 -- Unchecked_Union (this code is executed for records
2043 -- that do not have variants), we may reference its
2044 -- discriminant(s).
2049 then
2050 Lhs_Discr_Val :=
2053 Selector_Name =>
2054 New_Copy (
2055 Get_Discriminant_Value (
2057 Lhs_Type,
2060 else
2062 Get_Discriminant_Value (
2064 Lhs_Type,
2068 else
2069 -- It is not possible to infer the discriminant since
2070 -- the subtype is not constrained.
2072 return
2077 -- Rhs of the composite equality
2083 then
2084 Rhs_Discr_Val :=
2087 Selector_Name =>
2088 New_Copy (
2089 Get_Discriminant_Value (
2091 Rhs_Type,
2094 else
2096 Get_Discriminant_Value (
2098 Rhs_Type,
2102 else
2103 return
2108 -- Call the TSS equality function with the inferred
2109 -- discriminant values.
2111 return
2115 Lhs,
2116 Rhs,
2117 Lhs_Discr_Val,
2118 Rhs_Discr_Val));
2122 -- Shouldn't this be an else, we can't fall through the above
2123 -- IF, right???
2125 return
2131 else
2135 else
2136 -- It can be a simple record or the full view of a scalar private
2142 ------------------------------
2143 -- Expand_Concatenate_Other --
2144 ------------------------------
2146 -- Let n be the number of array operands to be concatenated, Base_Typ their
2147 -- base type, Ind_Typ their index type, and Arr_Typ the original array type
2148 -- to which the concatenation operator applies, then the following
2149 -- subprogram is constructed:
2151 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
2152 -- L : Ind_Typ;
2153 -- begin
2154 -- if S1'Length /= 0 then
2155 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
2156 -- XXX = Arr_Typ'First otherwise
2157 -- elsif S2'Length /= 0 then
2158 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
2159 -- YYY = Arr_Typ'First otherwise
2160 -- ...
2161 -- elsif Sn-1'Length /= 0 then
2162 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
2163 -- ZZZ = Arr_Typ'First otherwise
2164 -- else
2165 -- return Sn;
2166 -- end if;
2168 -- declare
2169 -- P : Ind_Typ;
2170 -- H : Ind_Typ :=
2171 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
2172 -- + Ind_Typ'Pos (L));
2173 -- R : Base_Typ (L .. H);
2174 -- begin
2175 -- if S1'Length /= 0 then
2176 -- P := S1'First;
2177 -- loop
2178 -- R (L) := S1 (P);
2179 -- L := Ind_Typ'Succ (L);
2180 -- exit when P = S1'Last;
2181 -- P := Ind_Typ'Succ (P);
2182 -- end loop;
2183 -- end if;
2184 --
2185 -- if S2'Length /= 0 then
2186 -- L := Ind_Typ'Succ (L);
2187 -- loop
2188 -- R (L) := S2 (P);
2189 -- L := Ind_Typ'Succ (L);
2190 -- exit when P = S2'Last;
2191 -- P := Ind_Typ'Succ (P);
2192 -- end loop;
2193 -- end if;
2195 -- ...
2197 -- if Sn'Length /= 0 then
2198 -- P := Sn'First;
2199 -- loop
2200 -- R (L) := Sn (P);
2201 -- L := Ind_Typ'Succ (L);
2202 -- exit when P = Sn'Last;
2203 -- P := Ind_Typ'Succ (P);
2204 -- end loop;
2205 -- end if;
2207 -- return R;
2208 -- end;
2209 -- end Cnn;]
2248 -- Builds the sequence of statement:
2249 -- P := Si'First;
2250 -- loop
2251 -- R (L) := Si (P);
2252 -- L := Ind_Typ'Succ (L);
2253 -- exit when P = Si'Last;
2254 -- P := Ind_Typ'Succ (P);
2255 -- end loop;
2256 --
2257 -- where i is the input parameter I given.
2258 -- If the flag Last is true, the exit statement is emitted before
2259 -- incrementing the lower bound, to prevent the creation out of
2260 -- bound values.
2263 -- Builds the statement:
2264 -- L := Arr_Typ'First; If Arr_Typ is constrained
2265 -- L := Si'First; otherwise (where I is the input param given)
2268 -- Builds reference to identifier H
2271 -- Builds expression Ind_Typ'Val (E);
2274 -- Builds reference to identifier L
2277 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
2278 -- expression to avoid universal_integer computations whenever possible,
2279 -- in the expression for the upper bound H.
2282 -- Builds expression Ind_Typ'Succ (L)
2285 -- Builds integer literal one
2288 -- Builds reference to identifier P
2291 -- Builds expression Ind_Typ'Succ (P)
2294 -- Builds reference to identifier R
2297 -- Builds reference to identifier Si, where I is the value given
2300 -- Builds expression Si'First, where I is the value given
2303 -- Builds expression Si'Last, where I is the value given
2306 -- Builds expression Si'Length, where I is the value given
2309 -- Builds expression Si'Length /= 0, where I is the value given
2311 -------------------
2312 -- Copy_Into_R_S --
2313 -------------------
2324 begin
2325 -- First construct the initializations
2332 -- Then build the loop
2354 Loop_Stmt :=
2357 else
2358 Loop_Stmt :=
2368 -------
2369 -- H --
2370 -------
2373 begin
2377 -------------
2378 -- Ind_Val --
2379 -------------
2382 begin
2383 return
2390 ------------
2391 -- Init_L --
2392 ------------
2397 begin
2403 else
2410 -------
2411 -- L --
2412 -------
2415 begin
2419 -----------
2420 -- L_Pos --
2421 -----------
2426 begin
2427 -- If the index type is an enumeration type, the computation can be
2428 -- done in standard integer. Otherwise, choose a large enough integer
2429 -- type to accommodate the index type computation.
2436 then
2438 else
2442 return
2445 Expression =>
2452 ------------
2453 -- L_Succ --
2454 ------------
2457 begin
2458 return
2465 ---------
2466 -- One --
2467 ---------
2470 begin
2474 -------
2475 -- P --
2476 -------
2479 begin
2483 ------------
2484 -- P_Succ --
2485 ------------
2488 begin
2489 return
2496 -------
2497 -- R --
2498 -------
2501 begin
2505 -------
2506 -- S --
2507 -------
2510 begin
2514 -------------
2515 -- S_First --
2516 -------------
2519 begin
2525 ------------
2526 -- S_Last --
2527 ------------
2530 begin
2536 --------------
2537 -- S_Length --
2538 --------------
2541 begin
2547 -------------------
2548 -- S_Length_Test --
2549 -------------------
2552 begin
2553 return
2559 -- Start of processing for Expand_Concatenate_Other
2561 begin
2562 -- Construct the parameter specs and the overall function spec
2566 Append_To
2569 Defining_Identifier =>
2575 Func_Spec :=
2581 -- Construct L's object declaration
2583 L_Decl :=
2590 -- Construct the if-then-elsif statements
2599 If_Stmt :=
2607 -- Construct the declaration for H
2609 P_Decl :=
2619 -- If the index type is small modular type, we need to perform an
2620 -- additional check that the upper bound fits in the index type.
2621 -- Otherwise the computation of the upper bound can wrap around
2622 -- and yield meaningless results. The constraint check has to be
2623 -- explicit in the code, because the generated function is compiled
2624 -- with checks disabled, for efficiency.
2628 then
2629 I_Decl :=
2633 Expression =>
2638 H_Init :=
2639 Ind_Val (
2644 -- For other index types, computation is safe
2646 else
2650 H_Decl :=
2656 -- Construct the declaration for R
2659 R_Constr :=
2663 R_Decl :=
2666 Object_Definition =>
2671 -- Construct the declarations for the declare block
2675 -- Add constraint check for the modular index case
2679 then
2684 Condition =>
2686 Left_Opnd =>
2688 Right_Opnd =>
2697 -- Construct list of statements for the declare block
2707 Append_To
2710 -- Construct the declare block
2714 Handled_Statement_Sequence =>
2717 -- Construct the list of function statements
2721 -- Construct the function body
2723 Func_Body :=
2727 Handled_Statement_Sequence =>
2730 -- Insert the newly generated function in the code. This is analyzed
2731 -- with all checks off, since we have completed all the checks.
2733 -- Note that this does *not* fix the array concatenation bug when the
2734 -- low bound is Integer'first sibce that bug comes from the pointer
2735 -- dereferencing an unconstrained array. And there we need a constraint
2736 -- check to make sure the length of the concatenated array is ok. ???
2740 -- Construct list of arguments for the function call
2749 -- Insert the function call
2751 Rewrite
2759 -------------------------------
2760 -- Expand_Concatenate_String --
2761 -------------------------------
2771 -- RE_Id value for function to be called
2773 begin
2774 -- In all cases, we build a call to a routine giving the list of
2775 -- arguments as the parameter list to the routine.
2783 else
2792 else
2797 -- If we have anything other than Standard_Character or
2798 -- Standard_String, then we must have had a serious error
2799 -- earlier, so we just abandon the attempt at expansion.
2801 else
2820 -- Now generate the appropriate call
2829 exception
2834 ------------------------
2835 -- Expand_N_Allocator --
2836 ------------------------
2848 -- Generate finalization calls for all nested coextensions of N. This
2849 -- routine may allocate list controllers if necessary.
2852 -- Static coextensions have the same lifetime as the entity they
2853 -- constrain. Such occurrences can be rewritten as aliased objects
2854 -- and their unrestricted access used instead of the coextension.
2856 ---------------------------------------
2857 -- Complete_Coextension_Finalization --
2858 ---------------------------------------
2867 -- Determine whether node N is part of a return statement
2870 -- Determine whether node N is a subtype indicator allocator which
2871 -- acts a coextension. Such coextensions need initialization.
2873 -------------------------------
2874 -- Inside_A_Return_Statement --
2875 -------------------------------
2880 begin
2883 if Nkind_In
2885 then
2888 -- Stop the traversal when we reach a subprogram body
2900 -------------------------------
2901 -- Needs_Initialization_Call --
2902 -------------------------------
2907 begin
2911 N_Object_Declaration
2912 then
2915 return
2919 N_Qualified_Expression;
2925 -- Start of processing for Complete_Coextension_Finalization
2927 begin
2928 -- When a coextension root is inside a return statement, we need to
2929 -- use the finalization chain of the function's scope. This does not
2930 -- apply for controlled named access types because in those cases we
2931 -- can use the finalization chain of the type itself.
2934 and then
2936 or else
2939 then
2940 declare
2945 begin
2950 -- Retrieve the declaration of the body
2960 -- Push the scope of the function body since we are inserting
2961 -- the list before the body, but we are currently in the body
2962 -- itself. Override the finalization list of PtrT since the
2963 -- finalization context is now different.
2967 Pop_Scope;
2970 -- The root allocator may not be controlled, but it still needs a
2971 -- finalization list for all nested coextensions.
2977 Flist :=
2979 Prefix =>
2981 Selector_Name =>
2988 -- Generate:
2989 -- typ! (coext.all)
2992 Ref :=
2995 Expression =>
2998 else
3002 -- No initialization call if not allowed
3008 -- Generate:
3009 -- initialize (Ref)
3010 -- attach_to_final_list (Ref, Flist, 2)
3014 Make_Init_Call (
3020 -- Generate:
3021 -- attach_to_final_list (Ref, Flist, 2)
3023 else
3025 Make_Attach_Call (
3036 -------------------------
3037 -- Rewrite_Coextension --
3038 -------------------------
3045 -- Generate:
3046 -- Cnn : aliased Etyp;
3052 Object_Definition =>
3056 begin
3061 -- Find the proper insertion node for the declaration
3082 -- Start of processing for Expand_N_Allocator
3084 begin
3085 -- RM E.2.3(22). We enforce that the expected type of an allocator
3086 -- shall not be a remote access-to-class-wide-limited-private type
3088 -- Why is this being done at expansion time, seems clearly wrong ???
3092 -- Set the Storage Pool
3105 else
3111 -- Under certain circumstances we can replace an allocator by an access
3112 -- to statically allocated storage. The conditions, as noted in AARM
3113 -- 3.10 (10c) are as follows:
3115 -- Size and initial value is known at compile time
3116 -- Access type is access-to-constant
3118 -- The allocator is not part of a constraint on a record component,
3119 -- because in that case the inserted actions are delayed until the
3120 -- record declaration is fully analyzed, which is too late for the
3121 -- analysis of the rewritten allocator.
3129 then
3130 -- Here we can do the optimization. For the allocator
3132 -- new x'(y)
3134 -- We insert an object declaration
3136 -- Tnn : aliased x := y;
3138 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3139 -- marked as requiring static allocation.
3141 Temp :=
3146 -- If context is constrained, use constrained subtype directly,
3147 -- so that the constant is not labelled as having a nominally
3148 -- unconstrained subtype.
3169 -- We set the variable as statically allocated, since we don't want
3170 -- it going on the stack of the current procedure!
3176 -- Same if the allocator is an access discriminant for a local object:
3177 -- instead of an allocator we create a local value and constrain the
3178 -- the enclosing object with the corresponding access attribute.
3185 -- The current allocator creates an object which may contain nested
3186 -- coextensions. Use the current allocator's finalization list to
3187 -- generate finalization call for all nested coextensions.
3190 Complete_Coextension_Finalization;
3193 -- Handle case of qualified expression (other than optimization above)
3200 -- If the allocator is for a type which requires initialization, and
3201 -- there is no initial value (i.e. operand is a subtype indication
3202 -- rather than a qualified expression), then we must generate a call to
3203 -- the initialization routine using an expressions action node:
3205 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3207 -- Here ptr_T is the pointer type for the allocator, and T is the
3208 -- subtype of the allocator. A special case arises if the designated
3209 -- type of the access type is a task or contains tasks. In this case
3210 -- the call to Init (Temp.all ...) is replaced by code that ensures
3211 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3212 -- for details). In addition, if the type T is a task T, then the
3213 -- first argument to Init must be converted to the task record type.
3215 declare
3228 begin
3232 -- Case of no initialization procedure present
3236 -- Case of simple initialization required
3250 -- No initialization required
3252 else
3256 -- Case of initialization procedure present, must be called
3258 else
3266 -- Construct argument list for the initialization routine call
3268 Arg1 :=
3274 -- The initialization procedure expects a specific type. if the
3275 -- context is access to class wide, indicate that the object
3276 -- being allocated has the right specific type.
3282 -- If designated type is a concurrent type or if it is private
3283 -- type whose definition is a concurrent type, the first
3284 -- argument in the Init routine has to be unchecked conversion
3285 -- to the corresponding record type. If the designated type is
3286 -- a derived type, we also convert the argument to its root
3287 -- type.
3290 Arg1 :=
3296 then
3297 Arg1 :=
3298 Unchecked_Convert_To
3302 declare
3304 begin
3312 -- For the task case, pass the Master_Id of the access type as
3313 -- the value of the _Master parameter, and _Chain as the value
3314 -- of the _Chain parameter (_Chain will be defined as part of
3315 -- the generated code for the allocator).
3317 -- In Ada 2005, the context may be a function that returns an
3318 -- anonymous access type. In that case the Master_Id has been
3319 -- created when expanding the function declaration.
3324 -- If we have a non-library level task with restriction
3325 -- No_Task_Hierarchy set, then no point in expanding.
3329 then
3333 -- The designated type was an incomplete type, and the
3334 -- access type did not get expanded. Salvage it now.
3337 Expand_N_Full_Type_Declaration
3341 -- If the context of the allocator is a declaration or an
3342 -- assignment, we can generate a meaningful image for it,
3343 -- even though subsequent assignments might remove the
3344 -- connection between task and entity. We build this image
3345 -- when the left-hand side is a simple variable, a simple
3346 -- indexed assignment or a simple selected component.
3349 declare
3352 begin
3354 Decls :=
3355 Build_Task_Image_Decls
3357 New_Occurrence_Of
3360 elsif Nkind_In
3363 then
3364 Decls :=
3365 Build_Task_Image_Decls
3367 else
3373 Decls :=
3374 Build_Task_Image_Decls
3377 else
3382 New_Reference_To
3390 -- Has_Task is false, Decls not used
3392 else
3396 -- Add discriminants if discriminated type
3398 declare
3402 begin
3410 then
3417 -- If the allocated object will be constrained by the
3418 -- default values for discriminants, then build a subtype
3419 -- with those defaults, and change the allocated subtype
3420 -- to that. Note that this happens in fewer cases in Ada
3421 -- 2005 (AI-363).
3427 or else
3429 then
3439 -- AI-416: when the discriminant constraint is an
3440 -- anonymous access type make sure an accessibility
3441 -- check is inserted if necessary (3.10.2(22.q/2))
3444 and then
3446 then
3447 Apply_Accessibility_Check
3456 -- We set the allocator as analyzed so that when we analyze the
3457 -- expression actions node, we do not get an unwanted recursive
3458 -- expansion of the allocator expression.
3463 -- Here is the transformation:
3464 -- input: new T
3465 -- output: Temp : constant ptr_T := new T;
3466 -- Init (Temp.all, ...);
3467 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
3468 -- <CTRL> Initialize (Finalizable (Temp.all));
3470 -- Here ptr_T is the pointer type for the allocator, and is the
3471 -- subtype of the allocator.
3473 Temp_Decl :=
3483 -- If the designated type is a task type or contains tasks,
3484 -- create block to activate created tasks, and insert
3485 -- declaration for Task_Image variable ahead of call.
3488 declare
3491 begin
3498 else
3507 -- Postpone the generation of a finalization call for the
3508 -- current allocator if it acts as a coextension.
3517 else
3518 Flist :=
3521 -- Anonymous access types created for access parameters
3522 -- are attached to an explicitly constructed controller,
3523 -- which ensures that they can be finalized properly,
3524 -- even if their deallocation might not happen. The list
3525 -- associated with the controller is doubly-linked. For
3526 -- other anonymous access types, the object may end up
3527 -- on the global final list which is singly-linked.
3528 -- Work needed for access discriminants in Ada 2005 ???
3531 and then
3533 not in N_Subprogram_Specification
3534 then
3536 else
3541 Make_Init_Call (
3556 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
3557 -- object that has been rewritten as a reference, we displace "this"
3558 -- to reference properly its secondary dispatch table.
3562 then
3566 exception
3571 -----------------------
3572 -- Expand_N_And_Then --
3573 -----------------------
3575 -- Expand into conditional expression if Actions present, and also deal
3576 -- with optimizing case of arguments being True or False.
3585 begin
3586 -- Deal with non-standard booleans
3594 -- Check for cases where left argument is known to be True or False
3598 -- If left argument is True, change (True and then Right) to Right.
3599 -- Any actions associated with Right will be executed unconditionally
3600 -- and can thus be inserted into the tree unconditionally.
3609 -- If left argument is False, change (False and then Right) to False.
3610 -- In this case we can forget the actions associated with Right,
3611 -- since they will never be executed.
3623 -- If Actions are present, we expand
3625 -- left and then right
3627 -- into
3629 -- if left then right else false end
3631 -- with the actions becoming the Then_Actions of the conditional
3632 -- expression. This conditional expression is then further expanded
3633 -- (and will eventually disappear)
3640 Left,
3641 Right,
3650 -- No actions present, check for cases of right argument True/False
3654 -- Change (Left and then True) to Left. Note that we know there are
3655 -- no actions associated with the True operand, since we just checked
3656 -- for this case above.
3661 -- Change (Left and then False) to False, making sure to preserve any
3662 -- side effects associated with the Left operand.
3666 Rewrite
3674 -------------------------------------
3675 -- Expand_N_Conditional_Expression --
3676 -------------------------------------
3678 -- Expand into expression actions if then/else actions present
3689 begin
3690 -- If either then or else actions are present, then given:
3692 -- if cond then then-expr else else-expr end
3694 -- we insert the following sequence of actions (using Insert_Actions):
3696 -- Cnn : typ;
3697 -- if cond then
3698 -- <<then actions>>
3699 -- Cnn := then-expr;
3700 -- else
3701 -- <<else actions>>
3702 -- Cnn := else-expr
3703 -- end if;
3705 -- and replace the conditional expression by a reference to Cnn
3710 New_If :=
3728 Insert_List_Before
3733 Insert_List_Before
3749 -----------------------------------
3750 -- Expand_N_Explicit_Dereference --
3751 -----------------------------------
3754 begin
3755 -- Insert explicit dereference call for the checked storage pool case
3760 -----------------
3761 -- Expand_N_In --
3762 -----------------
3772 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3773 -- test for the left operand being in range of its subtype.
3775 ----------------------------
3776 -- Substitute_Valid_Check --
3777 ----------------------------
3780 begin
3793 -- Start of processing for Expand_N_In
3795 begin
3796 -- Check case of explicit test for an expression in range of its
3797 -- subtype. This is suspicious usage and we replace it with a 'Valid
3798 -- test and give a warning.
3805 then
3806 Substitute_Valid_Check;
3810 -- Do validity check on operands
3817 -- Case of explicit range
3820 declare
3835 Constant_Condition_Warnings
3837 -- This must be true for any of the optimization warnings, we
3838 -- clearly want to give them only for source with the flag on.
3841 Warn1
3844 -- For the case where only one bound warning is elided, we also
3845 -- insist on an explicit range and an integer type. The reason is
3846 -- that the use of enumeration ranges including an end point is
3847 -- common, as is the use of a subtype name, one of whose bounds
3848 -- is the same as the type of the expression.
3850 begin
3851 -- If test is explicit x'first .. x'last, replace by valid check
3864 then
3865 Substitute_Valid_Check;
3869 -- If bounds of type are known at compile time, and the end points
3870 -- are known at compile time and identical, this is another case
3871 -- for substituting a valid test. We only do this for discrete
3872 -- types, since it won't arise in practice for float types.
3883 -- Kill warnings in instances, since they may be cases where we
3884 -- have a test in the generic that makes sense with some types
3885 -- and not with other types.
3887 and then not In_Instance
3888 then
3889 Substitute_Valid_Check;
3893 -- If we have an explicit range, do a bit of optimization based
3894 -- on range analysis (we may be able to kill one or both checks).
3896 -- If either check is known to fail, replace result by False since
3897 -- the other check does not matter. Preserve the static flag for
3898 -- legality checks, because we are constant-folding beyond RM 4.9.
3913 -- If both checks are known to succeed, replace result by True,
3914 -- since we know we are in range.
3929 -- If lower bound check succeeds and upper bound check is not
3930 -- known to succeed or fail, then replace the range check with
3931 -- a comparison against the upper bound.
3947 -- If upper bound check succeeds and lower bound check is not
3948 -- known to succeed or fail, then replace the range check with
3949 -- a comparison against the lower bound.
3967 -- For all other cases of an explicit range, nothing to be done
3971 -- Here right operand is a subtype mark
3973 else
3974 declare
3980 begin
3983 -- For tagged type, do tagged membership operation
3987 -- No expansion will be performed when VM_Target, as the VM
3988 -- back-ends will handle the membership tests directly (tags
3989 -- are not explicitly represented in Java objects, so the
3990 -- normal tagged membership expansion is not what we want).
3999 -- If type is scalar type, rewrite as x in t'first .. t'last.
4000 -- This reason we do this is that the bounds may have the wrong
4001 -- type if they come from the original type definition.
4006 Low_Bound =>
4011 High_Bound =>
4018 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4019 -- a membership test if the subtype mark denotes a constrained
4020 -- Unchecked_Union subtype and the expression lacks inferable
4021 -- discriminants.
4026 then
4031 -- Prevent Gigi from generating incorrect code by rewriting
4032 -- the test as a standard False.
4040 -- Here we have a non-scalar type
4051 -- For the constrained array case, we have to check the subscripts
4052 -- for an exact match if the lengths are non-zero (the lengths
4053 -- must match in any case).
4058 function Construct_Attribute_Reference
4062 -- Build attribute reference E'Nam(Dim)
4064 -----------------------------------
4065 -- Construct_Attribute_Reference --
4066 -----------------------------------
4068 function Construct_Attribute_Reference
4072 is
4073 begin
4074 return
4082 -- Start processing for Check_Subscripts
4084 begin
4088 Left_Opnd =>
4089 Construct_Attribute_Reference
4092 Right_Opnd =>
4093 Construct_Attribute_Reference
4098 Left_Opnd =>
4099 Construct_Attribute_Reference
4102 Right_Opnd =>
4103 Construct_Attribute_Reference
4108 Cond :=
4110 Left_Opnd =>
4121 -- These are the cases where constraint checks may be required,
4122 -- e.g. records with possible discriminants
4124 else
4125 -- Expand the test into a series of discriminant comparisons.
4126 -- The expression that is built is the negation of the one that
4127 -- is used for checking discriminant constraints.
4137 Left_Opnd =>
4144 else
4155 --------------------------------
4156 -- Expand_N_Indexed_Component --
4157 --------------------------------
4165 begin
4166 -- A special optimization, if we have an indexed component that is
4167 -- selecting from a slice, then we can eliminate the slice, since, for
4168 -- example, x (i .. j)(k) is identical to x(k). The only difference is
4169 -- the range check required by the slice. The range check for the slice
4170 -- itself has already been generated. The range check for the
4171 -- subscripting operation is ensured by converting the subject to
4172 -- the subtype of the slice.
4174 -- This optimization not only generates better code, avoiding slice
4175 -- messing especially in the packed case, but more importantly bypasses
4176 -- some problems in handling this peculiar case, for example, the issue
4177 -- of dealing specially with object renamings.
4184 Convert_To
4191 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4192 -- function, then additional actuals must be passed.
4196 then
4200 -- If the prefix is an access type, then we unconditionally rewrite if
4201 -- as an explicit deference. This simplifies processing for several
4202 -- cases, including packed array cases and certain cases in which checks
4203 -- must be generated. We used to try to do this only when it was
4204 -- necessary, but it cleans up the code to do it all the time.
4211 -- Generate index and validity checks
4219 -- All done for the non-packed case
4225 -- For packed arrays that are not bit-packed (i.e. the case of an array
4226 -- with one or more index types with a non-contiguous enumeration type),
4227 -- we can always use the normal packed element get circuit.
4234 -- For a reference to a component of a bit packed array, we have to
4235 -- convert it to a reference to the corresponding Packed_Array_Type.
4236 -- We only want to do this for simple references, and not for:
4238 -- Left side of assignment, or prefix of left side of assignment, or
4239 -- prefix of the prefix, to handle packed arrays of packed arrays,
4240 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4242 -- Renaming objects in renaming associations
4243 -- This case is handled when a use of the renamed variable occurs
4245 -- Actual parameters for a procedure call
4246 -- This case is handled in Exp_Ch6.Expand_Actuals
4248 -- The second expression in a 'Read attribute reference
4250 -- The prefix of an address or size attribute reference
4252 -- The following circuit detects these exceptions
4254 declare
4258 begin
4259 loop
4264 N_Procedure_Call_Statement)
4266 and then
4268 then
4273 or else
4276 then
4281 then
4284 -- If the expression is an index of an indexed component, it must
4285 -- be expanded regardless of context.
4289 then
4295 then
4301 then
4306 then
4309 else
4314 -- Keep looking up tree for unchecked expression, or if we are the
4315 -- prefix of a possible assignment left side.
4323 ---------------------
4324 -- Expand_N_Not_In --
4325 ---------------------
4327 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
4328 -- can be done. This avoids needing to duplicate this expansion code.
4335 begin
4338 Right_Opnd =>
4343 -- We want this to appear as coming from source if original does (see
4344 -- transformations in Expand_N_In).
4349 -- Now analyze transformed node
4354 -------------------
4355 -- Expand_N_Null --
4356 -------------------
4358 -- The only replacement required is for the case of a null of type that is
4359 -- an access to protected subprogram. We represent such access values as a
4360 -- record, and so we must replace the occurrence of null by the equivalent
4361 -- record (with a null address and a null pointer in it), so that the
4362 -- backend creates the proper value.
4369 begin
4371 Agg :=
4380 -- For subsequent semantic analysis, the node must retain its type.
4381 -- Gigi in any case replaces this type by the corresponding record
4382 -- type before processing the node.
4387 exception
4392 ---------------------
4393 -- Expand_N_Op_Abs --
4394 ---------------------
4400 begin
4403 -- Deal with software overflow checking
4405 if not Backend_Overflow_Checks_On_Target
4408 then
4409 -- The only case to worry about is when the argument is equal to the
4410 -- largest negative number, so what we do is to insert the check:
4412 -- [constraint_error when Expr = typ'Base'First]
4414 -- with the usual Duplicate_Subexpr use coding for expr
4418 Condition =>
4421 Right_Opnd =>
4423 Prefix =>
4429 -- Vax floating-point types case
4436 ---------------------
4437 -- Expand_N_Op_Add --
4438 ---------------------
4443 begin
4446 -- N + 0 = 0 + N = N for integer types
4451 then
4457 then
4463 -- Arithmetic overflow checks for signed integer/fixed point types
4467 then
4471 -- Vax floating-point types case
4478 ---------------------
4479 -- Expand_N_Op_And --
4480 ---------------------
4485 begin
4499 ------------------------
4500 -- Expand_N_Op_Concat --
4501 ------------------------
4504 -- This is initialized the first time this routine is called. It records
4505 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
4506 -- available in the run-time:
4507 --
4508 -- 0 None available
4509 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
4510 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
4511 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
4512 -- 5 All routines including RE_Str_Concat_5 available
4515 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
4516 -- all three are available, False if any one of these is unavailable.
4520 -- List of operands to be concatenated
4523 -- Single operand for concatenation
4526 -- Node which is to be replaced by the result of concatenating the nodes
4527 -- in the list Opnds.
4530 -- Array type of concatenation result type
4533 -- Component type of concatenation represented by Cnode
4535 begin
4536 -- Initialize global variables showing run-time status
4540 -- See what routines are available and set max operand count
4541 -- according to the highest count available in the run-time.
4555 else
4559 Char_Concat_Available :=
4561 and then
4563 and then
4567 -- Ensure validity of both operands
4571 -- If we are the left operand of a concatenation higher up the tree,
4572 -- then do nothing for now, since we want to deal with a series of
4573 -- concatenations as a unit.
4577 then
4581 -- We get here with a concatenation whose left operand may be a
4582 -- concatenation itself with a consistent type. We need to process
4583 -- these concatenation operands from left to right, which means
4584 -- from the deepest node in the tree to the highest node.
4591 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
4592 -- nodes above, so now we process bottom up, doing the operations. We
4593 -- gather a string that is as long as possible up to five operands
4595 -- The outer loop runs more than once if there are more than five
4596 -- concatenations of type Standard.String, the most we handle for
4597 -- this case, or if more than one concatenation type is involved.
4603 -- The inner loop gathers concatenation operands. We gather any
4604 -- number of these in the non-string case, or if no concatenation
4605 -- routines are available for string (since in that case we will
4606 -- treat string like any other non-string case). Otherwise we only
4607 -- gather as many operands as can be handled by the available
4608 -- procedures in the run-time library (normally 5, but may be
4609 -- less for the configurable run-time case).
4613 or else
4615 or else
4617 Max_Available_String_Operands)
4620 loop
4625 -- Here we process the collected operands. First we convert singleton
4626 -- operands to singleton aggregates. This is skipped however for the
4627 -- case of two operands of type String since we have special routines
4628 -- for these cases.
4634 or else not Char_Concat_Available
4635 then
4637 loop
4650 -- Now call appropriate continuation routine
4654 then
4656 else
4665 ------------------------
4666 -- Expand_N_Op_Divide --
4667 ------------------------
4677 and then
4681 begin
4688 -- N / 1 = N for integer types
4695 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4696 -- Is_Power_Of_2_For_Shift is set means that we know that our left
4697 -- operand is an unsigned integer, as required for this to work.
4702 -- We cannot do this transformation in configurable run time mode if we
4703 -- have 64-bit -- integers and long shifts are not available.
4705 and then
4708 then
4712 Right_Opnd =>
4718 -- Do required fixup of universal fixed operation
4725 -- Divisions with fixed-point results
4729 -- No special processing if Treat_Fixed_As_Integer is set, since
4730 -- from a semantic point of view such operations are simply integer
4731 -- operations and will be treated that way.
4736 else
4741 -- Other cases of division of fixed-point operands. Again we exclude the
4742 -- case where Treat_Fixed_As_Integer is set.
4747 then
4750 else
4755 -- Mixed-mode operations can appear in a non-static universal context,
4756 -- in which case the integer argument must be converted explicitly.
4760 then
4768 then
4774 -- Non-fixed point cases, do integer zero divide and overflow checks
4779 -- Check for 64-bit division available, or long shifts if the divisor
4780 -- is a small power of 2 (since such divides will be converted into
4781 -- long shifts.
4784 and then not Support_64_Bit_Divides_On_Target
4785 and then
4787 or else not Support_Long_Shifts_On_Target
4794 then
4798 -- Deal with Vax_Float
4806 --------------------
4807 -- Expand_N_Op_Eq --
4808 --------------------
4823 -- If a constructed equality exists for the type or for its parent,
4824 -- build and analyze call, adding conversions if the operation is
4825 -- inherited.
4828 -- Determines whether a type has a subcomponent of an unconstrained
4829 -- Unchecked_Union subtype. Typ is a record type.
4831 -------------------------
4832 -- Build_Equality_Call --
4833 -------------------------
4840 begin
4843 then
4848 -- If we have an Unchecked_Union, we need to add the inferred
4849 -- discriminant values as actuals in the function call. At this
4850 -- point, the expansion has determined that both operands have
4851 -- inferable discriminants.
4854 declare
4860 begin
4861 -- Per-object constrained selected components require special
4862 -- attention. If the enclosing scope of the component is an
4863 -- Unchecked_Union, we cannot reference its discriminants
4864 -- directly. This is why we use the two extra parameters of
4865 -- the equality function of the enclosing Unchecked_Union.
4867 -- type UU_Type (Discr : Integer := 0) is
4868 -- . . .
4869 -- end record;
4870 -- pragma Unchecked_Union (UU_Type);
4872 -- 1. Unchecked_Union enclosing record:
4874 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4875 -- . . .
4876 -- Comp : UU_Type (Discr);
4877 -- . . .
4878 -- end Enclosing_UU_Type;
4879 -- pragma Unchecked_Union (Enclosing_UU_Type);
4881 -- Obj1 : Enclosing_UU_Type;
4882 -- Obj2 : Enclosing_UU_Type (1);
4884 -- [. . .] Obj1 = Obj2 [. . .]
4886 -- Generated code:
4888 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4890 -- A and B are the formal parameters of the equality function
4891 -- of Enclosing_UU_Type. The function always has two extra
4892 -- formals to capture the inferred discriminant values.
4894 -- 2. Non-Unchecked_Union enclosing record:
4896 -- type
4897 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4898 -- is record
4899 -- . . .
4900 -- Comp : UU_Type (Discr);
4901 -- . . .
4902 -- end Enclosing_Non_UU_Type;
4904 -- Obj1 : Enclosing_Non_UU_Type;
4905 -- Obj2 : Enclosing_Non_UU_Type (1);
4907 -- ... Obj1 = Obj2 ...
4909 -- Generated code:
4911 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4912 -- obj1.discr, obj2.discr)) then
4914 -- In this case we can directly reference the discriminants of
4915 -- the enclosing record.
4917 -- Lhs of equality
4920 and then Has_Per_Object_Constraint
4922 then
4923 -- Enclosing record is an Unchecked_Union, use formal A
4927 then
4928 Lhs_Discr_Val :=
4932 -- Enclosing record is of a non-Unchecked_Union type, it is
4933 -- possible to reference the discriminant.
4935 else
4936 Lhs_Discr_Val :=
4939 Selector_Name =>
4940 New_Copy
4941 (Get_Discriminant_Value
4943 Lhs_Type,
4947 -- Comment needed here ???
4949 else
4950 -- Infer the discriminant value
4952 Lhs_Discr_Val :=
4953 New_Copy
4954 (Get_Discriminant_Value
4956 Lhs_Type,
4960 -- Rhs of equality
4963 and then Has_Per_Object_Constraint
4965 then
4966 if Is_Unchecked_Union
4968 then
4969 Rhs_Discr_Val :=
4973 else
4974 Rhs_Discr_Val :=
4977 Selector_Name =>
4980 Rhs_Type,
4984 else
4985 Rhs_Discr_Val :=
4988 Rhs_Type,
4997 L_Exp,
4998 R_Exp,
4999 Lhs_Discr_Val,
5000 Rhs_Discr_Val)));
5003 -- Normal case, not an unchecked union
5005 else
5015 ------------------------------------
5016 -- Has_Unconstrained_UU_Component --
5017 ------------------------------------
5019 function Has_Unconstrained_UU_Component
5021 is
5027 function Component_Is_Unconstrained_UU
5029 -- Determines whether the subtype of the component is an
5030 -- unconstrained Unchecked_Union.
5032 function Variant_Is_Unconstrained_UU
5034 -- Determines whether a component of the variant has an unconstrained
5035 -- Unchecked_Union subtype.
5037 -----------------------------------
5038 -- Component_Is_Unconstrained_UU --
5039 -----------------------------------
5041 function Component_Is_Unconstrained_UU
5043 is
5044 begin
5049 declare
5053 begin
5054 -- Unconstrained nominal type. In the case of a constraint
5055 -- present, the node kind would have been N_Subtype_Indication.
5065 ---------------------------------
5066 -- Variant_Is_Unconstrained_UU --
5067 ---------------------------------
5069 function Variant_Is_Unconstrained_UU
5071 is
5074 begin
5079 -- We only need to test one component
5081 declare
5084 begin
5094 -- None of the components withing the variant were of
5095 -- unconstrained Unchecked_Union type.
5100 -- Start of processing for Has_Unconstrained_UU_Component
5102 begin
5110 -- Inspect available components
5113 declare
5116 begin
5119 -- One component is sufficient
5130 -- Inspect available components withing variants
5133 declare
5136 begin
5139 -- One component within a variant is sufficient
5150 -- Neither the available components, nor the components inside the
5151 -- variant parts were of an unconstrained Unchecked_Union subtype.
5156 -- Start of processing for Expand_N_Op_Eq
5158 begin
5165 else
5169 -- It may happen in error situations that the underlying type is not
5170 -- set. The error will be detected later, here we just defend the
5171 -- expander code.
5179 -- Boolean types (requiring handling of non-standard case)
5187 -- Array types
5191 -- If we are doing full validity checking, and it is possible for the
5192 -- array elements to be invalid then expand out array comparisons to
5193 -- make sure that we check the array elements.
5195 if Validity_Check_Operands
5197 then
5198 declare
5200 Force_Validity_Checks;
5201 begin
5204 Expand_Array_Equality
5208 Bodies,
5209 Typl));
5215 -- Packed case where both operands are known aligned
5220 then
5223 -- Where the component type is elementary we can use a block bit
5224 -- comparison (if supported on the target) exception in the case
5225 -- of floating-point (negative zero issues require element by
5226 -- element comparison), and atomic types (where we must be sure
5227 -- to load elements independently) and possibly unaligned arrays.
5234 and then Support_Composite_Compare_On_Target
5235 then
5238 -- For composite and floating-point cases, expand equality loop to
5239 -- make sure of using proper comparisons for tagged types, and
5240 -- correctly handling the floating-point case.
5242 else
5244 Expand_Array_Equality
5248 Bodies,
5249 Typl));
5254 -- Record Types
5258 -- For tagged types, use the primitive "="
5262 -- No need to do anything else compiling under restriction
5263 -- No_Dispatching_Calls. During the semantic analysis we
5264 -- already notified such violation.
5270 -- If this is derived from an untagged private type completed with
5271 -- a tagged type, it does not have a full view, so we use the
5272 -- primitive operations of the private type. This check should no
5273 -- longer be necessary when these types get their full views???
5279 then
5280 -- Search for equality operation, checking that the operands
5281 -- have the same type. Note that we must find a matching entry,
5282 -- or something is very wrong!
5290 and then
5299 -- Find the type's predefined equality or an overriding
5300 -- user- defined equality. The reason for not simply calling
5301 -- Find_Prim_Op here is that there may be a user-defined
5302 -- overloaded equality op that precedes the equality that we want,
5303 -- so we have to explicitly search (e.g., there could be an
5304 -- equality with two different parameter types).
5306 else
5316 and then
5328 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
5329 -- predefined equality operator for a type which has a subcomponent
5330 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
5337 -- Prevent Gigi from generating incorrect code by rewriting the
5338 -- equality as a standard False.
5345 -- If we can infer the discriminants of the operands, we make a
5346 -- call to the TSS equality function.
5349 and then
5351 then
5352 Build_Equality_Call
5355 else
5356 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5357 -- the predefined equality operator for an Unchecked_Union type
5358 -- if either of the operands lack inferable discriminants.
5364 -- Prevent Gigi from generating incorrect code by rewriting
5365 -- the equality as a standard False.
5372 -- If a type support function is present (for complex cases), use it
5375 Build_Equality_Call
5378 -- Otherwise expand the component by component equality. Note that
5379 -- we never use block-bit comparisons for records, because of the
5380 -- problems with gaps. The backend will often be able to recombine
5381 -- the separate comparisons that we generate here.
5383 else
5394 -- Test if result is known at compile time
5398 -- If we still have comparison for Vax_Float, process it
5406 -----------------------
5407 -- Expand_N_Op_Expon --
5408 -----------------------
5426 begin
5429 -- If either operand is of a private type, then we have the use of an
5430 -- intrinsic operator, and we get rid of the privateness, by using root
5431 -- types of underlying types for the actual operation. Otherwise the
5432 -- private types will cause trouble if we expand multiplications or
5433 -- shifts etc. We also do this transformation if the result type is
5434 -- different from the base type.
5437 or else
5439 or else
5441 or else
5443 then
5444 declare
5448 begin
5459 -- Test for case of known right argument
5464 -- We only fold small non-negative exponents. You might think we
5465 -- could fold small negative exponents for the real case, but we
5466 -- can't because we are required to raise Constraint_Error for
5467 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
5468 -- See ACVC test C4A012B.
5472 -- X ** 0 = 1 (or 1.0)
5476 -- Call Remove_Side_Effects to ensure that any side effects
5477 -- in the ignored left operand (in particular function calls
5478 -- to user defined functions) are properly executed.
5484 else
5488 -- X ** 1 = X
5493 -- X ** 2 = X * X
5496 Xnode :=
5501 -- X ** 3 = X * X * X
5504 Xnode :=
5506 Left_Opnd =>
5512 -- X ** 4 ->
5513 -- En : constant base'type := base * base;
5514 -- ...
5515 -- En * En
5518 Temp :=
5526 Expression =>
5531 Xnode :=
5543 -- Case of (2 ** expression) appearing as an argument of an integer
5544 -- multiplication, or as the right argument of a division of a non-
5545 -- negative integer. In such cases we leave the node untouched, setting
5546 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
5547 -- of the higher level node converts it into a shift.
5549 -- Note: this transformation is not applicable for a modular type with
5550 -- a non-binary modulus in the multiplication case, since we get a wrong
5551 -- result if the shift causes an overflow before the modular reduction.
5558 and then not Ovflo
5560 then
5561 declare
5566 begin
5569 and then
5571 or else
5575 or else
5581 then
5588 -- Fall through if exponentiation must be done using a runtime routine
5590 -- First deal with modular case
5594 -- Non-binary case, we call the special exponentiation routine for
5595 -- the non-binary case, converting the argument to Long_Long_Integer
5596 -- and passing the modulus value. Then the result is converted back
5597 -- to the base type.
5607 Exp))));
5609 -- Binary case, in this case, we call one of two routines, either the
5610 -- unsigned integer case, or the unsigned long long integer case,
5611 -- with a final "and" operation to do the required mod.
5613 else
5616 else
5623 Left_Opnd =>
5628 Exp)),
5629 Right_Opnd =>
5634 -- Common exit point for modular type case
5639 -- Signed integer cases, done using either Integer or Long_Long_Integer.
5640 -- It is not worth having routines for Short_[Short_]Integer, since for
5641 -- most machines it would not help, and it would generate more code that
5642 -- might need certification when a certified run time is required.
5644 -- In the integer cases, we have two routines, one for when overflow
5645 -- checks are required, and one when they are not required, since there
5646 -- is a real gain in omitting checks on many machines.
5650 and then
5653 then
5658 else
5667 else
5671 -- Floating-point cases, always done using Long_Long_Float. We do not
5672 -- need separate routines for the overflow case here, since in the case
5673 -- of floating-point, we generate infinities anyway as a rule (either
5674 -- that or we automatically trap overflow), and if there is an infinity
5675 -- generated and a range check is required, the check will fail anyway.
5677 else
5683 -- Common processing for integer cases and floating-point cases.
5684 -- If we are in the right type, we can call runtime routine directly
5689 then
5695 -- Otherwise we have to introduce conversions (conversions are also
5696 -- required in the universal cases, since the runtime routine is
5697 -- typed using one of the standard types.
5699 else
5706 Exp))));
5712 exception
5717 --------------------
5718 -- Expand_N_Op_Ge --
5719 --------------------
5727 begin
5744 -- If we still have comparison, and Vax_Float type, process it
5752 --------------------
5753 -- Expand_N_Op_Gt --
5754 --------------------
5762 begin
5779 -- If we still have comparison, and Vax_Float type, process it
5787 --------------------
5788 -- Expand_N_Op_Le --
5789 --------------------
5797 begin
5814 -- If we still have comparison, and Vax_Float type, process it
5822 --------------------
5823 -- Expand_N_Op_Lt --
5824 --------------------
5832 begin
5849 -- If we still have comparison, and Vax_Float type, process it
5857 -----------------------
5858 -- Expand_N_Op_Minus --
5859 -----------------------
5865 begin
5868 if not Backend_Overflow_Checks_On_Target
5871 then
5872 -- Software overflow checking expands -expr into (0 - expr)
5881 -- Vax floating-point types case
5888 ---------------------
5889 -- Expand_N_Op_Mod --
5890 ---------------------
5910 begin
5916 -- Convert mod to rem if operands are known non-negative. We do this
5917 -- since it is quite likely that this will improve the quality of code,
5918 -- (the operation now corresponds to the hardware remainder), and it
5919 -- does not seem likely that it could be harmful.
5922 and then
5924 then
5930 -- Instead of reanalyzing the node we do the analysis manually. This
5931 -- avoids anomalies when the replacement is done in an instance and
5932 -- is epsilon more efficient.
5941 -- Otherwise, normal mod processing
5943 else
5948 -- Apply optimization x mod 1 = 0. We don't really need that with
5949 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5950 -- certainly harmless.
5955 then
5956 -- Call Remove_Side_Effects to ensure that any side effects in
5957 -- the ignored left operand (in particular function calls to
5958 -- user defined functions) are properly executed.
5967 -- Deal with annoying case of largest negative number remainder
5968 -- minus one. Gigi does not handle this case correctly, because
5969 -- it generates a divide instruction which may trap in this case.
5971 -- In fact the check is quite easy, if the right operand is -1, then
5972 -- the mod value is always 0, and we can just ignore the left operand
5973 -- completely in this case.
5975 -- The operand type may be private (e.g. in the expansion of an
5976 -- intrinsic operation) so we must use the underlying type to get the
5977 -- bounds, and convert the literals explicitly.
5979 LLB :=
5980 Expr_Value
5984 and then
5986 then
5992 Right_Opnd =>
6005 --------------------------
6006 -- Expand_N_Op_Multiply --
6007 --------------------------
6026 begin
6029 -- Special optimizations for integer types
6033 -- N * 0 = 0 for integer types
6037 then
6038 -- Call Remove_Side_Effects to ensure that any side effects in
6039 -- the ignored left operand (in particular function calls to
6040 -- user defined functions) are properly executed.
6049 -- Similar handling for 0 * N = 0
6053 then
6060 -- N * 1 = 1 * N = N for integer types
6062 -- This optimisation is not done if we are going to
6063 -- rewrite the product 1 * 2 ** N to a shift.
6067 and then not Lp2
6068 then
6074 and then not Rp2
6075 then
6081 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
6082 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6083 -- operand is an integer, as required for this to work.
6088 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
6093 Right_Opnd =>
6100 else
6104 Right_Opnd =>
6110 -- Same processing for the operands the other way round
6116 Right_Opnd =>
6122 -- Do required fixup of universal fixed operation
6129 -- Multiplications with fixed-point results
6133 -- No special processing if Treat_Fixed_As_Integer is set, since from
6134 -- a semantic point of view such operations are simply integer
6135 -- operations and will be treated that way.
6139 -- Case of fixed * integer => fixed
6144 -- Case of integer * fixed => fixed
6149 -- Case of fixed * fixed => fixed
6151 else
6156 -- Other cases of multiplication of fixed-point operands. Again we
6157 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
6161 then
6164 else
6169 -- Mixed-mode operations can appear in a non-static universal context,
6170 -- in which case the integer argument must be converted explicitly.
6174 then
6181 then
6186 -- Non-fixed point cases, check software overflow checking required
6191 -- Deal with VAX float case
6199 --------------------
6200 -- Expand_N_Op_Ne --
6201 --------------------
6206 begin
6207 -- Case of elementary type with standard operator
6211 then
6214 -- Boolean types (requiring handling of non-standard case)
6225 -- If we still have comparison for Vax_Float, process it
6232 -- For all cases other than elementary types, we rewrite node as the
6233 -- negation of an equality operation, and reanalyze. The equality to be
6234 -- used is defined in the same scope and has the same signature. This
6235 -- signature must be set explicitly since in an instance it may not have
6236 -- the same visibility as in the generic unit. This avoids duplicating
6237 -- or factoring the complex code for record/array equality tests etc.
6239 else
6240 declare
6245 begin
6248 Neg :=
6250 Right_Opnd =>
6260 -- For navigation purposes, the inequality is treated as an
6261 -- implicit reference to the corresponding equality. Preserve the
6262 -- Comes_From_ source flag so that the proper Xref entry is
6263 -- generated.
6273 ---------------------
6274 -- Expand_N_Op_Not --
6275 ---------------------
6277 -- If the argument is other than a Boolean array type, there is no special
6278 -- expansion required.
6280 -- For the packed case, we call the special routine in Exp_Pakd, except
6281 -- that if the component size is greater than one, we use the standard
6282 -- routine generating a gruesome loop (it is so peculiar to have packed
6283 -- arrays with non-standard Boolean representations anyway, so it does not
6284 -- matter that we do not handle this case efficiently).
6286 -- For the unpacked case (and for the special packed case where we have non
6287 -- standard Booleans, as discussed above), we generate and insert into the
6288 -- tree the following function definition:
6290 -- function Nnnn (A : arr) is
6291 -- B : arr;
6292 -- begin
6293 -- for J in a'range loop
6294 -- B (J) := not A (J);
6295 -- end loop;
6296 -- return B;
6297 -- end Nnnn;
6299 -- Here arr is the actual subtype of the parameter (and hence always
6300 -- constrained). Then we replace the not with a call to this function.
6316 begin
6319 -- For boolean operand, deal with non-standard booleans
6328 -- Only array types need any other processing
6334 -- Case of array operand. If bit packed with a component size of 1,
6335 -- handle it in Exp_Pakd if the operand is known to be aligned.
6340 then
6345 -- Case of array operand which is not bit-packed. If the context is
6346 -- a safe assignment, call in-place operation, If context is a larger
6347 -- boolean expression in the context of a safe assignment, expansion is
6348 -- done by enclosing operation.
6361 -- Special case the negation of a binary operation
6364 and then Safe_In_Place_Array_Op
6366 then
6373 then
6374 declare
6379 begin
6383 then
6384 -- (not A) op (not B) can be reduced to a single call
6390 then
6391 -- A xor (not B) can also be special-cased
6403 A_J :=
6408 B_J :=
6413 Loop_Statement :=
6417 Iteration_Scheme =>
6419 Loop_Parameter_Specification =>
6422 Discrete_Subtype_Definition =>
6437 Specification =>
6451 Handled_Statement_Sequence =>
6454 Loop_Statement,
6456 Expression =>
6467 --------------------
6468 -- Expand_N_Op_Or --
6469 --------------------
6474 begin
6488 ----------------------
6489 -- Expand_N_Op_Plus --
6490 ----------------------
6493 begin
6497 ---------------------
6498 -- Expand_N_Op_Rem --
6499 ---------------------
6518 begin
6525 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
6526 -- but it is useful with other back ends (e.g. AAMP), and is certainly
6527 -- harmless.
6532 then
6533 -- Call Remove_Side_Effects to ensure that any side effects in the
6534 -- ignored left operand (in particular function calls to user defined
6535 -- functions) are properly executed.
6544 -- Deal with annoying case of largest negative number remainder minus
6545 -- one. Gigi does not handle this case correctly, because it generates
6546 -- a divide instruction which may trap in this case.
6548 -- In fact the check is quite easy, if the right operand is -1, then
6549 -- the remainder is always 0, and we can just ignore the left operand
6550 -- completely in this case.
6555 -- The operand type may be private (e.g. in the expansion of an
6556 -- intrinsic operation) so we must use the underlying type to get the
6557 -- bounds, and convert the literals explicitly.
6559 LLB :=
6560 Expr_Value
6563 -- Now perform the test, generating code only if needed
6566 and then
6568 then
6574 Right_Opnd =>
6588 -----------------------------
6589 -- Expand_N_Op_Rotate_Left --
6590 -----------------------------
6593 begin
6597 ------------------------------
6598 -- Expand_N_Op_Rotate_Right --
6599 ------------------------------
6602 begin
6606 ----------------------------
6607 -- Expand_N_Op_Shift_Left --
6608 ----------------------------
6611 begin
6615 -----------------------------
6616 -- Expand_N_Op_Shift_Right --
6617 -----------------------------
6620 begin
6624 ----------------------------------------
6625 -- Expand_N_Op_Shift_Right_Arithmetic --
6626 ----------------------------------------
6629 begin
6633 --------------------------
6634 -- Expand_N_Op_Subtract --
6635 --------------------------
6640 begin
6643 -- N - 0 = N for integer types
6648 then
6653 -- Arithmetic overflow checks for signed integer/fixed point types
6657 then
6660 -- Vax floating-point types case
6667 ---------------------
6668 -- Expand_N_Op_Xor --
6669 ---------------------
6674 begin
6688 ----------------------
6689 -- Expand_N_Or_Else --
6690 ----------------------
6692 -- Expand into conditional expression if Actions present, and also
6693 -- deal with optimizing case of arguments being True or False.
6702 begin
6703 -- Deal with non-standard booleans
6711 -- Check for cases where left argument is known to be True or False
6715 -- If left argument is False, change (False or else Right) to Right.
6716 -- Any actions associated with Right will be executed unconditionally
6717 -- and can thus be inserted into the tree unconditionally.
6726 -- If left argument is True, change (True and then Right) to True. In
6727 -- this case we can forget the actions associated with Right, since
6728 -- they will never be executed.
6740 -- If Actions are present, we expand
6742 -- left or else right
6744 -- into
6746 -- if left then True else right end
6748 -- with the actions becoming the Else_Actions of the conditional
6749 -- expression. This conditional expression is then further expanded
6750 -- (and will eventually disappear)
6757 Left,
6759 Right)));
6767 -- No actions present, check for cases of right argument True/False
6771 -- Change (Left or else False) to Left. Note that we know there are
6772 -- no actions associated with the True operand, since we just checked
6773 -- for this case above.
6778 -- Change (Left or else True) to True, making sure to preserve any
6779 -- side effects associated with the Left operand.
6783 Rewrite
6791 -----------------------------------
6792 -- Expand_N_Qualified_Expression --
6793 -----------------------------------
6799 begin
6800 -- Do validity check if validity checking operands
6802 if Validity_Checks_On
6803 and then Validity_Check_Operands
6804 then
6808 -- Apply possible constraint check
6813 ---------------------------------
6814 -- Expand_N_Selected_Component --
6815 ---------------------------------
6817 -- If the selector is a discriminant of a concurrent object, rewrite the
6818 -- prefix to denote the corresponding record type.
6830 -- Gigi needs a temporary for prefixes that depend on a discriminant,
6831 -- unless the context of an assignment can provide size information.
6832 -- Don't we have a general routine that does this???
6834 -----------------------
6835 -- In_Left_Hand_Side --
6836 -----------------------
6839 begin
6847 -- Start of processing for Expand_N_Selected_Component
6849 begin
6850 -- Insert explicit dereference if required
6858 then
6865 -- Deal with discriminant check required
6869 -- Present the discriminant checking function to the backend, so that
6870 -- it can inline the call to the function.
6872 Add_Inlined_Body
6873 (Discriminant_Checking_Func
6876 -- Now reset the flag and generate the call
6882 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6883 -- function, then additional actuals must be passed.
6887 then
6891 -- Gigi cannot handle unchecked conversions that are the prefix of a
6892 -- selected component with discriminants. This must be checked during
6893 -- expansion, because during analysis the type of the selector is not
6894 -- known at the point the prefix is analyzed. If the conversion is the
6895 -- target of an assignment, then we cannot force the evaluation.
6900 then
6904 -- Remaining processing applies only if selector is a discriminant
6908 -- If the selector is a discriminant of a constrained record type,
6909 -- we may be able to rewrite the expression with the actual value
6910 -- of the discriminant, a useful optimization in some cases.
6915 then
6916 -- Do this optimization for discrete types only, and not for
6917 -- access types (access discriminants get us into trouble!)
6922 -- Don't do this on the left hand of an assignment statement.
6923 -- Normally one would think that references like this would
6924 -- not occur, but they do in generated code, and mean that
6925 -- we really do want to assign the discriminant!
6929 then
6932 -- Don't do this optimization for the prefix of an attribute or
6933 -- the operand of an object renaming declaration since these are
6934 -- contexts where we do not want the value anyway.
6939 then
6942 -- Don't do this optimization if we are within the code for a
6943 -- discriminant check, since the whole point of such a check may
6944 -- be to verify the condition on which the code below depends!
6949 -- Green light to see if we can do the optimization. There is
6950 -- still one condition that inhibits the optimization below but
6951 -- now is the time to check the particular discriminant.
6953 else
6954 -- Loop through discriminants to find the matching discriminant
6955 -- constraint to see if we can copy it.
6961 -- Check if this is the matching discriminant
6965 -- Here we have the matching discriminant. Check for
6966 -- the case of a discriminant of a component that is
6967 -- constrained by an outer discriminant, which cannot
6968 -- be optimized away.
6970 if
6971 Denotes_Discriminant
6973 then
6976 -- In the context of a case statement, the expression may
6977 -- have the base type of the discriminant, and we need to
6978 -- preserve the constraint to avoid spurious errors on
6979 -- missing cases.
6983 then
6986 Subtype_Mark =>
6988 Expression =>
6992 -- In case that comes out as a static expression,
6993 -- reset it (a selected component is never static).
6998 -- Otherwise we can just copy the constraint, but the
6999 -- result is certainly not static! In some cases the
7000 -- discriminant constraint has been analyzed in the
7001 -- context of the original subtype indication, but for
7002 -- itypes the constraint might not have been analyzed
7003 -- yet, and this must be done now.
7005 else
7017 -- Note: the above loop should always find a matching
7018 -- discriminant, but if it does not, we just missed an
7019 -- optimization due to some glitch (perhaps a previous error),
7020 -- so ignore.
7025 -- The only remaining processing is in the case of a discriminant of
7026 -- a concurrent object, where we rewrite the prefix to denote the
7027 -- corresponding record type. If the type is derived and has renamed
7028 -- discriminants, use corresponding discriminant, which is the one
7029 -- that appears in the corresponding record.
7039 then
7043 New_N :=
7045 Prefix =>
7055 --------------------
7056 -- Expand_N_Slice --
7057 --------------------
7066 -- Check whether the argument is an actual for a procedure call, in
7067 -- which case the expansion of a bit-packed slice is deferred until the
7068 -- call itself is expanded. The reason this is required is that we might
7069 -- have an IN OUT or OUT parameter, and the copy out is essential, and
7070 -- that copy out would be missed if we created a temporary here in
7071 -- Expand_N_Slice. Note that we don't bother to test specifically for an
7072 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
7073 -- is harmless to defer expansion in the IN case, since the call
7074 -- processing will still generate the appropriate copy in operation,
7075 -- which will take care of the slice.
7078 -- Create a named variable for the value of the slice, in cases where
7079 -- the back-end cannot handle it properly, e.g. when packed types or
7080 -- unaligned slices are involved.
7082 -------------------------
7083 -- Is_Procedure_Actual --
7084 -------------------------
7089 begin
7090 loop
7091 -- If our parent is a procedure call we can return
7096 -- If our parent is a type conversion, keep climbing the tree,
7097 -- since a type conversion can be a procedure actual. Also keep
7098 -- climbing if parameter association or a qualified expression,
7099 -- since these are additional cases that do can appear on
7100 -- procedure actuals.
7103 N_Parameter_Association,
7104 N_Qualified_Expression)
7105 then
7108 -- Any other case is not what we are looking for
7110 else
7116 --------------------
7117 -- Make_Temporary --
7118 --------------------
7124 begin
7125 Decl :=
7133 Decl,
7142 -- Start of processing for Expand_N_Slice
7144 begin
7145 -- Special handling for access types
7158 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7159 -- function, then additional actuals must be passed.
7163 then
7167 -- Range checks are potentially also needed for cases involving a slice
7168 -- indexed by a subtype indication, but Do_Range_Check can currently
7169 -- only be set for expressions ???
7176 -- Do not enable range check to nodes associated with the frontend
7177 -- expansion of the dispatch table. We first check if Ada.Tags is
7178 -- already loaded to avoid the addition of an undesired dependence
7179 -- on such run-time unit.
7181 and then
7183 or else not
7189 then
7193 -- The remaining case to be handled is packed slices. We can leave
7194 -- packed slices as they are in the following situations:
7196 -- 1. Right or left side of an assignment (we can handle this
7197 -- situation correctly in the assignment statement expansion).
7199 -- 2. Prefix of indexed component (the slide is optimized away in this
7200 -- case, see the start of Expand_N_Slice.)
7202 -- 3. Object renaming declaration, since we want the name of the
7203 -- slice, not the value.
7205 -- 4. Argument to procedure call, since copy-in/copy-out handling may
7206 -- be required, and this is handled in the expansion of call
7207 -- itself.
7209 -- 5. Prefix of an address attribute (this is an error which is caught
7210 -- elsewhere, and the expansion would interfere with generating the
7211 -- error message).
7215 -- Apply transformation for actuals of a function call, where
7216 -- Expand_Actuals is not used.
7220 then
7221 Make_Temporary;
7227 then
7233 then
7238 then
7241 else
7242 Make_Temporary;
7246 ------------------------------
7247 -- Expand_N_Type_Conversion --
7248 ------------------------------
7257 -- This is called in the case of record and array type conversions to
7258 -- see if there is a change of representation to be handled. Change of
7259 -- representation is actually handled at the assignment statement level,
7260 -- and what this procedure does is rewrite node N conversion as an
7261 -- assignment to temporary. If there is no change of representation,
7262 -- then the conversion node is unchanged.
7265 -- Handles generation of range check for real target value
7267 -----------------------------------
7268 -- Handle_Changed_Representation --
7269 -----------------------------------
7279 begin
7280 -- Nothing else to do if no change of representation
7285 -- The real change of representation work is done by the assignment
7286 -- statement processing. So if this type conversion is appearing as
7287 -- the expression of an assignment statement, nothing needs to be
7288 -- done to the conversion.
7293 -- Otherwise we need to generate a temporary variable, and do the
7294 -- change of representation assignment into that temporary variable.
7295 -- The conversion is then replaced by a reference to this variable.
7297 else
7300 -- If type is unconstrained we have to add a constraint, copied
7301 -- from the actual value of the left hand side.
7316 Selector_Name =>
7327 -- We convert the bounds explicitly. We use an unchecked
7328 -- conversion because bounds checks are done elsewhere.
7332 Low_Bound =>
7335 Prefix =>
7336 Duplicate_Subexpr_No_Checks
7342 High_Bound =>
7345 Prefix =>
7346 Duplicate_Subexpr_No_Checks
7360 Odef :=
7363 Constraint =>
7369 Decl :=
7376 -- Insert required actions. It is essential to suppress checks
7377 -- since we have suppressed default initialization, which means
7378 -- that the variable we create may have no discriminants.
7381 New_List (
7382 Decl,
7393 ----------------------
7394 -- Real_Range_Check --
7395 ----------------------
7397 -- Case of conversions to floating-point or fixed-point. If range checks
7398 -- are enabled and the target type has a range constraint, we convert:
7400 -- typ (x)
7402 -- to
7404 -- Tnn : typ'Base := typ'Base (x);
7405 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7406 -- Tnn
7408 -- This is necessary when there is a conversion of integer to float or
7409 -- to fixed-point to ensure that the correct checks are made. It is not
7410 -- necessary for float to float where it is enough to simply set the
7411 -- Do_Range_Check flag.
7421 begin
7422 -- Nothing to do if conversion was rewritten
7428 -- Nothing to do if range checks suppressed, or target has the same
7429 -- range as the base type (or is the base type).
7433 and then
7435 then
7439 -- Nothing to do if expression is an entity on which checks have been
7440 -- suppressed.
7444 then
7448 -- Nothing to do if bounds are all static and we can tell that the
7449 -- expression is within the bounds of the target. Note that if the
7450 -- operand is of an unconstrained floating-point type, then we do
7451 -- not trust it to be in range (might be infinite)
7453 declare
7457 begin
7464 then
7465 declare
7471 begin
7475 else
7483 then
7491 -- For float to float conversions, we are done
7494 and then
7496 then
7500 -- Otherwise rewrite the conversion as described above
7503 Rewrite
7507 -- Enable overflow except for case of integer to float conversions,
7508 -- where it is never required, since we can never have overflow in
7509 -- this case.
7515 Tnn :=
7526 Condition =>
7528 Left_Opnd =>
7531 Right_Opnd =>
7534 Prefix =>
7537 Right_Opnd =>
7540 Right_Opnd =>
7543 Prefix =>
7551 -- Start of processing for Expand_N_Type_Conversion
7553 begin
7554 -- Nothing at all to do if conversion is to the identical type so remove
7555 -- the conversion completely, it is useless.
7562 -- Nothing to do if this is the second argument of read. This is a
7563 -- "backwards" conversion that will be handled by the specialized code
7564 -- in attribute processing.
7569 then
7573 -- Here if we may need to expand conversion
7575 -- Do validity check if validity checking operands
7577 if Validity_Checks_On
7578 and then Validity_Check_Operands
7579 then
7583 -- Special case of converting from non-standard boolean type
7587 then
7593 -- Case of converting to an access type
7597 -- Apply an accessibility check when the conversion operand is an
7598 -- access parameter (or a renaming thereof), unless conversion was
7599 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
7600 -- Note that other checks may still need to be applied below (such
7601 -- as tagged type checks).
7604 and then
7606 or else
7609 and then Is_Formal
7614 then
7615 Apply_Accessibility_Check
7618 -- If the level of the operand type is statically deeper than the
7619 -- level of the target type, then force Program_Error. Note that this
7620 -- can only occur for cases where the attribute is within the body of
7621 -- an instantiation (otherwise the conversion will already have been
7622 -- rejected as illegal). Note: warnings are issued by the analyzer
7623 -- for the instance cases.
7625 elsif In_Instance_Body
7628 then
7634 -- When the operand is a selected access discriminant the check needs
7635 -- to be made against the level of the object denoted by the prefix
7636 -- of the selected name. Force Program_Error for this case as well
7637 -- (this accessibility violation can only happen if within the body
7638 -- of an instantiation).
7640 elsif In_Instance_Body
7645 then
7653 -- Case of conversions of tagged types and access to tagged types
7655 -- When needed, that is to say when the expression is class-wide, Add
7656 -- runtime a tag check for (strict) downward conversion by using the
7657 -- membership test, generating:
7659 -- [constraint_error when Operand not in Target_Type'Class]
7661 -- or in the access type case
7663 -- [constraint_error
7664 -- when Operand /= null
7665 -- and then Operand.all not in
7666 -- Designated_Type (Target_Type)'Class]
7671 then
7672 -- Do not do any expansion in the access type case if the parent is a
7673 -- renaming, since this is an error situation which will be caught by
7674 -- Sem_Ch8, and the expansion can interfere with this error check.
7678 then
7682 -- Otherwise, proceed with processing tagged conversion
7684 declare
7691 -- Create a membership check to test whether Operand is a member
7692 -- of Targ_Typ. If the original Target_Type is an access, include
7693 -- a test for null value. The check is inserted at N.
7695 --------------------
7696 -- Make_Tag_Check --
7697 --------------------
7702 begin
7703 -- Generate:
7704 -- [Constraint_Error
7705 -- when Operand /= null
7706 -- and then Operand.all not in Targ_Typ]
7709 Cond :=
7711 Left_Opnd =>
7716 Right_Opnd =>
7718 Left_Opnd =>
7723 -- Generate:
7724 -- [Constraint_Error when Operand not in Targ_Typ]
7726 else
7727 Cond :=
7739 -- Start of processing
7741 begin
7746 else
7753 -- Ada 2005 (AI-251): Handle interface type conversion
7762 -- Create a runtime tag check for a downward class-wide type
7763 -- conversion.
7768 then
7773 -- AI05-0073: If the result subtype of the function is defined
7774 -- by an access_definition designating a specific tagged type
7775 -- T, a check is made that the result value is null or the tag
7776 -- of the object designated by the result value identifies T.
7777 -- Constraint_Error is raised if this check fails.
7780 declare
7784 begin
7785 -- Climb scope stack looking for the enclosing function
7790 loop
7794 -- The function's return subtype must be defined using
7795 -- an access definition.
7798 N_Access_Definition
7799 then
7802 -- The return subtype denotes a specific tagged type,
7803 -- in other words, a non class-wide type.
7807 then
7815 -- We have generated a tag check for either a class-wide type
7816 -- conversion or for AI05-0073.
7819 declare
7821 begin
7822 Conv :=
7833 -- Case of other access type conversions
7838 -- Case of conversions from a fixed-point type
7840 -- These conversions require special expansion and processing, found in
7841 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
7842 -- since from a semantic point of view, these are simple integer
7843 -- conversions, which do not need further processing.
7847 then
7848 -- We should never see universal fixed at this case, since the
7849 -- expansion of the constituent divide or multiply should have
7850 -- eliminated the explicit mention of universal fixed.
7854 -- Check for special case of the conversion to universal real that
7855 -- occurs as a result of the use of a round attribute. In this case,
7856 -- the real type for the conversion is taken from the target type of
7857 -- the Round attribute and the result must be marked as rounded.
7862 then
7867 -- Otherwise do correct fixed-conversion, but skip these if the
7868 -- Conversion_OK flag is set, because from a semantic point of
7869 -- view these are simple integer conversions needing no further
7870 -- processing (the backend will simply treat them as integers)
7875 Real_Range_Check;
7880 else
7883 Real_Range_Check;
7887 -- Case of conversions to a fixed-point type
7889 -- These conversions require special expansion and processing, found in
7890 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
7891 -- since from a semantic point of view, these are simple integer
7892 -- conversions, which do not need further processing.
7896 then
7899 Real_Range_Check;
7900 else
7903 Real_Range_Check;
7906 -- Case of float-to-integer conversions
7908 -- We also handle float-to-fixed conversions with Conversion_OK set
7909 -- since semantically the fixed-point target is treated as though it
7910 -- were an integer in such cases.
7913 and then
7915 or else
7917 then
7918 -- One more check here, gcc is still not able to do conversions of
7919 -- this type with proper overflow checking, and so gigi is doing an
7920 -- approximation of what is required by doing floating-point compares
7921 -- with the end-point. But that can lose precision in some cases, and
7922 -- give a wrong result. Converting the operand to Universal_Real is
7923 -- helpful, but still does not catch all cases with 64-bit integers
7924 -- on targets with only 64-bit floats
7926 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
7927 -- Can this code be removed ???
7932 Subtype_Mark =>
7934 Expression =>
7942 -- Case of array conversions
7944 -- Expansion of array conversions, add required length/range checks but
7945 -- only do this if there is no change of representation. For handling of
7946 -- this case, see Handle_Changed_Representation.
7952 else
7956 Handle_Changed_Representation;
7958 -- Case of conversions of discriminated types
7960 -- Add required discriminant checks if target is constrained. Again this
7961 -- change is skipped if we have a change of representation.
7965 then
7967 Handle_Changed_Representation;
7969 -- Case of all other record conversions. The only processing required
7970 -- is to check for a change of representation requiring the special
7971 -- assignment processing.
7975 -- Ada 2005 (AI-216): Program_Error is raised when converting from
7976 -- a derived Unchecked_Union type to an unconstrained type that is
7977 -- not Unchecked_Union if the operand lacks inferable discriminants.
7984 then
7985 -- To prevent Gigi from generating illegal code, we generate a
7986 -- Program_Error node, but we give it the target type of the
7987 -- conversion.
7989 declare
7993 begin
7998 else
7999 Handle_Changed_Representation;
8002 -- Case of conversions of enumeration types
8006 -- Special processing is required if there is a change of
8007 -- representation (from enumeration representation clauses)
8011 -- Convert: x(y) to x'val (ytyp'val (y))
8026 -- Case of conversions to floating-point
8029 Real_Range_Check;
8032 -- At this stage, either the conversion node has been transformed into
8033 -- some other equivalent expression, or left as a conversion that can
8034 -- be handled by Gigi. The conversions that Gigi can handle are the
8035 -- following:
8037 -- Conversions with no change of representation or type
8039 -- Numeric conversions involving integer, floating- and fixed-point
8040 -- values. Fixed-point values are allowed only if Conversion_OK is
8041 -- set, i.e. if the fixed-point values are to be treated as integers.
8043 -- No other conversions should be passed to Gigi
8045 -- Check: are these rules stated in sinfo??? if so, why restate here???
8047 -- The only remaining step is to generate a range check if we still have
8048 -- a type conversion at this stage and Do_Range_Check is set. For now we
8049 -- do this only for conversions of discrete types.
8053 then
8054 declare
8059 begin
8062 then
8065 -- Before we do a range check, we have to deal with treating a
8066 -- fixed-point operand as an integer. The way we do this is
8067 -- simply to do an unchecked conversion to an appropriate
8068 -- integer type large enough to hold the result.
8070 -- This code is not active yet, because we are only dealing
8071 -- with discrete types so far ???
8075 then
8080 else
8087 -- Reset overflow flag, since the range check will include
8088 -- dealing with possible overflow, and generate the check If
8089 -- Address is either a source type or target type, suppress
8090 -- range check to avoid typing anomalies when it is a visible
8091 -- integer type.
8096 then
8097 Generate_Range_Check
8104 -- Final step, if the result is a type conversion involving Vax_Float
8105 -- types, then it is subject for further special processing.
8109 then
8115 -----------------------------------
8116 -- Expand_N_Unchecked_Expression --
8117 -----------------------------------
8119 -- Remove the unchecked expression node from the tree. It's job was simply
8120 -- to make sure that its constituent expression was handled with checks
8121 -- off, and now that that is done, we can remove it from the tree, and
8122 -- indeed must, since gigi does not expect to see these nodes.
8127 begin
8132 ----------------------------------------
8133 -- Expand_N_Unchecked_Type_Conversion --
8134 ----------------------------------------
8136 -- If this cannot be handled by Gigi and we haven't already made a
8137 -- temporary for it, do it now.
8144 begin
8145 -- If we have a conversion of a compile time known value to a target
8146 -- type and the value is in range of the target type, then we can simply
8147 -- replace the construct by an integer literal of the correct type. We
8148 -- only apply this to integer types being converted. Possibly it may
8149 -- apply in other cases, but it is too much trouble to worry about.
8151 -- Note that we do not do this transformation if the Kill_Range_Check
8152 -- flag is set, since then the value may be outside the expected range.
8153 -- This happens in the Normalize_Scalars case.
8155 -- We also skip this if either the target or operand type is biased
8156 -- because in this case, the unchecked conversion is supposed to
8157 -- preserve the bit pattern, not the integer value.
8165 then
8166 declare
8169 begin
8171 and then
8173 and then
8175 and then
8177 then
8180 -- If Address is the target type, just set the type to avoid a
8181 -- spurious type error on the literal when Address is a visible
8182 -- integer type.
8186 else
8195 -- Nothing to do if conversion is safe
8201 -- Otherwise force evaluation unless Assignment_OK flag is set (this
8202 -- flag indicates ??? -- more comments needed here)
8206 else
8211 ----------------------------
8212 -- Expand_Record_Equality --
8213 ----------------------------
8215 -- For non-variant records, Equality is expanded when needed into:
8217 -- and then Lhs.Discr1 = Rhs.Discr1
8218 -- and then ...
8219 -- and then Lhs.Discrn = Rhs.Discrn
8220 -- and then Lhs.Cmp1 = Rhs.Cmp1
8221 -- and then ...
8222 -- and then Lhs.Cmpn = Rhs.Cmpn
8224 -- The expression is folded by the back-end for adjacent fields. This
8225 -- function is called for tagged record in only one occasion: for imple-
8226 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
8227 -- otherwise the primitive "=" is used directly.
8229 function Expand_Record_Equality
8235 is
8244 -- Return the first field to compare beginning with C, skipping the
8245 -- inherited components.
8247 ----------------------
8248 -- Suitable_Element --
8249 ----------------------
8252 begin
8258 then
8263 then
8268 then
8274 else
8279 -- Start of processing for Expand_Record_Equality
8281 begin
8282 -- Generates the following code: (assuming that Typ has one Discr and
8283 -- component C2 is also a record)
8285 -- True
8286 -- and then Lhs.Discr1 = Rhs.Discr1
8287 -- and then Lhs.C1 = Rhs.C1
8288 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8289 -- and then ...
8290 -- and then Lhs.Cmpn = Rhs.Cmpn
8296 declare
8301 begin
8306 else
8311 Check :=
8313 Lhs =>
8317 Rhs =>
8323 -- If some (sub)component is an unchecked_union, the whole
8324 -- operation will raise program error.
8330 else
8331 Result :=
8344 -------------------------------------
8345 -- Fixup_Universal_Fixed_Operation --
8346 -------------------------------------
8351 begin
8352 -- We must have a type conversion immediately above us
8356 -- Normally the type conversion gives our target type. The exception
8357 -- occurs in the case of the Round attribute, where the conversion
8358 -- will be to universal real, and our real type comes from the Round
8359 -- attribute (as well as an indication that we must round the result)
8363 then
8367 -- Normal case where type comes from conversion above us
8369 else
8374 ------------------------------
8375 -- Get_Allocator_Final_List --
8376 ------------------------------
8378 function Get_Allocator_Final_List
8382 is
8386 -- The entity whose finalization list must be used to attach the
8387 -- allocated object.
8389 begin
8392 -- If the context is an access parameter, we need to create a
8393 -- non-anonymous access type in order to have a usable final list,
8394 -- because there is otherwise no pool to which the allocated object
8395 -- can belong. We create both the type and the finalization chain
8396 -- here, because freezing an internal type does not create such a
8397 -- chain. The Final_Chain that is thus created is shared by the
8398 -- access parameter. The access type is tested against the result
8399 -- type of the function to exclude allocators whose type is an
8400 -- anonymous access result type. We freeze the type at once to
8401 -- ensure that it is properly decorated for the back-end, even
8402 -- if the context and current scope is a loop.
8405 in N_Subprogram_Specification
8406 and then
8407 PtrT /=
8409 then
8414 Type_Definition =>
8416 Subtype_Indication =>
8423 -- Ada 2005 (AI-318-02): If the context is a return object
8424 -- declaration, then the anonymous return subtype is defined to have
8425 -- the same accessibility level as that of the function's result
8426 -- subtype, which means that we want the scope where the function is
8427 -- declared.
8431 then
8434 -- Case of an access discriminant, or (Ada 2005), of an anonymous
8435 -- access component or anonymous access function result: find the
8436 -- final list associated with the scope of the type. (In the
8437 -- anonymous access component kind, a list controller will have
8438 -- been allocated when freezing the record type, and PtrT has an
8439 -- Associated_Final_Chain attribute designating it.)
8449 ---------------------------------
8450 -- Has_Inferable_Discriminants --
8451 ---------------------------------
8456 -- Determines whether the left-most prefix of a selected component is a
8457 -- formal parameter in a subprogram. Assumes N is a selected component.
8459 --------------------------------
8460 -- Prefix_Is_Formal_Parameter --
8461 --------------------------------
8466 begin
8467 -- Move to the left-most prefix by climbing up the tree
8471 loop
8478 -- Start of processing for Has_Inferable_Discriminants
8480 begin
8481 -- For identifiers and indexed components, it is sufficient to have a
8482 -- constrained Unchecked_Union nominal subtype.
8486 and then
8489 -- For selected components, the subtype of the selector must be a
8490 -- constrained Unchecked_Union. If the component is subject to a
8491 -- per-object constraint, then the enclosing object must have inferable
8492 -- discriminants.
8497 -- A small hack. If we have a per-object constrained selected
8498 -- component of a formal parameter, return True since we do not
8499 -- know the actual parameter association yet.
8505 -- Otherwise, check the enclosing object and the selector
8508 and then
8512 -- The call to Has_Inferable_Discriminants will determine whether
8513 -- the selector has a constrained Unchecked_Union nominal type.
8517 -- A qualified expression has inferable discriminants if its subtype
8518 -- mark is a constrained Unchecked_Union subtype.
8522 and then
8530 -------------------------------
8531 -- Insert_Dereference_Action --
8532 -------------------------------
8541 -- Return true if type of P is derived from Checked_Pool;
8543 -----------------------------
8544 -- Is_Checked_Storage_Pool --
8545 -----------------------------
8550 begin
8559 else
8567 -- Start of processing for Insert_Dereference_Action
8569 begin
8574 then
8585 -- Pool
8589 -- Storage_Address. We use the attribute Pool_Address, which uses
8590 -- the pointer itself to find the address of the object, and which
8591 -- handles unconstrained arrays properly by computing the address
8592 -- of the template. i.e. the correct address of the corresponding
8593 -- allocation.
8599 -- Size_In_Storage_Elements
8602 Left_Opnd =>
8604 Prefix =>
8608 Right_Opnd =>
8611 -- Alignment
8614 Prefix =>
8619 exception
8624 ------------------------------
8625 -- Make_Array_Comparison_Op --
8626 ------------------------------
8628 -- This is a hand-coded expansion of the following generic function:
8630 -- generic
8631 -- type elem is (<>);
8632 -- type index is (<>);
8633 -- type a is array (index range <>) of elem;
8635 -- function Gnnn (X : a; Y: a) return boolean is
8636 -- J : index := Y'first;
8638 -- begin
8639 -- if X'length = 0 then
8640 -- return false;
8642 -- elsif Y'length = 0 then
8643 -- return true;
8645 -- else
8646 -- for I in X'range loop
8647 -- if X (I) = Y (J) then
8648 -- if J = Y'last then
8649 -- exit;
8650 -- else
8651 -- J := index'succ (J);
8652 -- end if;
8654 -- else
8655 -- return X (I) > Y (J);
8656 -- end if;
8657 -- end loop;
8659 -- return X'length > Y'length;
8660 -- end if;
8661 -- end Gnnn;
8663 -- Note that since we are essentially doing this expansion by hand, we
8664 -- do not need to generate an actual or formal generic part, just the
8665 -- instantiated function itself.
8667 function Make_Array_Comparison_Op
8670 is
8691 begin
8692 -- if J = Y'last then
8693 -- exit;
8694 -- else
8695 -- J := index'succ (J);
8696 -- end if;
8698 Inner_If :=
8700 Condition =>
8703 Right_Opnd =>
8711 Else_Statements =>
8712 New_List (
8715 Expression =>
8721 -- if X (I) = Y (J) then
8722 -- if ... end if;
8723 -- else
8724 -- return X (I) > Y (J);
8725 -- end if;
8727 Loop_Body :=
8729 Condition =>
8731 Left_Opnd =>
8736 Right_Opnd =>
8745 Expression =>
8747 Left_Opnd =>
8752 Right_Opnd =>
8758 -- for I in X'range loop
8759 -- if ... end if;
8760 -- end loop;
8762 Loop_Statement :=
8766 Iteration_Scheme =>
8768 Loop_Parameter_Specification =>
8771 Discrete_Subtype_Definition =>
8778 -- if X'length = 0 then
8779 -- return false;
8780 -- elsif Y'length = 0 then
8781 -- return true;
8782 -- else
8783 -- for ... loop ... end loop;
8784 -- return X'length > Y'length;
8785 -- end if;
8787 Length1 :=
8792 Length2 :=
8797 Final_Expr :=
8802 If_Stat :=
8804 Condition =>
8806 Left_Opnd =>
8810 Right_Opnd =>
8813 Then_Statements =>
8814 New_List (
8820 Condition =>
8822 Left_Opnd =>
8826 Right_Opnd =>
8829 Then_Statements =>
8830 New_List (
8835 Loop_Statement,
8839 -- (X : a; Y: a)
8850 -- function Gnnn (...) return boolean is
8851 -- J : index := Y'first;
8852 -- begin
8853 -- if ... end if;
8854 -- end Gnnn;
8858 Func_Body :=
8860 Specification =>
8870 Expression =>
8875 Handled_Statement_Sequence =>
8882 ---------------------------
8883 -- Make_Boolean_Array_Op --
8884 ---------------------------
8886 -- For logical operations on boolean arrays, expand in line the following,
8887 -- replacing 'and' with 'or' or 'xor' where needed:
8889 -- function Annn (A : typ; B: typ) return typ is
8890 -- C : typ;
8891 -- begin
8892 -- for J in A'range loop
8893 -- C (J) := A (J) op B (J);
8894 -- end loop;
8895 -- return C;
8896 -- end Annn;
8898 -- Here typ is the boolean array type
8900 function Make_Boolean_Array_Op
8903 is
8921 begin
8922 A_J :=
8927 B_J :=
8932 C_J :=
8938 Op :=
8944 Op :=
8949 else
8950 Op :=
8956 Loop_Statement :=
8960 Iteration_Scheme =>
8962 Loop_Parameter_Specification =>
8965 Discrete_Subtype_Definition =>
8984 Func_Name :=
8988 Func_Body :=
8990 Specification =>
9001 Handled_Statement_Sequence =>
9004 Loop_Statement,
9011 ------------------------
9012 -- Rewrite_Comparison --
9013 ------------------------
9016 begin
9025 declare
9032 -- Res indicates if compare outcome can be compile time determined
9037 begin
9048 and then Constant_Condition_Warnings
9051 and then not In_Instance
9054 then
9055 Error_Msg_N
9072 and then Constant_Condition_Warnings
9075 and then not In_Instance
9078 then
9079 Error_Msg_N
9105 ----------------------------
9106 -- Safe_In_Place_Array_Op --
9107 ----------------------------
9109 function Safe_In_Place_Array_Op
9113 is
9117 -- Operand is safe if it cannot overlap part of the target of the
9118 -- operation. If the operand and the target are identical, the operand
9119 -- is safe. The operand can be empty in the case of negation.
9122 -- Check that N is a stand-alone entity
9124 ------------------
9125 -- Is_Unaliased --
9126 ------------------
9129 begin
9130 return
9136 ---------------------
9137 -- Is_Safe_Operand --
9138 ---------------------
9141 begin
9152 return
9159 else
9164 -- Start of processing for Is_Safe_In_Place_Array_Op
9166 begin
9167 -- Skip this processing if the component size is different from system
9168 -- storage unit (since at least for NOT this would cause problems).
9173 -- Cannot do in place stuff on VM_Target since cannot pass addresses
9178 -- Cannot do in place stuff if non-standard Boolean representation
9185 else
9188 return
9194 -----------------------
9195 -- Tagged_Membership --
9196 -----------------------
9198 -- There are two different cases to consider depending on whether the right
9199 -- operand is a class-wide type or not. If not we just compare the actual
9200 -- tag of the left expr to the target type tag:
9201 --
9202 -- Left_Expr.Tag = Right_Type'Tag;
9203 --
9204 -- If it is a class-wide type we use the RT function CW_Membership which is
9205 -- usually implemented by looking in the ancestor tables contained in the
9206 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
9208 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9209 -- function IW_Membership which is usually implemented by looking in the
9210 -- table of abstract interface types plus the ancestor table contained in
9211 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9222 begin
9230 Obj_Tag :=
9233 Selector_Name =>
9238 -- No need to issue a run-time check if we statically know that the
9239 -- result of this membership test is always true. For example,
9240 -- considering the following declarations:
9242 -- type Iface is interface;
9243 -- type T is tagged null record;
9244 -- type DT is new T and Iface with null record;
9246 -- Obj1 : T;
9247 -- Obj2 : DT;
9249 -- These membership tests are always true:
9251 -- Obj1 in T'Class
9252 -- Obj2 in T'Class;
9253 -- Obj2 in Iface'Class;
9255 -- We do not need to handle cases where the membership is illegal.
9256 -- For example:
9258 -- Obj1 in DT'Class; -- Compile time error
9259 -- Obj1 in Iface'Class; -- Compile time error
9264 and then Interface_Present_In_Ancestor
9267 then
9271 -- Ada 2005 (AI-251): Class-wide applied to interfaces
9275 -- Support to: "Iface_CW_Typ in Typ'Class"
9278 then
9279 -- Issue error if IW_Membership operation not available in a
9280 -- configurable run time setting.
9283 Error_Msg_CRT
9288 return
9295 New_Reference_To (
9296 Node (First_Elmt
9298 Loc)));
9300 -- Ada 95: Normal case
9302 else
9303 return
9306 Typ_Tag_Node =>
9307 New_Reference_To (
9308 Node (First_Elmt
9310 Loc));
9313 -- Right_Type is not a class-wide type
9315 else
9316 -- No need to check the tag of the object if Right_Typ is abstract
9321 else
9322 return
9325 Right_Opnd =>
9326 New_Reference_To
9332 ------------------------------
9333 -- Unary_Op_Validity_Checks --
9334 ------------------------------
9337 begin