| blob | 9cc8865b64d1d0a5d051a233f1d44438bf151828 |
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-2012, 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 ------------------------------------------------------------------------------
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
87 -- Performs validity checks for a binary operator
89 procedure Build_Boolean_Array_Proc_Call
93 -- If a boolean array assignment can be done in place, build call to
94 -- corresponding library procedure.
97 -- Return the entity of the heterogeneous finalization master belonging to
98 -- the current unit (either function, package or procedure). This master
99 -- services all anonymous access-to-controlled types. If the current unit
100 -- does not have such master, create one.
103 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
104 -- Expand_Allocator_Expression. Allocating class-wide interface objects
105 -- this routine displaces the pointer to the allocated object to reference
106 -- the component referencing the corresponding secondary dispatch table.
109 -- Subsidiary to Expand_N_Allocator, for the case when the expression
110 -- is a qualified expression or an aggregate.
113 -- This routine handles expansion of the comparison operators (N_Op_Lt,
114 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
115 -- code for these operators is similar, differing only in the details of
116 -- the actual comparison call that is made. Special processing (call a
117 -- run-time routine)
119 function Expand_Array_Equality
125 -- Expand an array equality into a call to a function implementing this
126 -- equality, and a call to it. Loc is the location for the generated nodes.
127 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
128 -- on which to attach bodies of local functions that are created in the
129 -- process. It is the responsibility of the caller to insert those bodies
130 -- at the right place. Nod provides the Sloc value for the generated code.
131 -- Normally the types used for the generated equality routine are taken
132 -- from Lhs and Rhs. However, in some situations of generated code, the
133 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
134 -- the type to be used for the formal parameters.
137 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
138 -- case of array type arguments.
141 -- Common expansion processing for short-circuit boolean operators
143 function Expand_Composite_Equality
149 -- Local recursive function used to expand equality for nested composite
150 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
151 -- to attach bodies of local functions that are created in the process.
152 -- It is the responsibility of the caller to insert those bodies at the
153 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
154 -- are the left and right sides for the comparison, and Typ is the type of
155 -- the objects to compare.
158 -- Routine to expand concatenation of a sequence of two or more operands
159 -- (in the list Operands) and replace node Cnode with the result of the
160 -- concatenation. The operands can be of any appropriate type, and can
161 -- include both arrays and singleton elements.
164 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
165 -- fixed. We do not have such a type at runtime, so the purpose of this
166 -- routine is to find the real type by looking up the tree. We also
167 -- determine if the operation must be rounded.
170 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
171 -- discriminants if it has a constrained nominal type, unless the object
172 -- is a component of an enclosing Unchecked_Union object that is subject
173 -- to a per-object constraint and the enclosing object lacks inferable
174 -- discriminants.
175 --
176 -- An expression of an Unchecked_Union type has inferable discriminants
177 -- if it is either a name of an object with inferable discriminants or a
178 -- qualified expression whose subtype mark denotes a constrained subtype.
181 -- N is an expression whose type is an access. When the type of the
182 -- associated storage pool is derived from Checked_Pool, generate a
183 -- call to the 'Dereference' primitive operation.
185 function Make_Array_Comparison_Op
188 -- Comparisons between arrays are expanded in line. This function produces
189 -- the body of the implementation of (a > b), where a and b are one-
190 -- dimensional arrays of some discrete type. The original node is then
191 -- expanded into the appropriate call to this function. Nod provides the
192 -- Sloc value for the generated code.
194 function Make_Boolean_Array_Op
197 -- Boolean operations on boolean arrays are expanded in line. This function
198 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
199 -- b). It is used only the normal case and not the packed case. The type
200 -- involved, Typ, is the Boolean array type, and the logical operations in
201 -- the body are simple boolean operations. Note that Typ is always a
202 -- constrained type (the caller has ensured this by using
203 -- Convert_To_Actual_Subtype if necessary).
206 -- Given an expression, if it is of the form X'Length op N (or the other
207 -- way round), where N is known at compile time to be 0 or 1, and X is a
208 -- simple entity, and op is a comparison operator, optimizes it into a
209 -- comparison of First and Last.
212 -- If N is the node for a comparison whose outcome can be determined at
213 -- compile time, then the node N can be rewritten with True or False. If
214 -- the outcome cannot be determined at compile time, the call has no
215 -- effect. If N is a type conversion, then this processing is applied to
216 -- its expression. If N is neither comparison nor a type conversion, the
217 -- call has no effect.
219 procedure Tagged_Membership
223 -- Construct the expression corresponding to the tagged membership test.
224 -- Deals with a second operand being (or not) a class-wide type.
226 function Safe_In_Place_Array_Op
230 -- In the context of an assignment, where the right-hand side is a boolean
231 -- operation on arrays, check whether operation can be performed in place.
235 -- Performs validity checks for a unary operator
237 -------------------------------
238 -- Binary_Op_Validity_Checks --
239 -------------------------------
242 begin
249 ------------------------------------
250 -- Build_Boolean_Array_Proc_Call --
251 ------------------------------------
253 procedure Build_Boolean_Array_Proc_Call
257 is
270 begin
274 -- Use negated version of the binary operators
286 Call_Node :=
291 Target,
304 else
307 Call_Node :=
311 Target,
322 else
323 -- We use the following equivalences:
325 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
326 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
327 -- (not X) xor (not Y) = X xor Y
328 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
337 else
341 else
349 else
354 Call_Node :=
358 Target,
373 exception
378 ------------------------------
379 -- Current_Anonymous_Master --
380 ------------------------------
389 begin
392 -- Find the entity of the current unit
396 -- When processing subprogram bodies, the proper scope is always that
397 -- of the spec.
402 loop
412 -- Find the declarations list of the current unit
426 else
438 -- The current unit has an existing anonymous master, traverse its
439 -- declarations and locate the entity.
442 declare
446 begin
450 -- Look for the first variable in the declarations whole type
451 -- is Finalization_Master.
458 then
466 -- The master was not found even though the unit was labeled as
467 -- having one.
472 -- Create a new anonymous master
474 else
475 declare
480 begin
481 -- Since the master and its associated initialization is inserted
482 -- at top level, use the scope of the unit when analyzing.
486 -- Create the finalization master
488 Fin_Mas_Id :=
492 -- Generate:
493 -- <Fin_Mas_Id> : Finalization_Master;
495 Action :=
498 Object_Definition =>
503 -- Mark the unit to prevent the generation of multiple masters
507 -- Do not set the base pool and mode of operation on .NET/JVM
508 -- since those targets do not support pools and all VM masters
509 -- are heterogeneous by default.
513 -- Generate:
514 -- Set_Base_Pool
515 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
517 Action :=
519 Name =>
525 Prefix =>
531 -- Generate:
532 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
534 Action :=
536 Name =>
544 -- Restore the original state of the scope stack
546 Pop_Scope;
553 --------------------------------
554 -- Displace_Allocator_Pointer --
555 --------------------------------
564 begin
565 -- Do nothing in case of VM targets: the virtual machine will handle
566 -- interfaces directly.
581 then
582 -- If the type of the allocator expression is not an interface type
583 -- we can generate code to reference the record component containing
584 -- the pointer to the secondary dispatch table.
587 declare
590 begin
591 -- 1) Get access to the allocated object
598 -- 2) Add the conversion to displace the pointer to reference
599 -- the secondary dispatch table.
604 -- 3) The 'access to the secondary dispatch table will be used
605 -- as the value returned by the allocator.
615 -- If the type of the allocator expression is an interface type we
616 -- generate a run-time call to displace "this" to reference the
617 -- component containing the pointer to the secondary dispatch table
618 -- or else raise Constraint_Error if the actual object does not
619 -- implement the target interface. This case corresponds with the
620 -- following example:
622 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
623 -- begin
624 -- return new Iface_2'Class'(Obj);
625 -- end Op;
627 else
636 New_Occurrence_Of
638 (First_Elmt
640 Loc)))));
646 ---------------------------------
647 -- Expand_Allocator_Expression --
648 ---------------------------------
656 procedure Apply_Accessibility_Check
659 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
660 -- type, generate an accessibility check to verify that the level of the
661 -- type of the created object is not deeper than the level of the access
662 -- type. If the type of the qualified expression is class-wide, then
663 -- always generate the check (except in the case where it is known to be
664 -- unnecessary, see comment below). Otherwise, only generate the check
665 -- if the level of the qualified expression type is statically deeper
666 -- than the access type.
667 --
668 -- Although the static accessibility will generally have been performed
669 -- as a legality check, it won't have been done in cases where the
670 -- allocator appears in generic body, so a run-time check is needed in
671 -- general. One special case is when the access type is declared in the
672 -- same scope as the class-wide allocator, in which case the check can
673 -- never fail, so it need not be generated.
674 --
675 -- As an open issue, there seem to be cases where the static level
676 -- associated with the class-wide object's underlying type is not
677 -- sufficient to perform the proper accessibility check, such as for
678 -- allocators in nested subprograms or accept statements initialized by
679 -- class-wide formals when the actual originates outside at a deeper
680 -- static level. The nested subprogram case might require passing
681 -- accessibility levels along with class-wide parameters, and the task
682 -- case seems to be an actual gap in the language rules that needs to
683 -- be fixed by the ARG. ???
685 -------------------------------
686 -- Apply_Accessibility_Check --
687 -------------------------------
689 procedure Apply_Accessibility_Check
692 is
699 begin
703 and then
705 or else
709 then
710 -- If the allocator was built in place, Ref is already a reference
711 -- to the access object initialized to the result of the allocator
712 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
713 -- Remove_Side_Effects for cases where the build-in-place call may
714 -- still be the prefix of the reference (to avoid generating
715 -- duplicate calls). Otherwise, it is the entity associated with
716 -- the object containing the address of the allocated object.
721 else
725 -- Step 1: Create the object clean up code
729 -- Create an explicit free statement to clean up the allocated
730 -- object in case the accessibility check fails. Generate:
732 -- Free (Obj_Ref);
739 -- Finalize the object (if applicable), but wrap the call inside
740 -- a block to ensure that the object would still be deallocated in
741 -- case the finalization fails. Generate:
743 -- begin
744 -- [Deep_]Finalize (Obj_Ref.all);
745 -- exception
746 -- when others =>
747 -- Free (Obj_Ref);
748 -- raise;
749 -- end;
754 Handled_Statement_Sequence =>
757 Make_Final_Call (
758 Obj_Ref =>
772 -- Signal the accessibility failure through a Program_Error
779 -- Step 2: Create the accessibility comparison
781 -- Generate:
782 -- Ref'Tag
784 Obj_Ref :=
789 -- For tagged types, determine the accessibility level by looking
790 -- at the type specific data of the dispatch table. Generate:
792 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
797 -- Use a runtime call to determine the accessibility level when
798 -- compiling on virtual machine targets. Generate:
800 -- Get_Access_Level (Ref'Tag)
802 else
803 Cond :=
805 Name =>
810 Cond :=
813 Right_Opnd =>
816 -- Due to the complexity and side effects of the check, utilize an
817 -- if statement instead of the regular Program_Error circuitry.
826 -- Local variables
837 -- Type used as source for tag assignment
840 -- Target reference for tag assignment
842 -- Start of processing for Expand_Allocator_Expression
844 begin
845 -- In the case of an Ada 2012 allocator whose initial value comes from a
846 -- function call, pass "the accessibility level determined by the point
847 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
848 -- Expand_Call but it couldn't be done there (because the Etype of the
849 -- allocator wasn't set then) so we generate the parameter here. See
850 -- the Boolean variable Defer in (a block within) Expand_Call.
853 declare
856 begin
859 else
866 Add_Extra_Actual_To_Call
874 -- Would be nice to comment the branches of this very long if ???
879 -- Generate:
880 -- Pnnn : constant ptr_T := new (T);
881 -- Init (Pnnn.all,...);
883 -- Allocate the object without an expression
888 -- Avoid its expansion to avoid generating a call to the default
889 -- C++ constructor.
895 Temp_Decl :=
905 -- Locate the enclosing list and insert the C++ constructor call
907 declare
910 begin
918 Id_Ref =>
930 -- Ada 2005 (AI-318-02): If the initialization expression is a call
931 -- to a build-in-place function, then access to the allocated object
932 -- must be passed to the function. Currently we limit such functions
933 -- to those with constrained limited result subtypes, but eventually
934 -- we plan to expand the allowed forms of functions that are treated
935 -- as build-in-place.
939 then
945 -- Actions inserted before:
946 -- Temp : constant ptr_T := new T'(Expression);
947 -- Temp._tag = T'tag; -- when not class-wide
948 -- [Deep_]Adjust (Temp.all);
950 -- We analyze by hand the new internal allocator to avoid any
951 -- recursion and inappropriate call to Initialize
953 -- We don't want to remove side effects when the expression must be
954 -- built in place. In the case of a build-in-place function call,
955 -- that could lead to a duplication of the call, which was already
956 -- substituted for the allocator.
964 -- For a class wide allocation generate the following code:
966 -- type Equiv_Record is record ... end record;
967 -- implicit subtype CW is <Class_Wide_Subytpe>;
968 -- temp : PtrT := new CW'(CW!(expr));
973 -- Ada 2005 (AI-251): If the expression is a class-wide interface
974 -- object we generate code to move up "this" to reference the
975 -- base of the object before allocating the new object.
977 -- Note that Exp'Address is recursively expanded into a call
978 -- to Base_Address (Exp.Tag)
982 and then Tagged_Type_Expansion
983 then
984 Set_Expression
992 else
993 Set_Expression
1001 -- Processing for allocators returning non-interface types
1005 Temp_Decl :=
1009 Expression =>
1011 Expression =>
1014 -- Copy the Comes_From_Source flag for the allocator we just
1015 -- built, since logically this allocator is a replacement of
1016 -- the original allocator node. This is for proper handling of
1017 -- restriction No_Implicit_Heap_Allocations.
1019 Set_Comes_From_Source
1028 -- Attach the object to the associated finalization master.
1029 -- This is done manually on .NET/JVM since those compilers do
1030 -- no support pools and can't benefit from internally generated
1031 -- Allocate / Deallocate procedures.
1036 then
1038 Make_Attach_Call (
1039 Obj_Ref =>
1044 else
1048 Temp_Decl :=
1058 -- Attach the object to the associated finalization master.
1059 -- This is done manually on .NET/JVM since those compilers do
1060 -- no support pools and can't benefit from internally generated
1061 -- Allocate / Deallocate procedures.
1066 then
1068 Make_Attach_Call (
1069 Obj_Ref =>
1075 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1076 -- interface type. In this case we use the type of the qualified
1077 -- expression to allocate the object.
1079 else
1080 declare
1084 begin
1085 New_Decl :=
1088 Type_Definition =>
1093 Subtype_Indication =>
1098 -- Inherit the allocation-related attributes from the original
1099 -- access type.
1106 -- Declare the object using the previous type declaration
1109 Temp_Decl :=
1113 Expression =>
1117 -- Copy the Comes_From_Source flag for the allocator we just
1118 -- built, since logically this allocator is a replacement of
1119 -- the original allocator node. This is for proper handling
1120 -- of restriction No_Implicit_Heap_Allocations.
1122 Set_Comes_From_Source
1131 else
1135 Temp_Decl :=
1146 -- Generate an additional object containing the address of the
1147 -- returned object. The type of this second object declaration
1148 -- is the correct type required for the common processing that
1149 -- is still performed by this subprogram. The displacement of
1150 -- this pointer to reference the component associated with the
1151 -- interface type will be done at the end of common processing.
1153 New_Decl :=
1157 Expression =>
1170 -- Generate the tag assignment
1172 -- Suppress the tag assignment when VM_Target because VM tags are
1173 -- represented implicitly in objects.
1178 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1179 -- interface objects because in this case the tag does not change.
1192 then
1194 TagR :=
1201 declare
1203 begin
1204 Tag_Assign :=
1206 Name =>
1209 Selector_Name =>
1211 Expression =>
1213 New_Reference_To
1218 -- The previous assignment has to be done in any case
1226 then
1227 -- Generate an Adjust call if the object will be moved. In Ada
1228 -- 2005, the object may be inherently limited, in which case
1229 -- there is no Adjust procedure, and the object is built in
1230 -- place. In Ada 95, the object can be limited but not
1231 -- inherently limited if this allocator came from a return
1232 -- statement (we're allocating the result on the secondary
1233 -- stack). In that case, the object will be moved, so we _do_
1234 -- want to Adjust.
1236 if not Aggr_In_Place
1238 then
1240 Make_Adjust_Call (
1241 Obj_Ref =>
1243 -- An unchecked conversion is needed in the classwide
1244 -- case because the designated type can be an ancestor
1245 -- of the subtype mark of the allocator.
1253 -- Generate:
1254 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1256 -- Do not generate this call in the following cases:
1258 -- * .NET/JVM - these targets do not support address arithmetic
1259 -- and unchecked conversion, key elements of Finalize_Address.
1261 -- * Alfa mode - the call is useless and results in unwanted
1262 -- expansion.
1264 -- * CodePeer mode - TSS primitive Finalize_Address is not
1265 -- created in this mode.
1268 and then not Alfa_Mode
1269 and then not CodePeer_Mode
1273 then
1275 Make_Set_Finalize_Address_Call
1285 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1286 -- component containing the secondary dispatch table of the interface
1287 -- type.
1295 Temp_Decl :=
1299 Expression =>
1303 -- Copy the Comes_From_Source flag for the allocator we just built,
1304 -- since logically this allocator is a replacement of the original
1305 -- allocator node. This is for proper handling of restriction
1306 -- No_Implicit_Heap_Allocations.
1308 Set_Comes_From_Source
1317 -- Attach the object to the associated finalization master. Thisis
1318 -- done manually on .NET/JVM since those compilers do no support
1319 -- pools and cannot benefit from internally generated Allocate and
1320 -- Deallocate procedures.
1325 then
1327 Make_Attach_Call
1337 then
1343 then
1344 -- Apply constraint to designated subtype indication
1352 -- Propagate constraint_error to enclosing allocator
1357 else
1360 -- If we have:
1361 -- type A is access T1;
1362 -- X : A := new T2'(...);
1363 -- T1 and T2 can be different subtypes, and we might need to check
1364 -- both constraints. First check against the type of the qualified
1365 -- expression.
1374 -- A check is also needed in cases where the designated subtype is
1375 -- constrained and differs from the subtype given in the qualified
1376 -- expression. Note that the check on the qualified expression does
1377 -- not allow sliding, but this check does (a relaxation from Ada 83).
1381 then
1382 Apply_Constraint_Check
1391 -- For an access to unconstrained packed array, GIGI needs to see an
1392 -- expression with a constrained subtype in order to compute the
1393 -- proper size for the allocator.
1398 then
1399 declare
1402 begin
1406 Subtype_Indication =>
1413 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1414 -- to a build-in-place function, then access to the allocated object
1415 -- must be passed to the function. Currently we limit such functions
1416 -- to those with constrained limited result subtypes, but eventually
1417 -- we plan to expand the allowed forms of functions that are treated
1418 -- as build-in-place.
1422 then
1427 exception
1432 -----------------------------
1433 -- Expand_Array_Comparison --
1434 -----------------------------
1436 -- Expansion is only required in the case of array types. For the unpacked
1437 -- case, an appropriate runtime routine is called. For packed cases, and
1438 -- also in some other cases where a runtime routine cannot be called, the
1439 -- form of the expansion is:
1441 -- [body for greater_nn; boolean_expression]
1443 -- The body is built by Make_Array_Comparison_Op, and the form of the
1444 -- Boolean expression depends on the operator involved.
1460 -- True for byte addressable target
1463 -- Returns True if the length of the given operand is known to be less
1464 -- than 4. Returns False if this length is known to be four or greater
1465 -- or is not known at compile time.
1467 ------------------------
1468 -- Length_Less_Than_4 --
1469 ------------------------
1474 begin
1478 else
1479 declare
1486 begin
1489 else
1495 else
1504 -- Start of processing for Expand_Array_Comparison
1506 begin
1507 -- Deal first with unpacked case, where we can call a runtime routine
1508 -- except that we avoid this for targets for which are not addressable
1509 -- by bytes, and for the JVM/CIL, since they do not support direct
1510 -- addressing of array components.
1513 and then Byte_Addressable
1515 then
1516 -- The call we generate is:
1518 -- Compare_Array_xn[_Unaligned]
1519 -- (left'address, right'address, left'length, right'length) <op> 0
1521 -- x = U for unsigned, S for signed
1522 -- n = 8,16,32,64 for component size
1523 -- Add _Unaligned if length < 4 and component size is 8.
1524 -- <op> is the standard comparison operator
1528 or else
1530 then
1533 else
1537 else
1540 else
1548 else
1555 else
1562 else
1600 -- Cases where we cannot make runtime call
1602 -- For (a <= b) we convert to not (a > b)
1607 Right_Opnd =>
1614 -- For < the Boolean expression is
1615 -- greater__nn (op2, op1)
1620 -- Switch operands
1625 -- For (a >= b) we convert to not (a < b)
1630 Right_Opnd =>
1637 -- For > the Boolean expression is
1638 -- greater__nn (op1, op2)
1640 else
1646 Expr :=
1655 exception
1660 ---------------------------
1661 -- Expand_Array_Equality --
1662 ---------------------------
1664 -- Expand an equality function for multi-dimensional arrays. Here is an
1665 -- example of such a function for Nb_Dimension = 2
1667 -- function Enn (A : atyp; B : btyp) return boolean is
1668 -- begin
1669 -- if (A'length (1) = 0 or else A'length (2) = 0)
1670 -- and then
1671 -- (B'length (1) = 0 or else B'length (2) = 0)
1672 -- then
1673 -- return True; -- RM 4.5.2(22)
1674 -- end if;
1676 -- if A'length (1) /= B'length (1)
1677 -- or else
1678 -- A'length (2) /= B'length (2)
1679 -- then
1680 -- return False; -- RM 4.5.2(23)
1681 -- end if;
1683 -- declare
1684 -- A1 : Index_T1 := A'first (1);
1685 -- B1 : Index_T1 := B'first (1);
1686 -- begin
1687 -- loop
1688 -- declare
1689 -- A2 : Index_T2 := A'first (2);
1690 -- B2 : Index_T2 := B'first (2);
1691 -- begin
1692 -- loop
1693 -- if A (A1, A2) /= B (B1, B2) then
1694 -- return False;
1695 -- end if;
1697 -- exit when A2 = A'last (2);
1698 -- A2 := Index_T2'succ (A2);
1699 -- B2 := Index_T2'succ (B2);
1700 -- end loop;
1701 -- end;
1703 -- exit when A1 = A'last (1);
1704 -- A1 := Index_T1'succ (A1);
1705 -- B1 := Index_T1'succ (B1);
1706 -- end loop;
1707 -- end;
1709 -- return true;
1710 -- end Enn;
1712 -- Note on the formal types used (atyp and btyp). If either of the arrays
1713 -- is of a private type, we use the underlying type, and do an unchecked
1714 -- conversion of the actual. If either of the arrays has a bound depending
1715 -- on a discriminant, then we use the base type since otherwise we have an
1716 -- escaped discriminant in the function.
1718 -- If both arrays are constrained and have the same bounds, we can generate
1719 -- a loop with an explicit iteration scheme using a 'Range attribute over
1720 -- the first array.
1722 function Expand_Array_Equality
1728 is
1744 -- The parameter types to be used for the formals
1746 function Arr_Attr
1750 -- This builds the attribute reference Arr'Nam (Expr)
1753 -- Create one statement to compare corresponding components, designated
1754 -- by a full set of indexes.
1757 -- Given one of the arguments, computes the appropriate type to be used
1758 -- for that argument in the corresponding function formal
1760 function Handle_One_Dimension
1763 -- This procedure returns the following code
1764 --
1765 -- declare
1766 -- Bn : Index_T := B'First (N);
1767 -- begin
1768 -- loop
1769 -- xxx
1770 -- exit when An = A'Last (N);
1771 -- An := Index_T'Succ (An)
1772 -- Bn := Index_T'Succ (Bn)
1773 -- end loop;
1774 -- end;
1775 --
1776 -- If both indexes are constrained and identical, the procedure
1777 -- returns a simpler loop:
1778 --
1779 -- for An in A'Range (N) loop
1780 -- xxx
1781 -- end loop
1782 --
1783 -- N is the dimension for which we are generating a loop. Index is the
1784 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1785 -- xxx statement is either the loop or declare for the next dimension
1786 -- or if this is the last dimension the comparison of corresponding
1787 -- components of the arrays.
1788 --
1789 -- The actual way the code works is to return the comparison of
1790 -- corresponding components for the N+1 call. That's neater!
1793 -- This function constructs the test for both arrays being empty
1794 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1795 -- and then
1796 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1799 -- This function constructs the test for arrays having different lengths
1800 -- in at least one index position, in which case the resulting code is:
1802 -- A'length (1) /= B'length (1)
1803 -- or else
1804 -- A'length (2) /= B'length (2)
1805 -- or else
1806 -- ...
1808 --------------
1809 -- Arr_Attr --
1810 --------------
1812 function Arr_Attr
1816 is
1817 begin
1818 return
1825 ------------------------
1826 -- Component_Equality --
1827 ------------------------
1833 begin
1834 -- if a(i1...) /= b(j1...) then return false; end if;
1836 L :=
1841 R :=
1846 Test := Expand_Composite_Equality
1849 -- If some (sub)component is an unchecked_union, the whole operation
1850 -- will raise program error.
1854 -- This node is going to be inserted at a location where a
1855 -- statement is expected: clear its Etype so analysis will set
1856 -- it to the expected Standard_Void_Type.
1861 else
1862 return
1871 ------------------
1872 -- Get_Arg_Type --
1873 ------------------
1879 begin
1885 else
1891 or else
1893 then
1905 --------------------------
1906 -- Handle_One_Dimension --
1907 ---------------------------
1909 function Handle_One_Dimension
1912 is
1914 Ltyp /= Rtyp
1916 -- If the index types are identical, and we are working with
1917 -- constrained types, then we can use the same index for both
1918 -- of the arrays.
1927 begin
1932 -- Case where we generate a loop
1938 else
1950 -- Generate guard for loop, followed by increments of indexes
1954 Condition =>
1962 Expression =>
1971 Expression =>
1978 -- If separate indexes, we need a declare block for An and Bn, and a
1979 -- loop without an iteration scheme.
1982 Loop_Stm :=
1985 return
1998 Handled_Statement_Sequence =>
2002 -- If no separate indexes, return loop statement with explicit
2003 -- iteration scheme on its own
2005 else
2006 Loop_Stm :=
2009 Iteration_Scheme =>
2011 Loop_Parameter_Specification =>
2014 Discrete_Subtype_Definition =>
2020 -----------------------
2021 -- Test_Empty_Arrays --
2022 -----------------------
2031 begin
2035 Atest :=
2040 Btest :=
2049 else
2050 Alist :=
2055 Blist :=
2062 return
2068 -----------------------------
2069 -- Test_Lengths_Correspond --
2070 -----------------------------
2076 begin
2079 Rtest :=
2086 else
2087 Result :=
2097 -- Start of processing for Expand_Array_Equality
2099 begin
2103 -- For now, if the argument types are not the same, go to the base type,
2104 -- since the code assumes that the formals have the same type. This is
2105 -- fixable in future ???
2113 -- Build list of formals for function
2126 -- Build statement sequence for function
2128 Func_Body :=
2130 Specification =>
2138 Handled_Statement_Sequence =>
2146 Expression =>
2153 Expression =>
2164 -- If the array type is distinct from the type of the arguments, it
2165 -- is the full view of a private type. Apply an unchecked conversion
2166 -- to insure that analysis of the call succeeds.
2168 declare
2171 begin
2177 then
2183 then
2192 return
2198 -----------------------------
2199 -- Expand_Boolean_Operator --
2200 -----------------------------
2202 -- Note that we first get the actual subtypes of the operands, since we
2203 -- always want to deal with types that have bounds.
2208 begin
2209 -- Special case of bit packed array where both operands are known to be
2210 -- properly aligned. In this case we use an efficient run time routine
2211 -- to carry out the operation (see System.Bit_Ops).
2216 then
2221 -- For the normal non-packed case, the general expansion is to build
2222 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2223 -- and then inserting it into the tree. The original operator node is
2224 -- then rewritten as a call to this function. We also use this in the
2225 -- packed case if either operand is a possibly unaligned object.
2227 declare
2234 begin
2247 then
2252 and then
2254 then
2256 else
2262 -- Now rewrite the expression with a call
2267 Parameter_Associations =>
2268 New_List (
2269 L,
2270 Make_Type_Conversion
2278 -------------------------------
2279 -- Expand_Composite_Equality --
2280 -------------------------------
2282 -- This function is only called for comparing internal fields of composite
2283 -- types when these fields are themselves composites. This is a special
2284 -- case because it is not possible to respect normal Ada visibility rules.
2286 function Expand_Composite_Equality
2292 is
2299 -- AI05-0123: Locate primitive equality for type if it exists, and
2300 -- build the corresponding call. If operation is abstract, replace
2301 -- call with an explicit raise. Return Empty if there is no primitive.
2303 -----------------------
2304 -- Find_Primitive_Eq --
2305 -----------------------
2311 begin
2316 -- Locate primitive equality with the right signature
2322 then
2324 return
2328 else
2329 return
2339 -- If not found, predefined operation will be used
2344 -- Start of processing for Expand_Composite_Equality
2346 begin
2349 else
2353 -- Defense against malformed private types with no completion the error
2354 -- will be diagnosed later by check_completion
2364 -- If the operand is an elementary type other than a floating-point
2365 -- type, then we can simply use the built-in block bitwise equality,
2366 -- since the predefined equality operators always apply and bitwise
2367 -- equality is fine for all these cases.
2371 then
2374 -- For composite component types, and floating-point types, use the
2375 -- expansion. This deals with tagged component types (where we use
2376 -- the applicable equality routine) and floating-point, (where we
2377 -- need to worry about negative zeroes), and also the case of any
2378 -- composite type recursively containing such fields.
2380 else
2386 -- Call the primitive operation "=" of this type
2392 -- If this is derived from an untagged private type completed with a
2393 -- tagged type, it does not have a full view, so we use the primitive
2394 -- operations of the private type. This check should no longer be
2395 -- necessary when these types receive their full views ???
2402 then
2404 else
2408 loop
2420 return
2423 Parameter_Associations =>
2424 New_List
2434 -- Inherited equality from parent type. Convert the actuals to
2435 -- match signature of operation.
2437 declare
2440 begin
2441 return
2449 else
2450 -- Comparison between Unchecked_Union components
2453 declare
2459 begin
2460 -- Lhs subtype
2466 -- Rhs subtype
2472 -- Lhs of the composite equality
2476 -- Since the enclosing record type can never be an
2477 -- Unchecked_Union (this code is executed for records
2478 -- that do not have variants), we may reference its
2479 -- discriminant(s).
2484 then
2485 Lhs_Discr_Val :=
2488 Selector_Name =>
2489 New_Copy
2490 (Get_Discriminant_Value
2492 Lhs_Type,
2495 else
2496 Lhs_Discr_Val :=
2497 New_Copy
2498 (Get_Discriminant_Value
2500 Lhs_Type,
2504 else
2505 -- It is not possible to infer the discriminant since
2506 -- the subtype is not constrained.
2508 return
2513 -- Rhs of the composite equality
2517 and then Has_Per_Object_Constraint
2519 then
2520 Rhs_Discr_Val :=
2523 Selector_Name =>
2524 New_Copy
2525 (Get_Discriminant_Value
2527 Rhs_Type,
2530 else
2531 Rhs_Discr_Val :=
2532 New_Copy
2533 (Get_Discriminant_Value
2535 Rhs_Type,
2539 else
2540 return
2545 -- Call the TSS equality function with the inferred
2546 -- discriminant values.
2548 return
2552 Lhs,
2553 Rhs,
2554 Lhs_Discr_Val,
2555 Rhs_Discr_Val));
2558 else
2559 return
2566 -- Equality composes in Ada 2012 for untagged record types. It also
2567 -- composes for bounded strings, because they are part of the
2568 -- predefined environment. We could make it compose for bounded
2569 -- strings by making them tagged, or by making sure all subcomponents
2570 -- are set to the same value, even when not used. Instead, we have
2571 -- this special case in the compiler, because it's more efficient.
2575 -- if no TSS has been created for the type, check whether there is
2576 -- a primitive equality declared for it.
2578 declare
2581 begin
2582 -- Use user-defined primitive if it exists, otherwise use
2583 -- predefined equality.
2587 else
2592 else
2596 else
2597 -- If not array or record type, it is predefined equality.
2603 ------------------------
2604 -- Expand_Concatenate --
2605 ------------------------
2611 -- Result type of concatenation
2614 -- Component type. Elements of this component type can appear as one
2615 -- of the operands of concatenation as well as arrays.
2618 -- Index subtype
2621 -- Index type. This is the base type of the index subtype, and is used
2622 -- for all computed bounds (which may be out of range of Istyp in the
2623 -- case of null ranges).
2626 -- This is the type we use to do arithmetic to compute the bounds and
2627 -- lengths of operands. The choice of this type is a little subtle and
2628 -- is discussed in a separate section at the start of the body code.
2631 -- Raised if concatenation is sure to raise a CE
2634 -- Reset to False if at least one operand is encountered which is known
2635 -- at compile time to be non-null. Used for handling the special case
2636 -- of setting the high bound to the last operand high bound for a null
2637 -- result, thus ensuring a proper high bound in the super-flat case.
2640 -- Number of concatenation operands including possibly null operands
2643 -- Number of operands excluding any known to be null, except that the
2644 -- last operand is always retained, in case it provides the bounds for
2645 -- a null result.
2648 -- Current operand being processed in the loop through operands. After
2649 -- this loop is complete, always contains the last operand (which is not
2650 -- the same as Operands (NN), since null operands are skipped).
2652 -- Arrays describing the operands, only the first NN entries of each
2653 -- array are set (NN < N when we exclude known null operands).
2656 -- True if length of corresponding operand known at compile time
2659 -- Set to the corresponding entry in the Opnds list (but note that null
2660 -- operands are excluded, so not all entries in the list are stored).
2663 -- Set to length of operand. Entries in this array are set only if the
2664 -- corresponding entry in Is_Fixed_Length is True.
2667 -- Set to lower bound of operand. Either an integer literal in the case
2668 -- where the bound is known at compile time, else actual lower bound.
2669 -- The operand low bound is of type Ityp.
2672 -- Set to an entity of type Natural that contains the length of an
2673 -- operand whose length is not known at compile time. Entries in this
2674 -- array are set only if the corresponding entry in Is_Fixed_Length
2675 -- is False. The entity is of type Artyp.
2678 -- The J'th entry in an expression node that represents the total length
2679 -- of operands 1 through J. It is either an integer literal node, or a
2680 -- reference to a constant entity with the right value, so it is fine
2681 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2682 -- entry always is set to zero. The length is of type Artyp.
2685 -- A tree node representing the low bound of the result (of type Ityp).
2686 -- This is either an integer literal node, or an identifier reference to
2687 -- a constant entity initialized to the appropriate value.
2690 -- A tree node representing the low bound of the last operand. This
2691 -- need only be set if the result could be null. It is used for the
2692 -- special case of setting the right low bound for a null result.
2693 -- This is of type Ityp.
2696 -- A tree node representing the high bound of the last operand. This
2697 -- need only be set if the result could be null. It is used for the
2698 -- special case of setting the right high bound for a null result.
2699 -- This is of type Ityp.
2702 -- A tree node representing the high bound of the result (of type Ityp)
2705 -- Result of the concatenation (of type Ityp)
2708 -- Collect actions to be inserted
2711 -- Set True during generation of the assignments of operands into
2712 -- result once an operand known to be non-null has been seen.
2715 -- This function makes an N_Integer_Literal node that is returned in
2716 -- analyzed form with the type set to Artyp. Importantly this literal
2717 -- is not flagged as static, so that if we do computations with it that
2718 -- result in statically detected out of range conditions, we will not
2719 -- generate error messages but instead warning messages.
2722 -- Given a node of type Ityp, returns the corresponding value of type
2723 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2724 -- For enum types, the Pos of the value is returned.
2727 -- The inverse function (uses Val in the case of enumeration types)
2729 ------------------------
2730 -- Make_Artyp_Literal --
2731 ------------------------
2735 begin
2742 --------------
2743 -- To_Artyp --
2744 --------------
2747 begin
2752 return
2758 else
2763 -------------
2764 -- To_Ityp --
2765 -------------
2768 begin
2770 return
2776 -- Case where we will do a type conversion
2778 else
2781 else
2787 -- Local Declarations
2796 -- Start of processing for Expand_Concatenate
2798 begin
2799 -- Choose an appropriate computational type
2801 -- We will be doing calculations of lengths and bounds in this routine
2802 -- and computing one from the other in some cases, e.g. getting the high
2803 -- bound by adding the length-1 to the low bound.
2805 -- We can't just use the index type, or even its base type for this
2806 -- purpose for two reasons. First it might be an enumeration type which
2807 -- is not suitable for computations of any kind, and second it may
2808 -- simply not have enough range. For example if the index type is
2809 -- -128..+127 then lengths can be up to 256, which is out of range of
2810 -- the type.
2812 -- For enumeration types, we can simply use Standard_Integer, this is
2813 -- sufficient since the actual number of enumeration literals cannot
2814 -- possibly exceed the range of integer (remember we will be doing the
2815 -- arithmetic with POS values, not representation values).
2820 -- If index type is Positive, we use the standard unsigned type, to give
2821 -- more room on the top of the range, obviating the need for an overflow
2822 -- check when creating the upper bound. This is needed to avoid junk
2823 -- overflow checks in the common case of String types.
2825 -- ??? Disabled for now
2827 -- elsif Istyp = Standard_Positive then
2828 -- Artyp := Standard_Unsigned;
2830 -- For modular types, we use a 32-bit modular type for types whose size
2831 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2832 -- identity type, and for larger unsigned types we use 64-bits.
2839 else
2843 -- Similar treatment for signed types
2845 else
2850 else
2855 -- Supply dummy entry at start of length array
2859 -- Go through operands setting up the above arrays
2866 -- The parent got messed up when we put the operands in a list,
2867 -- so now put back the proper parent for the saved operand, that
2868 -- is to say the concatenation node, to make sure that each operand
2869 -- is seen as a subexpression, e.g. if actions must be inserted.
2873 -- Set will be True when we have setup one entry in the array
2877 -- Singleton element (or character literal) case
2886 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2887 -- since we know that the result cannot be null).
2896 -- String literal case (can only occur for strings of course)
2905 -- Capture last operand low and high bound if result could be null
2908 Last_Opnd_Low_Bound :=
2911 Last_Opnd_High_Bound :=
2913 Left_Opnd =>
2918 -- Skip null string literal
2928 -- Set length and bounds
2937 -- All other cases
2939 else
2940 -- Check constrained case with known bounds
2943 declare
2949 begin
2950 -- Fixed length constrained array type with known at compile
2951 -- time bounds is last case of fixed length operand.
2954 and then
2956 then
2957 declare
2963 begin
2968 -- Capture last operand bounds if result could be null
2971 Last_Opnd_Low_Bound :=
2975 Last_Opnd_High_Bound :=
2980 -- Exclude null length case unless last operand
2992 To_Ityp
3000 -- All cases where the length is not known at compile time, or the
3001 -- special case of an operand which is known to be null but has a
3002 -- lower bound other than 1 or is other than a string type.
3007 -- Capture operand bounds
3011 Prefix =>
3015 -- Capture last operand bounds if result could be null
3018 Last_Opnd_Low_Bound :=
3021 Prefix =>
3025 Last_Opnd_High_Bound :=
3028 Prefix =>
3033 -- Capture length of operand in entity
3045 Expression =>
3047 Prefix =>
3053 -- Set next entry in aggregate length array
3055 -- For first entry, make either integer literal for fixed length
3056 -- or a reference to the saved length for variable length.
3061 else
3065 -- If entry is fixed length and only fixed lengths so far, make
3066 -- appropriate new integer literal adding new length.
3070 then
3075 -- All other cases, construct an addition node for the length and
3076 -- create an entity initialized to this length.
3078 else
3083 else
3092 Expression =>
3104 -- If we have only skipped null operands, return the last operand
3111 -- If we have only one non-null operand, return it and we are done.
3112 -- There is one case in which this cannot be done, and that is when
3113 -- the sole operand is of the element type, in which case it must be
3114 -- converted to an array, and the easiest way of doing that is to go
3115 -- through the normal general circuit.
3119 then
3124 -- Cases where we have a real concatenation
3126 -- Next step is to find the low bound for the result array that we
3127 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3129 -- If the ultimate ancestor of the index subtype is a constrained array
3130 -- definition, then the lower bound is that of the index subtype as
3131 -- specified by (RM 4.5.3(6)).
3133 -- The right test here is to go to the root type, and then the ultimate
3134 -- ancestor is the first subtype of this root type.
3137 Low_Bound :=
3139 Prefix =>
3143 -- If the first operand in the list has known length we know that
3144 -- the lower bound of the result is the lower bound of this operand.
3149 -- OK, we don't know the lower bound, we have to build a horrible
3150 -- conditional expression node of the form
3152 -- if Cond1'Length /= 0 then
3153 -- Opnd1 low bound
3154 -- else
3155 -- if Opnd2'Length /= 0 then
3156 -- Opnd2 low bound
3157 -- else
3158 -- ...
3160 -- The nesting ends either when we hit an operand whose length is known
3161 -- at compile time, or on reaching the last operand, whose low bound we
3162 -- take unconditionally whether or not it is null. It's easiest to do
3163 -- this with a recursive procedure:
3165 else
3166 declare
3168 -- Returns the lower bound determined by operands J .. NN
3170 ---------------------
3171 -- Get_Known_Bound --
3172 ---------------------
3175 begin
3179 else
3180 return
3193 begin
3207 -- Now we can safely compute the upper bound, normally
3208 -- Low_Bound + Length - 1.
3210 High_Bound :=
3211 To_Ityp (
3214 Right_Opnd =>
3219 -- Note that calculation of the high bound may cause overflow in some
3220 -- very weird cases, so in the general case we need an overflow check on
3221 -- the high bound. We can avoid this for the common case of string types
3222 -- and other types whose index is Positive, since we chose a wider range
3223 -- for the arithmetic type.
3229 -- Handle the exceptional case where the result is null, in which case
3230 -- case the bounds come from the last operand (so that we get the proper
3231 -- bounds if the last operand is super-flat).
3234 Low_Bound :=
3240 Last_Opnd_Low_Bound,
3241 Low_Bound));
3243 High_Bound :=
3249 Last_Opnd_High_Bound,
3250 High_Bound));
3253 -- Here is where we insert the saved up actions
3257 -- Now we construct an array object with appropriate bounds. We mark
3258 -- the target as internal to prevent useless initialization when
3259 -- Initialize_Scalars is enabled. Also since this is the actual result
3260 -- entity, we make sure we have debug information for the result.
3266 -- If the bound is statically known to be out of range, we do not want
3267 -- to abort, we want a warning and a runtime constraint error. Note that
3268 -- we have arranged that the result will not be treated as a static
3269 -- constant, so we won't get an illegality during this insertion.
3274 Object_Definition =>
3277 Constraint =>
3285 -- If the result of the concatenation appears as the initializing
3286 -- expression of an object declaration, we can just rename the
3287 -- result, rather than copying it.
3291 -- Catch the static out of range case now
3297 -- Now we will generate the assignments to do the actual concatenation
3299 -- There is one case in which we will not do this, namely when all the
3300 -- following conditions are met:
3302 -- The result type is Standard.String
3304 -- There are nine or fewer retained (non-null) operands
3306 -- The optimization level is -O0
3308 -- The corresponding System.Concat_n.Str_Concat_n routine is
3309 -- available in the run time.
3311 -- The debug flag gnatd.c is not set
3313 -- If all these conditions are met then we generate a call to the
3314 -- relevant concatenation routine. The purpose of this is to avoid
3315 -- undesirable code bloat at -O0.
3320 and then not Debug_Flag_Dot_C
3321 then
3322 declare
3325 RE_Str_Concat_3,
3326 RE_Str_Concat_4,
3327 RE_Str_Concat_5,
3328 RE_Str_Concat_6,
3329 RE_Str_Concat_7,
3330 RE_Str_Concat_8,
3331 RE_Str_Concat_9);
3333 begin
3335 declare
3339 begin
3354 else
3371 -- Not special case so generate the assignments
3376 declare
3385 Right_Opnd =>
3390 begin
3391 -- Singleton case, simple assignment
3397 Name =>
3404 -- Array case, slice assignment, skipped when argument is fixed
3405 -- length and known to be null.
3408 declare
3411 Name =>
3413 Prefix =>
3415 Discrete_Range =>
3420 begin
3426 -- Here if operand length is not statically known and no
3427 -- operand known to be non-null has been processed yet.
3428 -- If operand length is 0, we do not need to perform the
3429 -- assignment, and we must avoid the evaluation of the
3430 -- high bound of the slice, since it may underflow if the
3431 -- low bound is Ityp'First.
3433 Assign :=
3435 Condition =>
3437 Left_Opnd =>
3449 -- Finally we build the result, which is a reference to the array object
3457 exception
3460 -- Kill warning generated for the declaration of the static out of
3461 -- range high bound, and instead generate a Constraint_Error with
3462 -- an appropriate specific message.
3465 Apply_Compile_Time_Constraint_Error
3469 -- Set_Etype (Cnode, Atyp);
3472 ------------------------
3473 -- Expand_N_Allocator --
3474 ------------------------
3487 -- Static coextensions have the same lifetime as the entity they
3488 -- constrain. Such occurrences can be rewritten as aliased objects
3489 -- and their unrestricted access used instead of the coextension.
3492 -- Given a constrained array type E, returns a node representing the
3493 -- code to compute the size in storage elements for the given type.
3494 -- This is done without using the attribute (which malfunctions for
3495 -- large sizes ???)
3497 -------------------------
3498 -- Rewrite_Coextension --
3499 -------------------------
3505 begin
3506 -- Generate:
3507 -- Cnn : aliased Etyp;
3509 Temp_Decl :=
3528 ------------------------------
3529 -- Size_In_Storage_Elements --
3530 ------------------------------
3533 begin
3534 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3535 -- However, the reason for the existence of this function is
3536 -- to construct a test for sizes too large, which means near the
3537 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3538 -- is that we get overflows when sizes are greater than 2**31.
3540 -- So what we end up doing for array types is to use the expression:
3542 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
3544 -- which avoids this problem. All this is a bit bogus, but it does
3545 -- mean we catch common cases of trying to allocate arrays that
3546 -- are too large, and which in the absence of a check results in
3547 -- undetected chaos ???
3549 declare
3553 begin
3555 Len :=
3564 else
3565 Res :=
3572 return
3575 Right_Opnd =>
3582 -- Start of processing for Expand_N_Allocator
3584 begin
3585 -- RM E.2.3(22). We enforce that the expected type of an allocator
3586 -- shall not be a remote access-to-class-wide-limited-private type
3588 -- Why is this being done at expansion time, seems clearly wrong ???
3592 -- Processing for anonymous access-to-controlled types. These access
3593 -- types receive a special finalization master which appears in the
3594 -- declarations of the enclosing semantic unit. This expansion is done
3595 -- now to ensure that any additional types generated by this routine or
3596 -- Expand_Allocator_Expression inherit the proper type attributes.
3599 or else
3602 then
3603 -- Anonymous access-to-controlled types allocate on the global pool.
3604 -- Do not set this attribute on .NET/JVM since those targets do not
3605 -- support pools.
3608 Set_Associated_Storage_Pool
3612 -- The finalization master must be inserted and analyzed as part of
3613 -- the current semantic unit. This form of expansion is not carried
3614 -- out in Alfa mode because it is useless. Note that the master is
3615 -- updated when analysis changes current units.
3622 -- Set the storage pool and find the appropriate version of Allocate to
3623 -- call. Do not overwrite the storage pool if it is already set, which
3624 -- can happen for build-in-place function returns (see
3625 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
3638 -- In the case of an allocator for a simple storage pool, locate
3639 -- and save a reference to the pool type's Allocate routine.
3643 then
3644 declare
3647 begin
3653 then
3656 else
3665 else
3672 -- Under certain circumstances we can replace an allocator by an access
3673 -- to statically allocated storage. The conditions, as noted in AARM
3674 -- 3.10 (10c) are as follows:
3676 -- Size and initial value is known at compile time
3677 -- Access type is access-to-constant
3679 -- The allocator is not part of a constraint on a record component,
3680 -- because in that case the inserted actions are delayed until the
3681 -- record declaration is fully analyzed, which is too late for the
3682 -- analysis of the rewritten allocator.
3687 and then Size_Known_At_Compile_Time
3690 then
3691 -- Here we can do the optimization. For the allocator
3693 -- new x'(y)
3695 -- We insert an object declaration
3697 -- Tnn : aliased x := y;
3699 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3700 -- marked as requiring static allocation.
3705 -- If context is constrained, use constrained subtype directly,
3706 -- so that the constant is not labelled as having a nominally
3707 -- unconstrained subtype.
3728 -- We set the variable as statically allocated, since we don't want
3729 -- it going on the stack of the current procedure!
3735 -- Same if the allocator is an access discriminant for a local object:
3736 -- instead of an allocator we create a local value and constrain the
3737 -- enclosing object with the corresponding access attribute.
3744 -- Check for size too large, we do this because the back end misses
3745 -- proper checks here and can generate rubbish allocation calls when
3746 -- we are near the limit. We only do this for the 32-bit address case
3747 -- since that is from a practical point of view where we see a problem.
3753 then
3754 -- The check we want to generate should look like
3756 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
3757 -- raise Storage_Error;
3758 -- end if;
3760 -- where 3.5 gigabytes is a constant large enough to accommodate any
3761 -- reasonable request for. But we can't do it this way because at
3762 -- least at the moment we don't compute this attribute right, and
3763 -- can silently give wrong results when the result gets large. Since
3764 -- this is all about large results, that's bad, so instead we only
3765 -- apply the check for constrained arrays, and manually compute the
3766 -- value of the attribute ???
3771 Condition =>
3774 Right_Opnd =>
3780 -- Handle case of qualified expression (other than optimization above)
3781 -- First apply constraint checks, because the bounds or discriminants
3782 -- in the aggregate might not match the subtype mark in the allocator.
3785 Apply_Constraint_Check
3792 -- If the allocator is for a type which requires initialization, and
3793 -- there is no initial value (i.e. operand is a subtype indication
3794 -- rather than a qualified expression), then we must generate a call to
3795 -- the initialization routine using an expressions action node:
3797 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3799 -- Here ptr_T is the pointer type for the allocator, and T is the
3800 -- subtype of the allocator. A special case arises if the designated
3801 -- type of the access type is a task or contains tasks. In this case
3802 -- the call to Init (Temp.all ...) is replaced by code that ensures
3803 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3804 -- for details). In addition, if the type T is a task T, then the
3805 -- first argument to Init must be converted to the task record type.
3807 declare
3818 begin
3821 -- Even though this might be a simple allocation, create a custom
3822 -- Allocate if the context requires it. Since .NET/JVM compilers
3823 -- do not support pools, this step is skipped.
3827 then
3828 Build_Allocate_Deallocate_Proc
3833 -- Case of no initialization procedure present
3837 -- Case of simple initialization required
3851 -- No initialization required
3853 else
3857 -- Case of initialization procedure present, must be called
3859 else
3867 -- Construct argument list for the initialization routine call
3869 Init_Arg1 :=
3871 Prefix =>
3877 -- The initialization procedure expects a specific type. if the
3878 -- context is access to class wide, indicate that the object
3879 -- being allocated has the right specific type.
3885 -- If designated type is a concurrent type or if it is private
3886 -- type whose definition is a concurrent type, the first
3887 -- argument in the Init routine has to be unchecked conversion
3888 -- to the corresponding record type. If the designated type is
3889 -- a derived type, also convert the argument to its root type.
3892 Init_Arg1 :=
3893 Unchecked_Convert_To (
3899 then
3900 Init_Arg1 :=
3901 Unchecked_Convert_To
3905 declare
3908 begin
3916 -- For the task case, pass the Master_Id of the access type as
3917 -- the value of the _Master parameter, and _Chain as the value
3918 -- of the _Chain parameter (_Chain will be defined as part of
3919 -- the generated code for the allocator).
3921 -- In Ada 2005, the context may be a function that returns an
3922 -- anonymous access type. In that case the Master_Id has been
3923 -- created when expanding the function declaration.
3928 -- The designated type was an incomplete type, and the
3929 -- access type did not get expanded. Salvage it now.
3933 Expand_N_Full_Type_Declaration
3938 -- If the context of the allocator is a declaration or an
3939 -- assignment, we can generate a meaningful image for it,
3940 -- even though subsequent assignments might remove the
3941 -- connection between task and entity. We build this image
3942 -- when the left-hand side is a simple variable, a simple
3943 -- indexed assignment or a simple selected component.
3946 declare
3949 begin
3951 Decls :=
3952 Build_Task_Image_Decls
3954 New_Occurrence_Of
3958 N_Selected_Component)
3960 then
3961 Decls :=
3962 Build_Task_Image_Decls
3964 else
3970 Decls :=
3971 Build_Task_Image_Decls
3974 else
3981 else
3983 New_Reference_To
3993 -- Has_Task is false, Decls not used
3995 else
3999 -- Add discriminants if discriminated type
4001 declare
4005 begin
4013 then
4020 -- If the allocated object will be constrained by the
4021 -- default values for discriminants, then build a subtype
4022 -- with those defaults, and change the allocated subtype
4023 -- to that. Note that this happens in fewer cases in Ada
4024 -- 2005 (AI-363).
4030 or else not
4031 Effectively_Has_Constrained_Partial_View
4034 then
4044 -- AI-416: when the discriminant constraint is an
4045 -- anonymous access type make sure an accessibility
4046 -- check is inserted if necessary (3.10.2(22.q/2))
4049 and then
4051 then
4052 Apply_Accessibility_Check
4061 -- We set the allocator as analyzed so that when we analyze
4062 -- the conditional expression node, we do not get an unwanted
4063 -- recursive expansion of the allocator expression.
4068 -- Here is the transformation:
4069 -- input: new Ctrl_Typ
4070 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4071 -- Ctrl_TypIP (Temp.all, ...);
4072 -- [Deep_]Initialize (Temp.all);
4074 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4075 -- is the subtype of the allocator.
4077 Temp_Decl :=
4089 -- If the designated type is a task type or contains tasks,
4090 -- create block to activate created tasks, and insert
4091 -- declaration for Task_Image variable ahead of call.
4094 declare
4097 begin
4104 else
4113 -- Generate:
4114 -- [Deep_]Initialize (Init_Arg1);
4117 Make_Init_Call
4123 -- Special processing for .NET/JVM, the allocated object
4124 -- is attached to the finalization master. Generate:
4126 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4128 -- Types derived from [Limited_]Controlled are the only
4129 -- ones considered since they have fields Prev and Next.
4134 Make_Attach_Call
4139 -- Default case, generate:
4141 -- Set_Finalize_Address
4142 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
4144 -- Do not generate this call in the following cases:
4145 --
4146 -- * Alfa mode - the call is useless and results in
4147 -- unwanted expansion.
4148 --
4149 -- * CodePeer mode - TSS primitive Finalize_Address is
4150 -- not created in this mode.
4152 elsif not Alfa_Mode
4153 and then not CodePeer_Mode
4154 then
4156 Make_Set_Finalize_Address_Call
4170 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4171 -- object that has been rewritten as a reference, we displace "this"
4172 -- to reference properly its secondary dispatch table.
4176 then
4180 exception
4185 -----------------------
4186 -- Expand_N_And_Then --
4187 -----------------------
4192 ------------------------------
4193 -- Expand_N_Case_Expression --
4194 ------------------------------
4207 begin
4208 -- We expand
4210 -- case X is when A => AX, when B => BX ...
4212 -- to
4214 -- do
4215 -- Tnn : typ;
4216 -- case X is
4217 -- when A =>
4218 -- Tnn := AX;
4219 -- when B =>
4220 -- Tnn := BX;
4221 -- ...
4222 -- end case;
4223 -- in Tnn end;
4225 -- However, this expansion is wrong for limited types, and also
4226 -- wrong for unconstrained types (since the bounds may not be the
4227 -- same in all branches). Furthermore it involves an extra copy
4228 -- for large objects. So we take care of this by using the following
4229 -- modified expansion for non-scalar types:
4231 -- do
4232 -- type Pnn is access all typ;
4233 -- Tnn : Pnn;
4234 -- case X is
4235 -- when A =>
4236 -- T := AX'Unrestricted_Access;
4237 -- when B =>
4238 -- T := BX'Unrestricted_Access;
4239 -- ...
4240 -- end case;
4241 -- in Tnn.all end;
4243 Cstmt :=
4250 -- Scalar case
4255 else
4260 Type_Definition =>
4263 Subtype_Indication =>
4274 -- Now process the alternatives
4278 declare
4283 begin
4284 -- As described above, take Unrestricted_Access for case of non-
4285 -- scalar types, to avoid big copies, and special cases.
4288 Aexp :=
4299 -- Propagate declarations inserted in the node by Insert_Actions
4300 -- (for example, temporaries generated to remove side effects).
4301 -- These actions must remain attached to the alternative, given
4302 -- that they are generated by the corresponding expression.
4308 Append_To
4320 -- Construct and return final expression with actions
4324 else
4325 Fexp :=
4338 -------------------------------------
4339 -- Expand_N_Conditional_Expression --
4340 -------------------------------------
4342 -- Deal with limited types and condition actions
4345 function Create_Alternative
4350 -- Build the statements of a "then" or "else" conditional expression
4351 -- alternative. Temp_Id is the conditional expression result, Flag_Id
4352 -- is a finalization flag created to service expression Expr.
4355 -- Determine if expression Expr is a rewritten controlled function call
4357 ------------------------
4358 -- Create_Alternative --
4359 ------------------------
4361 function Create_Alternative
4366 is
4369 begin
4370 -- Generate:
4371 -- Fnn := True;
4375 then
4382 -- Generate:
4383 -- Cnn := <expr>'Unrestricted_Access;
4388 Expression =>
4396 ---------------------------------
4397 -- Is_Controlled_Function_Call --
4398 ---------------------------------
4401 begin
4402 return
4407 -- Local variables
4422 begin
4423 -- Fold at compile time if condition known. We have already folded
4424 -- static conditional expressions, but it is possible to fold any
4425 -- case in which the condition is known at compile time, even though
4426 -- the result is non-static.
4428 -- Note that we don't do the fold of such cases in Sem_Elab because
4429 -- it can cause infinite loops with the expander adding a conditional
4430 -- expression, and Sem_Elab circuitry removing it repeatedly.
4436 else
4445 -- If we are not allowed to use Expression_With_Actions, just skip
4446 -- the optimization, it is not critical for correctness.
4458 else
4462 -- Note that the result is never static (legitimate cases of static
4463 -- conditional expressions were folded in Sem_Eval).
4471 -- If the type is limited or unconstrained, we expand as follows to
4472 -- avoid any possibility of improper copies.
4474 -- Note: it may be possible to avoid this special processing if the
4475 -- back end uses its own mechanisms for handling by-reference types ???
4477 -- type Ptr is access all Typ;
4478 -- Cnn : Ptr;
4479 -- if cond then
4480 -- <<then actions>>
4481 -- Cnn := then-expr'Unrestricted_Access;
4482 -- else
4483 -- <<else actions>>
4484 -- Cnn := else-expr'Unrestricted_Access;
4485 -- end if;
4487 -- and replace the conditional expression by a reference to Cnn.all.
4489 -- This special case can be skipped if the back end handles limited
4490 -- types properly and ensures that no incorrect copies are made.
4493 and then not Back_End_Handles_Limited_Types
4494 then
4495 declare
4499 begin
4502 -- At least one of the conditional expression alternatives uses a
4503 -- controlled function to provide the result. Create a status flag
4504 -- to signal the finalization machinery that Cnn needs special
4505 -- handling.
4508 or else
4510 then
4516 Object_Definition =>
4518 Expression =>
4522 -- Generate:
4523 -- type Ann is access all Typ;
4530 Type_Definition =>
4535 -- Generate:
4536 -- Cnn : Ann;
4542 Decl :=
4547 New_If :=
4550 Then_Statements =>
4552 Else_Statements =>
4555 New_N :=
4560 -- For other types, we only need to expand if there are other actions
4561 -- associated with either branch.
4565 -- We have two approaches to handling this. If we are allowed to use
4566 -- N_Expression_With_Actions, then we can just wrap the actions into
4567 -- the appropriate expression.
4590 -- if we can't use N_Expression_With_Actions nodes, then we insert
4591 -- the following sequence of actions (using Insert_Actions):
4593 -- Cnn : typ;
4594 -- if cond then
4595 -- <<then actions>>
4596 -- Cnn := then-expr;
4597 -- else
4598 -- <<else actions>>
4599 -- Cnn := else-expr
4600 -- end if;
4602 -- and replace the conditional expression by a reference to Cnn
4604 else
4607 Decl :=
4612 New_If :=
4632 -- If no actions then no expansion needed, gigi will handle it using
4633 -- the same approach as a C conditional expression.
4635 else
4639 -- Fall through here for either the limited expansion, or the case of
4640 -- inserting actions for non-limited types. In both these cases, we must
4641 -- move the SLOC of the parent If statement to the newly created one and
4642 -- change it to the SLOC of the expression which, after expansion, will
4643 -- correspond to what is being evaluated.
4647 then
4652 -- Make sure Then_Actions and Else_Actions are appropriately moved
4653 -- to the new if statement.
4656 Insert_List_Before
4661 Insert_List_Before
4671 -----------------------------------
4672 -- Expand_N_Explicit_Dereference --
4673 -----------------------------------
4676 begin
4677 -- Insert explicit dereference call for the checked storage pool case
4681 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
4682 -- we set the atomic sync flag.
4686 then
4691 --------------------------------------
4692 -- Expand_N_Expression_With_Actions --
4693 --------------------------------------
4698 -- Given the declaration of a controlled transient declared inside the
4699 -- Actions list of an Expression_With_Actions, generate all necessary
4700 -- types and hooks in order to properly finalize the transient. This
4701 -- mechanism works in conjunction with Build_Finalizer.
4703 ------------------------------
4704 -- Process_Transient_Object --
4705 ------------------------------
4710 -- Complex conditions in if statements may be converted into nested
4711 -- EWAs. In this case, any generated code must be inserted before the
4712 -- if statement to ensure proper visibility of the hook objects. This
4713 -- routine returns the top most short circuit operator or the parent
4714 -- of the EWA if no nesting was detected.
4716 -------------------------
4717 -- Find_Insertion_Node --
4718 -------------------------
4723 begin
4724 -- Climb up the branches of a complex condition
4734 -- Local variables
4747 -- Start of processing for Process_Transient_Object
4749 begin
4750 -- Step 1: Create the access type which provides a reference to the
4751 -- transient object.
4755 else
4759 -- Generate:
4760 -- Ann : access [all] <Desig_Typ>;
4764 Ptr_Decl :=
4767 Type_Definition =>
4769 All_Present =>
4776 -- Step 2: Create a temporary which acts as a hook to the transient
4777 -- object. Generate:
4779 -- Temp : Ptr_Id := null;
4783 Temp_Decl :=
4791 -- Mark this temporary as created for the purposes of exporting the
4792 -- transient declaration out of the Actions list. This signals the
4793 -- machinery in Build_Finalizer to recognize this special case.
4797 -- Step 3: Hook the transient object to the temporary
4801 else
4802 Expr :=
4808 -- Generate:
4809 -- Temp := Ptr_Id (Obj_Id);
4810 -- <or>
4811 -- Temp := Obj_Id'Unrestricted_Access;
4819 -- Local variables
4823 -- Start of processing for Expand_N_Expression_With_Actions
4825 begin
4830 then
4838 -----------------
4839 -- Expand_N_In --
4840 -----------------
4853 -- Replaces node N by Lop'Valid. This is done when we have an explicit
4854 -- test for the left operand being in range of its subtype.
4856 ----------------------------
4857 -- Substitute_Valid_Check --
4858 ----------------------------
4861 begin
4870 Error_Msg_N -- CODEFIX
4875 -- Start of processing for Expand_N_In
4877 begin
4878 -- If set membership case, expand with separate procedure
4885 -- Not set membership, proceed with expansion
4890 -- Check case of explicit test for an expression in range of its
4891 -- subtype. This is suspicious usage and we replace it with a 'Valid
4892 -- test and give a warning. For floating point types however, this is a
4893 -- standard way to check for finite numbers, and using 'Valid would
4894 -- typically be a pessimization. Also skip this test for predicated
4895 -- types, since it is perfectly reasonable to check if a value meets
4896 -- its predicate.
4906 then
4907 Substitute_Valid_Check;
4911 -- Do validity check on operands
4918 -- Case of explicit range
4921 declare
4932 Constant_Condition_Warnings
4935 -- This must be true for any of the optimization warnings, we
4936 -- clearly want to give them only for source with the flag on. We
4937 -- also skip these warnings in an instance since it may be the
4938 -- case that different instantiations have different ranges.
4941 Warn1
4944 -- For the case where only one bound warning is elided, we also
4945 -- insist on an explicit range and an integer type. The reason is
4946 -- that the use of enumeration ranges including an end point is
4947 -- common, as is the use of a subtype name, one of whose bounds is
4948 -- the same as the type of the expression.
4950 begin
4951 -- If test is explicit x'First .. x'Last, replace by valid check
4953 -- Could use some individual comments for this complex test ???
4966 then
4967 Substitute_Valid_Check;
4971 -- If bounds of type are known at compile time, and the end points
4972 -- are known at compile time and identical, this is another case
4973 -- for substituting a valid test. We only do this for discrete
4974 -- types, since it won't arise in practice for float types.
4985 -- Kill warnings in instances, since they may be cases where we
4986 -- have a test in the generic that makes sense with some types
4987 -- and not with other types.
4989 and then not In_Instance
4990 then
4991 Substitute_Valid_Check;
4995 -- If we have an explicit range, do a bit of optimization based on
4996 -- range analysis (we may be able to kill one or both checks).
5001 -- If either check is known to fail, replace result by False since
5002 -- the other check does not matter. Preserve the static flag for
5003 -- legality checks, because we are constant-folding beyond RM 4.9.
5016 -- If both checks are known to succeed, replace result by True,
5017 -- since we know we are in range.
5030 -- If lower bound check succeeds and upper bound check is not
5031 -- known to succeed or fail, then replace the range check with
5032 -- a comparison against the upper bound.
5047 -- If upper bound check succeeds and lower bound check is not
5048 -- known to succeed or fail, then replace the range check with
5049 -- a comparison against the lower bound.
5065 -- We couldn't optimize away the range check, but there is one
5066 -- more issue. If we are checking constant conditionals, then we
5067 -- see if we can determine the outcome assuming everything is
5068 -- valid, and if so give an appropriate warning.
5074 -- Result is out of range for valid value
5077 Error_Msg_N
5080 -- Result is in range for valid value
5083 Error_Msg_N
5086 -- Lower bound check succeeds if value is valid
5089 Error_Msg_N
5092 -- Upper bound check succeeds if value is valid
5095 Error_Msg_N
5101 -- For all other cases of an explicit range, nothing to be done
5105 -- Here right operand is a subtype mark
5107 else
5108 declare
5116 begin
5119 -- For tagged type, do tagged membership operation
5123 -- No expansion will be performed when VM_Target, as the VM
5124 -- back-ends will handle the membership tests directly (tags
5125 -- are not explicitly represented in Java objects, so the
5126 -- normal tagged membership expansion is not what we want).
5133 -- Update decoration of relocated node referenced by the
5134 -- SCIL node.
5143 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5144 -- This reason we do this is that the bounds may have the wrong
5145 -- type if they come from the original type definition. Also this
5146 -- way we get all the processing above for an explicit range.
5148 -- Don't do this for predicated types, since in this case we
5149 -- want to check the predicate!
5155 Low_Bound =>
5160 High_Bound =>
5169 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5170 -- a membership test if the subtype mark denotes a constrained
5171 -- Unchecked_Union subtype and the expression lacks inferable
5172 -- discriminants.
5177 then
5182 -- Prevent Gigi from generating incorrect code by rewriting the
5183 -- test as False.
5189 -- Here we have a non-scalar type
5199 -- For the constrained array case, we have to check the subscripts
5200 -- for an exact match if the lengths are non-zero (the lengths
5201 -- must match in any case).
5205 function Build_Attribute_Reference
5209 -- Build attribute reference E'Nam (Dim)
5211 -------------------------------
5212 -- Build_Attribute_Reference --
5213 -------------------------------
5215 function Build_Attribute_Reference
5219 is
5220 begin
5221 return
5229 -- Start of processing for Check_Subscripts
5231 begin
5235 Left_Opnd =>
5236 Build_Attribute_Reference
5239 Right_Opnd =>
5240 Build_Attribute_Reference
5245 Left_Opnd =>
5246 Build_Attribute_Reference
5249 Right_Opnd =>
5250 Build_Attribute_Reference
5255 Cond :=
5257 Left_Opnd =>
5268 -- These are the cases where constraint checks may be required,
5269 -- e.g. records with possible discriminants
5271 else
5272 -- Expand the test into a series of discriminant comparisons.
5273 -- The expression that is built is the negation of the one that
5274 -- is used for checking discriminant constraints.
5284 Left_Opnd =>
5291 else
5299 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5300 -- expression of an anonymous access type. This can involve an
5301 -- accessibility test and a tagged type membership test in the
5302 -- case of tagged designated types.
5305 and then Is_Acc
5307 then
5308 declare
5314 begin
5323 -- If a conversion of the anonymous access value to the
5324 -- tested type would be illegal, then the result is False.
5326 if not Valid_Conversion
5328 then
5332 -- Apply an accessibility check if the access object has an
5333 -- associated access level and when the level of the type is
5334 -- less deep than the level of the access parameter. This
5335 -- only occur for access parameters and stand-alone objects
5336 -- of an anonymous access type.
5338 else
5340 and then
5341 Present
5345 then
5346 Param_Level :=
5347 New_Occurrence_Of
5350 Type_Level :=
5353 -- Return True only if the accessibility level of the
5354 -- expression entity is not deeper than the level of
5355 -- the tested access type.
5367 -- If the designated type is tagged, do tagged membership
5368 -- operation.
5370 -- *** NOTE: we have to check not null before doing the
5371 -- tagged membership test (but maybe that can be done
5372 -- inside Tagged_Membership?).
5378 Right_Opnd =>
5383 -- No expansion will be performed when VM_Target, as
5384 -- the VM back-ends will handle the membership tests
5385 -- directly (tags are not explicitly represented in
5386 -- Java objects, so the normal tagged membership
5387 -- expansion is not what we want).
5391 -- Note that we have to pass Original_Node, because
5392 -- the membership test might already have been
5393 -- rewritten by earlier parts of membership test.
5395 Tagged_Membership
5398 -- Update decoration of relocated node referenced
5399 -- by the SCIL node.
5419 -- At this point, we have done the processing required for the basic
5420 -- membership test, but not yet dealt with the predicate.
5424 -- If a predicate is present, then we do the predicate test, but we
5425 -- most certainly want to omit this if we are within the predicate
5426 -- function itself, since otherwise we have an infinite recursion!
5428 declare
5431 begin
5434 then
5440 -- Analyze new expression, mark left operand as analyzed to
5441 -- avoid infinite recursion adding predicate calls. Similarly,
5442 -- suppress further range checks on the call.
5447 -- All done, skip attempt at compile time determination of result
5454 --------------------------------
5455 -- Expand_N_Indexed_Component --
5456 --------------------------------
5465 begin
5466 -- A special optimization, if we have an indexed component that is
5467 -- selecting from a slice, then we can eliminate the slice, since, for
5468 -- example, x (i .. j)(k) is identical to x(k). The only difference is
5469 -- the range check required by the slice. The range check for the slice
5470 -- itself has already been generated. The range check for the
5471 -- subscripting operation is ensured by converting the subject to
5472 -- the subtype of the slice.
5474 -- This optimization not only generates better code, avoiding slice
5475 -- messing especially in the packed case, but more importantly bypasses
5476 -- some problems in handling this peculiar case, for example, the issue
5477 -- of dealing specially with object renamings.
5484 Convert_To
5491 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
5492 -- function, then additional actuals must be passed.
5496 then
5500 -- If the prefix is an access type, then we unconditionally rewrite if
5501 -- as an explicit dereference. This simplifies processing for several
5502 -- cases, including packed array cases and certain cases in which checks
5503 -- must be generated. We used to try to do this only when it was
5504 -- necessary, but it cleans up the code to do it all the time.
5510 else
5514 -- Generate index and validity checks
5522 -- If selecting from an array with atomic components, and atomic sync
5523 -- is not suppressed for this array type, set atomic sync flag.
5529 then
5533 -- All done for the non-packed case
5539 -- For packed arrays that are not bit-packed (i.e. the case of an array
5540 -- with one or more index types with a non-contiguous enumeration type),
5541 -- we can always use the normal packed element get circuit.
5548 -- For a reference to a component of a bit packed array, we have to
5549 -- convert it to a reference to the corresponding Packed_Array_Type.
5550 -- We only want to do this for simple references, and not for:
5552 -- Left side of assignment, or prefix of left side of assignment, or
5553 -- prefix of the prefix, to handle packed arrays of packed arrays,
5554 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
5556 -- Renaming objects in renaming associations
5557 -- This case is handled when a use of the renamed variable occurs
5559 -- Actual parameters for a procedure call
5560 -- This case is handled in Exp_Ch6.Expand_Actuals
5562 -- The second expression in a 'Read attribute reference
5564 -- The prefix of an address or bit or size attribute reference
5566 -- The following circuit detects these exceptions
5568 declare
5572 begin
5573 loop
5578 N_Procedure_Call_Statement)
5580 and then
5582 then
5587 or else
5589 or else
5592 then
5597 then
5600 -- If the expression is an index of an indexed component, it must
5601 -- be expanded regardless of context.
5605 then
5611 then
5617 then
5622 then
5625 else
5630 -- Keep looking up tree for unchecked expression, or if we are the
5631 -- prefix of a possible assignment left side.
5639 ---------------------
5640 -- Expand_N_Not_In --
5641 ---------------------
5643 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
5644 -- can be done. This avoids needing to duplicate this expansion code.
5651 begin
5654 Right_Opnd =>
5659 -- If this is a set membership, preserve list of alternatives
5663 -- We want this to appear as coming from source if original does (see
5664 -- transformations in Expand_N_In).
5669 -- Now analyze transformed node
5674 -------------------
5675 -- Expand_N_Null --
5676 -------------------
5678 -- The only replacement required is for the case of a null of a type that
5679 -- is an access to protected subprogram, or a subtype thereof. We represent
5680 -- such access values as a record, and so we must replace the occurrence of
5681 -- null by the equivalent record (with a null address and a null pointer in
5682 -- it), so that the backend creates the proper value.
5689 begin
5691 Agg :=
5700 -- For subsequent semantic analysis, the node must retain its type.
5701 -- Gigi in any case replaces this type by the corresponding record
5702 -- type before processing the node.
5707 exception
5712 ---------------------
5713 -- Expand_N_Op_Abs --
5714 ---------------------
5720 begin
5723 -- Deal with software overflow checking
5725 if not Backend_Overflow_Checks_On_Target
5728 then
5729 -- The only case to worry about is when the argument is equal to the
5730 -- largest negative number, so what we do is to insert the check:
5732 -- [constraint_error when Expr = typ'Base'First]
5734 -- with the usual Duplicate_Subexpr use coding for expr
5738 Condition =>
5741 Right_Opnd =>
5743 Prefix =>
5749 -- Vax floating-point types case
5756 ---------------------
5757 -- Expand_N_Op_Add --
5758 ---------------------
5763 begin
5766 -- N + 0 = 0 + N = N for integer types
5771 then
5777 then
5783 -- Arithmetic overflow checks for signed integer/fixed point types
5787 then
5791 -- Vax floating-point types case
5798 ---------------------
5799 -- Expand_N_Op_And --
5800 ---------------------
5805 begin
5823 ------------------------
5824 -- Expand_N_Op_Concat --
5825 ------------------------
5829 -- List of operands to be concatenated
5832 -- Node which is to be replaced by the result of concatenating the nodes
5833 -- in the list Opnds.
5835 begin
5836 -- Ensure validity of both operands
5840 -- If we are the left operand of a concatenation higher up the tree,
5841 -- then do nothing for now, since we want to deal with a series of
5842 -- concatenations as a unit.
5846 then
5850 -- We get here with a concatenation whose left operand may be a
5851 -- concatenation itself with a consistent type. We need to process
5852 -- these concatenation operands from left to right, which means
5853 -- from the deepest node in the tree to the highest node.
5860 -- Now Cnode is the deepest concatenation, and its parents are the
5861 -- concatenation nodes above, so now we process bottom up, doing the
5862 -- operations. We gather a string that is as long as possible up to five
5863 -- operands.
5865 -- The outer loop runs more than once if more than one concatenation
5866 -- type is involved.
5872 -- The inner loop gathers concatenation operands
5877 loop
5889 ------------------------
5890 -- Expand_N_Op_Divide --
5891 ------------------------
5901 and then
5905 begin
5912 -- N / 1 = N for integer types
5919 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
5920 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5921 -- operand is an unsigned integer, as required for this to work.
5926 -- We cannot do this transformation in configurable run time mode if we
5927 -- have 64-bit integers and long shifts are not available.
5929 and then
5932 then
5936 Right_Opnd =>
5942 -- Do required fixup of universal fixed operation
5949 -- Divisions with fixed-point results
5953 -- No special processing if Treat_Fixed_As_Integer is set, since
5954 -- from a semantic point of view such operations are simply integer
5955 -- operations and will be treated that way.
5960 else
5965 -- Other cases of division of fixed-point operands. Again we exclude the
5966 -- case where Treat_Fixed_As_Integer is set.
5971 then
5974 else
5979 -- Mixed-mode operations can appear in a non-static universal context,
5980 -- in which case the integer argument must be converted explicitly.
5984 then
5992 then
5998 -- Non-fixed point cases, do integer zero divide and overflow checks
6003 -- Deal with Vax_Float
6011 --------------------
6012 -- Expand_N_Op_Eq --
6013 --------------------
6028 -- If a constructed equality exists for the type or for its parent,
6029 -- build and analyze call, adding conversions if the operation is
6030 -- inherited.
6033 -- Determines whether a type has a subcomponent of an unconstrained
6034 -- Unchecked_Union subtype. Typ is a record type.
6036 -------------------------
6037 -- Build_Equality_Call --
6038 -------------------------
6045 begin
6048 then
6053 -- If we have an Unchecked_Union, we need to add the inferred
6054 -- discriminant values as actuals in the function call. At this
6055 -- point, the expansion has determined that both operands have
6056 -- inferable discriminants.
6059 declare
6065 begin
6066 -- Per-object constrained selected components require special
6067 -- attention. If the enclosing scope of the component is an
6068 -- Unchecked_Union, we cannot reference its discriminants
6069 -- directly. This is why we use the two extra parameters of
6070 -- the equality function of the enclosing Unchecked_Union.
6072 -- type UU_Type (Discr : Integer := 0) is
6073 -- . . .
6074 -- end record;
6075 -- pragma Unchecked_Union (UU_Type);
6077 -- 1. Unchecked_Union enclosing record:
6079 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6080 -- . . .
6081 -- Comp : UU_Type (Discr);
6082 -- . . .
6083 -- end Enclosing_UU_Type;
6084 -- pragma Unchecked_Union (Enclosing_UU_Type);
6086 -- Obj1 : Enclosing_UU_Type;
6087 -- Obj2 : Enclosing_UU_Type (1);
6089 -- [. . .] Obj1 = Obj2 [. . .]
6091 -- Generated code:
6093 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6095 -- A and B are the formal parameters of the equality function
6096 -- of Enclosing_UU_Type. The function always has two extra
6097 -- formals to capture the inferred discriminant values.
6099 -- 2. Non-Unchecked_Union enclosing record:
6101 -- type
6102 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6103 -- is record
6104 -- . . .
6105 -- Comp : UU_Type (Discr);
6106 -- . . .
6107 -- end Enclosing_Non_UU_Type;
6109 -- Obj1 : Enclosing_Non_UU_Type;
6110 -- Obj2 : Enclosing_Non_UU_Type (1);
6112 -- ... Obj1 = Obj2 ...
6114 -- Generated code:
6116 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6117 -- obj1.discr, obj2.discr)) then
6119 -- In this case we can directly reference the discriminants of
6120 -- the enclosing record.
6122 -- Lhs of equality
6125 and then Has_Per_Object_Constraint
6127 then
6128 -- Enclosing record is an Unchecked_Union, use formal A
6130 if Is_Unchecked_Union
6132 then
6135 -- Enclosing record is of a non-Unchecked_Union type, it is
6136 -- possible to reference the discriminant.
6138 else
6139 Lhs_Discr_Val :=
6142 Selector_Name =>
6143 New_Copy
6144 (Get_Discriminant_Value
6146 Lhs_Type,
6150 -- Comment needed here ???
6152 else
6153 -- Infer the discriminant value
6155 Lhs_Discr_Val :=
6156 New_Copy
6157 (Get_Discriminant_Value
6159 Lhs_Type,
6163 -- Rhs of equality
6166 and then Has_Per_Object_Constraint
6168 then
6169 if Is_Unchecked_Union
6171 then
6174 else
6175 Rhs_Discr_Val :=
6178 Selector_Name =>
6181 Rhs_Type,
6185 else
6186 Rhs_Discr_Val :=
6189 Rhs_Type,
6198 L_Exp,
6199 R_Exp,
6200 Lhs_Discr_Val,
6201 Rhs_Discr_Val)));
6204 -- Normal case, not an unchecked union
6206 else
6216 ------------------------------------
6217 -- Has_Unconstrained_UU_Component --
6218 ------------------------------------
6220 function Has_Unconstrained_UU_Component
6222 is
6228 function Component_Is_Unconstrained_UU
6230 -- Determines whether the subtype of the component is an
6231 -- unconstrained Unchecked_Union.
6233 function Variant_Is_Unconstrained_UU
6235 -- Determines whether a component of the variant has an unconstrained
6236 -- Unchecked_Union subtype.
6238 -----------------------------------
6239 -- Component_Is_Unconstrained_UU --
6240 -----------------------------------
6242 function Component_Is_Unconstrained_UU
6244 is
6245 begin
6250 declare
6254 begin
6255 -- Unconstrained nominal type. In the case of a constraint
6256 -- present, the node kind would have been N_Subtype_Indication.
6266 ---------------------------------
6267 -- Variant_Is_Unconstrained_UU --
6268 ---------------------------------
6270 function Variant_Is_Unconstrained_UU
6272 is
6275 begin
6280 -- We only need to test one component
6282 declare
6285 begin
6295 -- None of the components withing the variant were of
6296 -- unconstrained Unchecked_Union type.
6301 -- Start of processing for Has_Unconstrained_UU_Component
6303 begin
6311 -- Inspect available components
6314 declare
6317 begin
6320 -- One component is sufficient
6331 -- Inspect available components withing variants
6334 declare
6337 begin
6340 -- One component within a variant is sufficient
6351 -- Neither the available components, nor the components inside the
6352 -- variant parts were of an unconstrained Unchecked_Union subtype.
6357 -- Start of processing for Expand_N_Op_Eq
6359 begin
6366 else
6370 -- It may happen in error situations that the underlying type is not
6371 -- set. The error will be detected later, here we just defend the
6372 -- expander code.
6380 -- Boolean types (requiring handling of non-standard case)
6388 -- Array types
6392 -- If we are doing full validity checking, and it is possible for the
6393 -- array elements to be invalid then expand out array comparisons to
6394 -- make sure that we check the array elements.
6396 if Validity_Check_Operands
6398 then
6399 declare
6401 Force_Validity_Checks;
6402 begin
6405 Expand_Array_Equality
6409 Bodies,
6410 Typl));
6416 -- Packed case where both operands are known aligned
6421 then
6424 -- Where the component type is elementary we can use a block bit
6425 -- comparison (if supported on the target) exception in the case
6426 -- of floating-point (negative zero issues require element by
6427 -- element comparison), and atomic types (where we must be sure
6428 -- to load elements independently) and possibly unaligned arrays.
6435 and then Support_Composite_Compare_On_Target
6436 then
6439 -- For composite and floating-point cases, expand equality loop to
6440 -- make sure of using proper comparisons for tagged types, and
6441 -- correctly handling the floating-point case.
6443 else
6445 Expand_Array_Equality
6449 Bodies,
6450 Typl));
6455 -- Record Types
6459 -- For tagged types, use the primitive "="
6463 -- No need to do anything else compiling under restriction
6464 -- No_Dispatching_Calls. During the semantic analysis we
6465 -- already notified such violation.
6471 -- If this is derived from an untagged private type completed with
6472 -- a tagged type, it does not have a full view, so we use the
6473 -- primitive operations of the private type. This check should no
6474 -- longer be necessary when these types get their full views???
6480 then
6481 -- Search for equality operation, checking that the operands
6482 -- have the same type. Note that we must find a matching entry,
6483 -- or something is very wrong!
6491 and then
6500 -- Find the type's predefined equality or an overriding
6501 -- user- defined equality. The reason for not simply calling
6502 -- Find_Prim_Op here is that there may be a user-defined
6503 -- overloaded equality op that precedes the equality that we want,
6504 -- so we have to explicitly search (e.g., there could be an
6505 -- equality with two different parameter types).
6507 else
6517 and then
6529 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
6530 -- predefined equality operator for a type which has a subcomponent
6531 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
6538 -- Prevent Gigi from generating incorrect code by rewriting the
6539 -- equality as a standard False.
6546 -- If we can infer the discriminants of the operands, we make a
6547 -- call to the TSS equality function.
6550 and then
6552 then
6553 Build_Equality_Call
6556 else
6557 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
6558 -- the predefined equality operator for an Unchecked_Union type
6559 -- if either of the operands lack inferable discriminants.
6565 -- Prevent Gigi from generating incorrect code by rewriting
6566 -- the equality as a standard False.
6573 -- If a type support function is present (for complex cases), use it
6576 Build_Equality_Call
6579 -- Otherwise expand the component by component equality. Note that
6580 -- we never use block-bit comparisons for records, because of the
6581 -- problems with gaps. The backend will often be able to recombine
6582 -- the separate comparisons that we generate here.
6584 else
6595 -- Test if result is known at compile time
6599 -- If we still have comparison for Vax_Float, process it
6609 -----------------------
6610 -- Expand_N_Op_Expon --
6611 -----------------------
6629 begin
6632 -- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node
6638 -- If either operand is of a private type, then we have the use of an
6639 -- intrinsic operator, and we get rid of the privateness, by using root
6640 -- types of underlying types for the actual operation. Otherwise the
6641 -- private types will cause trouble if we expand multiplications or
6642 -- shifts etc. We also do this transformation if the result type is
6643 -- different from the base type.
6649 then
6650 declare
6654 begin
6665 -- Test for case of known right argument
6670 -- We only fold small non-negative exponents. You might think we
6671 -- could fold small negative exponents for the real case, but we
6672 -- can't because we are required to raise Constraint_Error for
6673 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
6674 -- See ACVC test C4A012B.
6678 -- X ** 0 = 1 (or 1.0)
6682 -- Call Remove_Side_Effects to ensure that any side effects
6683 -- in the ignored left operand (in particular function calls
6684 -- to user defined functions) are properly executed.
6690 else
6694 -- X ** 1 = X
6699 -- X ** 2 = X * X
6702 Xnode :=
6707 -- X ** 3 = X * X * X
6710 Xnode :=
6712 Left_Opnd =>
6718 -- X ** 4 ->
6719 -- En : constant base'type := base * base;
6720 -- ...
6721 -- En * En
6731 Expression =>
6736 Xnode :=
6748 -- Case of (2 ** expression) appearing as an argument of an integer
6749 -- multiplication, or as the right argument of a division of a non-
6750 -- negative integer. In such cases we leave the node untouched, setting
6751 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
6752 -- of the higher level node converts it into a shift.
6754 -- Another case is 2 ** N in any other context. We simply convert
6755 -- this to 1 * 2 ** N, and then the above transformation applies.
6757 -- Note: this transformation is not applicable for a modular type with
6758 -- a non-binary modulus in the multiplication case, since we get a wrong
6759 -- result if the shift causes an overflow before the modular reduction.
6766 and then not Ovflo
6767 then
6768 -- First the multiply and divide cases
6771 declare
6776 begin
6779 and then
6781 or else
6784 or else
6790 then
6796 -- Now the other cases
6808 -- Fall through if exponentiation must be done using a runtime routine
6810 -- First deal with modular case
6814 -- Non-binary case, we call the special exponentiation routine for
6815 -- the non-binary case, converting the argument to Long_Long_Integer
6816 -- and passing the modulus value. Then the result is converted back
6817 -- to the base type.
6827 Exp))));
6829 -- Binary case, in this case, we call one of two routines, either the
6830 -- unsigned integer case, or the unsigned long long integer case,
6831 -- with a final "and" operation to do the required mod.
6833 else
6836 else
6843 Left_Opnd =>
6848 Exp)),
6849 Right_Opnd =>
6854 -- Common exit point for modular type case
6859 -- Signed integer cases, done using either Integer or Long_Long_Integer.
6860 -- It is not worth having routines for Short_[Short_]Integer, since for
6861 -- most machines it would not help, and it would generate more code that
6862 -- might need certification when a certified run time is required.
6864 -- In the integer cases, we have two routines, one for when overflow
6865 -- checks are required, and one when they are not required, since there
6866 -- is a real gain in omitting checks on many machines.
6870 and then
6873 then
6878 else
6887 else
6891 -- Floating-point cases, always done using Long_Long_Float. We do not
6892 -- need separate routines for the overflow case here, since in the case
6893 -- of floating-point, we generate infinities anyway as a rule (either
6894 -- that or we automatically trap overflow), and if there is an infinity
6895 -- generated and a range check is required, the check will fail anyway.
6897 else
6903 -- Common processing for integer cases and floating-point cases.
6904 -- If we are in the right type, we can call runtime routine directly
6909 then
6915 -- Otherwise we have to introduce conversions (conversions are also
6916 -- required in the universal cases, since the runtime routine is
6917 -- typed using one of the standard types).
6919 else
6926 Exp))));
6932 exception
6937 --------------------
6938 -- Expand_N_Op_Ge --
6939 --------------------
6947 begin
6964 -- If we still have comparison, and Vax_Float type, process it
6974 --------------------
6975 -- Expand_N_Op_Gt --
6976 --------------------
6984 begin
7001 -- If we still have comparison, and Vax_Float type, process it
7011 --------------------
7012 -- Expand_N_Op_Le --
7013 --------------------
7021 begin
7038 -- If we still have comparison, and Vax_Float type, process it
7048 --------------------
7049 -- Expand_N_Op_Lt --
7050 --------------------
7058 begin
7075 -- If we still have comparison, and Vax_Float type, process it
7085 -----------------------
7086 -- Expand_N_Op_Minus --
7087 -----------------------
7093 begin
7096 if not Backend_Overflow_Checks_On_Target
7099 then
7100 -- Software overflow checking expands -expr into (0 - expr)
7109 -- Vax floating-point types case
7116 ---------------------
7117 -- Expand_N_Op_Mod --
7118 ---------------------
7138 begin
7144 -- Convert mod to rem if operands are known non-negative. We do this
7145 -- since it is quite likely that this will improve the quality of code,
7146 -- (the operation now corresponds to the hardware remainder), and it
7147 -- does not seem likely that it could be harmful.
7150 and then
7152 then
7158 -- Instead of reanalyzing the node we do the analysis manually. This
7159 -- avoids anomalies when the replacement is done in an instance and
7160 -- is epsilon more efficient.
7169 -- Otherwise, normal mod processing
7171 else
7176 -- Apply optimization x mod 1 = 0. We don't really need that with
7177 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
7178 -- certainly harmless.
7183 then
7184 -- Call Remove_Side_Effects to ensure that any side effects in
7185 -- the ignored left operand (in particular function calls to
7186 -- user defined functions) are properly executed.
7195 -- Deal with annoying case of largest negative number remainder
7196 -- minus one. Gigi does not handle this case correctly, because
7197 -- it generates a divide instruction which may trap in this case.
7199 -- In fact the check is quite easy, if the right operand is -1, then
7200 -- the mod value is always 0, and we can just ignore the left operand
7201 -- completely in this case.
7203 -- The operand type may be private (e.g. in the expansion of an
7204 -- intrinsic operation) so we must use the underlying type to get the
7205 -- bounds, and convert the literals explicitly.
7207 LLB :=
7208 Expr_Value
7212 and then
7214 then
7220 Right_Opnd =>
7233 --------------------------
7234 -- Expand_N_Op_Multiply --
7235 --------------------------
7254 begin
7257 -- Special optimizations for integer types
7261 -- N * 0 = 0 for integer types
7265 then
7266 -- Call Remove_Side_Effects to ensure that any side effects in
7267 -- the ignored left operand (in particular function calls to
7268 -- user defined functions) are properly executed.
7277 -- Similar handling for 0 * N = 0
7281 then
7288 -- N * 1 = 1 * N = N for integer types
7290 -- This optimisation is not done if we are going to
7291 -- rewrite the product 1 * 2 ** N to a shift.
7295 and then not Lp2
7296 then
7302 and then not Rp2
7303 then
7309 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
7310 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7311 -- operand is an integer, as required for this to work.
7316 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
7321 Right_Opnd =>
7328 else
7332 Right_Opnd =>
7338 -- Same processing for the operands the other way round
7344 Right_Opnd =>
7350 -- Do required fixup of universal fixed operation
7357 -- Multiplications with fixed-point results
7361 -- No special processing if Treat_Fixed_As_Integer is set, since from
7362 -- a semantic point of view such operations are simply integer
7363 -- operations and will be treated that way.
7367 -- Case of fixed * integer => fixed
7372 -- Case of integer * fixed => fixed
7377 -- Case of fixed * fixed => fixed
7379 else
7384 -- Other cases of multiplication of fixed-point operands. Again we
7385 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
7389 then
7392 else
7397 -- Mixed-mode operations can appear in a non-static universal context,
7398 -- in which case the integer argument must be converted explicitly.
7402 then
7409 then
7414 -- Non-fixed point cases, check software overflow checking required
7419 -- Deal with VAX float case
7427 --------------------
7428 -- Expand_N_Op_Ne --
7429 --------------------
7434 begin
7435 -- Case of elementary type with standard operator
7439 then
7442 -- Boolean types (requiring handling of non-standard case)
7453 -- If we still have comparison for Vax_Float, process it
7460 -- For all cases other than elementary types, we rewrite node as the
7461 -- negation of an equality operation, and reanalyze. The equality to be
7462 -- used is defined in the same scope and has the same signature. This
7463 -- signature must be set explicitly since in an instance it may not have
7464 -- the same visibility as in the generic unit. This avoids duplicating
7465 -- or factoring the complex code for record/array equality tests etc.
7467 else
7468 declare
7473 begin
7476 Neg :=
7478 Right_Opnd =>
7488 -- For navigation purposes, we want to treat the inequality as an
7489 -- implicit reference to the corresponding equality. Preserve the
7490 -- Comes_From_ source flag to generate proper Xref entries.
7502 ---------------------
7503 -- Expand_N_Op_Not --
7504 ---------------------
7506 -- If the argument is other than a Boolean array type, there is no special
7507 -- expansion required, except for VMS operations on signed integers.
7509 -- For the packed case, we call the special routine in Exp_Pakd, except
7510 -- that if the component size is greater than one, we use the standard
7511 -- routine generating a gruesome loop (it is so peculiar to have packed
7512 -- arrays with non-standard Boolean representations anyway, so it does not
7513 -- matter that we do not handle this case efficiently).
7515 -- For the unpacked case (and for the special packed case where we have non
7516 -- standard Booleans, as discussed above), we generate and insert into the
7517 -- tree the following function definition:
7519 -- function Nnnn (A : arr) is
7520 -- B : arr;
7521 -- begin
7522 -- for J in a'range loop
7523 -- B (J) := not A (J);
7524 -- end loop;
7525 -- return B;
7526 -- end Nnnn;
7528 -- Here arr is the actual subtype of the parameter (and hence always
7529 -- constrained). Then we replace the not with a call to this function.
7545 begin
7548 -- For boolean operand, deal with non-standard booleans
7557 -- For the VMS "not" on signed integer types, use conversion to and from
7558 -- a predefined modular type.
7561 declare
7565 begin
7566 -- If this is a derived type, retrieve original VMS type so that
7567 -- the proper sized type is used for intermediate values.
7571 else
7575 -- The proper unsigned type must have a size compatible with the
7576 -- operand, to prevent misalignment.
7587 else
7600 -- Only array types need any other processing
7606 -- Case of array operand. If bit packed with a component size of 1,
7607 -- handle it in Exp_Pakd if the operand is known to be aligned.
7612 then
7617 -- Case of array operand which is not bit-packed. If the context is
7618 -- a safe assignment, call in-place operation, If context is a larger
7619 -- boolean expression in the context of a safe assignment, expansion is
7620 -- done by enclosing operation.
7633 -- Special case the negation of a binary operation
7636 and then Safe_In_Place_Array_Op
7638 then
7645 then
7646 declare
7651 begin
7654 -- (not A) op (not B) can be reduced to a single call
7662 -- A xor (not B) can also be special-cased
7675 A_J :=
7680 B_J :=
7685 Loop_Statement :=
7689 Iteration_Scheme =>
7691 Loop_Parameter_Specification =>
7694 Discrete_Subtype_Definition =>
7709 Specification =>
7723 Handled_Statement_Sequence =>
7726 Loop_Statement,
7738 --------------------
7739 -- Expand_N_Op_Or --
7740 --------------------
7745 begin
7763 ----------------------
7764 -- Expand_N_Op_Plus --
7765 ----------------------
7768 begin
7772 ---------------------
7773 -- Expand_N_Op_Rem --
7774 ---------------------
7789 -- Set if corresponding operand can be negative
7793 begin
7800 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
7801 -- but it is useful with other back ends (e.g. AAMP), and is certainly
7802 -- harmless.
7807 then
7808 -- Call Remove_Side_Effects to ensure that any side effects in the
7809 -- ignored left operand (in particular function calls to user defined
7810 -- functions) are properly executed.
7819 -- Deal with annoying case of largest negative number remainder minus
7820 -- one. Gigi does not handle this case correctly, because it generates
7821 -- a divide instruction which may trap in this case.
7823 -- In fact the check is quite easy, if the right operand is -1, then
7824 -- the remainder is always 0, and we can just ignore the left operand
7825 -- completely in this case.
7833 -- We won't mess with trying to find out if the left operand can really
7834 -- be the largest negative number (that's a pain in the case of private
7835 -- types and this is really marginal). We will just assume that we need
7836 -- the test if the left operand can be negative at all.
7844 Right_Opnd =>
7857 -----------------------------
7858 -- Expand_N_Op_Rotate_Left --
7859 -----------------------------
7862 begin
7866 ------------------------------
7867 -- Expand_N_Op_Rotate_Right --
7868 ------------------------------
7871 begin
7875 ----------------------------
7876 -- Expand_N_Op_Shift_Left --
7877 ----------------------------
7880 begin
7884 -----------------------------
7885 -- Expand_N_Op_Shift_Right --
7886 -----------------------------
7889 begin
7893 ----------------------------------------
7894 -- Expand_N_Op_Shift_Right_Arithmetic --
7895 ----------------------------------------
7898 begin
7902 --------------------------
7903 -- Expand_N_Op_Subtract --
7904 --------------------------
7909 begin
7912 -- N - 0 = N for integer types
7917 then
7922 -- Arithmetic overflow checks for signed integer/fixed point types
7925 or else
7927 then
7930 -- VAX floating-point types case
7937 ---------------------
7938 -- Expand_N_Op_Xor --
7939 ---------------------
7944 begin
7962 ----------------------
7963 -- Expand_N_Or_Else --
7964 ----------------------
7969 -----------------------------------
7970 -- Expand_N_Qualified_Expression --
7971 -----------------------------------
7977 begin
7978 -- Do validity check if validity checking operands
7984 -- Apply possible constraint check
7994 ------------------------------------
7995 -- Expand_N_Quantified_Expression --
7996 ------------------------------------
7998 -- We expand:
8000 -- for all X in range => Cond
8002 -- into:
8004 -- T := True;
8005 -- for X in range loop
8006 -- if not Cond then
8007 -- T := False;
8008 -- exit;
8009 -- end if;
8010 -- end loop;
8012 -- Similarly, an existentially quantified expression:
8014 -- for some X in range => Cond
8016 -- becomes:
8018 -- T := False;
8019 -- for X in range loop
8020 -- if Cond then
8021 -- T := True;
8022 -- exit;
8023 -- end if;
8024 -- end loop;
8026 -- In both cases, the iteration may be over a container in which case it is
8027 -- given by an iterator specification, not a loop parameter specification.
8040 begin
8041 -- Create the declaration of the flag which tracks the status of the
8042 -- quantified expression. Generate:
8044 -- Flag : Boolean := (True | False);
8052 Expression =>
8055 -- Construct the circuitry which tracks the status of the quantified
8056 -- expression. Generate:
8058 -- if [not] Cond then
8059 -- Flag := (False | True);
8060 -- exit;
8061 -- end if;
8075 Expression =>
8079 -- Build the loop equivalent of the quantified expression
8082 Scheme :=
8085 else
8086 Scheme :=
8097 -- Transform the quantified expression
8106 ---------------------------------
8107 -- Expand_N_Selected_Component --
8108 ---------------------------------
8121 -- Gigi needs a temporary for prefixes that depend on a discriminant,
8122 -- unless the context of an assignment can provide size information.
8123 -- Don't we have a general routine that does this???
8126 -- The replacement of a discriminant reference by its value is required
8127 -- if this is part of the initialization of an temporary generated by a
8128 -- change of representation. This shows up as the construction of a
8129 -- discriminant constraint for a subtype declared at the same point as
8130 -- the entity in the prefix of the selected component. We recognize this
8131 -- case when the context of the reference is:
8132 -- subtype ST is T(Obj.D);
8133 -- where the entity for Obj comes from source, and ST has the same sloc.
8135 -----------------------
8136 -- In_Left_Hand_Side --
8137 -----------------------
8140 begin
8148 -----------------------------
8149 -- Is_Subtype_Declaration --
8150 -----------------------------
8154 begin
8155 return
8162 -- Start of processing for Expand_N_Selected_Component
8164 begin
8165 -- Insert explicit dereference if required
8169 -- First set prefix type to proper access type, in case it currently
8170 -- has a private (non-access) view of this type.
8179 then
8186 -- Deal with discriminant check required
8190 -- Present the discriminant checking function to the backend, so that
8191 -- it can inline the call to the function.
8193 Add_Inlined_Body
8194 (Discriminant_Checking_Func
8197 -- Now reset the flag and generate the call
8203 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
8204 -- function, then additional actuals must be passed.
8208 then
8212 -- Gigi cannot handle unchecked conversions that are the prefix of a
8213 -- selected component with discriminants. This must be checked during
8214 -- expansion, because during analysis the type of the selector is not
8215 -- known at the point the prefix is analyzed. If the conversion is the
8216 -- target of an assignment, then we cannot force the evaluation.
8221 then
8225 -- Remaining processing applies only if selector is a discriminant
8229 -- If the selector is a discriminant of a constrained record type,
8230 -- we may be able to rewrite the expression with the actual value
8231 -- of the discriminant, a useful optimization in some cases.
8236 then
8237 -- Do this optimization for discrete types only, and not for
8238 -- access types (access discriminants get us into trouble!)
8243 -- Don't do this on the left hand of an assignment statement.
8244 -- Normally one would think that references like this would not
8245 -- occur, but they do in generated code, and mean that we really
8246 -- do want to assign the discriminant!
8250 then
8253 -- Don't do this optimization for the prefix of an attribute or
8254 -- the name of an object renaming declaration since these are
8255 -- contexts where we do not want the value anyway.
8260 then
8263 -- Don't do this optimization if we are within the code for a
8264 -- discriminant check, since the whole point of such a check may
8265 -- be to verify the condition on which the code below depends!
8270 -- Green light to see if we can do the optimization. There is
8271 -- still one condition that inhibits the optimization below but
8272 -- now is the time to check the particular discriminant.
8274 else
8275 -- Loop through discriminants to find the matching discriminant
8276 -- constraint to see if we can copy it.
8283 -- Check if this is the matching discriminant and if the
8284 -- discriminant value is simple enough to make sense to
8285 -- copy. We don't want to copy complex expressions, and
8286 -- indeed to do so can cause trouble (before we put in
8287 -- this guard, a discriminant expression containing an
8288 -- AND THEN was copied, causing problems for coverage
8289 -- analysis tools).
8291 -- However, if the reference is part of the initialization
8292 -- code generated for an object declaration, we must use
8293 -- the discriminant value from the subtype constraint,
8294 -- because the selected component may be a reference to the
8295 -- object being initialized, whose discriminant is not yet
8296 -- set. This only happens in complex cases involving changes
8297 -- or representation.
8303 then
8304 -- Here we have the matching discriminant. Check for
8305 -- the case of a discriminant of a component that is
8306 -- constrained by an outer discriminant, which cannot
8307 -- be optimized away.
8309 if Denotes_Discriminant
8311 then
8315 and then
8316 Denotes_Discriminant
8318 then
8321 -- Do not retrieve value if constraint is not static. It
8322 -- is generally not useful, and the constraint may be a
8323 -- rewritten outer discriminant in which case it is in
8324 -- fact incorrect.
8328 N_Object_Declaration
8330 and then
8331 not Is_Static_Expression
8333 then
8336 -- In the context of a case statement, the expression may
8337 -- have the base type of the discriminant, and we need to
8338 -- preserve the constraint to avoid spurious errors on
8339 -- missing cases.
8343 then
8346 Subtype_Mark =>
8348 Expression =>
8352 -- In case that comes out as a static expression,
8353 -- reset it (a selected component is never static).
8358 -- Otherwise we can just copy the constraint, but the
8359 -- result is certainly not static! In some cases the
8360 -- discriminant constraint has been analyzed in the
8361 -- context of the original subtype indication, but for
8362 -- itypes the constraint might not have been analyzed
8363 -- yet, and this must be done now.
8365 else
8377 -- Note: the above loop should always find a matching
8378 -- discriminant, but if it does not, we just missed an
8379 -- optimization due to some glitch (perhaps a previous
8380 -- error), so ignore.
8385 -- The only remaining processing is in the case of a discriminant of
8386 -- a concurrent object, where we rewrite the prefix to denote the
8387 -- corresponding record type. If the type is derived and has renamed
8388 -- discriminants, use corresponding discriminant, which is the one
8389 -- that appears in the corresponding record.
8399 then
8403 New_N :=
8405 Prefix =>
8414 -- Set Atomic_Sync_Required if necessary for atomic component
8417 declare
8421 begin
8422 -- If component is atomic, but type is not, setting depends on
8423 -- disable/enable state for the component.
8428 -- If component is not atomic, but its type is atomic, setting
8429 -- depends on disable/enable state for the type.
8434 -- If both component and type are atomic, we disable if either
8435 -- component or its type have sync disabled.
8439 and then
8442 else
8446 -- Set flag if required
8455 --------------------
8456 -- Expand_N_Slice --
8457 --------------------
8466 -- Check whether the argument is an actual for a procedure call, in
8467 -- which case the expansion of a bit-packed slice is deferred until the
8468 -- call itself is expanded. The reason this is required is that we might
8469 -- have an IN OUT or OUT parameter, and the copy out is essential, and
8470 -- that copy out would be missed if we created a temporary here in
8471 -- Expand_N_Slice. Note that we don't bother to test specifically for an
8472 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
8473 -- is harmless to defer expansion in the IN case, since the call
8474 -- processing will still generate the appropriate copy in operation,
8475 -- which will take care of the slice.
8478 -- Create a named variable for the value of the slice, in cases where
8479 -- the back-end cannot handle it properly, e.g. when packed types or
8480 -- unaligned slices are involved.
8482 -------------------------
8483 -- Is_Procedure_Actual --
8484 -------------------------
8489 begin
8490 loop
8491 -- If our parent is a procedure call we can return
8496 -- If our parent is a type conversion, keep climbing the tree,
8497 -- since a type conversion can be a procedure actual. Also keep
8498 -- climbing if parameter association or a qualified expression,
8499 -- since these are additional cases that do can appear on
8500 -- procedure actuals.
8503 N_Parameter_Association,
8504 N_Qualified_Expression)
8505 then
8508 -- Any other case is not what we are looking for
8510 else
8516 ------------------------------
8517 -- Make_Temporary_For_Slice --
8518 ------------------------------
8524 begin
8525 Decl :=
8533 Decl,
8542 -- Start of processing for Expand_N_Slice
8544 begin
8545 -- Special handling for access types
8558 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
8559 -- function, then additional actuals must be passed.
8563 then
8567 -- The remaining case to be handled is packed slices. We can leave
8568 -- packed slices as they are in the following situations:
8570 -- 1. Right or left side of an assignment (we can handle this
8571 -- situation correctly in the assignment statement expansion).
8573 -- 2. Prefix of indexed component (the slide is optimized away in this
8574 -- case, see the start of Expand_N_Slice.)
8576 -- 3. Object renaming declaration, since we want the name of the
8577 -- slice, not the value.
8579 -- 4. Argument to procedure call, since copy-in/copy-out handling may
8580 -- be required, and this is handled in the expansion of call
8581 -- itself.
8583 -- 5. Prefix of an address attribute (this is an error which is caught
8584 -- elsewhere, and the expansion would interfere with generating the
8585 -- error message).
8589 -- Apply transformation for actuals of a function call, where
8590 -- Expand_Actuals is not used.
8594 then
8595 Make_Temporary_For_Slice;
8601 then
8607 then
8612 then
8615 else
8616 Make_Temporary_For_Slice;
8620 ------------------------------
8621 -- Expand_N_Type_Conversion --
8622 ------------------------------
8631 -- This is called in the case of record and array type conversions to
8632 -- see if there is a change of representation to be handled. Change of
8633 -- representation is actually handled at the assignment statement level,
8634 -- and what this procedure does is rewrite node N conversion as an
8635 -- assignment to temporary. If there is no change of representation,
8636 -- then the conversion node is unchanged.
8639 -- Called when we know that an accessibility check will fail. Rewrites
8640 -- node N to an appropriate raise statement and outputs warning msgs.
8641 -- The Etype of the raise node is set to Target_Type.
8644 -- Handles generation of range check for real target value
8647 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
8648 -- evaluates to True.
8650 -----------------------------------
8651 -- Handle_Changed_Representation --
8652 -----------------------------------
8662 begin
8663 -- Nothing else to do if no change of representation
8668 -- The real change of representation work is done by the assignment
8669 -- statement processing. So if this type conversion is appearing as
8670 -- the expression of an assignment statement, nothing needs to be
8671 -- done to the conversion.
8676 -- Otherwise we need to generate a temporary variable, and do the
8677 -- change of representation assignment into that temporary variable.
8678 -- The conversion is then replaced by a reference to this variable.
8680 else
8683 -- If type is unconstrained we have to add a constraint, copied
8684 -- from the actual value of the left hand side.
8698 Prefix =>
8700 Selector_Name =>
8711 -- We convert the bounds explicitly. We use an unchecked
8712 -- conversion because bounds checks are done elsewhere.
8716 Low_Bound =>
8719 Prefix =>
8720 Duplicate_Subexpr_No_Checks
8726 High_Bound =>
8729 Prefix =>
8730 Duplicate_Subexpr_No_Checks
8744 Odef :=
8747 Constraint =>
8753 Decl :=
8760 -- Insert required actions. It is essential to suppress checks
8761 -- since we have suppressed default initialization, which means
8762 -- that the variable we create may have no discriminants.
8765 New_List (
8766 Decl,
8777 -------------------------------
8778 -- Raise_Accessibility_Error --
8779 -------------------------------
8782 begin
8789 Error_Msg_NE
8793 ----------------------
8794 -- Real_Range_Check --
8795 ----------------------
8797 -- Case of conversions to floating-point or fixed-point. If range checks
8798 -- are enabled and the target type has a range constraint, we convert:
8800 -- typ (x)
8802 -- to
8804 -- Tnn : typ'Base := typ'Base (x);
8805 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
8806 -- Tnn
8808 -- This is necessary when there is a conversion of integer to float or
8809 -- to fixed-point to ensure that the correct checks are made. It is not
8810 -- necessary for float to float where it is enough to simply set the
8811 -- Do_Range_Check flag.
8821 begin
8822 -- Nothing to do if conversion was rewritten
8828 -- Nothing to do if range checks suppressed, or target has the same
8829 -- range as the base type (or is the base type).
8833 and then
8835 then
8839 -- Nothing to do if expression is an entity on which checks have been
8840 -- suppressed.
8844 then
8848 -- Nothing to do if bounds are all static and we can tell that the
8849 -- expression is within the bounds of the target. Note that if the
8850 -- operand is of an unconstrained floating-point type, then we do
8851 -- not trust it to be in range (might be infinite)
8853 declare
8857 begin
8864 then
8865 declare
8871 begin
8875 else
8883 then
8891 -- For float to float conversions, we are done
8894 and then
8896 then
8900 -- Otherwise rewrite the conversion as described above
8906 -- Enable overflow except for case of integer to float conversions,
8907 -- where it is never required, since we can never have overflow in
8908 -- this case.
8924 Condition =>
8926 Left_Opnd =>
8929 Right_Opnd =>
8932 Prefix =>
8935 Right_Opnd =>
8938 Right_Opnd =>
8941 Prefix =>
8949 -----------------------------
8950 -- Has_Extra_Accessibility --
8951 -----------------------------
8953 -- Returns true for a formal of an anonymous access type or for
8954 -- an Ada 2012-style stand-alone object of an anonymous access type.
8957 begin
8960 else
8965 -- Start of processing for Expand_N_Type_Conversion
8967 begin
8968 -- Nothing at all to do if conversion is to the identical type so remove
8969 -- the conversion completely, it is useless, except that it may carry
8970 -- an Assignment_OK attribute, which must be propagated to the operand.
8981 -- Nothing to do if this is the second argument of read. This is a
8982 -- "backwards" conversion that will be handled by the specialized code
8983 -- in attribute processing.
8988 then
8992 -- Check for case of converting to a type that has an invariant
8993 -- associated with it. This required an invariant check. We convert
8995 -- typ (expr)
8997 -- into
8999 -- do invariant_check (typ (expr)) in typ (expr);
9001 -- using Duplicate_Subexpr to avoid multiple side effects
9003 -- Note: the Comes_From_Source check, and then the resetting of this
9004 -- flag prevents what would otherwise be an infinite recursion.
9009 then
9020 -- Here if we may need to expand conversion
9022 -- If the operand of the type conversion is an arithmetic operation on
9023 -- signed integers, and the based type of the signed integer type in
9024 -- question is smaller than Standard.Integer, we promote both of the
9025 -- operands to type Integer.
9027 -- For example, if we have
9029 -- target-type (opnd1 + opnd2)
9031 -- and opnd1 and opnd2 are of type short integer, then we rewrite
9032 -- this as:
9034 -- target-type (integer(opnd1) + integer(opnd2))
9036 -- We do this because we are always allowed to compute in a larger type
9037 -- if we do the right thing with the result, and in this case we are
9038 -- going to do a conversion which will do an appropriate check to make
9039 -- sure that things are in range of the target type in any case. This
9040 -- avoids some unnecessary intermediate overflows.
9042 -- We might consider a similar transformation in the case where the
9043 -- target is a real type or a 64-bit integer type, and the operand
9044 -- is an arithmetic operation using a 32-bit integer type. However,
9045 -- we do not bother with this case, because it could cause significant
9046 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
9047 -- much cheaper, but we don't want different behavior on 32-bit and
9048 -- 64-bit machines. Note that the exclusion of the 64-bit case also
9049 -- handles the configurable run-time cases where 64-bit arithmetic
9050 -- may simply be unavailable.
9052 -- Note: this circuit is partially redundant with respect to the circuit
9053 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
9054 -- the processing here. Also we still need the Checks circuit, since we
9055 -- have to be sure not to generate junk overflow checks in the first
9056 -- place, since it would be trick to remove them here!
9060 -- All conditions met, go ahead with transformation
9062 declare
9066 begin
9067 R :=
9076 L :=
9094 -- Do validity check if validity checking operands
9096 if Validity_Checks_On
9097 and then Validity_Check_Operands
9098 then
9102 -- Special case of converting from non-standard boolean type
9106 then
9112 -- Case of converting to an access type
9116 -- Apply an accessibility check when the conversion operand is an
9117 -- access parameter (or a renaming thereof), unless conversion was
9118 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
9119 -- Note that other checks may still need to be applied below (such
9120 -- as tagged type checks).
9127 then
9128 Apply_Accessibility_Check
9131 -- If the level of the operand type is statically deeper than the
9132 -- level of the target type, then force Program_Error. Note that this
9133 -- can only occur for cases where the attribute is within the body of
9134 -- an instantiation (otherwise the conversion will already have been
9135 -- rejected as illegal). Note: warnings are issued by the analyzer
9136 -- for the instance cases.
9138 elsif In_Instance_Body
9141 then
9142 Raise_Accessibility_Error;
9144 -- When the operand is a selected access discriminant the check needs
9145 -- to be made against the level of the object denoted by the prefix
9146 -- of the selected name. Force Program_Error for this case as well
9147 -- (this accessibility violation can only happen if within the body
9148 -- of an instantiation).
9150 elsif In_Instance_Body
9155 then
9156 Raise_Accessibility_Error;
9161 -- Case of conversions of tagged types and access to tagged types
9163 -- When needed, that is to say when the expression is class-wide, Add
9164 -- runtime a tag check for (strict) downward conversion by using the
9165 -- membership test, generating:
9167 -- [constraint_error when Operand not in Target_Type'Class]
9169 -- or in the access type case
9171 -- [constraint_error
9172 -- when Operand /= null
9173 -- and then Operand.all not in
9174 -- Designated_Type (Target_Type)'Class]
9179 then
9180 -- Do not do any expansion in the access type case if the parent is a
9181 -- renaming, since this is an error situation which will be caught by
9182 -- Sem_Ch8, and the expansion can interfere with this error check.
9188 -- Otherwise, proceed with processing tagged conversion
9197 -- Create a membership check to test whether Operand is a member
9198 -- of Targ_Typ. If the original Target_Type is an access, include
9199 -- a test for null value. The check is inserted at N.
9201 --------------------
9202 -- Make_Tag_Check --
9203 --------------------
9208 begin
9209 -- Generate:
9210 -- [Constraint_Error
9211 -- when Operand /= null
9212 -- and then Operand.all not in Targ_Typ]
9215 Cond :=
9217 Left_Opnd =>
9222 Right_Opnd =>
9224 Left_Opnd =>
9229 -- Generate:
9230 -- [Constraint_Error when Operand not in Targ_Typ]
9232 else
9233 Cond :=
9245 -- Start of processing for Tagged_Conversion
9247 begin
9248 -- Handle entities from the limited view
9251 Actual_Op_Typ :=
9253 else
9258 Actual_Targ_Typ :=
9260 else
9266 -- Ada 2005 (AI-251): Handle interface type conversion
9275 -- Create a runtime tag check for a downward class-wide type
9276 -- conversion.
9283 then
9288 -- AI05-0073: If the result subtype of the function is defined
9289 -- by an access_definition designating a specific tagged type
9290 -- T, a check is made that the result value is null or the tag
9291 -- of the object designated by the result value identifies T.
9292 -- Constraint_Error is raised if this check fails.
9295 declare
9299 begin
9300 -- Climb scope stack looking for the enclosing function
9305 loop
9309 -- The function's return subtype must be defined using
9310 -- an access definition.
9313 N_Access_Definition
9314 then
9317 -- The return subtype denotes a specific tagged type,
9318 -- in other words, a non class-wide type.
9322 then
9330 -- We have generated a tag check for either a class-wide type
9331 -- conversion or for AI05-0073.
9334 declare
9336 begin
9337 Conv :=
9348 -- Case of other access type conversions
9353 -- Case of conversions from a fixed-point type
9355 -- These conversions require special expansion and processing, found in
9356 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
9357 -- since from a semantic point of view, these are simple integer
9358 -- conversions, which do not need further processing.
9362 then
9363 -- We should never see universal fixed at this case, since the
9364 -- expansion of the constituent divide or multiply should have
9365 -- eliminated the explicit mention of universal fixed.
9369 -- Check for special case of the conversion to universal real that
9370 -- occurs as a result of the use of a round attribute. In this case,
9371 -- the real type for the conversion is taken from the target type of
9372 -- the Round attribute and the result must be marked as rounded.
9377 then
9382 -- Otherwise do correct fixed-conversion, but skip these if the
9383 -- Conversion_OK flag is set, because from a semantic point of view
9384 -- these are simple integer conversions needing no further processing
9385 -- (the backend will simply treat them as integers).
9390 Real_Range_Check;
9395 else
9398 Real_Range_Check;
9402 -- Case of conversions to a fixed-point type
9404 -- These conversions require special expansion and processing, found in
9405 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
9406 -- since from a semantic point of view, these are simple integer
9407 -- conversions, which do not need further processing.
9411 then
9414 Real_Range_Check;
9415 else
9418 Real_Range_Check;
9421 -- Case of float-to-integer conversions
9423 -- We also handle float-to-fixed conversions with Conversion_OK set
9424 -- since semantically the fixed-point target is treated as though it
9425 -- were an integer in such cases.
9428 and then
9430 or else
9432 then
9433 -- One more check here, gcc is still not able to do conversions of
9434 -- this type with proper overflow checking, and so gigi is doing an
9435 -- approximation of what is required by doing floating-point compares
9436 -- with the end-point. But that can lose precision in some cases, and
9437 -- give a wrong result. Converting the operand to Universal_Real is
9438 -- helpful, but still does not catch all cases with 64-bit integers
9439 -- on targets with only 64-bit floats.
9441 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
9442 -- Can this code be removed ???
9447 Subtype_Mark =>
9449 Expression =>
9457 -- Case of array conversions
9459 -- Expansion of array conversions, add required length/range checks but
9460 -- only do this if there is no change of representation. For handling of
9461 -- this case, see Handle_Changed_Representation.
9466 else
9470 Handle_Changed_Representation;
9472 -- Case of conversions of discriminated types
9474 -- Add required discriminant checks if target is constrained. Again this
9475 -- change is skipped if we have a change of representation.
9479 then
9481 Handle_Changed_Representation;
9483 -- Case of all other record conversions. The only processing required
9484 -- is to check for a change of representation requiring the special
9485 -- assignment processing.
9489 -- Ada 2005 (AI-216): Program_Error is raised when converting from
9490 -- a derived Unchecked_Union type to an unconstrained type that is
9491 -- not Unchecked_Union if the operand lacks inferable discriminants.
9498 then
9499 -- To prevent Gigi from generating illegal code, we generate a
9500 -- Program_Error node, but we give it the target type of the
9501 -- conversion.
9503 declare
9507 begin
9512 else
9513 Handle_Changed_Representation;
9516 -- Case of conversions of enumeration types
9520 -- Special processing is required if there is a change of
9521 -- representation (from enumeration representation clauses).
9525 -- Convert: x(y) to x'val (ytyp'val (y))
9540 -- Case of conversions to floating-point
9543 Real_Range_Check;
9546 -- At this stage, either the conversion node has been transformed into
9547 -- some other equivalent expression, or left as a conversion that can be
9548 -- handled by Gigi, in the following cases:
9550 -- Conversions with no change of representation or type
9552 -- Numeric conversions involving integer, floating- and fixed-point
9553 -- values. Fixed-point values are allowed only if Conversion_OK is
9554 -- set, i.e. if the fixed-point values are to be treated as integers.
9556 -- No other conversions should be passed to Gigi
9558 -- Check: are these rules stated in sinfo??? if so, why restate here???
9560 -- The only remaining step is to generate a range check if we still have
9561 -- a type conversion at this stage and Do_Range_Check is set. For now we
9562 -- do this only for conversions of discrete types.
9566 then
9567 declare
9572 begin
9575 then
9578 -- Before we do a range check, we have to deal with treating a
9579 -- fixed-point operand as an integer. The way we do this is
9580 -- simply to do an unchecked conversion to an appropriate
9581 -- integer type large enough to hold the result.
9583 -- This code is not active yet, because we are only dealing
9584 -- with discrete types so far ???
9588 then
9593 else
9600 -- Reset overflow flag, since the range check will include
9601 -- dealing with possible overflow, and generate the check. If
9602 -- Address is either a source type or target type, suppress
9603 -- range check to avoid typing anomalies when it is a visible
9604 -- integer type.
9609 then
9610 Generate_Range_Check
9617 -- Final step, if the result is a type conversion involving Vax_Float
9618 -- types, then it is subject for further special processing.
9622 then
9627 -- Here at end of processing
9630 -- Apply predicate check if required. Note that we can't just call
9631 -- Apply_Predicate_Check here, because the type looks right after
9632 -- the conversion and it would omit the check. The Comes_From_Source
9633 -- guard is necessary to prevent infinite recursions when we generate
9634 -- internal conversions for the purpose of checking predicates.
9639 then
9640 declare
9643 begin
9644 -- Avoid infinite recursion on the subsequent expansion of
9645 -- of the copy of the original type conversion.
9653 -----------------------------------
9654 -- Expand_N_Unchecked_Expression --
9655 -----------------------------------
9657 -- Remove the unchecked expression node from the tree. Its job was simply
9658 -- to make sure that its constituent expression was handled with checks
9659 -- off, and now that that is done, we can remove it from the tree, and
9660 -- indeed must, since Gigi does not expect to see these nodes.
9664 begin
9669 ----------------------------------------
9670 -- Expand_N_Unchecked_Type_Conversion --
9671 ----------------------------------------
9673 -- If this cannot be handled by Gigi and we haven't already made a
9674 -- temporary for it, do it now.
9681 begin
9682 -- Nothing at all to do if conversion is to the identical type so remove
9683 -- the conversion completely, it is useless, except that it may carry
9684 -- an Assignment_OK indication which must be propagated to the operand.
9688 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
9698 -- If we have a conversion of a compile time known value to a target
9699 -- type and the value is in range of the target type, then we can simply
9700 -- replace the construct by an integer literal of the correct type. We
9701 -- only apply this to integer types being converted. Possibly it may
9702 -- apply in other cases, but it is too much trouble to worry about.
9704 -- Note that we do not do this transformation if the Kill_Range_Check
9705 -- flag is set, since then the value may be outside the expected range.
9706 -- This happens in the Normalize_Scalars case.
9708 -- We also skip this if either the target or operand type is biased
9709 -- because in this case, the unchecked conversion is supposed to
9710 -- preserve the bit pattern, not the integer value.
9718 then
9719 declare
9722 begin
9724 and then
9726 and then
9728 and then
9730 then
9733 -- If Address is the target type, just set the type to avoid a
9734 -- spurious type error on the literal when Address is a visible
9735 -- integer type.
9739 else
9748 -- Nothing to do if conversion is safe
9754 -- Otherwise force evaluation unless Assignment_OK flag is set (this
9755 -- flag indicates ??? -- more comments needed here)
9759 else
9764 ----------------------------
9765 -- Expand_Record_Equality --
9766 ----------------------------
9768 -- For non-variant records, Equality is expanded when needed into:
9770 -- and then Lhs.Discr1 = Rhs.Discr1
9771 -- and then ...
9772 -- and then Lhs.Discrn = Rhs.Discrn
9773 -- and then Lhs.Cmp1 = Rhs.Cmp1
9774 -- and then ...
9775 -- and then Lhs.Cmpn = Rhs.Cmpn
9777 -- The expression is folded by the back-end for adjacent fields. This
9778 -- function is called for tagged record in only one occasion: for imple-
9779 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
9780 -- otherwise the primitive "=" is used directly.
9782 function Expand_Record_Equality
9788 is
9797 -- Return the first field to compare beginning with C, skipping the
9798 -- inherited components.
9800 ----------------------
9801 -- Suitable_Element --
9802 ----------------------
9805 begin
9811 then
9816 then
9822 -- The .NET/JVM version of type Root_Controlled contains two fields
9823 -- which should not be considered part of the object. To achieve
9824 -- proper equiality between two controlled objects on .NET/JVM, skip
9825 -- field _parent whenever it is of type Root_Controlled.
9830 then
9836 else
9841 -- Start of processing for Expand_Record_Equality
9843 begin
9844 -- Generates the following code: (assuming that Typ has one Discr and
9845 -- component C2 is also a record)
9847 -- True
9848 -- and then Lhs.Discr1 = Rhs.Discr1
9849 -- and then Lhs.C1 = Rhs.C1
9850 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
9851 -- and then ...
9852 -- and then Lhs.Cmpn = Rhs.Cmpn
9857 declare
9862 begin
9867 else
9872 Check :=
9874 Lhs =>
9878 Rhs =>
9884 -- If some (sub)component is an unchecked_union, the whole
9885 -- operation will raise program error.
9891 else
9892 Result :=
9905 ---------------------------
9906 -- Expand_Set_Membership --
9907 ---------------------------
9915 -- If the alternative is a subtype mark, create a simple membership
9916 -- test. Otherwise create an equality test for it.
9918 ---------------
9919 -- Make_Cond --
9920 ---------------
9927 begin
9930 then
9931 Cond :=
9935 else
9936 Cond :=
9945 -- Start of processing for Expand_Set_Membership
9947 begin
9955 Res :=
9966 -----------------------------------
9967 -- Expand_Short_Circuit_Operator --
9968 -----------------------------------
9970 -- Deal with special expansion if actions are present for the right operand
9971 -- and deal with optimizing case of arguments being True or False. We also
9972 -- deal with the special case of non-standard boolean values.
9984 -- If Left = Shortcut_Value then Right need not be evaluated
9987 -- For Opnd a boolean expression, return a Boolean expression equivalent
9988 -- to Opnd /= Shortcut_Value.
9990 --------------------
9991 -- Make_Test_Expr --
9992 --------------------
9995 begin
9998 else
10004 -- Entity for a temporary variable holding the value of the operator,
10005 -- used for expansion in the case where actions are present.
10007 -- Start of processing for Expand_Short_Circuit_Operator
10009 begin
10010 -- Deal with non-standard booleans
10018 -- Check for cases where left argument is known to be True or False
10022 -- Mark SCO for left condition as compile time known
10028 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
10029 -- Any actions associated with Right will be executed unconditionally
10030 -- and can thus be inserted into the tree unconditionally.
10039 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
10040 -- In this case we can forget the actions associated with Right,
10041 -- since they will never be executed.
10043 else
10053 -- If Actions are present for the right operand, we have to do some
10054 -- special processing. We can't just let these actions filter back into
10055 -- code preceding the short circuit (which is what would have happened
10056 -- if we had not trapped them in the short-circuit form), since they
10057 -- must only be executed if the right operand of the short circuit is
10058 -- executed and not otherwise.
10060 -- the temporary variable C.
10065 -- The old approach is to expand:
10067 -- left AND THEN right
10069 -- into
10071 -- C : Boolean := False;
10072 -- IF left THEN
10073 -- Actions;
10074 -- IF right THEN
10075 -- C := True;
10076 -- END IF;
10077 -- END IF;
10079 -- and finally rewrite the operator into a reference to C. Similarly
10080 -- for left OR ELSE right, with negated values. Note that this
10081 -- rewrite causes some difficulties for coverage analysis because
10082 -- of the introduction of the new variable C, which obscures the
10083 -- structure of the test.
10085 -- We use this "old approach" if use of N_Expression_With_Actions
10086 -- is False (see description in Opt of when this is or is not set).
10093 Defining_Identifier =>
10094 Op_Var,
10095 Object_Definition =>
10097 Expression =>
10106 Expression =>
10107 New_Occurrence_Of
10118 -- The new approach, activated for now by the use of debug flag
10119 -- -gnatd.X is to use the new Expression_With_Actions node for the
10120 -- right operand of the short-circuit form. This should solve the
10121 -- traceability problems for coverage analysis.
10123 else
10136 -- No actions present, check for cases of right argument True/False
10140 -- Mark SCO for left condition as compile time known
10146 -- Change (Left and then True), (Left or else False) to Left.
10147 -- Note that we know there are no actions associated with the right
10148 -- operand, since we just checked for this case above.
10153 -- Change (Left and then False), (Left or else True) to Right,
10154 -- making sure to preserve any side effects associated with the Left
10155 -- operand.
10157 else
10166 -------------------------------------
10167 -- Fixup_Universal_Fixed_Operation --
10168 -------------------------------------
10173 begin
10174 -- We must have a type conversion immediately above us
10178 -- Normally the type conversion gives our target type. The exception
10179 -- occurs in the case of the Round attribute, where the conversion
10180 -- will be to universal real, and our real type comes from the Round
10181 -- attribute (as well as an indication that we must round the result)
10185 then
10189 -- Normal case where type comes from conversion above us
10191 else
10196 ---------------------------------
10197 -- Has_Inferable_Discriminants --
10198 ---------------------------------
10203 -- Determines whether the left-most prefix of a selected component is a
10204 -- formal parameter in a subprogram. Assumes N is a selected component.
10206 --------------------------------
10207 -- Prefix_Is_Formal_Parameter --
10208 --------------------------------
10213 begin
10214 -- Move to the left-most prefix by climbing up the tree
10219 loop
10226 -- Start of processing for Has_Inferable_Discriminants
10228 begin
10229 -- For selected components, the subtype of the selector must be a
10230 -- constrained Unchecked_Union. If the component is subject to a
10231 -- per-object constraint, then the enclosing object must have inferable
10232 -- discriminants.
10237 -- A small hack. If we have a per-object constrained selected
10238 -- component of a formal parameter, return True since we do not
10239 -- know the actual parameter association yet.
10244 -- Otherwise, check the enclosing object and the selector
10246 else
10251 -- The call to Has_Inferable_Discriminants will determine whether
10252 -- the selector has a constrained Unchecked_Union nominal type.
10254 else
10258 -- A qualified expression has inferable discriminants if its subtype
10259 -- mark is a constrained Unchecked_Union subtype.
10265 -- For all other names, it is sufficient to have a constrained
10266 -- Unchecked_Union nominal subtype.
10268 else
10274 -------------------------------
10275 -- Insert_Dereference_Action --
10276 -------------------------------
10281 -- Return true if type of P is derived from Checked_Pool;
10283 -----------------------------
10284 -- Is_Checked_Storage_Pool --
10285 -----------------------------
10290 begin
10299 else
10307 -- Local variables
10321 -- Start of processing for Insert_Dereference_Action
10323 begin
10326 -- Do not re-expand a dereference which has already been processed by
10327 -- this routine.
10332 -- Do not perform this type of expansion for internally-generated
10333 -- dereferences.
10338 -- A dereference action is only applicable to objects which have been
10339 -- allocated on a checked pool.
10345 -- Extract the address of the dereferenced object. Generate:
10347 -- Addr : System.Address := <N>'Pool_Address;
10354 Object_Definition =>
10356 Expression =>
10361 -- Calculate the size of the dereferenced object. Generate:
10363 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
10365 Deref :=
10376 Object_Definition =>
10379 Expression =>
10381 Left_Opnd =>
10385 Right_Opnd =>
10388 -- Calculate the alignment of the dereferenced object. Generate:
10389 -- Alig : constant Storage_Count := <N>.all'Alignment;
10391 Deref :=
10401 Object_Definition =>
10403 Expression =>
10408 -- A dereference of a controlled object requires special processing. The
10409 -- finalization machinery requests additional space from the underlying
10410 -- pool to allocate and hide two pointers. As a result, a checked pool
10411 -- may mark the wrong memory as valid. Since checked pools do not have
10412 -- knowledge of hidden pointers, we have to bring the two pointers back
10413 -- in view in order to restore the original state of the object.
10417 -- Adjust the address and size of the dereferenced object. Generate:
10418 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
10420 Stmt :=
10422 Name =>
10429 -- Class-wide types complicate things because we cannot determine
10430 -- statically whether the actual object is truly controlled. We must
10431 -- generate a runtime check to detect this property. Generate:
10432 --
10433 -- if Needs_Finalization (<N>.all'Tag) then
10434 -- <Stmt>;
10435 -- end if;
10438 Deref :=
10443 Stmt :=
10445 Condition =>
10447 Name =>
10459 -- Generate:
10460 -- Dereference (Pool, Addr, Size, Alig);
10464 Name =>
10465 New_Reference_To
10473 -- Mark the explicit dereference as processed to avoid potential
10474 -- infinite expansion.
10478 exception
10483 --------------------------------
10484 -- Integer_Promotion_Possible --
10485 --------------------------------
10492 begin
10495 return
10497 -- We only do the transformation for source constructs. We assume
10498 -- that the expander knows what it is doing when it generates code.
10502 -- If the operand type is Short_Integer or Short_Short_Integer,
10503 -- then we will promote to Integer, which is available on all
10504 -- targets, and is sufficient to ensure no intermediate overflow.
10505 -- Furthermore it is likely to be as efficient or more efficient
10506 -- than using the smaller type for the computation so we do this
10507 -- unconditionally.
10509 and then
10511 or else
10514 -- Test for interesting operation, which includes addition,
10515 -- division, exponentiation, multiplication, subtraction, absolute
10516 -- value and unary negation. Unary "+" is omitted since it is a
10517 -- no-op and thus can't overflow.
10520 N_Op_Add,
10521 N_Op_Divide,
10522 N_Op_Expon,
10523 N_Op_Minus,
10524 N_Op_Multiply,
10525 N_Op_Subtract);
10528 ------------------------------
10529 -- Make_Array_Comparison_Op --
10530 ------------------------------
10532 -- This is a hand-coded expansion of the following generic function:
10534 -- generic
10535 -- type elem is (<>);
10536 -- type index is (<>);
10537 -- type a is array (index range <>) of elem;
10539 -- function Gnnn (X : a; Y: a) return boolean is
10540 -- J : index := Y'first;
10542 -- begin
10543 -- if X'length = 0 then
10544 -- return false;
10546 -- elsif Y'length = 0 then
10547 -- return true;
10549 -- else
10550 -- for I in X'range loop
10551 -- if X (I) = Y (J) then
10552 -- if J = Y'last then
10553 -- exit;
10554 -- else
10555 -- J := index'succ (J);
10556 -- end if;
10558 -- else
10559 -- return X (I) > Y (J);
10560 -- end if;
10561 -- end loop;
10563 -- return X'length > Y'length;
10564 -- end if;
10565 -- end Gnnn;
10567 -- Note that since we are essentially doing this expansion by hand, we
10568 -- do not need to generate an actual or formal generic part, just the
10569 -- instantiated function itself.
10571 function Make_Array_Comparison_Op
10574 is
10595 begin
10596 -- if J = Y'last then
10597 -- exit;
10598 -- else
10599 -- J := index'succ (J);
10600 -- end if;
10602 Inner_If :=
10604 Condition =>
10607 Right_Opnd =>
10615 Else_Statements =>
10616 New_List (
10619 Expression =>
10625 -- if X (I) = Y (J) then
10626 -- if ... end if;
10627 -- else
10628 -- return X (I) > Y (J);
10629 -- end if;
10631 Loop_Body :=
10633 Condition =>
10635 Left_Opnd =>
10640 Right_Opnd =>
10649 Expression =>
10651 Left_Opnd =>
10656 Right_Opnd =>
10662 -- for I in X'range loop
10663 -- if ... end if;
10664 -- end loop;
10666 Loop_Statement :=
10670 Iteration_Scheme =>
10672 Loop_Parameter_Specification =>
10675 Discrete_Subtype_Definition =>
10682 -- if X'length = 0 then
10683 -- return false;
10684 -- elsif Y'length = 0 then
10685 -- return true;
10686 -- else
10687 -- for ... loop ... end loop;
10688 -- return X'length > Y'length;
10689 -- end if;
10691 Length1 :=
10696 Length2 :=
10701 Final_Expr :=
10706 If_Stat :=
10708 Condition =>
10710 Left_Opnd =>
10714 Right_Opnd =>
10717 Then_Statements =>
10718 New_List (
10724 Condition =>
10726 Left_Opnd =>
10730 Right_Opnd =>
10733 Then_Statements =>
10734 New_List (
10739 Loop_Statement,
10743 -- (X : a; Y: a)
10754 -- function Gnnn (...) return boolean is
10755 -- J : index := Y'first;
10756 -- begin
10757 -- if ... end if;
10758 -- end Gnnn;
10762 Func_Body :=
10764 Specification =>
10774 Expression =>
10779 Handled_Statement_Sequence =>
10786 ---------------------------
10787 -- Make_Boolean_Array_Op --
10788 ---------------------------
10790 -- For logical operations on boolean arrays, expand in line the following,
10791 -- replacing 'and' with 'or' or 'xor' where needed:
10793 -- function Annn (A : typ; B: typ) return typ is
10794 -- C : typ;
10795 -- begin
10796 -- for J in A'range loop
10797 -- C (J) := A (J) op B (J);
10798 -- end loop;
10799 -- return C;
10800 -- end Annn;
10802 -- Here typ is the boolean array type
10804 function Make_Boolean_Array_Op
10807 is
10825 begin
10826 A_J :=
10831 B_J :=
10836 C_J :=
10842 Op :=
10848 Op :=
10853 else
10854 Op :=
10860 Loop_Statement :=
10864 Iteration_Scheme =>
10866 Loop_Parameter_Specification =>
10869 Discrete_Subtype_Definition =>
10891 Func_Body :=
10893 Specification =>
10904 Handled_Statement_Sequence =>
10907 Loop_Statement,
10914 --------------------------------
10915 -- Optimize_Length_Comparison --
10916 --------------------------------
10925 -- First and Last attribute reference nodes, which end up as left and
10926 -- right operands of the optimized result.
10929 -- True for comparison operand of zero
10932 -- Comparison operand, set only if Is_Zero is false
10935 -- Entity whose length is being compared
10938 -- Integer_Literal node for length attribute expression, or Empty
10939 -- if there is no such expression present.
10942 -- Type of array index to which 'Length is applied
10945 -- Kind of comparison operator, gets flipped if operands backwards
10948 -- Tests N to see if it is an optimizable comparison value (defined as
10949 -- constant zero or one, or something else where the value is known to
10950 -- be positive and in the range of 32-bits, and where the corresponding
10951 -- Length value is also known to be 32-bits. If result is true, sets
10952 -- Is_Zero, Ityp, and Comp accordingly.
10955 -- Tests if N is a length attribute applied to a simple entity. If so,
10956 -- returns True, and sets Ent to the entity, and Index to the integer
10957 -- literal provided as an attribute expression, or to Empty if none.
10958 -- Also returns True if the expression is a generated type conversion
10959 -- whose expression is of the desired form. This latter case arises
10960 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
10961 -- to check for being in range, which is not needed in this context.
10962 -- Returns False if neither condition holds.
10965 -- Given a discrete expression, returns a Long_Long_Integer typed
10966 -- expression representing the underlying value of the expression.
10967 -- This is done with an unchecked conversion to the result type. We
10968 -- use unchecked conversion to handle the enumeration type case.
10970 ----------------------
10971 -- Is_Entity_Length --
10972 ----------------------
10975 begin
10979 then
10984 else
10992 then
10995 else
11000 --------------------
11001 -- Is_Optimizable --
11002 --------------------
11011 begin
11027 -- Here we have to make sure of being within 32-bits
11031 if not OK
11034 then
11038 -- Comparison value was within range, so now we must check the index
11039 -- value to make sure it is also within 32-bits.
11060 ----------------
11061 -- Prepare_64 --
11062 ----------------
11065 begin
11069 -- Start of processing for Optimize_Length_Comparison
11071 begin
11072 -- Nothing to do if not a comparison
11078 -- Nothing to do if special -gnatd.P debug flag set
11084 -- Ent'Length op 0/1
11088 then
11091 -- 0/1 op Ent'Length
11095 then
11096 -- Flip comparison to opposite sense
11106 -- Else optimization not possible
11108 else
11112 -- Fall through if we will do the optimization
11114 -- Cases to handle:
11116 -- X'Length = 0 => X'First > X'Last
11117 -- X'Length = 1 => X'First = X'Last
11118 -- X'Length = n => X'First + (n - 1) = X'Last
11120 -- X'Length /= 0 => X'First <= X'Last
11121 -- X'Length /= 1 => X'First /= X'Last
11122 -- X'Length /= n => X'First + (n - 1) /= X'Last
11124 -- X'Length >= 0 => always true, warn
11125 -- X'Length >= 1 => X'First <= X'Last
11126 -- X'Length >= n => X'First + (n - 1) <= X'Last
11128 -- X'Length > 0 => X'First <= X'Last
11129 -- X'Length > 1 => X'First < X'Last
11130 -- X'Length > n => X'First + (n - 1) < X'Last
11132 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
11133 -- X'Length <= 1 => X'First >= X'Last
11134 -- X'Length <= n => X'First + (n - 1) >= X'Last
11136 -- X'Length < 0 => always false (warn)
11137 -- X'Length < 1 => X'First > X'Last
11138 -- X'Length < n => X'First + (n - 1) > X'Last
11140 -- Note: for the cases of n (not constant 0,1), we require that the
11141 -- corresponding index type be integer or shorter (i.e. not 64-bit),
11142 -- and the same for the comparison value. Then we do the comparison
11143 -- using 64-bit arithmetic (actually long long integer), so that we
11144 -- cannot have overflow intefering with the result.
11146 -- First deal with warning cases
11151 -- X'Length >= 0
11160 -- X'Length < 0
11170 if Constant_Condition_Warnings
11172 then
11183 -- Build the First reference we will use
11185 Left :=
11194 -- If general value case, then do the addition of (n - 1), and
11195 -- also add the needed conversions to type Long_Long_Integer.
11198 Left :=
11201 Right_Opnd =>
11207 -- Build the Last reference we will use
11209 Right :=
11218 -- If general operand, convert Last reference to Long_Long_Integer
11224 -- Check for cases to optimize
11226 -- X'Length = 0 => X'First > X'Last
11227 -- X'Length < 1 => X'First > X'Last
11228 -- X'Length < n => X'First + (n - 1) > X'Last
11232 then
11233 Result :=
11238 -- X'Length = 1 => X'First = X'Last
11239 -- X'Length = n => X'First + (n - 1) = X'Last
11242 Result :=
11247 -- X'Length /= 0 => X'First <= X'Last
11248 -- X'Length > 0 => X'First <= X'Last
11251 Result :=
11256 -- X'Length /= 1 => X'First /= X'Last
11257 -- X'Length /= n => X'First + (n - 1) /= X'Last
11260 Result :=
11265 -- X'Length >= 1 => X'First <= X'Last
11266 -- X'Length >= n => X'First + (n - 1) <= X'Last
11269 Result :=
11274 -- X'Length > 1 => X'First < X'Last
11275 -- X'Length > n => X'First + (n = 1) < X'Last
11278 Result :=
11283 -- X'Length <= 1 => X'First >= X'Last
11284 -- X'Length <= n => X'First + (n - 1) >= X'Last
11287 Result :=
11292 -- Should not happen at this stage
11294 else
11298 -- Rewrite and finish up
11305 ------------------------
11306 -- Rewrite_Comparison --
11307 ------------------------
11311 -- Set to True if first pass with Assume_Valid generates a warning in
11312 -- which case we skip the second pass to avoid warning overloaded.
11315 -- Set to Standard_True or Standard_False
11317 begin
11326 -- Now start looking at the comparison in detail. We potentially go
11327 -- through this loop twice. The first time, Assume_Valid is set False
11328 -- in the call to Compile_Time_Compare. If this call results in a
11329 -- clear result of always True or Always False, that's decisive and
11330 -- we are done. Otherwise we repeat the processing with Assume_Valid
11331 -- set to True to generate additional warnings. We can skip that step
11332 -- if Constant_Condition_Warnings is False.
11335 declare
11342 -- Res indicates if compare outcome can be compile time determined
11347 begin
11358 and then Constant_Condition_Warnings
11361 and then not In_Instance
11364 then
11365 Error_Msg_N
11383 and then Constant_Condition_Warnings
11386 and then not In_Instance
11389 then
11390 Error_Msg_N
11400 -- If this is the first iteration, then we actually convert the
11401 -- comparison into True or False, if the result is certain.
11414 -- If this is the second iteration (AV = True), and the original
11415 -- node comes from source and we are not in an instance, then give
11416 -- a warning if we know result would be True or False. Note: we
11417 -- know Constant_Condition_Warnings is set if we get here.
11420 and then not In_Instance
11421 then
11423 Error_Msg_N
11425 N);
11427 Error_Msg_N
11429 N);
11434 -- Skip second iteration if not warning on constant conditions or
11435 -- if the first iteration already generated a warning of some kind or
11436 -- if we are in any case assuming all values are valid (so that the
11437 -- first iteration took care of the valid case).
11445 ----------------------------
11446 -- Safe_In_Place_Array_Op --
11447 ----------------------------
11449 function Safe_In_Place_Array_Op
11453 is
11457 -- Operand is safe if it cannot overlap part of the target of the
11458 -- operation. If the operand and the target are identical, the operand
11459 -- is safe. The operand can be empty in the case of negation.
11462 -- Check that N is a stand-alone entity
11464 ------------------
11465 -- Is_Unaliased --
11466 ------------------
11469 begin
11470 return
11476 ---------------------
11477 -- Is_Safe_Operand --
11478 ---------------------
11481 begin
11492 return
11499 else
11504 -- Start of processing for Is_Safe_In_Place_Array_Op
11506 begin
11507 -- Skip this processing if the component size is different from system
11508 -- storage unit (since at least for NOT this would cause problems).
11513 -- Cannot do in place stuff on VM_Target since cannot pass addresses
11518 -- Cannot do in place stuff if non-standard Boolean representation
11526 else
11532 -----------------------
11533 -- Tagged_Membership --
11534 -----------------------
11536 -- There are two different cases to consider depending on whether the right
11537 -- operand is a class-wide type or not. If not we just compare the actual
11538 -- tag of the left expr to the target type tag:
11539 --
11540 -- Left_Expr.Tag = Right_Type'Tag;
11541 --
11542 -- If it is a class-wide type we use the RT function CW_Membership which is
11543 -- usually implemented by looking in the ancestor tables contained in the
11544 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
11546 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
11547 -- function IW_Membership which is usually implemented by looking in the
11548 -- table of abstract interface types plus the ancestor table contained in
11549 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
11551 procedure Tagged_Membership
11555 is
11566 begin
11569 -- Handle entities from the limited view
11574 -- In the case where the type is an access type, the test is applied
11575 -- using the designated types (needed in Ada 2012 for implicit anonymous
11576 -- access conversions, for AI05-0149).
11589 else
11593 Obj_Tag :=
11596 Selector_Name =>
11601 -- No need to issue a run-time check if we statically know that the
11602 -- result of this membership test is always true. For example,
11603 -- considering the following declarations:
11605 -- type Iface is interface;
11606 -- type T is tagged null record;
11607 -- type DT is new T and Iface with null record;
11609 -- Obj1 : T;
11610 -- Obj2 : DT;
11612 -- These membership tests are always true:
11614 -- Obj1 in T'Class
11615 -- Obj2 in T'Class;
11616 -- Obj2 in Iface'Class;
11618 -- We do not need to handle cases where the membership is illegal.
11619 -- For example:
11621 -- Obj1 in DT'Class; -- Compile time error
11622 -- Obj1 in Iface'Class; -- Compile time error
11628 and then Interface_Present_In_Ancestor
11631 then
11636 -- Ada 2005 (AI-251): Class-wide applied to interfaces
11640 -- Support to: "Iface_CW_Typ in Typ'Class"
11643 then
11644 -- Issue error if IW_Membership operation not available in a
11645 -- configurable run time setting.
11648 Error_Msg_CRT
11654 Result :=
11661 New_Reference_To (
11663 Loc)));
11665 -- Ada 95: Normal case
11667 else
11670 Typ_Tag_Node =>
11671 New_Reference_To (
11676 -- Generate the SCIL node for this class-wide membership test.
11677 -- Done here because the previous call to Build_CW_Membership
11678 -- relocates Obj_Tag.
11689 -- Right_Type is not a class-wide type
11691 else
11692 -- No need to check the tag of the object if Right_Typ is abstract
11697 else
11698 Result :=
11701 Right_Opnd =>
11702 New_Reference_To
11708 ------------------------------
11709 -- Unary_Op_Validity_Checks --
11710 ------------------------------
11713 begin