| blob | ad65378cffb600d26c33c18d6f554f1dd2e80403 |
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-2013, 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
144 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
145 -- where we allow comparison of "out of range" values.
147 function Expand_Composite_Equality
153 -- Local recursive function used to expand equality for nested composite
154 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
155 -- to attach bodies of local functions that are created in the process.
156 -- It is the responsibility of the caller to insert those bodies at the
157 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
158 -- are the left and right sides for the comparison, and Typ is the type of
159 -- the objects to compare.
162 -- Routine to expand concatenation of a sequence of two or more operands
163 -- (in the list Operands) and replace node Cnode with the result of the
164 -- concatenation. The operands can be of any appropriate type, and can
165 -- include both arrays and singleton elements.
168 -- N is an N_In membership test mode, with the overflow check mode set to
169 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
170 -- integer type. This is a case where top level processing is required to
171 -- handle overflow checks in subtrees.
174 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
175 -- fixed. We do not have such a type at runtime, so the purpose of this
176 -- routine is to find the real type by looking up the tree. We also
177 -- determine if the operation must be rounded.
180 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
181 -- discriminants if it has a constrained nominal type, unless the object
182 -- is a component of an enclosing Unchecked_Union object that is subject
183 -- to a per-object constraint and the enclosing object lacks inferable
184 -- discriminants.
185 --
186 -- An expression of an Unchecked_Union type has inferable discriminants
187 -- if it is either a name of an object with inferable discriminants or a
188 -- qualified expression whose subtype mark denotes a constrained subtype.
191 -- N is an expression whose type is an access. When the type of the
192 -- associated storage pool is derived from Checked_Pool, generate a
193 -- call to the 'Dereference' primitive operation.
195 function Make_Array_Comparison_Op
198 -- Comparisons between arrays are expanded in line. This function produces
199 -- the body of the implementation of (a > b), where a and b are one-
200 -- dimensional arrays of some discrete type. The original node is then
201 -- expanded into the appropriate call to this function. Nod provides the
202 -- Sloc value for the generated code.
204 function Make_Boolean_Array_Op
207 -- Boolean operations on boolean arrays are expanded in line. This function
208 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
209 -- b). It is used only the normal case and not the packed case. The type
210 -- involved, Typ, is the Boolean array type, and the logical operations in
211 -- the body are simple boolean operations. Note that Typ is always a
212 -- constrained type (the caller has ensured this by using
213 -- Convert_To_Actual_Subtype if necessary).
216 -- For signed arithmetic operations when the current overflow mode is
217 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
218 -- as the first thing we do. We then return. We count on the recursive
219 -- apparatus for overflow checks to call us back with an equivalent
220 -- operation that is in CHECKED mode, avoiding a recursive entry into this
221 -- routine, and that is when we will proceed with the expansion of the
222 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
223 -- these optimizations without first making this check, since there may be
224 -- operands further down the tree that are relying on the recursive calls
225 -- triggered by the top level nodes to properly process overflow checking
226 -- and remaining expansion on these nodes. Note that this call back may be
227 -- skipped if the operation is done in Bignum mode but that's fine, since
228 -- the Bignum call takes care of everything.
231 -- Given an expression, if it is of the form X'Length op N (or the other
232 -- way round), where N is known at compile time to be 0 or 1, and X is a
233 -- simple entity, and op is a comparison operator, optimizes it into a
234 -- comparison of First and Last.
236 procedure Process_Transient_Object
239 -- Subsidiary routine to the expansion of expression_with_actions and if
240 -- expressions. Generate all the necessary code to finalize a transient
241 -- controlled object when the enclosing context is elaborated or evaluated.
242 -- Decl denotes the declaration of the transient controlled object which is
243 -- usually the result of a controlled function call. Rel_Node denotes the
244 -- context, either an expression_with_actions or an if expression.
247 -- If N is the node for a comparison whose outcome can be determined at
248 -- compile time, then the node N can be rewritten with True or False. If
249 -- the outcome cannot be determined at compile time, the call has no
250 -- effect. If N is a type conversion, then this processing is applied to
251 -- its expression. If N is neither comparison nor a type conversion, the
252 -- call has no effect.
254 procedure Tagged_Membership
258 -- Construct the expression corresponding to the tagged membership test.
259 -- Deals with a second operand being (or not) a class-wide type.
261 function Safe_In_Place_Array_Op
265 -- In the context of an assignment, where the right-hand side is a boolean
266 -- operation on arrays, check whether operation can be performed in place.
270 -- Performs validity checks for a unary operator
272 -------------------------------
273 -- Binary_Op_Validity_Checks --
274 -------------------------------
277 begin
284 ------------------------------------
285 -- Build_Boolean_Array_Proc_Call --
286 ------------------------------------
288 procedure Build_Boolean_Array_Proc_Call
292 is
305 begin
309 -- Use negated version of the binary operators
321 Call_Node :=
326 Target,
339 else
342 Call_Node :=
346 Target,
357 else
358 -- We use the following equivalences:
360 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
361 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
362 -- (not X) xor (not Y) = X xor Y
363 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
373 else
377 else
385 else
390 Call_Node :=
394 Target,
409 exception
414 ------------------------------
415 -- Current_Anonymous_Master --
416 ------------------------------
425 begin
428 -- Find the entity of the current unit
432 -- When processing subprogram bodies, the proper scope is always that
433 -- of the spec.
438 loop
448 -- Find the declarations list of the current unit
462 else
474 -- The current unit has an existing anonymous master, traverse its
475 -- declarations and locate the entity.
478 declare
482 begin
486 -- Look for the first variable in the declarations whole type
487 -- is Finalization_Master.
494 then
502 -- The master was not found even though the unit was labeled as
503 -- having one.
508 -- Create a new anonymous master
510 else
511 declare
516 begin
517 -- Since the master and its associated initialization is inserted
518 -- at top level, use the scope of the unit when analyzing.
522 -- Create the finalization master
524 Fin_Mas_Id :=
528 -- Generate:
529 -- <Fin_Mas_Id> : Finalization_Master;
531 Action :=
534 Object_Definition =>
539 -- Mark the unit to prevent the generation of multiple masters
543 -- Do not set the base pool and mode of operation on .NET/JVM
544 -- since those targets do not support pools and all VM masters
545 -- are heterogeneous by default.
549 -- Generate:
550 -- Set_Base_Pool
551 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
553 Action :=
555 Name =>
561 Prefix =>
567 -- Generate:
568 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
570 Action :=
572 Name =>
580 -- Restore the original state of the scope stack
582 Pop_Scope;
589 --------------------------------
590 -- Displace_Allocator_Pointer --
591 --------------------------------
600 begin
601 -- Do nothing in case of VM targets: the virtual machine will handle
602 -- interfaces directly.
617 -- If the type of the allocator expression is not an interface type
618 -- we can generate code to reference the record component containing
619 -- the pointer to the secondary dispatch table.
622 declare
625 begin
626 -- 1) Get access to the allocated object
633 -- 2) Add the conversion to displace the pointer to reference
634 -- the secondary dispatch table.
639 -- 3) The 'access to the secondary dispatch table will be used
640 -- as the value returned by the allocator.
650 -- If the type of the allocator expression is an interface type we
651 -- generate a run-time call to displace "this" to reference the
652 -- component containing the pointer to the secondary dispatch table
653 -- or else raise Constraint_Error if the actual object does not
654 -- implement the target interface. This case corresponds to the
655 -- following example:
657 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
658 -- begin
659 -- return new Iface_2'Class'(Obj);
660 -- end Op;
662 else
671 New_Occurrence_Of
673 (First_Elmt
675 Loc)))));
681 ---------------------------------
682 -- Expand_Allocator_Expression --
683 ---------------------------------
691 procedure Apply_Accessibility_Check
694 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
695 -- type, generate an accessibility check to verify that the level of the
696 -- type of the created object is not deeper than the level of the access
697 -- type. If the type of the qualified expression is class-wide, then
698 -- always generate the check (except in the case where it is known to be
699 -- unnecessary, see comment below). Otherwise, only generate the check
700 -- if the level of the qualified expression type is statically deeper
701 -- than the access type.
702 --
703 -- Although the static accessibility will generally have been performed
704 -- as a legality check, it won't have been done in cases where the
705 -- allocator appears in generic body, so a run-time check is needed in
706 -- general. One special case is when the access type is declared in the
707 -- same scope as the class-wide allocator, in which case the check can
708 -- never fail, so it need not be generated.
709 --
710 -- As an open issue, there seem to be cases where the static level
711 -- associated with the class-wide object's underlying type is not
712 -- sufficient to perform the proper accessibility check, such as for
713 -- allocators in nested subprograms or accept statements initialized by
714 -- class-wide formals when the actual originates outside at a deeper
715 -- static level. The nested subprogram case might require passing
716 -- accessibility levels along with class-wide parameters, and the task
717 -- case seems to be an actual gap in the language rules that needs to
718 -- be fixed by the ARG. ???
720 -------------------------------
721 -- Apply_Accessibility_Check --
722 -------------------------------
724 procedure Apply_Accessibility_Check
727 is
735 begin
740 and then
742 or else
745 then
746 -- If the allocator was built in place, Ref is already a reference
747 -- to the access object initialized to the result of the allocator
748 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
749 -- Remove_Side_Effects for cases where the build-in-place call may
750 -- still be the prefix of the reference (to avoid generating
751 -- duplicate calls). Otherwise, it is the entity associated with
752 -- the object containing the address of the allocated object.
757 else
761 -- Step 1: Create the object clean up code
765 -- Deallocate the object if the accessibility check fails. This
766 -- is done only on targets or profiles that support deallocation.
768 -- Free (Obj_Ref);
776 -- The target or profile cannot deallocate objects
778 else
782 -- Finalize the object if applicable. Generate:
784 -- [Deep_]Finalize (Obj_Ref.all);
787 Fin_Call :=
788 Make_Final_Call (
789 Obj_Ref =>
793 -- When the target or profile supports deallocation, wrap the
794 -- finalization call in a block to ensure proper deallocation
795 -- even if finalization fails. Generate:
797 -- begin
798 -- <Fin_Call>
799 -- exception
800 -- when others =>
801 -- <Free_Stmt>
802 -- raise;
803 -- end;
806 Fin_Call :=
808 Handled_Statement_Sequence =>
825 -- Signal the accessibility failure through a Program_Error
832 -- Step 2: Create the accessibility comparison
834 -- Generate:
835 -- Ref'Tag
837 Obj_Ref :=
842 -- For tagged types, determine the accessibility level by looking
843 -- at the type specific data of the dispatch table. Generate:
845 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
850 -- Use a runtime call to determine the accessibility level when
851 -- compiling on virtual machine targets. Generate:
853 -- Get_Access_Level (Ref'Tag)
855 else
856 Cond :=
858 Name =>
863 Cond :=
866 Right_Opnd =>
869 -- Due to the complexity and side effects of the check, utilize an
870 -- if statement instead of the regular Program_Error circuitry.
879 -- Local variables
890 -- Type used as source for tag assignment
893 -- Target reference for tag assignment
895 -- Start of processing for Expand_Allocator_Expression
897 begin
898 -- Handle call to C++ constructor
901 Make_CPP_Constructor_Call_In_Allocator
907 -- In the case of an Ada 2012 allocator whose initial value comes from a
908 -- function call, pass "the accessibility level determined by the point
909 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
910 -- Expand_Call but it couldn't be done there (because the Etype of the
911 -- allocator wasn't set then) so we generate the parameter here. See
912 -- the Boolean variable Defer in (a block within) Expand_Call.
915 declare
918 begin
921 else
928 Add_Extra_Actual_To_Call
936 -- Case of tagged type or type requiring finalization
940 -- Ada 2005 (AI-318-02): If the initialization expression is a call
941 -- to a build-in-place function, then access to the allocated object
942 -- must be passed to the function. Currently we limit such functions
943 -- to those with constrained limited result subtypes, but eventually
944 -- we plan to expand the allowed forms of functions that are treated
945 -- as build-in-place.
949 then
955 -- Actions inserted before:
956 -- Temp : constant ptr_T := new T'(Expression);
957 -- Temp._tag = T'tag; -- when not class-wide
958 -- [Deep_]Adjust (Temp.all);
960 -- We analyze by hand the new internal allocator to avoid any
961 -- recursion and inappropriate call to Initialize
963 -- We don't want to remove side effects when the expression must be
964 -- built in place. In the case of a build-in-place function call,
965 -- that could lead to a duplication of the call, which was already
966 -- substituted for the allocator.
974 -- For a class wide allocation generate the following code:
976 -- type Equiv_Record is record ... end record;
977 -- implicit subtype CW is <Class_Wide_Subytpe>;
978 -- temp : PtrT := new CW'(CW!(expr));
983 -- Ada 2005 (AI-251): If the expression is a class-wide interface
984 -- object we generate code to move up "this" to reference the
985 -- base of the object before allocating the new object.
987 -- Note that Exp'Address is recursively expanded into a call
988 -- to Base_Address (Exp.Tag)
992 and then Tagged_Type_Expansion
993 then
994 Set_Expression
1002 else
1003 Set_Expression
1011 -- Processing for allocators returning non-interface types
1015 Temp_Decl :=
1019 Expression =>
1021 Expression =>
1024 -- Copy the Comes_From_Source flag for the allocator we just
1025 -- built, since logically this allocator is a replacement of
1026 -- the original allocator node. This is for proper handling of
1027 -- restriction No_Implicit_Heap_Allocations.
1029 Set_Comes_From_Source
1038 -- Attach the object to the associated finalization master.
1039 -- This is done manually on .NET/JVM since those compilers do
1040 -- no support pools and can't benefit from internally generated
1041 -- Allocate / Deallocate procedures.
1046 then
1048 Make_Attach_Call (
1049 Obj_Ref =>
1054 else
1058 Temp_Decl :=
1068 -- Attach the object to the associated finalization master.
1069 -- This is done manually on .NET/JVM since those compilers do
1070 -- no support pools and can't benefit from internally generated
1071 -- Allocate / Deallocate procedures.
1076 then
1078 Make_Attach_Call (
1079 Obj_Ref =>
1085 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1086 -- interface type. In this case we use the type of the qualified
1087 -- expression to allocate the object.
1089 else
1090 declare
1094 begin
1095 New_Decl :=
1098 Type_Definition =>
1102 Constant_Present =>
1104 Subtype_Indication =>
1109 -- Inherit the allocation-related attributes from the original
1110 -- access type.
1117 -- Declare the object using the previous type declaration
1120 Temp_Decl :=
1124 Expression =>
1128 -- Copy the Comes_From_Source flag for the allocator we just
1129 -- built, since logically this allocator is a replacement of
1130 -- the original allocator node. This is for proper handling
1131 -- of restriction No_Implicit_Heap_Allocations.
1133 Set_Comes_From_Source
1142 else
1146 Temp_Decl :=
1157 -- Generate an additional object containing the address of the
1158 -- returned object. The type of this second object declaration
1159 -- is the correct type required for the common processing that
1160 -- is still performed by this subprogram. The displacement of
1161 -- this pointer to reference the component associated with the
1162 -- interface type will be done at the end of common processing.
1164 New_Decl :=
1168 Expression =>
1181 -- Generate the tag assignment
1183 -- Suppress the tag assignment when VM_Target because VM tags are
1184 -- represented implicitly in objects.
1189 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1190 -- interface objects because in this case the tag does not change.
1203 then
1205 TagR :=
1212 declare
1214 begin
1215 Tag_Assign :=
1217 Name =>
1220 Selector_Name =>
1222 Expression =>
1224 New_Reference_To
1229 -- The previous assignment has to be done in any case
1237 -- Generate an Adjust call if the object will be moved. In Ada
1238 -- 2005, the object may be inherently limited, in which case
1239 -- there is no Adjust procedure, and the object is built in
1240 -- place. In Ada 95, the object can be limited but not
1241 -- inherently limited if this allocator came from a return
1242 -- statement (we're allocating the result on the secondary
1243 -- stack). In that case, the object will be moved, so we _do_
1244 -- want to Adjust.
1246 if not Aggr_In_Place
1248 then
1251 -- An unchecked conversion is needed in the classwide case
1252 -- because the designated type can be an ancestor of the
1253 -- subtype mark of the allocator.
1255 Make_Adjust_Call
1263 -- Generate:
1264 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1266 -- Do not generate this call in the following cases:
1268 -- * .NET/JVM - these targets do not support address arithmetic
1269 -- and unchecked conversion, key elements of Finalize_Address.
1271 -- * CodePeer mode - TSS primitive Finalize_Address is not
1272 -- created in this mode.
1275 and then not CodePeer_Mode
1279 then
1281 Make_Set_Finalize_Address_Call
1291 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1292 -- component containing the secondary dispatch table of the interface
1293 -- type.
1301 Temp_Decl :=
1305 Expression =>
1309 -- Copy the Comes_From_Source flag for the allocator we just built,
1310 -- since logically this allocator is a replacement of the original
1311 -- allocator node. This is for proper handling of restriction
1312 -- No_Implicit_Heap_Allocations.
1314 Set_Comes_From_Source
1323 -- Attach the object to the associated finalization master. Thisis
1324 -- done manually on .NET/JVM since those compilers do no support
1325 -- pools and cannot benefit from internally generated Allocate and
1326 -- Deallocate procedures.
1331 then
1333 Make_Attach_Call
1347 then
1348 -- Apply constraint to designated subtype indication
1356 -- Propagate constraint_error to enclosing allocator
1361 else
1364 -- If we have:
1365 -- type A is access T1;
1366 -- X : A := new T2'(...);
1367 -- T1 and T2 can be different subtypes, and we might need to check
1368 -- both constraints. First check against the type of the qualified
1369 -- expression.
1378 -- A check is also needed in cases where the designated subtype is
1379 -- constrained and differs from the subtype given in the qualified
1380 -- expression. Note that the check on the qualified expression does
1381 -- not allow sliding, but this check does (a relaxation from Ada 83).
1385 then
1386 Apply_Constraint_Check
1395 -- For an access to unconstrained packed array, GIGI needs to see an
1396 -- expression with a constrained subtype in order to compute the
1397 -- proper size for the allocator.
1402 then
1403 declare
1406 begin
1410 Subtype_Indication =>
1417 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1418 -- to a build-in-place function, then access to the allocated object
1419 -- must be passed to the function. Currently we limit such functions
1420 -- to those with constrained limited result subtypes, but eventually
1421 -- we plan to expand the allowed forms of functions that are treated
1422 -- as build-in-place.
1426 then
1431 exception
1436 -----------------------------
1437 -- Expand_Array_Comparison --
1438 -----------------------------
1440 -- Expansion is only required in the case of array types. For the unpacked
1441 -- case, an appropriate runtime routine is called. For packed cases, and
1442 -- also in some other cases where a runtime routine cannot be called, the
1443 -- form of the expansion is:
1445 -- [body for greater_nn; boolean_expression]
1447 -- The body is built by Make_Array_Comparison_Op, and the form of the
1448 -- Boolean expression depends on the operator involved.
1464 -- True for byte addressable target
1467 -- Returns True if the length of the given operand is known to be less
1468 -- than 4. Returns False if this length is known to be four or greater
1469 -- or is not known at compile time.
1471 ------------------------
1472 -- Length_Less_Than_4 --
1473 ------------------------
1478 begin
1482 else
1483 declare
1490 begin
1493 else
1499 else
1508 -- Start of processing for Expand_Array_Comparison
1510 begin
1511 -- Deal first with unpacked case, where we can call a runtime routine
1512 -- except that we avoid this for targets for which are not addressable
1513 -- by bytes, and for the JVM/CIL, since they do not support direct
1514 -- addressing of array components.
1517 and then Byte_Addressable
1519 then
1520 -- The call we generate is:
1522 -- Compare_Array_xn[_Unaligned]
1523 -- (left'address, right'address, left'length, right'length) <op> 0
1525 -- x = U for unsigned, S for signed
1526 -- n = 8,16,32,64 for component size
1527 -- Add _Unaligned if length < 4 and component size is 8.
1528 -- <op> is the standard comparison operator
1532 or else
1534 then
1537 else
1541 else
1544 else
1552 else
1559 else
1566 else
1604 -- Cases where we cannot make runtime call
1606 -- For (a <= b) we convert to not (a > b)
1611 Right_Opnd =>
1618 -- For < the Boolean expression is
1619 -- greater__nn (op2, op1)
1624 -- Switch operands
1629 -- For (a >= b) we convert to not (a < b)
1634 Right_Opnd =>
1641 -- For > the Boolean expression is
1642 -- greater__nn (op1, op2)
1644 else
1650 Expr :=
1659 exception
1664 ---------------------------
1665 -- Expand_Array_Equality --
1666 ---------------------------
1668 -- Expand an equality function for multi-dimensional arrays. Here is an
1669 -- example of such a function for Nb_Dimension = 2
1671 -- function Enn (A : atyp; B : btyp) return boolean is
1672 -- begin
1673 -- if (A'length (1) = 0 or else A'length (2) = 0)
1674 -- and then
1675 -- (B'length (1) = 0 or else B'length (2) = 0)
1676 -- then
1677 -- return True; -- RM 4.5.2(22)
1678 -- end if;
1680 -- if A'length (1) /= B'length (1)
1681 -- or else
1682 -- A'length (2) /= B'length (2)
1683 -- then
1684 -- return False; -- RM 4.5.2(23)
1685 -- end if;
1687 -- declare
1688 -- A1 : Index_T1 := A'first (1);
1689 -- B1 : Index_T1 := B'first (1);
1690 -- begin
1691 -- loop
1692 -- declare
1693 -- A2 : Index_T2 := A'first (2);
1694 -- B2 : Index_T2 := B'first (2);
1695 -- begin
1696 -- loop
1697 -- if A (A1, A2) /= B (B1, B2) then
1698 -- return False;
1699 -- end if;
1701 -- exit when A2 = A'last (2);
1702 -- A2 := Index_T2'succ (A2);
1703 -- B2 := Index_T2'succ (B2);
1704 -- end loop;
1705 -- end;
1707 -- exit when A1 = A'last (1);
1708 -- A1 := Index_T1'succ (A1);
1709 -- B1 := Index_T1'succ (B1);
1710 -- end loop;
1711 -- end;
1713 -- return true;
1714 -- end Enn;
1716 -- Note on the formal types used (atyp and btyp). If either of the arrays
1717 -- is of a private type, we use the underlying type, and do an unchecked
1718 -- conversion of the actual. If either of the arrays has a bound depending
1719 -- on a discriminant, then we use the base type since otherwise we have an
1720 -- escaped discriminant in the function.
1722 -- If both arrays are constrained and have the same bounds, we can generate
1723 -- a loop with an explicit iteration scheme using a 'Range attribute over
1724 -- the first array.
1726 function Expand_Array_Equality
1732 is
1748 -- The parameter types to be used for the formals
1750 function Arr_Attr
1754 -- This builds the attribute reference Arr'Nam (Expr)
1757 -- Create one statement to compare corresponding components, designated
1758 -- by a full set of indexes.
1761 -- Given one of the arguments, computes the appropriate type to be used
1762 -- for that argument in the corresponding function formal
1764 function Handle_One_Dimension
1767 -- This procedure returns the following code
1768 --
1769 -- declare
1770 -- Bn : Index_T := B'First (N);
1771 -- begin
1772 -- loop
1773 -- xxx
1774 -- exit when An = A'Last (N);
1775 -- An := Index_T'Succ (An)
1776 -- Bn := Index_T'Succ (Bn)
1777 -- end loop;
1778 -- end;
1779 --
1780 -- If both indexes are constrained and identical, the procedure
1781 -- returns a simpler loop:
1782 --
1783 -- for An in A'Range (N) loop
1784 -- xxx
1785 -- end loop
1786 --
1787 -- N is the dimension for which we are generating a loop. Index is the
1788 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1789 -- xxx statement is either the loop or declare for the next dimension
1790 -- or if this is the last dimension the comparison of corresponding
1791 -- components of the arrays.
1792 --
1793 -- The actual way the code works is to return the comparison of
1794 -- corresponding components for the N+1 call. That's neater!
1797 -- This function constructs the test for both arrays being empty
1798 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1799 -- and then
1800 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1803 -- This function constructs the test for arrays having different lengths
1804 -- in at least one index position, in which case the resulting code is:
1806 -- A'length (1) /= B'length (1)
1807 -- or else
1808 -- A'length (2) /= B'length (2)
1809 -- or else
1810 -- ...
1812 --------------
1813 -- Arr_Attr --
1814 --------------
1816 function Arr_Attr
1820 is
1821 begin
1822 return
1829 ------------------------
1830 -- Component_Equality --
1831 ------------------------
1837 begin
1838 -- if a(i1...) /= b(j1...) then return false; end if;
1840 L :=
1845 R :=
1850 Test := Expand_Composite_Equality
1853 -- If some (sub)component is an unchecked_union, the whole operation
1854 -- will raise program error.
1858 -- This node is going to be inserted at a location where a
1859 -- statement is expected: clear its Etype so analysis will set
1860 -- it to the expected Standard_Void_Type.
1865 else
1866 return
1875 ------------------
1876 -- Get_Arg_Type --
1877 ------------------
1883 begin
1889 else
1895 or else
1897 then
1909 --------------------------
1910 -- Handle_One_Dimension --
1911 ---------------------------
1913 function Handle_One_Dimension
1916 is
1919 -- If the index types are identical, and we are working with
1920 -- constrained types, then we can use the same index for both
1921 -- of the arrays.
1930 begin
1935 -- Case where we generate a loop
1941 else
1953 -- Generate guard for loop, followed by increments of indexes
1957 Condition =>
1965 Expression =>
1974 Expression =>
1981 -- If separate indexes, we need a declare block for An and Bn, and a
1982 -- loop without an iteration scheme.
1985 Loop_Stm :=
1988 return
2001 Handled_Statement_Sequence =>
2005 -- If no separate indexes, return loop statement with explicit
2006 -- iteration scheme on its own
2008 else
2009 Loop_Stm :=
2012 Iteration_Scheme =>
2014 Loop_Parameter_Specification =>
2017 Discrete_Subtype_Definition =>
2023 -----------------------
2024 -- Test_Empty_Arrays --
2025 -----------------------
2034 begin
2038 Atest :=
2043 Btest :=
2052 else
2053 Alist :=
2058 Blist :=
2065 return
2071 -----------------------------
2072 -- Test_Lengths_Correspond --
2073 -----------------------------
2079 begin
2082 Rtest :=
2089 else
2090 Result :=
2100 -- Start of processing for Expand_Array_Equality
2102 begin
2106 -- For now, if the argument types are not the same, go to the base type,
2107 -- since the code assumes that the formals have the same type. This is
2108 -- fixable in future ???
2116 -- Build list of formals for function
2129 -- Build statement sequence for function
2131 Func_Body :=
2133 Specification =>
2141 Handled_Statement_Sequence =>
2149 Expression =>
2156 Expression =>
2167 -- If the array type is distinct from the type of the arguments, it
2168 -- is the full view of a private type. Apply an unchecked conversion
2169 -- to insure that analysis of the call succeeds.
2171 declare
2174 begin
2180 then
2186 then
2195 return
2201 -----------------------------
2202 -- Expand_Boolean_Operator --
2203 -----------------------------
2205 -- Note that we first get the actual subtypes of the operands, since we
2206 -- always want to deal with types that have bounds.
2211 begin
2212 -- Special case of bit packed array where both operands are known to be
2213 -- properly aligned. In this case we use an efficient run time routine
2214 -- to carry out the operation (see System.Bit_Ops).
2219 then
2224 -- For the normal non-packed case, the general expansion is to build
2225 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2226 -- and then inserting it into the tree. The original operator node is
2227 -- then rewritten as a call to this function. We also use this in the
2228 -- packed case if either operand is a possibly unaligned object.
2230 declare
2237 begin
2250 then
2255 and then
2257 then
2259 else
2265 -- Now rewrite the expression with a call
2270 Parameter_Associations =>
2271 New_List (
2272 L,
2273 Make_Type_Conversion
2281 ------------------------------------------------
2282 -- Expand_Compare_Minimize_Eliminate_Overflow --
2283 ------------------------------------------------
2289 -- Capture result type (could be a derived boolean type)
2295 -- Entity for Long_Long_Integer'Base
2298 -- Current overflow checking mode
2302 -- These procedures rewrite N with an occurrence of Standard_True or
2303 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2305 ---------------
2306 -- Set_False --
2307 ---------------
2310 begin
2315 --------------
2316 -- Set_True --
2317 --------------
2320 begin
2325 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2327 begin
2328 -- Nothing to do unless we have a comparison operator with operands
2329 -- that are signed integer types, and we are operating in either
2330 -- MINIMIZED or ELIMINATED overflow checking mode.
2335 then
2339 -- OK, this is the case we are interested in. First step is to process
2340 -- our operands using the Minimize_Eliminate circuitry which applies
2341 -- this processing to the two operand subtrees.
2343 Minimize_Eliminate_Overflows
2345 Minimize_Eliminate_Overflows
2348 -- See if the range information decides the result of the comparison.
2349 -- We can only do this if we in fact have full range information (which
2350 -- won't be the case if either operand is bignum at this stage).
2356 Set_True;
2358 Set_False;
2363 Set_True;
2365 Set_False;
2370 Set_True;
2372 Set_False;
2377 Set_False;
2379 Set_True;
2384 Set_False;
2386 Set_True;
2391 Set_False;
2393 Set_True;
2397 -- All done if we did the rewrite
2404 -- Otherwise, time to do the comparison
2406 declare
2410 begin
2411 -- If the two operands have the same signed integer type we are
2412 -- all set, nothing more to do. This is the case where either
2413 -- both operands were unchanged, or we rewrote both of them to
2414 -- be Long_Long_Integer.
2416 -- Note: Entity for the comparison may be wrong, but it's not worth
2417 -- the effort to change it, since the back end does not use it.
2421 then
2424 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2427 declare
2430 -- Bignum references for left and right operands
2432 begin
2439 -- We rewrite our node with:
2441 -- do
2442 -- Bnn : Result_Type;
2443 -- declare
2444 -- M : Mark_Id := SS_Mark;
2445 -- begin
2446 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2447 -- SS_Release (M);
2448 -- end;
2449 -- in
2450 -- Bnn
2451 -- end
2453 declare
2458 begin
2468 -- Insert assignment to Bnn into the bignum block
2470 Insert_Before
2474 Expression =>
2476 Name =>
2480 -- Now do the rewrite with expression actions
2487 Object_Definition =>
2489 Blk),
2495 -- No bignums involved, but types are different, so we must have
2496 -- rewritten one of the operands as a Long_Long_Integer but not
2497 -- the other one.
2499 -- If left operand is Long_Long_Integer, convert right operand
2500 -- and we are done (with a comparison of two Long_Long_Integers).
2507 -- If right operand is Long_Long_Integer, convert left operand
2508 -- and we are done (with a comparison of two Long_Long_Integers).
2510 -- This is the only remaining possibility
2520 -------------------------------
2521 -- Expand_Composite_Equality --
2522 -------------------------------
2524 -- This function is only called for comparing internal fields of composite
2525 -- types when these fields are themselves composites. This is a special
2526 -- case because it is not possible to respect normal Ada visibility rules.
2528 function Expand_Composite_Equality
2534 is
2541 -- AI05-0123: Locate primitive equality for type if it exists, and
2542 -- build the corresponding call. If operation is abstract, replace
2543 -- call with an explicit raise. Return Empty if there is no primitive.
2545 -----------------------
2546 -- Find_Primitive_Eq --
2547 -----------------------
2553 begin
2558 -- Locate primitive equality with the right signature
2564 then
2566 return
2570 else
2571 return
2581 -- If not found, predefined operation will be used
2586 -- Start of processing for Expand_Composite_Equality
2588 begin
2591 else
2595 -- If the private type has no completion the context may be the
2596 -- expansion of a composite equality for a composite type with some
2597 -- still incomplete components. The expression will not be analyzed
2598 -- until the enclosing type is completed, at which point this will be
2599 -- properly expanded, unless there is a bona fide completion error.
2607 -- When the base type itself is private, use the full view to expand
2608 -- the composite equality.
2614 -- Case of array types
2618 -- If the operand is an elementary type other than a floating-point
2619 -- type, then we can simply use the built-in block bitwise equality,
2620 -- since the predefined equality operators always apply and bitwise
2621 -- equality is fine for all these cases.
2625 then
2628 -- For composite component types, and floating-point types, use the
2629 -- expansion. This deals with tagged component types (where we use
2630 -- the applicable equality routine) and floating-point, (where we
2631 -- need to worry about negative zeroes), and also the case of any
2632 -- composite type recursively containing such fields.
2634 else
2638 -- Case of tagged record types
2642 -- Call the primitive operation "=" of this type
2648 -- If this is derived from an untagged private type completed with a
2649 -- tagged type, it does not have a full view, so we use the primitive
2650 -- operations of the private type. This check should no longer be
2651 -- necessary when these types receive their full views ???
2658 then
2660 else
2664 loop
2676 return
2679 Parameter_Associations =>
2680 New_List
2684 -- Case of untagged record types
2692 -- Inherited equality from parent type. Convert the actuals to
2693 -- match signature of operation.
2695 declare
2698 begin
2699 return
2707 else
2708 -- Comparison between Unchecked_Union components
2711 declare
2717 begin
2718 -- Lhs subtype
2724 -- Rhs subtype
2730 -- Lhs of the composite equality
2734 -- Since the enclosing record type can never be an
2735 -- Unchecked_Union (this code is executed for records
2736 -- that do not have variants), we may reference its
2737 -- discriminant(s).
2740 and then Has_Per_Object_Constraint
2742 then
2743 Lhs_Discr_Val :=
2746 Selector_Name =>
2747 New_Copy
2748 (Get_Discriminant_Value
2750 Lhs_Type,
2753 else
2754 Lhs_Discr_Val :=
2755 New_Copy
2756 (Get_Discriminant_Value
2758 Lhs_Type,
2762 else
2763 -- It is not possible to infer the discriminant since
2764 -- the subtype is not constrained.
2766 return
2771 -- Rhs of the composite equality
2775 and then Has_Per_Object_Constraint
2777 then
2778 Rhs_Discr_Val :=
2781 Selector_Name =>
2782 New_Copy
2783 (Get_Discriminant_Value
2785 Rhs_Type,
2788 else
2789 Rhs_Discr_Val :=
2790 New_Copy
2791 (Get_Discriminant_Value
2793 Rhs_Type,
2797 else
2798 return
2803 -- Call the TSS equality function with the inferred
2804 -- discriminant values.
2806 return
2810 Lhs,
2811 Rhs,
2812 Lhs_Discr_Val,
2813 Rhs_Discr_Val));
2816 else
2817 return
2824 -- Equality composes in Ada 2012 for untagged record types. It also
2825 -- composes for bounded strings, because they are part of the
2826 -- predefined environment. We could make it compose for bounded
2827 -- strings by making them tagged, or by making sure all subcomponents
2828 -- are set to the same value, even when not used. Instead, we have
2829 -- this special case in the compiler, because it's more efficient.
2833 -- If no TSS has been created for the type, check whether there is
2834 -- a primitive equality declared for it.
2836 declare
2839 begin
2840 -- Use user-defined primitive if it exists, otherwise use
2841 -- predefined equality.
2845 else
2850 else
2854 -- Non-composite types (always use predefined equality)
2856 else
2861 ------------------------
2862 -- Expand_Concatenate --
2863 ------------------------
2869 -- Result type of concatenation
2872 -- Component type. Elements of this component type can appear as one
2873 -- of the operands of concatenation as well as arrays.
2876 -- Index subtype
2879 -- Index type. This is the base type of the index subtype, and is used
2880 -- for all computed bounds (which may be out of range of Istyp in the
2881 -- case of null ranges).
2884 -- This is the type we use to do arithmetic to compute the bounds and
2885 -- lengths of operands. The choice of this type is a little subtle and
2886 -- is discussed in a separate section at the start of the body code.
2889 -- Raised if concatenation is sure to raise a CE
2892 -- Reset to False if at least one operand is encountered which is known
2893 -- at compile time to be non-null. Used for handling the special case
2894 -- of setting the high bound to the last operand high bound for a null
2895 -- result, thus ensuring a proper high bound in the super-flat case.
2898 -- Number of concatenation operands including possibly null operands
2901 -- Number of operands excluding any known to be null, except that the
2902 -- last operand is always retained, in case it provides the bounds for
2903 -- a null result.
2906 -- Current operand being processed in the loop through operands. After
2907 -- this loop is complete, always contains the last operand (which is not
2908 -- the same as Operands (NN), since null operands are skipped).
2910 -- Arrays describing the operands, only the first NN entries of each
2911 -- array are set (NN < N when we exclude known null operands).
2914 -- True if length of corresponding operand known at compile time
2917 -- Set to the corresponding entry in the Opnds list (but note that null
2918 -- operands are excluded, so not all entries in the list are stored).
2921 -- Set to length of operand. Entries in this array are set only if the
2922 -- corresponding entry in Is_Fixed_Length is True.
2925 -- Set to lower bound of operand. Either an integer literal in the case
2926 -- where the bound is known at compile time, else actual lower bound.
2927 -- The operand low bound is of type Ityp.
2930 -- Set to an entity of type Natural that contains the length of an
2931 -- operand whose length is not known at compile time. Entries in this
2932 -- array are set only if the corresponding entry in Is_Fixed_Length
2933 -- is False. The entity is of type Artyp.
2936 -- The J'th entry in an expression node that represents the total length
2937 -- of operands 1 through J. It is either an integer literal node, or a
2938 -- reference to a constant entity with the right value, so it is fine
2939 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2940 -- entry always is set to zero. The length is of type Artyp.
2943 -- A tree node representing the low bound of the result (of type Ityp).
2944 -- This is either an integer literal node, or an identifier reference to
2945 -- a constant entity initialized to the appropriate value.
2948 -- A tree node representing the low bound of the last operand. This
2949 -- need only be set if the result could be null. It is used for the
2950 -- special case of setting the right low bound for a null result.
2951 -- This is of type Ityp.
2954 -- A tree node representing the high bound of the last operand. This
2955 -- need only be set if the result could be null. It is used for the
2956 -- special case of setting the right high bound for a null result.
2957 -- This is of type Ityp.
2960 -- A tree node representing the high bound of the result (of type Ityp)
2963 -- Result of the concatenation (of type Ityp)
2966 -- Collect actions to be inserted
2969 -- Set True during generation of the assignments of operands into
2970 -- result once an operand known to be non-null has been seen.
2973 -- This function makes an N_Integer_Literal node that is returned in
2974 -- analyzed form with the type set to Artyp. Importantly this literal
2975 -- is not flagged as static, so that if we do computations with it that
2976 -- result in statically detected out of range conditions, we will not
2977 -- generate error messages but instead warning messages.
2980 -- Given a node of type Ityp, returns the corresponding value of type
2981 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2982 -- For enum types, the Pos of the value is returned.
2985 -- The inverse function (uses Val in the case of enumeration types)
2987 ------------------------
2988 -- Make_Artyp_Literal --
2989 ------------------------
2993 begin
3000 --------------
3001 -- To_Artyp --
3002 --------------
3005 begin
3010 return
3016 else
3021 -------------
3022 -- To_Ityp --
3023 -------------
3026 begin
3028 return
3034 -- Case where we will do a type conversion
3036 else
3039 else
3045 -- Local Declarations
3054 -- Start of processing for Expand_Concatenate
3056 begin
3057 -- Choose an appropriate computational type
3059 -- We will be doing calculations of lengths and bounds in this routine
3060 -- and computing one from the other in some cases, e.g. getting the high
3061 -- bound by adding the length-1 to the low bound.
3063 -- We can't just use the index type, or even its base type for this
3064 -- purpose for two reasons. First it might be an enumeration type which
3065 -- is not suitable for computations of any kind, and second it may
3066 -- simply not have enough range. For example if the index type is
3067 -- -128..+127 then lengths can be up to 256, which is out of range of
3068 -- the type.
3070 -- For enumeration types, we can simply use Standard_Integer, this is
3071 -- sufficient since the actual number of enumeration literals cannot
3072 -- possibly exceed the range of integer (remember we will be doing the
3073 -- arithmetic with POS values, not representation values).
3078 -- If index type is Positive, we use the standard unsigned type, to give
3079 -- more room on the top of the range, obviating the need for an overflow
3080 -- check when creating the upper bound. This is needed to avoid junk
3081 -- overflow checks in the common case of String types.
3083 -- ??? Disabled for now
3085 -- elsif Istyp = Standard_Positive then
3086 -- Artyp := Standard_Unsigned;
3088 -- For modular types, we use a 32-bit modular type for types whose size
3089 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3090 -- identity type, and for larger unsigned types we use 64-bits.
3097 else
3101 -- Similar treatment for signed types
3103 else
3108 else
3113 -- Supply dummy entry at start of length array
3117 -- Go through operands setting up the above arrays
3124 -- The parent got messed up when we put the operands in a list,
3125 -- so now put back the proper parent for the saved operand, that
3126 -- is to say the concatenation node, to make sure that each operand
3127 -- is seen as a subexpression, e.g. if actions must be inserted.
3131 -- Set will be True when we have setup one entry in the array
3135 -- Singleton element (or character literal) case
3144 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3145 -- since we know that the result cannot be null).
3154 -- String literal case (can only occur for strings of course)
3163 -- Capture last operand low and high bound if result could be null
3166 Last_Opnd_Low_Bound :=
3169 Last_Opnd_High_Bound :=
3171 Left_Opnd =>
3176 -- Skip null string literal
3186 -- Set length and bounds
3195 -- All other cases
3197 else
3198 -- Check constrained case with known bounds
3201 declare
3207 begin
3208 -- Fixed length constrained array type with known at compile
3209 -- time bounds is last case of fixed length operand.
3212 and then
3214 then
3215 declare
3221 begin
3226 -- Capture last operand bounds if result could be null
3229 Last_Opnd_Low_Bound :=
3233 Last_Opnd_High_Bound :=
3238 -- Exclude null length case unless last operand
3250 To_Ityp
3258 -- All cases where the length is not known at compile time, or the
3259 -- special case of an operand which is known to be null but has a
3260 -- lower bound other than 1 or is other than a string type.
3265 -- Capture operand bounds
3269 Prefix =>
3273 -- Capture last operand bounds if result could be null
3276 Last_Opnd_Low_Bound :=
3279 Prefix =>
3283 Last_Opnd_High_Bound :=
3286 Prefix =>
3291 -- Capture length of operand in entity
3303 Expression =>
3305 Prefix =>
3311 -- Set next entry in aggregate length array
3313 -- For first entry, make either integer literal for fixed length
3314 -- or a reference to the saved length for variable length.
3319 else
3323 -- If entry is fixed length and only fixed lengths so far, make
3324 -- appropriate new integer literal adding new length.
3328 then
3333 -- All other cases, construct an addition node for the length and
3334 -- create an entity initialized to this length.
3336 else
3341 else
3350 Expression =>
3362 -- If we have only skipped null operands, return the last operand
3369 -- If we have only one non-null operand, return it and we are done.
3370 -- There is one case in which this cannot be done, and that is when
3371 -- the sole operand is of the element type, in which case it must be
3372 -- converted to an array, and the easiest way of doing that is to go
3373 -- through the normal general circuit.
3380 -- Cases where we have a real concatenation
3382 -- Next step is to find the low bound for the result array that we
3383 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3385 -- If the ultimate ancestor of the index subtype is a constrained array
3386 -- definition, then the lower bound is that of the index subtype as
3387 -- specified by (RM 4.5.3(6)).
3389 -- The right test here is to go to the root type, and then the ultimate
3390 -- ancestor is the first subtype of this root type.
3393 Low_Bound :=
3395 Prefix =>
3399 -- If the first operand in the list has known length we know that
3400 -- the lower bound of the result is the lower bound of this operand.
3405 -- OK, we don't know the lower bound, we have to build a horrible
3406 -- if expression node of the form
3408 -- if Cond1'Length /= 0 then
3409 -- Opnd1 low bound
3410 -- else
3411 -- if Opnd2'Length /= 0 then
3412 -- Opnd2 low bound
3413 -- else
3414 -- ...
3416 -- The nesting ends either when we hit an operand whose length is known
3417 -- at compile time, or on reaching the last operand, whose low bound we
3418 -- take unconditionally whether or not it is null. It's easiest to do
3419 -- this with a recursive procedure:
3421 else
3422 declare
3424 -- Returns the lower bound determined by operands J .. NN
3426 ---------------------
3427 -- Get_Known_Bound --
3428 ---------------------
3431 begin
3435 else
3436 return
3449 begin
3463 -- Now we can safely compute the upper bound, normally
3464 -- Low_Bound + Length - 1.
3466 High_Bound :=
3467 To_Ityp (
3470 Right_Opnd =>
3475 -- Note that calculation of the high bound may cause overflow in some
3476 -- very weird cases, so in the general case we need an overflow check on
3477 -- the high bound. We can avoid this for the common case of string types
3478 -- and other types whose index is Positive, since we chose a wider range
3479 -- for the arithmetic type.
3485 -- Handle the exceptional case where the result is null, in which case
3486 -- case the bounds come from the last operand (so that we get the proper
3487 -- bounds if the last operand is super-flat).
3490 Low_Bound :=
3496 Last_Opnd_Low_Bound,
3497 Low_Bound));
3499 High_Bound :=
3505 Last_Opnd_High_Bound,
3506 High_Bound));
3509 -- Here is where we insert the saved up actions
3513 -- Now we construct an array object with appropriate bounds. We mark
3514 -- the target as internal to prevent useless initialization when
3515 -- Initialize_Scalars is enabled. Also since this is the actual result
3516 -- entity, we make sure we have debug information for the result.
3522 -- If the bound is statically known to be out of range, we do not want
3523 -- to abort, we want a warning and a runtime constraint error. Note that
3524 -- we have arranged that the result will not be treated as a static
3525 -- constant, so we won't get an illegality during this insertion.
3530 Object_Definition =>
3533 Constraint =>
3541 -- If the result of the concatenation appears as the initializing
3542 -- expression of an object declaration, we can just rename the
3543 -- result, rather than copying it.
3547 -- Catch the static out of range case now
3553 -- Now we will generate the assignments to do the actual concatenation
3555 -- There is one case in which we will not do this, namely when all the
3556 -- following conditions are met:
3558 -- The result type is Standard.String
3560 -- There are nine or fewer retained (non-null) operands
3562 -- The optimization level is -O0
3564 -- The corresponding System.Concat_n.Str_Concat_n routine is
3565 -- available in the run time.
3567 -- The debug flag gnatd.c is not set
3569 -- If all these conditions are met then we generate a call to the
3570 -- relevant concatenation routine. The purpose of this is to avoid
3571 -- undesirable code bloat at -O0.
3576 and then not Debug_Flag_Dot_C
3577 then
3578 declare
3581 RE_Str_Concat_3,
3582 RE_Str_Concat_4,
3583 RE_Str_Concat_5,
3584 RE_Str_Concat_6,
3585 RE_Str_Concat_7,
3586 RE_Str_Concat_8,
3587 RE_Str_Concat_9);
3589 begin
3591 declare
3595 begin
3610 else
3627 -- Not special case so generate the assignments
3632 declare
3641 Right_Opnd =>
3646 begin
3647 -- Singleton case, simple assignment
3653 Name =>
3660 -- Array case, slice assignment, skipped when argument is fixed
3661 -- length and known to be null.
3664 declare
3667 Name =>
3669 Prefix =>
3671 Discrete_Range =>
3676 begin
3682 -- Here if operand length is not statically known and no
3683 -- operand known to be non-null has been processed yet.
3684 -- If operand length is 0, we do not need to perform the
3685 -- assignment, and we must avoid the evaluation of the
3686 -- high bound of the slice, since it may underflow if the
3687 -- low bound is Ityp'First.
3689 Assign :=
3691 Condition =>
3693 Left_Opnd =>
3705 -- Finally we build the result, which is a reference to the array object
3713 exception
3716 -- Kill warning generated for the declaration of the static out of
3717 -- range high bound, and instead generate a Constraint_Error with
3718 -- an appropriate specific message.
3721 Apply_Compile_Time_Constraint_Error
3727 ---------------------------------------------------
3728 -- Expand_Membership_Minimize_Eliminate_Overflow --
3729 ---------------------------------------------------
3733 -- Despite the name, this routine applies only to N_In, not to
3734 -- N_Not_In. The latter is always rewritten as not (X in Y).
3737 -- Capture result type, may be a derived boolean type
3743 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3744 -- is thus tempting to capture these values, but due to the rewrites
3745 -- that occur as a result of overflow checking, these values change
3746 -- as we go along, and it is safe just to always use Etype explicitly.
3749 -- Save result type
3752 -- Bounds in Minimize calls, not used currently
3755 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3757 begin
3760 -- If right operand is a subtype name, and the subtype name has no
3761 -- predicate, then we can just replace the right operand with an
3762 -- explicit range T'First .. T'Last, and use the explicit range code.
3766 then
3767 declare
3769 begin
3772 Low_Bound =>
3776 High_Bound =>
3784 -- Here for the explicit range case. Note that the bounds of the range
3785 -- have not been processed for minimized or eliminated checks.
3788 Minimize_Eliminate_Overflows
3790 Minimize_Eliminate_Overflows
3793 -- We have A in B .. C, treated as A >= B and then A <= C
3795 -- Bignum case
3800 then
3801 declare
3812 -- Now we rewrite the membership test node to look like
3814 -- do
3815 -- Bnn : Result_Type;
3816 -- declare
3817 -- M : Mark_Id := SS_Mark;
3818 -- L : Bignum := Lopnd;
3819 -- begin
3820 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3821 -- SS_Release (M);
3822 -- end;
3823 -- in
3824 -- Bnn
3825 -- end
3827 begin
3828 -- Insert declaration of L into declarations of bignum block
3830 Insert_After
3834 Object_Definition =>
3838 -- Insert assignment to Bnn into expressions of bignum block
3840 Insert_Before
3844 Expression =>
3846 Left_Opnd =>
3848 Name =>
3852 Lbound)),
3853 Right_Opnd =>
3855 Name =>
3859 Hbound)))));
3861 -- Now rewrite the node
3868 Object_Definition =>
3870 Blk),
3876 -- Here if no bignums around
3878 else
3879 -- Case where types are all the same
3882 and then
3884 then
3887 -- If types are not all the same, it means that we have rewritten
3888 -- at least one of them to be of type Long_Long_Integer, and we
3889 -- will convert the other operands to Long_Long_Integer.
3891 else
3896 -- For the right operand, avoid unnecessary recursion into
3897 -- this routine, we know that overflow is not possible.
3905 -- Now the three operands are of the same signed integer type,
3906 -- so we can use the normal expansion routine for membership,
3907 -- setting the flag to prevent recursion into this procedure.
3913 -- Right operand is a subtype name and the subtype has a predicate. We
3914 -- have to make sure the predicate is checked, and for that we need to
3915 -- use the standard N_In circuitry with appropriate types.
3917 else
3920 -- If types are "right", just call Expand_N_In preventing recursion
3926 -- Bignum case
3930 -- For X in T, we want to rewrite our node as
3932 -- do
3933 -- Bnn : Result_Type;
3935 -- declare
3936 -- M : Mark_Id := SS_Mark;
3937 -- Lnn : Long_Long_Integer'Base
3938 -- Nnn : Bignum;
3940 -- begin
3941 -- Nnn := X;
3943 -- if not Bignum_In_LLI_Range (Nnn) then
3944 -- Bnn := False;
3945 -- else
3946 -- Lnn := From_Bignum (Nnn);
3947 -- Bnn :=
3948 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3949 -- and then T'Base (Lnn) in T;
3950 -- end if;
3951 --
3952 -- SS_Release (M);
3953 -- end
3954 -- in
3955 -- Bnn
3956 -- end
3958 -- A bit gruesome, but there doesn't seem to be a simpler way
3960 declare
3969 begin
3970 -- Mark the last membership operation to prevent recursion
3972 Nin :=
3978 -- Now decorate the block
3980 Insert_After
3986 Insert_After
3990 Object_Definition =>
3993 Insert_List_Before
3995 New_List (
4001 Condition =>
4003 Right_Opnd =>
4005 Name =>
4006 New_Occurrence_Of
4014 Expression =>
4020 Expression =>
4022 Name =>
4029 Expression =>
4031 Left_Opnd =>
4034 Right_Opnd =>
4036 Low_Bound =>
4040 Prefix =>
4043 High_Bound =>
4047 Prefix =>
4052 -- Now we can do the rewrite
4059 Object_Definition =>
4061 Blk),
4067 -- Not bignum case, but types don't match (this means we rewrote the
4068 -- left operand to be Long_Long_Integer).
4070 else
4073 -- We rewrite the membership test as (where T is the type with
4074 -- the predicate, i.e. the type of the right operand)
4076 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4077 -- and then T'Base (Lop) in T
4079 declare
4084 begin
4085 -- The last membership test is marked to prevent recursion
4087 Nin :=
4093 -- Now do the rewrite
4097 Left_Opnd =>
4100 Right_Opnd =>
4102 Low_Bound =>
4107 High_Bound =>
4120 ------------------------
4121 -- Expand_N_Allocator --
4122 ------------------------
4130 -- Static coextensions have the same lifetime as the entity they
4131 -- constrain. Such occurrences can be rewritten as aliased objects
4132 -- and their unrestricted access used instead of the coextension.
4135 -- Given a constrained array type E, returns a node representing the
4136 -- code to compute the size in storage elements for the given type.
4137 -- This is done without using the attribute (which malfunctions for
4138 -- large sizes ???)
4140 -------------------------
4141 -- Rewrite_Coextension --
4142 -------------------------
4148 begin
4149 -- Generate:
4150 -- Cnn : aliased Etyp;
4152 Temp_Decl :=
4171 ------------------------------
4172 -- Size_In_Storage_Elements --
4173 ------------------------------
4176 begin
4177 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4178 -- However, the reason for the existence of this function is
4179 -- to construct a test for sizes too large, which means near the
4180 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4181 -- is that we get overflows when sizes are greater than 2**31.
4183 -- So what we end up doing for array types is to use the expression:
4185 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4187 -- which avoids this problem. All this is a bit bogus, but it does
4188 -- mean we catch common cases of trying to allocate arrays that
4189 -- are too large, and which in the absence of a check results in
4190 -- undetected chaos ???
4192 -- Note in particular that this is a pessimistic estimate in the
4193 -- case of packed array types, where an array element might occupy
4194 -- just a fraction of a storage element???
4196 declare
4200 begin
4202 Len :=
4211 else
4212 Res :=
4219 return
4222 Right_Opnd =>
4229 -- Local variables
4238 -- Start of processing for Expand_N_Allocator
4240 begin
4241 -- RM E.2.3(22). We enforce that the expected type of an allocator
4242 -- shall not be a remote access-to-class-wide-limited-private type
4244 -- Why is this being done at expansion time, seems clearly wrong ???
4248 -- Processing for anonymous access-to-controlled types. These access
4249 -- types receive a special finalization master which appears in the
4250 -- declarations of the enclosing semantic unit. This expansion is done
4251 -- now to ensure that any additional types generated by this routine or
4252 -- Expand_Allocator_Expression inherit the proper type attributes.
4257 then
4258 -- Detect the allocation of an anonymous controlled object where the
4259 -- type of the context is named. For example:
4261 -- procedure Proc (Ptr : Named_Access_Typ);
4262 -- Proc (new Designated_Typ);
4264 -- Regardless of the anonymous-to-named access type conversion, the
4265 -- lifetime of the object must be associated with the named access
4266 -- type. Use the finalization-related attributes of this type.
4269 N_Unchecked_Type_Conversion)
4271 E_Access_Type,
4272 E_General_Access_Type)
4273 then
4275 else
4279 -- Anonymous access-to-controlled types allocate on the global pool.
4280 -- Do not set this attribute on .NET/JVM since those targets do not
4281 -- support pools.
4287 else
4293 -- The finalization master must be inserted and analyzed as part of
4294 -- the current semantic unit. Note that the master is updated when
4295 -- analysis changes current units.
4299 else
4304 -- Set the storage pool and find the appropriate version of Allocate to
4305 -- call. Do not overwrite the storage pool if it is already set, which
4306 -- can happen for build-in-place function returns (see
4307 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4320 -- In the case of an allocator for a simple storage pool, locate
4321 -- and save a reference to the pool type's Allocate routine.
4325 then
4326 declare
4329 begin
4335 then
4338 else
4347 else
4354 -- Under certain circumstances we can replace an allocator by an access
4355 -- to statically allocated storage. The conditions, as noted in AARM
4356 -- 3.10 (10c) are as follows:
4358 -- Size and initial value is known at compile time
4359 -- Access type is access-to-constant
4361 -- The allocator is not part of a constraint on a record component,
4362 -- because in that case the inserted actions are delayed until the
4363 -- record declaration is fully analyzed, which is too late for the
4364 -- analysis of the rewritten allocator.
4369 and then Size_Known_At_Compile_Time
4372 then
4373 -- Here we can do the optimization. For the allocator
4375 -- new x'(y)
4377 -- We insert an object declaration
4379 -- Tnn : aliased x := y;
4381 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4382 -- marked as requiring static allocation.
4387 -- If context is constrained, use constrained subtype directly,
4388 -- so that the constant is not labelled as having a nominally
4389 -- unconstrained subtype.
4410 -- We set the variable as statically allocated, since we don't want
4411 -- it going on the stack of the current procedure!
4417 -- Same if the allocator is an access discriminant for a local object:
4418 -- instead of an allocator we create a local value and constrain the
4419 -- enclosing object with the corresponding access attribute.
4426 -- Check for size too large, we do this because the back end misses
4427 -- proper checks here and can generate rubbish allocation calls when
4428 -- we are near the limit. We only do this for the 32-bit address case
4429 -- since that is from a practical point of view where we see a problem.
4435 then
4436 -- The check we want to generate should look like
4438 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4439 -- raise Storage_Error;
4440 -- end if;
4442 -- where 3.5 gigabytes is a constant large enough to accommodate any
4443 -- reasonable request for. But we can't do it this way because at
4444 -- least at the moment we don't compute this attribute right, and
4445 -- can silently give wrong results when the result gets large. Since
4446 -- this is all about large results, that's bad, so instead we only
4447 -- apply the check for constrained arrays, and manually compute the
4448 -- value of the attribute ???
4453 Condition =>
4456 Right_Opnd =>
4462 -- Handle case of qualified expression (other than optimization above)
4463 -- First apply constraint checks, because the bounds or discriminants
4464 -- in the aggregate might not match the subtype mark in the allocator.
4467 Apply_Constraint_Check
4474 -- If the allocator is for a type which requires initialization, and
4475 -- there is no initial value (i.e. operand is a subtype indication
4476 -- rather than a qualified expression), then we must generate a call to
4477 -- the initialization routine using an expressions action node:
4479 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4481 -- Here ptr_T is the pointer type for the allocator, and T is the
4482 -- subtype of the allocator. A special case arises if the designated
4483 -- type of the access type is a task or contains tasks. In this case
4484 -- the call to Init (Temp.all ...) is replaced by code that ensures
4485 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4486 -- for details). In addition, if the type T is a task T, then the
4487 -- first argument to Init must be converted to the task record type.
4489 declare
4500 begin
4503 -- Even though this might be a simple allocation, create a custom
4504 -- Allocate if the context requires it. Since .NET/JVM compilers
4505 -- do not support pools, this step is skipped.
4509 then
4510 Build_Allocate_Deallocate_Proc
4515 -- Case of no initialization procedure present
4519 -- Case of simple initialization required
4533 -- No initialization required
4535 else
4539 -- Case of initialization procedure present, must be called
4541 else
4549 -- Construct argument list for the initialization routine call
4551 Init_Arg1 :=
4553 Prefix =>
4559 -- The initialization procedure expects a specific type. if the
4560 -- context is access to class wide, indicate that the object
4561 -- being allocated has the right specific type.
4567 -- If designated type is a concurrent type or if it is private
4568 -- type whose definition is a concurrent type, the first
4569 -- argument in the Init routine has to be unchecked conversion
4570 -- to the corresponding record type. If the designated type is
4571 -- a derived type, also convert the argument to its root type.
4574 Init_Arg1 :=
4575 Unchecked_Convert_To (
4581 then
4582 Init_Arg1 :=
4583 Unchecked_Convert_To
4587 declare
4590 begin
4598 -- For the task case, pass the Master_Id of the access type as
4599 -- the value of the _Master parameter, and _Chain as the value
4600 -- of the _Chain parameter (_Chain will be defined as part of
4601 -- the generated code for the allocator).
4603 -- In Ada 2005, the context may be a function that returns an
4604 -- anonymous access type. In that case the Master_Id has been
4605 -- created when expanding the function declaration.
4610 -- The designated type was an incomplete type, and the
4611 -- access type did not get expanded. Salvage it now.
4615 Expand_N_Full_Type_Declaration
4618 -- The only other possibility is an itype. For this
4619 -- case, the master must exist in the context. This is
4620 -- the case when the allocator initializes an access
4621 -- component in an init-proc.
4623 else
4630 -- If the context of the allocator is a declaration or an
4631 -- assignment, we can generate a meaningful image for it,
4632 -- even though subsequent assignments might remove the
4633 -- connection between task and entity. We build this image
4634 -- when the left-hand side is a simple variable, a simple
4635 -- indexed assignment or a simple selected component.
4638 declare
4641 begin
4643 Decls :=
4644 Build_Task_Image_Decls
4646 New_Occurrence_Of
4650 N_Selected_Component)
4652 then
4653 Decls :=
4654 Build_Task_Image_Decls
4656 else
4662 Decls :=
4663 Build_Task_Image_Decls
4666 else
4673 else
4675 New_Reference_To
4685 -- Has_Task is false, Decls not used
4687 else
4691 -- Add discriminants if discriminated type
4693 declare
4697 begin
4705 then
4712 -- If the allocated object will be constrained by the
4713 -- default values for discriminants, then build a subtype
4714 -- with those defaults, and change the allocated subtype
4715 -- to that. Note that this happens in fewer cases in Ada
4716 -- 2005 (AI-363).
4722 or else not
4723 Object_Type_Has_Constrained_Partial_View
4725 then
4735 -- AI-416: when the discriminant constraint is an
4736 -- anonymous access type make sure an accessibility
4737 -- check is inserted if necessary (3.10.2(22.q/2))
4740 and then
4742 then
4743 Apply_Accessibility_Check
4752 -- We set the allocator as analyzed so that when we analyze
4753 -- the if expression node, we do not get an unwanted recursive
4754 -- expansion of the allocator expression.
4759 -- Here is the transformation:
4760 -- input: new Ctrl_Typ
4761 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4762 -- Ctrl_TypIP (Temp.all, ...);
4763 -- [Deep_]Initialize (Temp.all);
4765 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4766 -- is the subtype of the allocator.
4768 Temp_Decl :=
4780 -- If the designated type is a task type or contains tasks,
4781 -- create block to activate created tasks, and insert
4782 -- declaration for Task_Image variable ahead of call.
4785 declare
4788 begin
4795 else
4804 -- Generate:
4805 -- [Deep_]Initialize (Init_Arg1);
4808 Make_Init_Call
4814 -- Special processing for .NET/JVM, the allocated object
4815 -- is attached to the finalization master. Generate:
4817 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4819 -- Types derived from [Limited_]Controlled are the only
4820 -- ones considered since they have fields Prev and Next.
4825 Make_Attach_Call
4830 -- Default case, generate:
4832 -- Set_Finalize_Address
4833 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
4835 -- Do not generate this call in CodePeer mode, as TSS
4836 -- primitive Finalize_Address is not created in this
4837 -- mode.
4841 Make_Set_Finalize_Address_Call
4855 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4856 -- object that has been rewritten as a reference, we displace "this"
4857 -- to reference properly its secondary dispatch table.
4863 exception
4868 -----------------------
4869 -- Expand_N_And_Then --
4870 -----------------------
4875 ------------------------------
4876 -- Expand_N_Case_Expression --
4877 ------------------------------
4891 begin
4892 -- Check for MINIMIZED/ELIMINATED overflow mode
4899 -- We expand
4901 -- case X is when A => AX, when B => BX ...
4903 -- to
4905 -- do
4906 -- Tnn : typ;
4907 -- case X is
4908 -- when A =>
4909 -- Tnn := AX;
4910 -- when B =>
4911 -- Tnn := BX;
4912 -- ...
4913 -- end case;
4914 -- in Tnn end;
4916 -- However, this expansion is wrong for limited types, and also
4917 -- wrong for unconstrained types (since the bounds may not be the
4918 -- same in all branches). Furthermore it involves an extra copy
4919 -- for large objects. So we take care of this by using the following
4920 -- modified expansion for non-elementary types:
4922 -- do
4923 -- type Pnn is access all typ;
4924 -- Tnn : Pnn;
4925 -- case X is
4926 -- when A =>
4927 -- T := AX'Unrestricted_Access;
4928 -- when B =>
4929 -- T := BX'Unrestricted_Access;
4930 -- ...
4931 -- end case;
4932 -- in Tnn.all end;
4934 Cstmt :=
4941 -- Scalar case
4946 else
4951 Type_Definition =>
4960 -- Create declaration for target of expression, and indicate that it
4961 -- does not require initialization.
4963 Decl :=
4970 -- Now process the alternatives
4974 declare
4979 begin
4980 -- As described above, take Unrestricted_Access for case of non-
4981 -- scalar types, to avoid big copies, and special cases.
4984 Aexp :=
4995 -- Propagate declarations inserted in the node by Insert_Actions
4996 -- (for example, temporaries generated to remove side effects).
4997 -- These actions must remain attached to the alternative, given
4998 -- that they are generated by the corresponding expression.
5004 Append_To
5016 -- Construct and return final expression with actions
5020 else
5021 Fexp :=
5034 -----------------------------------
5035 -- Expand_N_Explicit_Dereference --
5036 -----------------------------------
5039 begin
5040 -- Insert explicit dereference call for the checked storage pool case
5044 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5045 -- we set the atomic sync flag.
5049 then
5054 --------------------------------------
5055 -- Expand_N_Expression_With_Actions --
5056 --------------------------------------
5060 -- Inspect and process a single action of an expression_with_actions for
5061 -- transient controlled objects. If such objects are found, the routine
5062 -- generates code to clean them up when the context of the expression is
5063 -- evaluated or elaborated.
5065 --------------------
5066 -- Process_Action --
5067 --------------------
5070 begin
5073 then
5077 -- Avoid processing temporary function results multiple times when
5078 -- dealing with nested expression_with_actions.
5083 -- Do not process temporary function results in loops. This is done
5084 -- by Expand_N_Loop_Statement and Build_Finalizer.
5095 -- Local variables
5099 -- Start of processing for Expand_N_Expression_With_Actions
5101 begin
5110 ----------------------------
5111 -- Expand_N_If_Expression --
5112 ----------------------------
5114 -- Deal with limited types and condition actions
5118 -- Inspect and process a single action list of an if expression for
5119 -- transient controlled objects. If such objects are found, the routine
5120 -- generates code to clean them up when the context of the expression is
5121 -- evaluated or elaborated.
5123 ---------------------
5124 -- Process_Actions --
5125 ---------------------
5130 begin
5135 then
5143 -- Local variables
5159 -- Start of processing for Expand_N_If_Expression
5161 begin
5162 -- Check for MINIMIZED/ELIMINATED overflow mode
5169 -- Fold at compile time if condition known. We have already folded
5170 -- static if expressions, but it is possible to fold any case in which
5171 -- the condition is known at compile time, even though the result is
5172 -- non-static.
5174 -- Note that we don't do the fold of such cases in Sem_Elab because
5175 -- it can cause infinite loops with the expander adding a conditional
5176 -- expression, and Sem_Elab circuitry removing it repeatedly.
5182 else
5195 else
5199 -- Note that the result is never static (legitimate cases of static
5200 -- if expressions were folded in Sem_Eval).
5206 -- If the type is limited or unconstrained, we expand as follows to
5207 -- avoid any possibility of improper copies.
5209 -- Note: it may be possible to avoid this special processing if the
5210 -- back end uses its own mechanisms for handling by-reference types ???
5212 -- type Ptr is access all Typ;
5213 -- Cnn : Ptr;
5214 -- if cond then
5215 -- <<then actions>>
5216 -- Cnn := then-expr'Unrestricted_Access;
5217 -- else
5218 -- <<else actions>>
5219 -- Cnn := else-expr'Unrestricted_Access;
5220 -- end if;
5222 -- and replace the if expression by a reference to Cnn.all.
5224 -- This special case can be skipped if the back end handles limited
5225 -- types properly and ensures that no incorrect copies are made.
5228 and then not Back_End_Handles_Limited_Types
5229 then
5230 -- When the "then" or "else" expressions involve controlled function
5231 -- calls, generated temporaries are chained on the corresponding list
5232 -- of actions. These temporaries need to be finalized after the if
5233 -- expression is evaluated.
5238 -- Generate:
5239 -- type Ann is access all Typ;
5246 Type_Definition =>
5251 -- Generate:
5252 -- Cnn : Ann;
5256 Decl :=
5261 -- Generate:
5262 -- if Cond then
5263 -- Cnn := <Thenx>'Unrestricted_Access;
5264 -- else
5265 -- Cnn := <Elsex>'Unrestricted_Access;
5266 -- end if;
5268 New_If :=
5274 Expression =>
5282 Expression =>
5287 New_N :=
5291 -- For other types, we only need to expand if there are other actions
5292 -- associated with either branch.
5296 -- We now wrap the actions into the appropriate expression
5320 -- If no actions then no expansion needed, gigi will handle it using the
5321 -- same approach as a C conditional expression.
5323 else
5327 -- Fall through here for either the limited expansion, or the case of
5328 -- inserting actions for non-limited types. In both these cases, we must
5329 -- move the SLOC of the parent If statement to the newly created one and
5330 -- change it to the SLOC of the expression which, after expansion, will
5331 -- correspond to what is being evaluated.
5338 -- Make sure Then_Actions and Else_Actions are appropriately moved
5339 -- to the new if statement.
5342 Insert_List_Before
5347 Insert_List_Before
5357 -----------------
5358 -- Expand_N_In --
5359 -----------------
5372 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5373 -- test for the left operand being in range of its subtype.
5375 ----------------------------
5376 -- Substitute_Valid_Check --
5377 ----------------------------
5380 begin
5388 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5389 -- in which case, this usage makes sense, and in any case, we have
5390 -- actually eliminated the danger of optimization above.
5393 Error_Msg_N
5395 Error_Msg_N -- CODEFIX
5402 -- Start of processing for Expand_N_In
5404 begin
5405 -- If set membership case, expand with separate procedure
5412 -- Not set membership, proceed with expansion
5417 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5418 -- type, then expand with a separate procedure. Note the use of the
5419 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5424 then
5429 -- Check case of explicit test for an expression in range of its
5430 -- subtype. This is suspicious usage and we replace it with a 'Valid
5431 -- test and give a warning for scalar types.
5435 -- Only relevant for source comparisons
5439 -- In floating-point this is a standard way to check for finite values
5440 -- and using 'Valid would typically be a pessimization.
5444 -- Don't give the message unless right operand is a type entity and
5445 -- the type of the left operand matches this type. Note that this
5446 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5447 -- checks have changed the type of the left operand.
5452 -- Skip in VM mode, where we have no sense of invalid values. The
5453 -- warning still seems relevant, but not important enough to worry.
5457 -- Skip this for predicated types, where such expressions are a
5458 -- reasonable way of testing if something meets the predicate.
5461 then
5462 Substitute_Valid_Check;
5466 -- Do validity check on operands
5473 -- Case of explicit range
5476 declare
5487 Constant_Condition_Warnings
5490 -- This must be true for any of the optimization warnings, we
5491 -- clearly want to give them only for source with the flag on. We
5492 -- also skip these warnings in an instance since it may be the
5493 -- case that different instantiations have different ranges.
5496 Warn1
5499 -- For the case where only one bound warning is elided, we also
5500 -- insist on an explicit range and an integer type. The reason is
5501 -- that the use of enumeration ranges including an end point is
5502 -- common, as is the use of a subtype name, one of whose bounds is
5503 -- the same as the type of the expression.
5505 begin
5506 -- If test is explicit x'First .. x'Last, replace by valid check
5508 -- Could use some individual comments for this complex test ???
5512 -- And left operand is X'First where X matches left operand
5513 -- type (this eliminates cases of type mismatch, including
5514 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5515 -- type of the left operand.
5522 -- Same tests for right operand
5529 -- Relevant only for source cases
5533 -- Omit for VM cases, where we don't have invalid values
5536 then
5537 Substitute_Valid_Check;
5541 -- If bounds of type are known at compile time, and the end points
5542 -- are known at compile time and identical, this is another case
5543 -- for substituting a valid test. We only do this for discrete
5544 -- types, since it won't arise in practice for float types.
5555 -- Kill warnings in instances, since they may be cases where we
5556 -- have a test in the generic that makes sense with some types
5557 -- and not with other types.
5559 and then not In_Instance
5560 then
5561 Substitute_Valid_Check;
5565 -- If we have an explicit range, do a bit of optimization based on
5566 -- range analysis (we may be able to kill one or both checks).
5571 -- If either check is known to fail, replace result by False since
5572 -- the other check does not matter. Preserve the static flag for
5573 -- legality checks, because we are constant-folding beyond RM 4.9.
5586 -- If both checks are known to succeed, replace result by True,
5587 -- since we know we are in range.
5600 -- If lower bound check succeeds and upper bound check is not
5601 -- known to succeed or fail, then replace the range check with
5602 -- a comparison against the upper bound.
5617 -- If upper bound check succeeds and lower bound check is not
5618 -- known to succeed or fail, then replace the range check with
5619 -- a comparison against the lower bound.
5635 -- We couldn't optimize away the range check, but there is one
5636 -- more issue. If we are checking constant conditionals, then we
5637 -- see if we can determine the outcome assuming everything is
5638 -- valid, and if so give an appropriate warning.
5644 -- Result is out of range for valid value
5647 Error_Msg_N
5650 -- Result is in range for valid value
5653 Error_Msg_N
5656 -- Lower bound check succeeds if value is valid
5659 Error_Msg_N
5662 -- Upper bound check succeeds if value is valid
5665 Error_Msg_N
5671 -- For all other cases of an explicit range, nothing to be done
5675 -- Here right operand is a subtype mark
5677 else
5678 declare
5686 begin
5689 -- For tagged type, do tagged membership operation
5693 -- No expansion will be performed when VM_Target, as the VM
5694 -- back-ends will handle the membership tests directly (tags
5695 -- are not explicitly represented in Java objects, so the
5696 -- normal tagged membership expansion is not what we want).
5703 -- Update decoration of relocated node referenced by the
5704 -- SCIL node.
5713 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5714 -- This reason we do this is that the bounds may have the wrong
5715 -- type if they come from the original type definition. Also this
5716 -- way we get all the processing above for an explicit range.
5718 -- Don't do this for predicated types, since in this case we
5719 -- want to check the predicate!
5725 Low_Bound =>
5730 High_Bound =>
5739 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5740 -- a membership test if the subtype mark denotes a constrained
5741 -- Unchecked_Union subtype and the expression lacks inferable
5742 -- discriminants.
5747 then
5752 -- Prevent Gigi from generating incorrect code by rewriting the
5753 -- test as False. What is this undocumented thing about ???
5759 -- Here we have a non-scalar type
5769 -- For the constrained array case, we have to check the subscripts
5770 -- for an exact match if the lengths are non-zero (the lengths
5771 -- must match in any case).
5775 function Build_Attribute_Reference
5779 -- Build attribute reference E'Nam (Dim)
5781 -------------------------------
5782 -- Build_Attribute_Reference --
5783 -------------------------------
5785 function Build_Attribute_Reference
5789 is
5790 begin
5791 return
5799 -- Start of processing for Check_Subscripts
5801 begin
5805 Left_Opnd =>
5806 Build_Attribute_Reference
5809 Right_Opnd =>
5810 Build_Attribute_Reference
5815 Left_Opnd =>
5816 Build_Attribute_Reference
5819 Right_Opnd =>
5820 Build_Attribute_Reference
5825 Cond :=
5827 Left_Opnd =>
5838 -- These are the cases where constraint checks may be required,
5839 -- e.g. records with possible discriminants
5841 else
5842 -- Expand the test into a series of discriminant comparisons.
5843 -- The expression that is built is the negation of the one that
5844 -- is used for checking discriminant constraints.
5854 Left_Opnd =>
5861 else
5869 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5870 -- expression of an anonymous access type. This can involve an
5871 -- accessibility test and a tagged type membership test in the
5872 -- case of tagged designated types.
5875 and then Is_Acc
5877 then
5878 declare
5884 begin
5893 -- If a conversion of the anonymous access value to the
5894 -- tested type would be illegal, then the result is False.
5896 if not Valid_Conversion
5898 then
5902 -- Apply an accessibility check if the access object has an
5903 -- associated access level and when the level of the type is
5904 -- less deep than the level of the access parameter. This
5905 -- only occur for access parameters and stand-alone objects
5906 -- of an anonymous access type.
5908 else
5910 and then
5911 Present
5915 then
5916 Param_Level :=
5917 New_Occurrence_Of
5920 Type_Level :=
5923 -- Return True only if the accessibility level of the
5924 -- expression entity is not deeper than the level of
5925 -- the tested access type.
5937 -- If the designated type is tagged, do tagged membership
5938 -- operation.
5940 -- *** NOTE: we have to check not null before doing the
5941 -- tagged membership test (but maybe that can be done
5942 -- inside Tagged_Membership?).
5948 Right_Opnd =>
5953 -- No expansion will be performed when VM_Target, as
5954 -- the VM back-ends will handle the membership tests
5955 -- directly (tags are not explicitly represented in
5956 -- Java objects, so the normal tagged membership
5957 -- expansion is not what we want).
5961 -- Note that we have to pass Original_Node, because
5962 -- the membership test might already have been
5963 -- rewritten by earlier parts of membership test.
5965 Tagged_Membership
5968 -- Update decoration of relocated node referenced
5969 -- by the SCIL node.
5989 -- At this point, we have done the processing required for the basic
5990 -- membership test, but not yet dealt with the predicate.
5994 -- If a predicate is present, then we do the predicate test, but we
5995 -- most certainly want to omit this if we are within the predicate
5996 -- function itself, since otherwise we have an infinite recursion!
5997 -- The check should also not be emitted when testing against a range
5998 -- (the check is only done when the right operand is a subtype; see
5999 -- RM12-4.5.2 (28.1/3-30/3)).
6001 declare
6004 begin
6008 then
6014 -- Analyze new expression, mark left operand as analyzed to
6015 -- avoid infinite recursion adding predicate calls. Similarly,
6016 -- suppress further range checks on the call.
6021 -- All done, skip attempt at compile time determination of result
6028 --------------------------------
6029 -- Expand_N_Indexed_Component --
6030 --------------------------------
6039 begin
6040 -- A special optimization, if we have an indexed component that is
6041 -- selecting from a slice, then we can eliminate the slice, since, for
6042 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6043 -- the range check required by the slice. The range check for the slice
6044 -- itself has already been generated. The range check for the
6045 -- subscripting operation is ensured by converting the subject to
6046 -- the subtype of the slice.
6048 -- This optimization not only generates better code, avoiding slice
6049 -- messing especially in the packed case, but more importantly bypasses
6050 -- some problems in handling this peculiar case, for example, the issue
6051 -- of dealing specially with object renamings.
6058 Convert_To
6065 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6066 -- function, then additional actuals must be passed.
6070 then
6074 -- If the prefix is an access type, then we unconditionally rewrite if
6075 -- as an explicit dereference. This simplifies processing for several
6076 -- cases, including packed array cases and certain cases in which checks
6077 -- must be generated. We used to try to do this only when it was
6078 -- necessary, but it cleans up the code to do it all the time.
6084 else
6088 -- Generate index and validity checks
6096 -- If selecting from an array with atomic components, and atomic sync
6097 -- is not suppressed for this array type, set atomic sync flag.
6103 then
6107 -- All done for the non-packed case
6113 -- For packed arrays that are not bit-packed (i.e. the case of an array
6114 -- with one or more index types with a non-contiguous enumeration type),
6115 -- we can always use the normal packed element get circuit.
6122 -- For a reference to a component of a bit packed array, we have to
6123 -- convert it to a reference to the corresponding Packed_Array_Type.
6124 -- We only want to do this for simple references, and not for:
6126 -- Left side of assignment, or prefix of left side of assignment, or
6127 -- prefix of the prefix, to handle packed arrays of packed arrays,
6128 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6130 -- Renaming objects in renaming associations
6131 -- This case is handled when a use of the renamed variable occurs
6133 -- Actual parameters for a procedure call
6134 -- This case is handled in Exp_Ch6.Expand_Actuals
6136 -- The second expression in a 'Read attribute reference
6138 -- The prefix of an address or bit or size attribute reference
6140 -- The following circuit detects these exceptions
6142 declare
6146 begin
6147 loop
6152 N_Procedure_Call_Statement)
6154 and then
6156 then
6161 Name_Bit,
6162 Name_Size)
6164 then
6169 then
6172 -- If the expression is an index of an indexed component, it must
6173 -- be expanded regardless of context.
6177 then
6183 then
6189 then
6194 then
6197 else
6202 -- Keep looking up tree for unchecked expression, or if we are the
6203 -- prefix of a possible assignment left side.
6211 ---------------------
6212 -- Expand_N_Not_In --
6213 ---------------------
6215 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6216 -- can be done. This avoids needing to duplicate this expansion code.
6223 begin
6226 Right_Opnd =>
6231 -- If this is a set membership, preserve list of alternatives
6235 -- We want this to appear as coming from source if original does (see
6236 -- transformations in Expand_N_In).
6241 -- Now analyze transformed node
6246 -------------------
6247 -- Expand_N_Null --
6248 -------------------
6250 -- The only replacement required is for the case of a null of a type that
6251 -- is an access to protected subprogram, or a subtype thereof. We represent
6252 -- such access values as a record, and so we must replace the occurrence of
6253 -- null by the equivalent record (with a null address and a null pointer in
6254 -- it), so that the backend creates the proper value.
6261 begin
6263 Agg :=
6272 -- For subsequent semantic analysis, the node must retain its type.
6273 -- Gigi in any case replaces this type by the corresponding record
6274 -- type before processing the node.
6279 exception
6284 ---------------------
6285 -- Expand_N_Op_Abs --
6286 ---------------------
6292 begin
6295 -- Check for MINIMIZED/ELIMINATED overflow mode
6302 -- Deal with software overflow checking
6304 if not Backend_Overflow_Checks_On_Target
6307 then
6308 -- The only case to worry about is when the argument is equal to the
6309 -- largest negative number, so what we do is to insert the check:
6311 -- [constraint_error when Expr = typ'Base'First]
6313 -- with the usual Duplicate_Subexpr use coding for expr
6317 Condition =>
6320 Right_Opnd =>
6322 Prefix =>
6328 -- Vax floating-point types case
6335 ---------------------
6336 -- Expand_N_Op_Add --
6337 ---------------------
6342 begin
6345 -- Check for MINIMIZED/ELIMINATED overflow mode
6352 -- N + 0 = 0 + N = N for integer types
6357 then
6363 then
6369 -- Arithmetic overflow checks for signed integer/fixed point types
6375 -- Vax floating-point types case
6382 ---------------------
6383 -- Expand_N_Op_And --
6384 ---------------------
6389 begin
6407 ------------------------
6408 -- Expand_N_Op_Concat --
6409 ------------------------
6413 -- List of operands to be concatenated
6416 -- Node which is to be replaced by the result of concatenating the nodes
6417 -- in the list Opnds.
6419 begin
6420 -- Ensure validity of both operands
6424 -- If we are the left operand of a concatenation higher up the tree,
6425 -- then do nothing for now, since we want to deal with a series of
6426 -- concatenations as a unit.
6430 then
6434 -- We get here with a concatenation whose left operand may be a
6435 -- concatenation itself with a consistent type. We need to process
6436 -- these concatenation operands from left to right, which means
6437 -- from the deepest node in the tree to the highest node.
6444 -- Now Cnode is the deepest concatenation, and its parents are the
6445 -- concatenation nodes above, so now we process bottom up, doing the
6446 -- operands.
6448 -- The outer loop runs more than once if more than one concatenation
6449 -- type is involved.
6455 -- The inner loop gathers concatenation operands
6460 loop
6472 ------------------------
6473 -- Expand_N_Op_Divide --
6474 ------------------------
6484 and then
6488 begin
6491 -- Check for MINIMIZED/ELIMINATED overflow mode
6498 -- Otherwise proceed with expansion of division
6504 -- N / 1 = N for integer types
6511 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6512 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6513 -- operand is an unsigned integer, as required for this to work.
6518 -- We cannot do this transformation in configurable run time mode if we
6519 -- have 64-bit integers and long shifts are not available.
6522 then
6526 Right_Opnd =>
6532 -- Do required fixup of universal fixed operation
6539 -- Divisions with fixed-point results
6543 -- No special processing if Treat_Fixed_As_Integer is set, since
6544 -- from a semantic point of view such operations are simply integer
6545 -- operations and will be treated that way.
6550 else
6555 -- Other cases of division of fixed-point operands. Again we exclude the
6556 -- case where Treat_Fixed_As_Integer is set.
6560 then
6563 else
6568 -- Mixed-mode operations can appear in a non-static universal context,
6569 -- in which case the integer argument must be converted explicitly.
6583 -- Non-fixed point cases, do integer zero divide and overflow checks
6588 -- Deal with Vax_Float
6596 --------------------
6597 -- Expand_N_Op_Eq --
6598 --------------------
6613 -- If a constructed equality exists for the type or for its parent,
6614 -- build and analyze call, adding conversions if the operation is
6615 -- inherited.
6618 -- Determines whether a type has a subcomponent of an unconstrained
6619 -- Unchecked_Union subtype. Typ is a record type.
6621 -------------------------
6622 -- Build_Equality_Call --
6623 -------------------------
6630 begin
6633 then
6638 -- If we have an Unchecked_Union, we need to add the inferred
6639 -- discriminant values as actuals in the function call. At this
6640 -- point, the expansion has determined that both operands have
6641 -- inferable discriminants.
6644 declare
6649 -- List of inferred discriminant values for left operand.
6652 -- List of inferred discriminant values for right operand.
6656 begin
6660 -- Per-object constrained selected components require special
6661 -- attention. If the enclosing scope of the component is an
6662 -- Unchecked_Union, we cannot reference its discriminants
6663 -- directly. This is why we use the extra parameters of the
6664 -- equality function of the enclosing Unchecked_Union.
6666 -- type UU_Type (Discr : Integer := 0) is
6667 -- . . .
6668 -- end record;
6669 -- pragma Unchecked_Union (UU_Type);
6671 -- 1. Unchecked_Union enclosing record:
6673 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6674 -- . . .
6675 -- Comp : UU_Type (Discr);
6676 -- . . .
6677 -- end Enclosing_UU_Type;
6678 -- pragma Unchecked_Union (Enclosing_UU_Type);
6680 -- Obj1 : Enclosing_UU_Type;
6681 -- Obj2 : Enclosing_UU_Type (1);
6683 -- [. . .] Obj1 = Obj2 [. . .]
6685 -- Generated code:
6687 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6689 -- A and B are the formal parameters of the equality function
6690 -- of Enclosing_UU_Type. The function always has two extra
6691 -- formals to capture the inferred discriminant values for
6692 -- each discriminant of the type.
6694 -- 2. Non-Unchecked_Union enclosing record:
6696 -- type
6697 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6698 -- is record
6699 -- . . .
6700 -- Comp : UU_Type (Discr);
6701 -- . . .
6702 -- end Enclosing_Non_UU_Type;
6704 -- Obj1 : Enclosing_Non_UU_Type;
6705 -- Obj2 : Enclosing_Non_UU_Type (1);
6707 -- ... Obj1 = Obj2 ...
6709 -- Generated code:
6711 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6712 -- obj1.discr, obj2.discr)) then
6714 -- In this case we can directly reference the discriminants of
6715 -- the enclosing record.
6717 -- Process left operand of equality
6720 and then
6722 then
6723 -- If enclosing record is an Unchecked_Union, use formals
6724 -- corresponding to each discriminant. The name of the
6725 -- formal is that of the discriminant, with added suffix,
6726 -- see Exp_Ch3.Build_Record_Equality for details.
6728 if Is_Unchecked_Union
6730 then
6731 Discr :=
6732 First_Discriminant
6735 Append_Elmt (
6742 -- If enclosing record is of a non-Unchecked_Union type, it
6743 -- is possible to reference its discriminants directly.
6745 else
6748 Append_Elmt (
6751 Selector_Name =>
6752 New_Copy
6754 Lhs_Type,
6761 -- Otherwise operand is on object with a constrained type.
6762 -- Infer the discriminant values from the constraint.
6764 else
6768 Append_Elmt (
6769 New_Copy
6771 Lhs_Type,
6778 -- Similar processing for right operand of equality
6781 and then
6783 then
6784 if Is_Unchecked_Union
6786 then
6787 Discr :=
6788 First_Discriminant
6791 Append_Elmt (
6798 else
6801 Append_Elmt (
6804 Selector_Name =>
6805 New_Copy (Get_Discriminant_Value
6807 Rhs_Type,
6814 else
6817 Append_Elmt (
6818 New_Copy (Get_Discriminant_Value
6820 Rhs_Type,
6827 -- Now merge the list of discriminant values so that values
6828 -- of corresponding discriminants are adjacent.
6830 declare
6835 begin
6853 -- Normal case, not an unchecked union
6855 else
6865 ------------------------------------
6866 -- Has_Unconstrained_UU_Component --
6867 ------------------------------------
6869 function Has_Unconstrained_UU_Component
6871 is
6877 function Component_Is_Unconstrained_UU
6879 -- Determines whether the subtype of the component is an
6880 -- unconstrained Unchecked_Union.
6882 function Variant_Is_Unconstrained_UU
6884 -- Determines whether a component of the variant has an unconstrained
6885 -- Unchecked_Union subtype.
6887 -----------------------------------
6888 -- Component_Is_Unconstrained_UU --
6889 -----------------------------------
6891 function Component_Is_Unconstrained_UU
6893 is
6894 begin
6899 declare
6903 begin
6904 -- Unconstrained nominal type. In the case of a constraint
6905 -- present, the node kind would have been N_Subtype_Indication.
6915 ---------------------------------
6916 -- Variant_Is_Unconstrained_UU --
6917 ---------------------------------
6919 function Variant_Is_Unconstrained_UU
6921 is
6924 begin
6929 -- We only need to test one component
6931 declare
6934 begin
6944 -- None of the components withing the variant were of
6945 -- unconstrained Unchecked_Union type.
6950 -- Start of processing for Has_Unconstrained_UU_Component
6952 begin
6960 -- Inspect available components
6963 declare
6966 begin
6969 -- One component is sufficient
6980 -- Inspect available components withing variants
6983 declare
6986 begin
6989 -- One component within a variant is sufficient
7000 -- Neither the available components, nor the components inside the
7001 -- variant parts were of an unconstrained Unchecked_Union subtype.
7006 -- Start of processing for Expand_N_Op_Eq
7008 begin
7011 -- Deal with private types
7017 else
7021 -- It may happen in error situations that the underlying type is not
7022 -- set. The error will be detected later, here we just defend the
7023 -- expander code.
7031 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7032 -- means we no longer have a comparison operation, we are all done.
7040 -- Boolean types (requiring handling of non-standard case)
7048 -- Array types
7052 -- If we are doing full validity checking, and it is possible for the
7053 -- array elements to be invalid then expand out array comparisons to
7054 -- make sure that we check the array elements.
7056 if Validity_Check_Operands
7058 then
7059 declare
7061 Force_Validity_Checks;
7062 begin
7065 Expand_Array_Equality
7069 Bodies,
7070 Typl));
7076 -- Packed case where both operands are known aligned
7081 then
7084 -- Where the component type is elementary we can use a block bit
7085 -- comparison (if supported on the target) exception in the case
7086 -- of floating-point (negative zero issues require element by
7087 -- element comparison), and atomic types (where we must be sure
7088 -- to load elements independently) and possibly unaligned arrays.
7095 and then Support_Composite_Compare_On_Target
7096 then
7099 -- For composite and floating-point cases, expand equality loop to
7100 -- make sure of using proper comparisons for tagged types, and
7101 -- correctly handling the floating-point case.
7103 else
7105 Expand_Array_Equality
7109 Bodies,
7110 Typl));
7115 -- Record Types
7119 -- For tagged types, use the primitive "="
7123 -- No need to do anything else compiling under restriction
7124 -- No_Dispatching_Calls. During the semantic analysis we
7125 -- already notified such violation.
7131 -- If this is derived from an untagged private type completed with
7132 -- a tagged type, it does not have a full view, so we use the
7133 -- primitive operations of the private type. This check should no
7134 -- longer be necessary when these types get their full views???
7140 then
7141 -- Search for equality operation, checking that the operands
7142 -- have the same type. Note that we must find a matching entry,
7143 -- or something is very wrong!
7151 and then
7160 -- Find the type's predefined equality or an overriding
7161 -- user- defined equality. The reason for not simply calling
7162 -- Find_Prim_Op here is that there may be a user-defined
7163 -- overloaded equality op that precedes the equality that we want,
7164 -- so we have to explicitly search (e.g., there could be an
7165 -- equality with two different parameter types).
7167 else
7177 and then
7189 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7190 -- predefined equality operator for a type which has a subcomponent
7191 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7198 -- Prevent Gigi from generating incorrect code by rewriting the
7199 -- equality as a standard False. (is this documented somewhere???)
7206 -- If we can infer the discriminants of the operands, we make a
7207 -- call to the TSS equality function.
7210 and then
7212 then
7213 Build_Equality_Call
7216 else
7217 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7218 -- the predefined equality operator for an Unchecked_Union type
7219 -- if either of the operands lack inferable discriminants.
7225 -- Prevent Gigi from generating incorrect code by rewriting
7226 -- the equality as a standard False (documented where???).
7233 -- If a type support function is present (for complex cases), use it
7236 Build_Equality_Call
7239 -- When comparing two Bounded_Strings, use the primitive equality of
7240 -- the root Super_String type.
7243 Prim :=
7255 -- A Super_String type should always have a primitive equality
7260 -- Otherwise expand the component by component equality. Note that
7261 -- we never use block-bit comparisons for records, because of the
7262 -- problems with gaps. The backend will often be able to recombine
7263 -- the separate comparisons that we generate here.
7265 else
7276 -- Test if result is known at compile time
7280 -- If we still have comparison for Vax_Float, process it
7290 -----------------------
7291 -- Expand_N_Op_Expon --
7292 -----------------------
7310 begin
7313 -- CodePeer wants to see the unexpanded N_Op_Expon node
7319 -- If either operand is of a private type, then we have the use of an
7320 -- intrinsic operator, and we get rid of the privateness, by using root
7321 -- types of underlying types for the actual operation. Otherwise the
7322 -- private types will cause trouble if we expand multiplications or
7323 -- shifts etc. We also do this transformation if the result type is
7324 -- different from the base type.
7330 then
7331 declare
7335 begin
7346 -- Check for MINIMIZED/ELIMINATED overflow mode
7353 -- Test for case of known right argument where we can replace the
7354 -- exponentiation by an equivalent expression using multiplication.
7359 -- We only fold small non-negative exponents. You might think we
7360 -- could fold small negative exponents for the real case, but we
7361 -- can't because we are required to raise Constraint_Error for
7362 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7363 -- See ACVC test C4A012B.
7367 -- X ** 0 = 1 (or 1.0)
7371 -- Call Remove_Side_Effects to ensure that any side effects
7372 -- in the ignored left operand (in particular function calls
7373 -- to user defined functions) are properly executed.
7379 else
7383 -- X ** 1 = X
7388 -- X ** 2 = X * X
7391 Xnode :=
7396 -- X ** 3 = X * X * X
7399 Xnode :=
7401 Left_Opnd =>
7407 -- X ** 4 ->
7409 -- do
7410 -- En : constant base'type := base * base;
7411 -- in
7412 -- En * En
7414 else
7418 Xnode :=
7425 Expression =>
7427 Left_Opnd =>
7429 Right_Opnd =>
7432 Expression =>
7444 -- Case of (2 ** expression) appearing as an argument of an integer
7445 -- multiplication, or as the right argument of a division of a non-
7446 -- negative integer. In such cases we leave the node untouched, setting
7447 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
7448 -- of the higher level node converts it into a shift.
7450 -- Another case is 2 ** N in any other context. We simply convert
7451 -- this to 1 * 2 ** N, and then the above transformation applies.
7453 -- Note: this transformation is not applicable for a modular type with
7454 -- a non-binary modulus in the multiplication case, since we get a wrong
7455 -- result if the shift causes an overflow before the modular reduction.
7462 and then not Ovflo
7463 then
7464 -- First the multiply and divide cases
7467 declare
7472 begin
7475 and then
7477 or else
7480 or else
7486 then
7492 -- Now the other cases
7504 -- Fall through if exponentiation must be done using a runtime routine
7506 -- First deal with modular case
7510 -- Non-binary case, we call the special exponentiation routine for
7511 -- the non-binary case, converting the argument to Long_Long_Integer
7512 -- and passing the modulus value. Then the result is converted back
7513 -- to the base type.
7523 Exp))));
7525 -- Binary case, in this case, we call one of two routines, either the
7526 -- unsigned integer case, or the unsigned long long integer case,
7527 -- with a final "and" operation to do the required mod.
7529 else
7532 else
7539 Left_Opnd =>
7544 Exp)),
7545 Right_Opnd =>
7550 -- Common exit point for modular type case
7555 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7556 -- It is not worth having routines for Short_[Short_]Integer, since for
7557 -- most machines it would not help, and it would generate more code that
7558 -- might need certification when a certified run time is required.
7560 -- In the integer cases, we have two routines, one for when overflow
7561 -- checks are required, and one when they are not required, since there
7562 -- is a real gain in omitting checks on many machines.
7566 and then
7569 then
7574 else
7583 else
7587 -- Floating-point cases, always done using Long_Long_Float. We do not
7588 -- need separate routines for the overflow case here, since in the case
7589 -- of floating-point, we generate infinities anyway as a rule (either
7590 -- that or we automatically trap overflow), and if there is an infinity
7591 -- generated and a range check is required, the check will fail anyway.
7593 else
7599 -- Common processing for integer cases and floating-point cases.
7600 -- If we are in the right type, we can call runtime routine directly
7605 then
7611 -- Otherwise we have to introduce conversions (conversions are also
7612 -- required in the universal cases, since the runtime routine is
7613 -- typed using one of the standard types).
7615 else
7622 Exp))));
7628 exception
7633 --------------------
7634 -- Expand_N_Op_Ge --
7635 --------------------
7643 begin
7646 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7647 -- means we no longer have a comparison operation, we are all done.
7655 -- Array type case
7662 -- Deal with boolean operands
7673 -- If we still have comparison, and Vax_Float type, process it
7683 --------------------
7684 -- Expand_N_Op_Gt --
7685 --------------------
7693 begin
7696 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7697 -- means we no longer have a comparison operation, we are all done.
7705 -- Deal with array type operands
7712 -- Deal with boolean type operands
7723 -- If we still have comparison, and Vax_Float type, process it
7733 --------------------
7734 -- Expand_N_Op_Le --
7735 --------------------
7743 begin
7746 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7747 -- means we no longer have a comparison operation, we are all done.
7755 -- Deal with array type operands
7762 -- Deal with Boolean type operands
7773 -- If we still have comparison, and Vax_Float type, process it
7783 --------------------
7784 -- Expand_N_Op_Lt --
7785 --------------------
7793 begin
7796 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7797 -- means we no longer have a comparison operation, we are all done.
7805 -- Deal with array type operands
7812 -- Deal with Boolean type operands
7823 -- If we still have comparison, and Vax_Float type, process it
7833 -----------------------
7834 -- Expand_N_Op_Minus --
7835 -----------------------
7841 begin
7844 -- Check for MINIMIZED/ELIMINATED overflow mode
7851 if not Backend_Overflow_Checks_On_Target
7854 then
7855 -- Software overflow checking expands -expr into (0 - expr)
7864 -- Vax floating-point types case
7871 ---------------------
7872 -- Expand_N_Op_Mod --
7873 ---------------------
7893 begin
7896 -- Check for MINIMIZED/ELIMINATED overflow mode
7906 -- All done if we don't have a MOD any more, which can happen as a
7907 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
7914 -- Proceed with expansion of mod operator
7922 -- Convert mod to rem if operands are known non-negative. We do this
7923 -- since it is quite likely that this will improve the quality of code,
7924 -- (the operation now corresponds to the hardware remainder), and it
7925 -- does not seem likely that it could be harmful.
7933 -- Instead of reanalyzing the node we do the analysis manually. This
7934 -- avoids anomalies when the replacement is done in an instance and
7935 -- is epsilon more efficient.
7943 -- Otherwise, normal mod processing
7945 else
7946 -- Apply optimization x mod 1 = 0. We don't really need that with
7947 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
7948 -- certainly harmless.
7953 then
7954 -- Call Remove_Side_Effects to ensure that any side effects in
7955 -- the ignored left operand (in particular function calls to
7956 -- user defined functions) are properly executed.
7965 -- Deal with annoying case of largest negative number remainder
7966 -- minus one. Gigi may not handle this case correctly, because
7967 -- on some targets, the mod value is computed using a divide
7968 -- instruction which gives an overflow trap for this case.
7970 -- It would be a bit more efficient to figure out which targets
7971 -- this is really needed for, but in practice it is reasonable
7972 -- to do the following special check in all cases, since it means
7973 -- we get a clearer message, and also the overhead is minimal given
7974 -- that division is expensive in any case.
7976 -- In fact the check is quite easy, if the right operand is -1, then
7977 -- the mod value is always 0, and we can just ignore the left operand
7978 -- completely in this case.
7980 -- This only applies if we still have a mod operator. Skip if we
7981 -- have already rewritten this (e.g. in the case of eliminated
7982 -- overflow checks which have driven us into bignum mode).
7986 -- The operand type may be private (e.g. in the expansion of an
7987 -- intrinsic operation) so we must use the underlying type to get
7988 -- the bounds, and convert the literals explicitly.
7990 LLB :=
7991 Expr_Value
7996 then
8002 Right_Opnd =>
8016 --------------------------
8017 -- Expand_N_Op_Multiply --
8018 --------------------------
8034 begin
8037 -- Check for MINIMIZED/ELIMINATED overflow mode
8044 -- Special optimizations for integer types
8048 -- N * 0 = 0 for integer types
8052 then
8053 -- Call Remove_Side_Effects to ensure that any side effects in
8054 -- the ignored left operand (in particular function calls to
8055 -- user defined functions) are properly executed.
8064 -- Similar handling for 0 * N = 0
8068 then
8075 -- N * 1 = 1 * N = N for integer types
8077 -- This optimisation is not done if we are going to
8078 -- rewrite the product 1 * 2 ** N to a shift.
8082 and then not Lp2
8083 then
8089 and then not Rp2
8090 then
8096 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8097 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8098 -- operand is an integer, as required for this to work.
8103 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8108 Right_Opnd =>
8115 else
8116 -- If the result is modular, perform the reduction of the result
8117 -- appropriately.
8121 then
8124 Left_Opnd =>
8127 Right_Opnd =>
8129 Right_Opnd =>
8132 else
8136 Right_Opnd =>
8144 -- Same processing for the operands the other way round
8149 then
8152 Left_Opnd =>
8155 Right_Opnd =>
8157 Right_Opnd =>
8160 else
8164 Right_Opnd =>
8172 -- Do required fixup of universal fixed operation
8179 -- Multiplications with fixed-point results
8183 -- No special processing if Treat_Fixed_As_Integer is set, since from
8184 -- a semantic point of view such operations are simply integer
8185 -- operations and will be treated that way.
8189 -- Case of fixed * integer => fixed
8194 -- Case of integer * fixed => fixed
8199 -- Case of fixed * fixed => fixed
8201 else
8206 -- Other cases of multiplication of fixed-point operands. Again we
8207 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8211 then
8214 else
8219 -- Mixed-mode operations can appear in a non-static universal context,
8220 -- in which case the integer argument must be converted explicitly.
8230 -- Non-fixed point cases, check software overflow checking required
8235 -- Deal with VAX float case
8243 --------------------
8244 -- Expand_N_Op_Ne --
8245 --------------------
8250 begin
8251 -- Case of elementary type with standard operator
8255 then
8258 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8259 -- means we no longer have a /= operation, we are all done.
8267 -- Boolean types (requiring handling of non-standard case)
8278 -- If we still have comparison for Vax_Float, process it
8285 -- For all cases other than elementary types, we rewrite node as the
8286 -- negation of an equality operation, and reanalyze. The equality to be
8287 -- used is defined in the same scope and has the same signature. This
8288 -- signature must be set explicitly since in an instance it may not have
8289 -- the same visibility as in the generic unit. This avoids duplicating
8290 -- or factoring the complex code for record/array equality tests etc.
8292 else
8293 declare
8298 begin
8301 Neg :=
8303 Right_Opnd =>
8313 -- For navigation purposes, we want to treat the inequality as an
8314 -- implicit reference to the corresponding equality. Preserve the
8315 -- Comes_From_ source flag to generate proper Xref entries.
8327 ---------------------
8328 -- Expand_N_Op_Not --
8329 ---------------------
8331 -- If the argument is other than a Boolean array type, there is no special
8332 -- expansion required, except for VMS operations on signed integers.
8334 -- For the packed case, we call the special routine in Exp_Pakd, except
8335 -- that if the component size is greater than one, we use the standard
8336 -- routine generating a gruesome loop (it is so peculiar to have packed
8337 -- arrays with non-standard Boolean representations anyway, so it does not
8338 -- matter that we do not handle this case efficiently).
8340 -- For the unpacked case (and for the special packed case where we have non
8341 -- standard Booleans, as discussed above), we generate and insert into the
8342 -- tree the following function definition:
8344 -- function Nnnn (A : arr) is
8345 -- B : arr;
8346 -- begin
8347 -- for J in a'range loop
8348 -- B (J) := not A (J);
8349 -- end loop;
8350 -- return B;
8351 -- end Nnnn;
8353 -- Here arr is the actual subtype of the parameter (and hence always
8354 -- constrained). Then we replace the not with a call to this function.
8370 begin
8373 -- For boolean operand, deal with non-standard booleans
8382 -- For the VMS "not" on signed integer types, use conversion to and from
8383 -- a predefined modular type.
8386 declare
8390 begin
8391 -- If this is a derived type, retrieve original VMS type so that
8392 -- the proper sized type is used for intermediate values.
8396 else
8400 -- The proper unsigned type must have a size compatible with the
8401 -- operand, to prevent misalignment.
8412 else
8425 -- Only array types need any other processing
8431 -- Case of array operand. If bit packed with a component size of 1,
8432 -- handle it in Exp_Pakd if the operand is known to be aligned.
8437 then
8442 -- Case of array operand which is not bit-packed. If the context is
8443 -- a safe assignment, call in-place operation, If context is a larger
8444 -- boolean expression in the context of a safe assignment, expansion is
8445 -- done by enclosing operation.
8458 -- Special case the negation of a binary operation
8461 and then Safe_In_Place_Array_Op
8463 then
8470 then
8471 declare
8476 begin
8479 -- (not A) op (not B) can be reduced to a single call
8487 -- A xor (not B) can also be special-cased
8500 A_J :=
8505 B_J :=
8510 Loop_Statement :=
8514 Iteration_Scheme =>
8516 Loop_Parameter_Specification =>
8519 Discrete_Subtype_Definition =>
8534 Specification =>
8548 Handled_Statement_Sequence =>
8551 Loop_Statement,
8563 --------------------
8564 -- Expand_N_Op_Or --
8565 --------------------
8570 begin
8588 ----------------------
8589 -- Expand_N_Op_Plus --
8590 ----------------------
8593 begin
8596 -- Check for MINIMIZED/ELIMINATED overflow mode
8604 ---------------------
8605 -- Expand_N_Op_Rem --
8606 ---------------------
8621 -- Set if corresponding operand can be negative
8625 begin
8628 -- Check for MINIMIZED/ELIMINATED overflow mode
8638 -- All done if we don't have a REM any more, which can happen as a
8639 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8646 -- Proceed with expansion of REM
8651 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
8652 -- but it is useful with other back ends (e.g. AAMP), and is certainly
8653 -- harmless.
8658 then
8659 -- Call Remove_Side_Effects to ensure that any side effects in the
8660 -- ignored left operand (in particular function calls to user defined
8661 -- functions) are properly executed.
8670 -- Deal with annoying case of largest negative number remainder minus
8671 -- one. Gigi may not handle this case correctly, because on some
8672 -- targets, the mod value is computed using a divide instruction
8673 -- which gives an overflow trap for this case.
8675 -- It would be a bit more efficient to figure out which targets this
8676 -- is really needed for, but in practice it is reasonable to do the
8677 -- following special check in all cases, since it means we get a clearer
8678 -- message, and also the overhead is minimal given that division is
8679 -- expensive in any case.
8681 -- In fact the check is quite easy, if the right operand is -1, then
8682 -- the remainder is always 0, and we can just ignore the left operand
8683 -- completely in this case.
8691 -- We won't mess with trying to find out if the left operand can really
8692 -- be the largest negative number (that's a pain in the case of private
8693 -- types and this is really marginal). We will just assume that we need
8694 -- the test if the left operand can be negative at all.
8702 Right_Opnd =>
8715 -----------------------------
8716 -- Expand_N_Op_Rotate_Left --
8717 -----------------------------
8720 begin
8724 ------------------------------
8725 -- Expand_N_Op_Rotate_Right --
8726 ------------------------------
8729 begin
8733 ----------------------------
8734 -- Expand_N_Op_Shift_Left --
8735 ----------------------------
8738 begin
8742 -----------------------------
8743 -- Expand_N_Op_Shift_Right --
8744 -----------------------------
8747 begin
8751 ----------------------------------------
8752 -- Expand_N_Op_Shift_Right_Arithmetic --
8753 ----------------------------------------
8756 begin
8760 --------------------------
8761 -- Expand_N_Op_Subtract --
8762 --------------------------
8767 begin
8770 -- Check for MINIMIZED/ELIMINATED overflow mode
8777 -- N - 0 = N for integer types
8782 then
8787 -- Arithmetic overflow checks for signed integer/fixed point types
8792 -- VAX floating-point types case
8799 ---------------------
8800 -- Expand_N_Op_Xor --
8801 ---------------------
8806 begin
8824 ----------------------
8825 -- Expand_N_Or_Else --
8826 ----------------------
8831 -----------------------------------
8832 -- Expand_N_Qualified_Expression --
8833 -----------------------------------
8839 begin
8840 -- Do validity check if validity checking operands
8846 -- Apply possible constraint check
8856 ------------------------------------
8857 -- Expand_N_Quantified_Expression --
8858 ------------------------------------
8860 -- We expand:
8862 -- for all X in range => Cond
8864 -- into:
8866 -- T := True;
8867 -- for X in range loop
8868 -- if not Cond then
8869 -- T := False;
8870 -- exit;
8871 -- end if;
8872 -- end loop;
8874 -- Similarly, an existentially quantified expression:
8876 -- for some X in range => Cond
8878 -- becomes:
8880 -- T := False;
8881 -- for X in range loop
8882 -- if Cond then
8883 -- T := True;
8884 -- exit;
8885 -- end if;
8886 -- end loop;
8888 -- In both cases, the iteration may be over a container in which case it is
8889 -- given by an iterator specification, not a loop parameter specification.
8902 begin
8903 -- Create the declaration of the flag which tracks the status of the
8904 -- quantified expression. Generate:
8906 -- Flag : Boolean := (True | False);
8914 Expression =>
8917 -- Construct the circuitry which tracks the status of the quantified
8918 -- expression. Generate:
8920 -- if [not] Cond then
8921 -- Flag := (False | True);
8922 -- exit;
8923 -- end if;
8937 Expression =>
8941 -- Build the loop equivalent of the quantified expression
8944 Scheme :=
8947 else
8948 Scheme :=
8959 -- Transform the quantified expression
8968 ---------------------------------
8969 -- Expand_N_Selected_Component --
8970 ---------------------------------
8984 -- Gigi needs a temporary for prefixes that depend on a discriminant,
8985 -- unless the context of an assignment can provide size information.
8986 -- Don't we have a general routine that does this???
8989 -- The replacement of a discriminant reference by its value is required
8990 -- if this is part of the initialization of an temporary generated by a
8991 -- change of representation. This shows up as the construction of a
8992 -- discriminant constraint for a subtype declared at the same point as
8993 -- the entity in the prefix of the selected component. We recognize this
8994 -- case when the context of the reference is:
8995 -- subtype ST is T(Obj.D);
8996 -- where the entity for Obj comes from source, and ST has the same sloc.
8998 -----------------------
8999 -- In_Left_Hand_Side --
9000 -----------------------
9003 begin
9011 -----------------------------
9012 -- Is_Subtype_Declaration --
9013 -----------------------------
9017 begin
9018 return
9025 -- Start of processing for Expand_N_Selected_Component
9027 begin
9028 -- Insert explicit dereference if required
9032 -- First set prefix type to proper access type, in case it currently
9033 -- has a private (non-access) view of this type.
9042 then
9049 -- Deal with discriminant check required
9054 then
9055 -- Present the discriminant checking function to the backend, so
9056 -- that it can inline the call to the function.
9058 Add_Inlined_Body
9059 (Discriminant_Checking_Func
9062 -- Now reset the flag and generate the call
9067 -- In the case of Unchecked_Union, no discriminant checking is
9068 -- actually performed.
9070 else
9075 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9076 -- function, then additional actuals must be passed.
9080 then
9084 -- Gigi cannot handle unchecked conversions that are the prefix of a
9085 -- selected component with discriminants. This must be checked during
9086 -- expansion, because during analysis the type of the selector is not
9087 -- known at the point the prefix is analyzed. If the conversion is the
9088 -- target of an assignment, then we cannot force the evaluation.
9093 then
9097 -- Remaining processing applies only if selector is a discriminant
9101 -- If the selector is a discriminant of a constrained record type,
9102 -- we may be able to rewrite the expression with the actual value
9103 -- of the discriminant, a useful optimization in some cases.
9108 then
9109 -- Do this optimization for discrete types only, and not for
9110 -- access types (access discriminants get us into trouble!)
9115 -- Don't do this on the left hand of an assignment statement.
9116 -- Normally one would think that references like this would not
9117 -- occur, but they do in generated code, and mean that we really
9118 -- do want to assign the discriminant!
9122 then
9125 -- Don't do this optimization for the prefix of an attribute or
9126 -- the name of an object renaming declaration since these are
9127 -- contexts where we do not want the value anyway.
9132 then
9135 -- Don't do this optimization if we are within the code for a
9136 -- discriminant check, since the whole point of such a check may
9137 -- be to verify the condition on which the code below depends!
9142 -- Green light to see if we can do the optimization. There is
9143 -- still one condition that inhibits the optimization below but
9144 -- now is the time to check the particular discriminant.
9146 else
9147 -- Loop through discriminants to find the matching discriminant
9148 -- constraint to see if we can copy it.
9155 -- Check if this is the matching discriminant and if the
9156 -- discriminant value is simple enough to make sense to
9157 -- copy. We don't want to copy complex expressions, and
9158 -- indeed to do so can cause trouble (before we put in
9159 -- this guard, a discriminant expression containing an
9160 -- AND THEN was copied, causing problems for coverage
9161 -- analysis tools).
9163 -- However, if the reference is part of the initialization
9164 -- code generated for an object declaration, we must use
9165 -- the discriminant value from the subtype constraint,
9166 -- because the selected component may be a reference to the
9167 -- object being initialized, whose discriminant is not yet
9168 -- set. This only happens in complex cases involving changes
9169 -- or representation.
9175 then
9176 -- Here we have the matching discriminant. Check for
9177 -- the case of a discriminant of a component that is
9178 -- constrained by an outer discriminant, which cannot
9179 -- be optimized away.
9181 if Denotes_Discriminant
9183 then
9187 and then
9188 Denotes_Discriminant
9190 then
9193 -- Do not retrieve value if constraint is not static. It
9194 -- is generally not useful, and the constraint may be a
9195 -- rewritten outer discriminant in which case it is in
9196 -- fact incorrect.
9199 and then
9202 and then not
9203 Is_Static_Expression
9205 then
9208 -- In the context of a case statement, the expression may
9209 -- have the base type of the discriminant, and we need to
9210 -- preserve the constraint to avoid spurious errors on
9211 -- missing cases.
9215 then
9218 Subtype_Mark =>
9220 Expression =>
9224 -- In case that comes out as a static expression,
9225 -- reset it (a selected component is never static).
9230 -- Otherwise we can just copy the constraint, but the
9231 -- result is certainly not static! In some cases the
9232 -- discriminant constraint has been analyzed in the
9233 -- context of the original subtype indication, but for
9234 -- itypes the constraint might not have been analyzed
9235 -- yet, and this must be done now.
9237 else
9249 -- Note: the above loop should always find a matching
9250 -- discriminant, but if it does not, we just missed an
9251 -- optimization due to some glitch (perhaps a previous
9252 -- error), so ignore.
9257 -- The only remaining processing is in the case of a discriminant of
9258 -- a concurrent object, where we rewrite the prefix to denote the
9259 -- corresponding record type. If the type is derived and has renamed
9260 -- discriminants, use corresponding discriminant, which is the one
9261 -- that appears in the corresponding record.
9271 then
9275 New_N :=
9277 Prefix =>
9286 -- Set Atomic_Sync_Required if necessary for atomic component
9289 declare
9293 begin
9294 -- If component is atomic, but type is not, setting depends on
9295 -- disable/enable state for the component.
9300 -- If component is not atomic, but its type is atomic, setting
9301 -- depends on disable/enable state for the type.
9306 -- If both component and type are atomic, we disable if either
9307 -- component or its type have sync disabled.
9311 and then
9314 else
9318 -- Set flag if required
9327 --------------------
9328 -- Expand_N_Slice --
9329 --------------------
9338 -- Check whether the argument is an actual for a procedure call, in
9339 -- which case the expansion of a bit-packed slice is deferred until the
9340 -- call itself is expanded. The reason this is required is that we might
9341 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9342 -- that copy out would be missed if we created a temporary here in
9343 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9344 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9345 -- is harmless to defer expansion in the IN case, since the call
9346 -- processing will still generate the appropriate copy in operation,
9347 -- which will take care of the slice.
9350 -- Create a named variable for the value of the slice, in cases where
9351 -- the back-end cannot handle it properly, e.g. when packed types or
9352 -- unaligned slices are involved.
9354 -------------------------
9355 -- Is_Procedure_Actual --
9356 -------------------------
9361 begin
9362 loop
9363 -- If our parent is a procedure call we can return
9368 -- If our parent is a type conversion, keep climbing the tree,
9369 -- since a type conversion can be a procedure actual. Also keep
9370 -- climbing if parameter association or a qualified expression,
9371 -- since these are additional cases that do can appear on
9372 -- procedure actuals.
9375 N_Parameter_Association,
9376 N_Qualified_Expression)
9377 then
9380 -- Any other case is not what we are looking for
9382 else
9388 ------------------------------
9389 -- Make_Temporary_For_Slice --
9390 ------------------------------
9396 begin
9397 Decl :=
9405 Decl,
9414 -- Start of processing for Expand_N_Slice
9416 begin
9417 -- Special handling for access types
9430 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9431 -- function, then additional actuals must be passed.
9435 then
9439 -- The remaining case to be handled is packed slices. We can leave
9440 -- packed slices as they are in the following situations:
9442 -- 1. Right or left side of an assignment (we can handle this
9443 -- situation correctly in the assignment statement expansion).
9445 -- 2. Prefix of indexed component (the slide is optimized away in this
9446 -- case, see the start of Expand_N_Slice.)
9448 -- 3. Object renaming declaration, since we want the name of the
9449 -- slice, not the value.
9451 -- 4. Argument to procedure call, since copy-in/copy-out handling may
9452 -- be required, and this is handled in the expansion of call
9453 -- itself.
9455 -- 5. Prefix of an address attribute (this is an error which is caught
9456 -- elsewhere, and the expansion would interfere with generating the
9457 -- error message).
9461 -- Apply transformation for actuals of a function call, where
9462 -- Expand_Actuals is not used.
9466 then
9467 Make_Temporary_For_Slice;
9473 then
9479 then
9484 then
9487 else
9488 Make_Temporary_For_Slice;
9492 ------------------------------
9493 -- Expand_N_Type_Conversion --
9494 ------------------------------
9503 -- This is called in the case of record and array type conversions to
9504 -- see if there is a change of representation to be handled. Change of
9505 -- representation is actually handled at the assignment statement level,
9506 -- and what this procedure does is rewrite node N conversion as an
9507 -- assignment to temporary. If there is no change of representation,
9508 -- then the conversion node is unchanged.
9511 -- Called when we know that an accessibility check will fail. Rewrites
9512 -- node N to an appropriate raise statement and outputs warning msgs.
9513 -- The Etype of the raise node is set to Target_Type.
9516 -- Handles generation of range check for real target value
9519 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
9520 -- evaluates to True.
9522 -----------------------------------
9523 -- Handle_Changed_Representation --
9524 -----------------------------------
9534 begin
9535 -- Nothing else to do if no change of representation
9540 -- The real change of representation work is done by the assignment
9541 -- statement processing. So if this type conversion is appearing as
9542 -- the expression of an assignment statement, nothing needs to be
9543 -- done to the conversion.
9548 -- Otherwise we need to generate a temporary variable, and do the
9549 -- change of representation assignment into that temporary variable.
9550 -- The conversion is then replaced by a reference to this variable.
9552 else
9555 -- If type is unconstrained we have to add a constraint, copied
9556 -- from the actual value of the left hand side.
9570 Prefix =>
9572 Selector_Name =>
9583 -- We convert the bounds explicitly. We use an unchecked
9584 -- conversion because bounds checks are done elsewhere.
9588 Low_Bound =>
9591 Prefix =>
9592 Duplicate_Subexpr_No_Checks
9598 High_Bound =>
9601 Prefix =>
9602 Duplicate_Subexpr_No_Checks
9616 Odef :=
9619 Constraint =>
9625 Decl :=
9632 -- Insert required actions. It is essential to suppress checks
9633 -- since we have suppressed default initialization, which means
9634 -- that the variable we create may have no discriminants.
9637 New_List (
9638 Decl,
9649 -------------------------------
9650 -- Raise_Accessibility_Error --
9651 -------------------------------
9654 begin
9660 Error_Msg_N
9662 Error_Msg_NE
9666 ----------------------
9667 -- Real_Range_Check --
9668 ----------------------
9670 -- Case of conversions to floating-point or fixed-point. If range checks
9671 -- are enabled and the target type has a range constraint, we convert:
9673 -- typ (x)
9675 -- to
9677 -- Tnn : typ'Base := typ'Base (x);
9678 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
9679 -- Tnn
9681 -- This is necessary when there is a conversion of integer to float or
9682 -- to fixed-point to ensure that the correct checks are made. It is not
9683 -- necessary for float to float where it is enough to simply set the
9684 -- Do_Range_Check flag.
9694 begin
9695 -- Nothing to do if conversion was rewritten
9701 -- Nothing to do if range checks suppressed, or target has the same
9702 -- range as the base type (or is the base type).
9706 and then
9708 then
9712 -- Nothing to do if expression is an entity on which checks have been
9713 -- suppressed.
9717 then
9721 -- Nothing to do if bounds are all static and we can tell that the
9722 -- expression is within the bounds of the target. Note that if the
9723 -- operand is of an unconstrained floating-point type, then we do
9724 -- not trust it to be in range (might be infinite)
9726 declare
9730 begin
9737 then
9738 declare
9744 begin
9748 else
9756 then
9764 -- For float to float conversions, we are done
9767 and then
9769 then
9773 -- Otherwise rewrite the conversion as described above
9779 -- Enable overflow except for case of integer to float conversions,
9780 -- where it is never required, since we can never have overflow in
9781 -- this case.
9797 Condition =>
9799 Left_Opnd =>
9802 Right_Opnd =>
9805 Prefix =>
9808 Right_Opnd =>
9811 Right_Opnd =>
9814 Prefix =>
9822 -----------------------------
9823 -- Has_Extra_Accessibility --
9824 -----------------------------
9826 -- Returns true for a formal of an anonymous access type or for
9827 -- an Ada 2012-style stand-alone object of an anonymous access type.
9830 begin
9833 else
9838 -- Start of processing for Expand_N_Type_Conversion
9840 begin
9841 -- First remove check marks put by the semantic analysis on the type
9842 -- conversion between array types. We need these checks, and they will
9843 -- be generated by this expansion routine, but we do not depend on these
9844 -- flags being set, and since we do intend to expand the checks in the
9845 -- front end, we don't want them on the tree passed to the back end.
9850 else
9855 -- Nothing at all to do if conversion is to the identical type so remove
9856 -- the conversion completely, it is useless, except that it may carry
9857 -- an Assignment_OK attribute, which must be propagated to the operand.
9868 -- Nothing to do if this is the second argument of read. This is a
9869 -- "backwards" conversion that will be handled by the specialized code
9870 -- in attribute processing.
9875 then
9879 -- Check for case of converting to a type that has an invariant
9880 -- associated with it. This required an invariant check. We convert
9882 -- typ (expr)
9884 -- into
9886 -- do invariant_check (typ (expr)) in typ (expr);
9888 -- using Duplicate_Subexpr to avoid multiple side effects
9890 -- Note: the Comes_From_Source check, and then the resetting of this
9891 -- flag prevents what would otherwise be an infinite recursion.
9896 then
9907 -- Here if we may need to expand conversion
9909 -- If the operand of the type conversion is an arithmetic operation on
9910 -- signed integers, and the based type of the signed integer type in
9911 -- question is smaller than Standard.Integer, we promote both of the
9912 -- operands to type Integer.
9914 -- For example, if we have
9916 -- target-type (opnd1 + opnd2)
9918 -- and opnd1 and opnd2 are of type short integer, then we rewrite
9919 -- this as:
9921 -- target-type (integer(opnd1) + integer(opnd2))
9923 -- We do this because we are always allowed to compute in a larger type
9924 -- if we do the right thing with the result, and in this case we are
9925 -- going to do a conversion which will do an appropriate check to make
9926 -- sure that things are in range of the target type in any case. This
9927 -- avoids some unnecessary intermediate overflows.
9929 -- We might consider a similar transformation in the case where the
9930 -- target is a real type or a 64-bit integer type, and the operand
9931 -- is an arithmetic operation using a 32-bit integer type. However,
9932 -- we do not bother with this case, because it could cause significant
9933 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
9934 -- much cheaper, but we don't want different behavior on 32-bit and
9935 -- 64-bit machines. Note that the exclusion of the 64-bit case also
9936 -- handles the configurable run-time cases where 64-bit arithmetic
9937 -- may simply be unavailable.
9939 -- Note: this circuit is partially redundant with respect to the circuit
9940 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
9941 -- the processing here. Also we still need the Checks circuit, since we
9942 -- have to be sure not to generate junk overflow checks in the first
9943 -- place, since it would be trick to remove them here!
9947 -- All conditions met, go ahead with transformation
9949 declare
9953 begin
9954 R :=
9963 L :=
9981 -- Do validity check if validity checking operands
9987 -- Special case of converting from non-standard boolean type
9991 then
9997 -- Case of converting to an access type
10001 -- Apply an accessibility check when the conversion operand is an
10002 -- access parameter (or a renaming thereof), unless conversion was
10003 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10004 -- Note that other checks may still need to be applied below (such
10005 -- as tagged type checks).
10012 then
10013 Apply_Accessibility_Check
10016 -- If the level of the operand type is statically deeper than the
10017 -- level of the target type, then force Program_Error. Note that this
10018 -- can only occur for cases where the attribute is within the body of
10019 -- an instantiation (otherwise the conversion will already have been
10020 -- rejected as illegal). Note: warnings are issued by the analyzer
10021 -- for the instance cases.
10023 elsif In_Instance_Body
10026 then
10027 Raise_Accessibility_Error;
10029 -- When the operand is a selected access discriminant the check needs
10030 -- to be made against the level of the object denoted by the prefix
10031 -- of the selected name. Force Program_Error for this case as well
10032 -- (this accessibility violation can only happen if within the body
10033 -- of an instantiation).
10035 elsif In_Instance_Body
10040 then
10041 Raise_Accessibility_Error;
10046 -- Case of conversions of tagged types and access to tagged types
10048 -- When needed, that is to say when the expression is class-wide, Add
10049 -- runtime a tag check for (strict) downward conversion by using the
10050 -- membership test, generating:
10052 -- [constraint_error when Operand not in Target_Type'Class]
10054 -- or in the access type case
10056 -- [constraint_error
10057 -- when Operand /= null
10058 -- and then Operand.all not in
10059 -- Designated_Type (Target_Type)'Class]
10064 then
10065 -- Do not do any expansion in the access type case if the parent is a
10066 -- renaming, since this is an error situation which will be caught by
10067 -- Sem_Ch8, and the expansion can interfere with this error check.
10073 -- Otherwise, proceed with processing tagged conversion
10082 -- Create a membership check to test whether Operand is a member
10083 -- of Targ_Typ. If the original Target_Type is an access, include
10084 -- a test for null value. The check is inserted at N.
10086 --------------------
10087 -- Make_Tag_Check --
10088 --------------------
10093 begin
10094 -- Generate:
10095 -- [Constraint_Error
10096 -- when Operand /= null
10097 -- and then Operand.all not in Targ_Typ]
10100 Cond :=
10102 Left_Opnd =>
10107 Right_Opnd =>
10109 Left_Opnd =>
10114 -- Generate:
10115 -- [Constraint_Error when Operand not in Targ_Typ]
10117 else
10118 Cond :=
10130 -- Start of processing for Tagged_Conversion
10132 begin
10133 -- Handle entities from the limited view
10136 Actual_Op_Typ :=
10138 else
10143 Actual_Targ_Typ :=
10145 else
10151 -- Ada 2005 (AI-251): Handle interface type conversion
10160 -- Create a runtime tag check for a downward class-wide type
10161 -- conversion.
10168 then
10173 -- AI05-0073: If the result subtype of the function is defined
10174 -- by an access_definition designating a specific tagged type
10175 -- T, a check is made that the result value is null or the tag
10176 -- of the object designated by the result value identifies T.
10177 -- Constraint_Error is raised if this check fails.
10180 declare
10184 begin
10185 -- Climb scope stack looking for the enclosing function
10190 loop
10194 -- The function's return subtype must be defined using
10195 -- an access definition.
10198 N_Access_Definition
10199 then
10202 -- The return subtype denotes a specific tagged type,
10203 -- in other words, a non class-wide type.
10207 then
10215 -- We have generated a tag check for either a class-wide type
10216 -- conversion or for AI05-0073.
10219 declare
10221 begin
10222 Conv :=
10233 -- Case of other access type conversions
10238 -- Case of conversions from a fixed-point type
10240 -- These conversions require special expansion and processing, found in
10241 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10242 -- since from a semantic point of view, these are simple integer
10243 -- conversions, which do not need further processing.
10247 then
10248 -- We should never see universal fixed at this case, since the
10249 -- expansion of the constituent divide or multiply should have
10250 -- eliminated the explicit mention of universal fixed.
10254 -- Check for special case of the conversion to universal real that
10255 -- occurs as a result of the use of a round attribute. In this case,
10256 -- the real type for the conversion is taken from the target type of
10257 -- the Round attribute and the result must be marked as rounded.
10262 then
10267 -- Otherwise do correct fixed-conversion, but skip these if the
10268 -- Conversion_OK flag is set, because from a semantic point of view
10269 -- these are simple integer conversions needing no further processing
10270 -- (the backend will simply treat them as integers).
10275 Real_Range_Check;
10280 else
10283 Real_Range_Check;
10287 -- Case of conversions to a fixed-point type
10289 -- These conversions require special expansion and processing, found in
10290 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10291 -- since from a semantic point of view, these are simple integer
10292 -- conversions, which do not need further processing.
10296 then
10299 Real_Range_Check;
10300 else
10303 Real_Range_Check;
10306 -- Case of float-to-integer conversions
10308 -- We also handle float-to-fixed conversions with Conversion_OK set
10309 -- since semantically the fixed-point target is treated as though it
10310 -- were an integer in such cases.
10313 and then
10315 or else
10317 then
10318 -- One more check here, gcc is still not able to do conversions of
10319 -- this type with proper overflow checking, and so gigi is doing an
10320 -- approximation of what is required by doing floating-point compares
10321 -- with the end-point. But that can lose precision in some cases, and
10322 -- give a wrong result. Converting the operand to Universal_Real is
10323 -- helpful, but still does not catch all cases with 64-bit integers
10324 -- on targets with only 64-bit floats.
10326 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10327 -- Can this code be removed ???
10332 Subtype_Mark =>
10334 Expression =>
10342 -- Case of array conversions
10344 -- Expansion of array conversions, add required length/range checks but
10345 -- only do this if there is no change of representation. For handling of
10346 -- this case, see Handle_Changed_Representation.
10351 else
10355 Handle_Changed_Representation;
10357 -- Case of conversions of discriminated types
10359 -- Add required discriminant checks if target is constrained. Again this
10360 -- change is skipped if we have a change of representation.
10364 then
10366 Handle_Changed_Representation;
10368 -- Case of all other record conversions. The only processing required
10369 -- is to check for a change of representation requiring the special
10370 -- assignment processing.
10374 -- Ada 2005 (AI-216): Program_Error is raised when converting from
10375 -- a derived Unchecked_Union type to an unconstrained type that is
10376 -- not Unchecked_Union if the operand lacks inferable discriminants.
10383 then
10384 -- To prevent Gigi from generating illegal code, we generate a
10385 -- Program_Error node, but we give it the target type of the
10386 -- conversion (is this requirement documented somewhere ???)
10388 declare
10392 begin
10397 else
10398 Handle_Changed_Representation;
10401 -- Case of conversions of enumeration types
10405 -- Special processing is required if there is a change of
10406 -- representation (from enumeration representation clauses).
10410 -- Convert: x(y) to x'val (ytyp'val (y))
10425 -- Case of conversions to floating-point
10428 Real_Range_Check;
10431 -- At this stage, either the conversion node has been transformed into
10432 -- some other equivalent expression, or left as a conversion that can be
10433 -- handled by Gigi, in the following cases:
10435 -- Conversions with no change of representation or type
10437 -- Numeric conversions involving integer, floating- and fixed-point
10438 -- values. Fixed-point values are allowed only if Conversion_OK is
10439 -- set, i.e. if the fixed-point values are to be treated as integers.
10441 -- No other conversions should be passed to Gigi
10443 -- Check: are these rules stated in sinfo??? if so, why restate here???
10445 -- The only remaining step is to generate a range check if we still have
10446 -- a type conversion at this stage and Do_Range_Check is set. For now we
10447 -- do this only for conversions of discrete types.
10451 then
10452 declare
10457 begin
10460 then
10463 -- Before we do a range check, we have to deal with treating a
10464 -- fixed-point operand as an integer. The way we do this is
10465 -- simply to do an unchecked conversion to an appropriate
10466 -- integer type large enough to hold the result.
10468 -- This code is not active yet, because we are only dealing
10469 -- with discrete types so far ???
10473 then
10478 else
10485 -- Reset overflow flag, since the range check will include
10486 -- dealing with possible overflow, and generate the check. If
10487 -- Address is either a source type or target type, suppress
10488 -- range check to avoid typing anomalies when it is a visible
10489 -- integer type.
10494 then
10495 Generate_Range_Check
10502 -- Final step, if the result is a type conversion involving Vax_Float
10503 -- types, then it is subject for further special processing.
10507 then
10512 -- Here at end of processing
10515 -- Apply predicate check if required. Note that we can't just call
10516 -- Apply_Predicate_Check here, because the type looks right after
10517 -- the conversion and it would omit the check. The Comes_From_Source
10518 -- guard is necessary to prevent infinite recursions when we generate
10519 -- internal conversions for the purpose of checking predicates.
10524 then
10525 declare
10528 begin
10529 -- Avoid infinite recursion on the subsequent expansion of
10530 -- of the copy of the original type conversion.
10538 -----------------------------------
10539 -- Expand_N_Unchecked_Expression --
10540 -----------------------------------
10542 -- Remove the unchecked expression node from the tree. Its job was simply
10543 -- to make sure that its constituent expression was handled with checks
10544 -- off, and now that that is done, we can remove it from the tree, and
10545 -- indeed must, since Gigi does not expect to see these nodes.
10549 begin
10554 ----------------------------------------
10555 -- Expand_N_Unchecked_Type_Conversion --
10556 ----------------------------------------
10558 -- If this cannot be handled by Gigi and we haven't already made a
10559 -- temporary for it, do it now.
10566 begin
10567 -- Nothing at all to do if conversion is to the identical type so remove
10568 -- the conversion completely, it is useless, except that it may carry
10569 -- an Assignment_OK indication which must be propagated to the operand.
10573 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
10583 -- If we have a conversion of a compile time known value to a target
10584 -- type and the value is in range of the target type, then we can simply
10585 -- replace the construct by an integer literal of the correct type. We
10586 -- only apply this to integer types being converted. Possibly it may
10587 -- apply in other cases, but it is too much trouble to worry about.
10589 -- Note that we do not do this transformation if the Kill_Range_Check
10590 -- flag is set, since then the value may be outside the expected range.
10591 -- This happens in the Normalize_Scalars case.
10593 -- We also skip this if either the target or operand type is biased
10594 -- because in this case, the unchecked conversion is supposed to
10595 -- preserve the bit pattern, not the integer value.
10603 then
10604 declare
10607 begin
10609 and then
10611 and then
10613 and then
10615 then
10618 -- If Address is the target type, just set the type to avoid a
10619 -- spurious type error on the literal when Address is a visible
10620 -- integer type.
10624 else
10633 -- Nothing to do if conversion is safe
10639 -- Otherwise force evaluation unless Assignment_OK flag is set (this
10640 -- flag indicates ??? More comments needed here)
10644 else
10649 ----------------------------
10650 -- Expand_Record_Equality --
10651 ----------------------------
10653 -- For non-variant records, Equality is expanded when needed into:
10655 -- and then Lhs.Discr1 = Rhs.Discr1
10656 -- and then ...
10657 -- and then Lhs.Discrn = Rhs.Discrn
10658 -- and then Lhs.Cmp1 = Rhs.Cmp1
10659 -- and then ...
10660 -- and then Lhs.Cmpn = Rhs.Cmpn
10662 -- The expression is folded by the back-end for adjacent fields. This
10663 -- function is called for tagged record in only one occasion: for imple-
10664 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
10665 -- otherwise the primitive "=" is used directly.
10667 function Expand_Record_Equality
10673 is
10682 -- Return the next discriminant or component to compare, starting with
10683 -- C, skipping inherited components.
10685 ------------------------
10686 -- Element_To_Compare --
10687 ------------------------
10692 begin
10694 loop
10695 -- Exit loop when the next element to be compared is found, or
10696 -- there is no more such element.
10703 -- Skip inherited components
10705 -- Note: for a tagged type, we always generate the "=" primitive
10706 -- for the base type (not on the first subtype), so the test for
10707 -- Comp /= Original_Record_Component (Comp) is True for
10708 -- inherited components only.
10713 -- Skip _Tag
10717 -- The .NET/JVM version of type Root_Controlled contains two
10718 -- fields which should not be considered part of the object. To
10719 -- achieve proper equiality between two controlled objects on
10720 -- .NET/JVM, skip _Parent whenever it has type Root_Controlled.
10726 -- Skip interface elements (secondary tags???)
10736 -- Start of processing for Expand_Record_Equality
10738 begin
10739 -- Generates the following code: (assuming that Typ has one Discr and
10740 -- component C2 is also a record)
10742 -- True
10743 -- and then Lhs.Discr1 = Rhs.Discr1
10744 -- and then Lhs.C1 = Rhs.C1
10745 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
10746 -- and then ...
10747 -- and then Lhs.Cmpn = Rhs.Cmpn
10752 declare
10757 begin
10762 else
10767 Check :=
10769 Lhs =>
10773 Rhs =>
10779 -- If some (sub)component is an unchecked_union, the whole
10780 -- operation will raise program error.
10786 else
10787 Result :=
10800 ---------------------------
10801 -- Expand_Set_Membership --
10802 ---------------------------
10810 -- If the alternative is a subtype mark, create a simple membership
10811 -- test. Otherwise create an equality test for it.
10813 ---------------
10814 -- Make_Cond --
10815 ---------------
10822 begin
10825 then
10826 Cond :=
10830 else
10831 Cond :=
10840 -- Start of processing for Expand_Set_Membership
10842 begin
10850 Res :=
10861 -----------------------------------
10862 -- Expand_Short_Circuit_Operator --
10863 -----------------------------------
10865 -- Deal with special expansion if actions are present for the right operand
10866 -- and deal with optimizing case of arguments being True or False. We also
10867 -- deal with the special case of non-standard boolean values.
10879 -- If Left = Shortcut_Value then Right need not be evaluated
10881 begin
10882 -- Deal with non-standard booleans
10890 -- Check for cases where left argument is known to be True or False
10894 -- Mark SCO for left condition as compile time known
10900 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
10901 -- Any actions associated with Right will be executed unconditionally
10902 -- and can thus be inserted into the tree unconditionally.
10911 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
10912 -- In this case we can forget the actions associated with Right,
10913 -- since they will never be executed.
10915 else
10925 -- If Actions are present for the right operand, we have to do some
10926 -- special processing. We can't just let these actions filter back into
10927 -- code preceding the short circuit (which is what would have happened
10928 -- if we had not trapped them in the short-circuit form), since they
10929 -- must only be executed if the right operand of the short circuit is
10930 -- executed and not otherwise.
10935 -- We now use an Expression_With_Actions node for the right operand
10936 -- of the short-circuit form. Note that this solves the traceability
10937 -- problems for coverage analysis.
10950 -- No actions present, check for cases of right argument True/False
10954 -- Mark SCO for left condition as compile time known
10960 -- Change (Left and then True), (Left or else False) to Left.
10961 -- Note that we know there are no actions associated with the right
10962 -- operand, since we just checked for this case above.
10967 -- Change (Left and then False), (Left or else True) to Right,
10968 -- making sure to preserve any side effects associated with the Left
10969 -- operand.
10971 else
10980 -------------------------------------
10981 -- Fixup_Universal_Fixed_Operation --
10982 -------------------------------------
10987 begin
10988 -- We must have a type conversion immediately above us
10992 -- Normally the type conversion gives our target type. The exception
10993 -- occurs in the case of the Round attribute, where the conversion
10994 -- will be to universal real, and our real type comes from the Round
10995 -- attribute (as well as an indication that we must round the result)
10999 then
11003 -- Normal case where type comes from conversion above us
11005 else
11010 ---------------------------------
11011 -- Has_Inferable_Discriminants --
11012 ---------------------------------
11017 -- Determines whether the left-most prefix of a selected component is a
11018 -- formal parameter in a subprogram. Assumes N is a selected component.
11020 --------------------------------
11021 -- Prefix_Is_Formal_Parameter --
11022 --------------------------------
11027 begin
11028 -- Move to the left-most prefix by climbing up the tree
11033 loop
11040 -- Start of processing for Has_Inferable_Discriminants
11042 begin
11043 -- For selected components, the subtype of the selector must be a
11044 -- constrained Unchecked_Union. If the component is subject to a
11045 -- per-object constraint, then the enclosing object must have inferable
11046 -- discriminants.
11051 -- A small hack. If we have a per-object constrained selected
11052 -- component of a formal parameter, return True since we do not
11053 -- know the actual parameter association yet.
11058 -- Otherwise, check the enclosing object and the selector
11060 else
11065 -- The call to Has_Inferable_Discriminants will determine whether
11066 -- the selector has a constrained Unchecked_Union nominal type.
11068 else
11072 -- A qualified expression has inferable discriminants if its subtype
11073 -- mark is a constrained Unchecked_Union subtype.
11079 -- For all other names, it is sufficient to have a constrained
11080 -- Unchecked_Union nominal subtype.
11082 else
11088 -------------------------------
11089 -- Insert_Dereference_Action --
11090 -------------------------------
11095 -- Return true if type of P is derived from Checked_Pool;
11097 -----------------------------
11098 -- Is_Checked_Storage_Pool --
11099 -----------------------------
11104 begin
11113 else
11121 -- Local variables
11135 -- Start of processing for Insert_Dereference_Action
11137 begin
11140 -- Do not re-expand a dereference which has already been processed by
11141 -- this routine.
11146 -- Do not perform this type of expansion for internally-generated
11147 -- dereferences.
11152 -- A dereference action is only applicable to objects which have been
11153 -- allocated on a checked pool.
11159 -- Extract the address of the dereferenced object. Generate:
11161 -- Addr : System.Address := <N>'Pool_Address;
11168 Object_Definition =>
11170 Expression =>
11175 -- Calculate the size of the dereferenced object. Generate:
11177 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11179 Deref :=
11190 Object_Definition =>
11193 Expression =>
11195 Left_Opnd =>
11199 Right_Opnd =>
11202 -- Calculate the alignment of the dereferenced object. Generate:
11203 -- Alig : constant Storage_Count := <N>.all'Alignment;
11205 Deref :=
11215 Object_Definition =>
11217 Expression =>
11222 -- A dereference of a controlled object requires special processing. The
11223 -- finalization machinery requests additional space from the underlying
11224 -- pool to allocate and hide two pointers. As a result, a checked pool
11225 -- may mark the wrong memory as valid. Since checked pools do not have
11226 -- knowledge of hidden pointers, we have to bring the two pointers back
11227 -- in view in order to restore the original state of the object.
11231 -- Adjust the address and size of the dereferenced object. Generate:
11232 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11234 Stmt :=
11236 Name =>
11243 -- Class-wide types complicate things because we cannot determine
11244 -- statically whether the actual object is truly controlled. We must
11245 -- generate a runtime check to detect this property. Generate:
11246 --
11247 -- if Needs_Finalization (<N>.all'Tag) then
11248 -- <Stmt>;
11249 -- end if;
11252 Deref :=
11257 Stmt :=
11259 Condition =>
11261 Name =>
11273 -- Generate:
11274 -- Dereference (Pool, Addr, Size, Alig);
11278 Name =>
11279 New_Reference_To
11287 -- Mark the explicit dereference as processed to avoid potential
11288 -- infinite expansion.
11292 exception
11297 --------------------------------
11298 -- Integer_Promotion_Possible --
11299 --------------------------------
11306 begin
11309 return
11311 -- We only do the transformation for source constructs. We assume
11312 -- that the expander knows what it is doing when it generates code.
11316 -- If the operand type is Short_Integer or Short_Short_Integer,
11317 -- then we will promote to Integer, which is available on all
11318 -- targets, and is sufficient to ensure no intermediate overflow.
11319 -- Furthermore it is likely to be as efficient or more efficient
11320 -- than using the smaller type for the computation so we do this
11321 -- unconditionally.
11323 and then
11325 or else
11328 -- Test for interesting operation, which includes addition,
11329 -- division, exponentiation, multiplication, subtraction, absolute
11330 -- value and unary negation. Unary "+" is omitted since it is a
11331 -- no-op and thus can't overflow.
11334 N_Op_Add,
11335 N_Op_Divide,
11336 N_Op_Expon,
11337 N_Op_Minus,
11338 N_Op_Multiply,
11339 N_Op_Subtract);
11342 ------------------------------
11343 -- Make_Array_Comparison_Op --
11344 ------------------------------
11346 -- This is a hand-coded expansion of the following generic function:
11348 -- generic
11349 -- type elem is (<>);
11350 -- type index is (<>);
11351 -- type a is array (index range <>) of elem;
11353 -- function Gnnn (X : a; Y: a) return boolean is
11354 -- J : index := Y'first;
11356 -- begin
11357 -- if X'length = 0 then
11358 -- return false;
11360 -- elsif Y'length = 0 then
11361 -- return true;
11363 -- else
11364 -- for I in X'range loop
11365 -- if X (I) = Y (J) then
11366 -- if J = Y'last then
11367 -- exit;
11368 -- else
11369 -- J := index'succ (J);
11370 -- end if;
11372 -- else
11373 -- return X (I) > Y (J);
11374 -- end if;
11375 -- end loop;
11377 -- return X'length > Y'length;
11378 -- end if;
11379 -- end Gnnn;
11381 -- Note that since we are essentially doing this expansion by hand, we
11382 -- do not need to generate an actual or formal generic part, just the
11383 -- instantiated function itself.
11385 function Make_Array_Comparison_Op
11388 is
11409 begin
11410 -- if J = Y'last then
11411 -- exit;
11412 -- else
11413 -- J := index'succ (J);
11414 -- end if;
11416 Inner_If :=
11418 Condition =>
11421 Right_Opnd =>
11429 Else_Statements =>
11430 New_List (
11433 Expression =>
11439 -- if X (I) = Y (J) then
11440 -- if ... end if;
11441 -- else
11442 -- return X (I) > Y (J);
11443 -- end if;
11445 Loop_Body :=
11447 Condition =>
11449 Left_Opnd =>
11454 Right_Opnd =>
11463 Expression =>
11465 Left_Opnd =>
11470 Right_Opnd =>
11476 -- for I in X'range loop
11477 -- if ... end if;
11478 -- end loop;
11480 Loop_Statement :=
11484 Iteration_Scheme =>
11486 Loop_Parameter_Specification =>
11489 Discrete_Subtype_Definition =>
11496 -- if X'length = 0 then
11497 -- return false;
11498 -- elsif Y'length = 0 then
11499 -- return true;
11500 -- else
11501 -- for ... loop ... end loop;
11502 -- return X'length > Y'length;
11503 -- end if;
11505 Length1 :=
11510 Length2 :=
11515 Final_Expr :=
11520 If_Stat :=
11522 Condition =>
11524 Left_Opnd =>
11528 Right_Opnd =>
11531 Then_Statements =>
11532 New_List (
11538 Condition =>
11540 Left_Opnd =>
11544 Right_Opnd =>
11547 Then_Statements =>
11548 New_List (
11553 Loop_Statement,
11557 -- (X : a; Y: a)
11568 -- function Gnnn (...) return boolean is
11569 -- J : index := Y'first;
11570 -- begin
11571 -- if ... end if;
11572 -- end Gnnn;
11576 Func_Body :=
11578 Specification =>
11588 Expression =>
11593 Handled_Statement_Sequence =>
11600 ---------------------------
11601 -- Make_Boolean_Array_Op --
11602 ---------------------------
11604 -- For logical operations on boolean arrays, expand in line the following,
11605 -- replacing 'and' with 'or' or 'xor' where needed:
11607 -- function Annn (A : typ; B: typ) return typ is
11608 -- C : typ;
11609 -- begin
11610 -- for J in A'range loop
11611 -- C (J) := A (J) op B (J);
11612 -- end loop;
11613 -- return C;
11614 -- end Annn;
11616 -- Here typ is the boolean array type
11618 function Make_Boolean_Array_Op
11621 is
11639 begin
11640 A_J :=
11645 B_J :=
11650 C_J :=
11656 Op :=
11662 Op :=
11667 else
11668 Op :=
11674 Loop_Statement :=
11678 Iteration_Scheme =>
11680 Loop_Parameter_Specification =>
11683 Discrete_Subtype_Definition =>
11705 Func_Body :=
11707 Specification =>
11718 Handled_Statement_Sequence =>
11721 Loop_Statement,
11728 -----------------------------------------
11729 -- Minimized_Eliminated_Overflow_Check --
11730 -----------------------------------------
11733 begin
11734 return
11739 --------------------------------
11740 -- Optimize_Length_Comparison --
11741 --------------------------------
11750 -- First and Last attribute reference nodes, which end up as left and
11751 -- right operands of the optimized result.
11754 -- True for comparison operand of zero
11757 -- Comparison operand, set only if Is_Zero is false
11760 -- Entity whose length is being compared
11763 -- Integer_Literal node for length attribute expression, or Empty
11764 -- if there is no such expression present.
11767 -- Type of array index to which 'Length is applied
11770 -- Kind of comparison operator, gets flipped if operands backwards
11773 -- Tests N to see if it is an optimizable comparison value (defined as
11774 -- constant zero or one, or something else where the value is known to
11775 -- be positive and in the range of 32-bits, and where the corresponding
11776 -- Length value is also known to be 32-bits. If result is true, sets
11777 -- Is_Zero, Ityp, and Comp accordingly.
11780 -- Tests if N is a length attribute applied to a simple entity. If so,
11781 -- returns True, and sets Ent to the entity, and Index to the integer
11782 -- literal provided as an attribute expression, or to Empty if none.
11783 -- Also returns True if the expression is a generated type conversion
11784 -- whose expression is of the desired form. This latter case arises
11785 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
11786 -- to check for being in range, which is not needed in this context.
11787 -- Returns False if neither condition holds.
11790 -- Given a discrete expression, returns a Long_Long_Integer typed
11791 -- expression representing the underlying value of the expression.
11792 -- This is done with an unchecked conversion to the result type. We
11793 -- use unchecked conversion to handle the enumeration type case.
11795 ----------------------
11796 -- Is_Entity_Length --
11797 ----------------------
11800 begin
11804 then
11809 else
11817 then
11820 else
11825 --------------------
11826 -- Is_Optimizable --
11827 --------------------
11836 begin
11852 -- Here we have to make sure of being within 32-bits
11856 if not OK
11859 then
11863 -- Comparison value was within range, so now we must check the index
11864 -- value to make sure it is also within 32-bits.
11885 ----------------
11886 -- Prepare_64 --
11887 ----------------
11890 begin
11894 -- Start of processing for Optimize_Length_Comparison
11896 begin
11897 -- Nothing to do if not a comparison
11903 -- Nothing to do if special -gnatd.P debug flag set
11909 -- Ent'Length op 0/1
11913 then
11916 -- 0/1 op Ent'Length
11920 then
11921 -- Flip comparison to opposite sense
11931 -- Else optimization not possible
11933 else
11937 -- Fall through if we will do the optimization
11939 -- Cases to handle:
11941 -- X'Length = 0 => X'First > X'Last
11942 -- X'Length = 1 => X'First = X'Last
11943 -- X'Length = n => X'First + (n - 1) = X'Last
11945 -- X'Length /= 0 => X'First <= X'Last
11946 -- X'Length /= 1 => X'First /= X'Last
11947 -- X'Length /= n => X'First + (n - 1) /= X'Last
11949 -- X'Length >= 0 => always true, warn
11950 -- X'Length >= 1 => X'First <= X'Last
11951 -- X'Length >= n => X'First + (n - 1) <= X'Last
11953 -- X'Length > 0 => X'First <= X'Last
11954 -- X'Length > 1 => X'First < X'Last
11955 -- X'Length > n => X'First + (n - 1) < X'Last
11957 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
11958 -- X'Length <= 1 => X'First >= X'Last
11959 -- X'Length <= n => X'First + (n - 1) >= X'Last
11961 -- X'Length < 0 => always false (warn)
11962 -- X'Length < 1 => X'First > X'Last
11963 -- X'Length < n => X'First + (n - 1) > X'Last
11965 -- Note: for the cases of n (not constant 0,1), we require that the
11966 -- corresponding index type be integer or shorter (i.e. not 64-bit),
11967 -- and the same for the comparison value. Then we do the comparison
11968 -- using 64-bit arithmetic (actually long long integer), so that we
11969 -- cannot have overflow intefering with the result.
11971 -- First deal with warning cases
11976 -- X'Length >= 0
11985 -- X'Length < 0
11995 if Constant_Condition_Warnings
11997 then
12008 -- Build the First reference we will use
12010 Left :=
12019 -- If general value case, then do the addition of (n - 1), and
12020 -- also add the needed conversions to type Long_Long_Integer.
12023 Left :=
12026 Right_Opnd =>
12032 -- Build the Last reference we will use
12034 Right :=
12043 -- If general operand, convert Last reference to Long_Long_Integer
12049 -- Check for cases to optimize
12051 -- X'Length = 0 => X'First > X'Last
12052 -- X'Length < 1 => X'First > X'Last
12053 -- X'Length < n => X'First + (n - 1) > X'Last
12057 then
12058 Result :=
12063 -- X'Length = 1 => X'First = X'Last
12064 -- X'Length = n => X'First + (n - 1) = X'Last
12067 Result :=
12072 -- X'Length /= 0 => X'First <= X'Last
12073 -- X'Length > 0 => X'First <= X'Last
12076 Result :=
12081 -- X'Length /= 1 => X'First /= X'Last
12082 -- X'Length /= n => X'First + (n - 1) /= X'Last
12085 Result :=
12090 -- X'Length >= 1 => X'First <= X'Last
12091 -- X'Length >= n => X'First + (n - 1) <= X'Last
12094 Result :=
12099 -- X'Length > 1 => X'First < X'Last
12100 -- X'Length > n => X'First + (n = 1) < X'Last
12103 Result :=
12108 -- X'Length <= 1 => X'First >= X'Last
12109 -- X'Length <= n => X'First + (n - 1) >= X'Last
12112 Result :=
12117 -- Should not happen at this stage
12119 else
12123 -- Rewrite and finish up
12130 ------------------------------
12131 -- Process_Transient_Object --
12132 ------------------------------
12134 procedure Process_Transient_Object
12137 is
12139 -- Node on which to insert the hook pointer (as an action)
12142 -- Node after which to insert finalization actions
12145 -- If False, call to finalizer includes a test of whether the
12146 -- hook pointer is null.
12149 -- Find the logical context where N appears, and initializae
12150 -- Hook_Context and Finalization_Context accordingly. Also
12151 -- sets Finalize_Always.
12153 -----------------------------
12154 -- Find_Enclosing_Contexts --
12155 -----------------------------
12162 -- Note: if we are in a transient scope, we want to reuse it as
12163 -- the context for actions insertion, if possible. But if N is itself
12164 -- part of the stored actions for the current transient scope,
12165 -- then we need to insert at the appropriate (inner) location in
12166 -- the not as an action on Node_To_Be_Wrapped.
12170 begin
12171 -- When the node is inside a case/if expression, the lifetime of any
12172 -- temporary controlled object is extended. Find a suitable insertion
12173 -- node by locating the topmost case or if expressions.
12180 N_If_Expression)
12181 then
12184 -- Prevent the search from going too far
12193 -- The topmost case or if expression is now recovered, but it may
12194 -- still not be the correct place to add generated code. Climb to
12195 -- find a parent that is part of a declarative or statement list.
12201 N_Discriminant_Association,
12202 N_Parameter_Association,
12203 N_Pragma_Argument_Association)
12204 then
12208 -- Prevent the search from going too far
12220 else
12224 -- Keep climbing past various operators
12228 then
12230 else
12237 -- The node may be located in a pragma in which case return the
12238 -- pragma itself:
12240 -- pragma Precondition (... and then Ctrl_Func_Call ...);
12242 -- Similar case occurs when the node is related to an object
12243 -- declaration or assignment:
12245 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
12247 -- Another case to consider is when the node is part of a return
12248 -- statement:
12250 -- return ... and then Ctrl_Func_Call ...;
12252 -- Another case is when the node acts as a formal in a procedure
12253 -- call statement:
12255 -- Proc (... and then Ctrl_Func_Call ...);
12259 else
12265 or else
12267 N_Object_Declaration,
12268 N_Pragma,
12269 N_Procedure_Call_Statement,
12270 N_Simple_Return_Statement)
12271 then
12275 -- Prevent the search from going too far
12284 -- Return the topmost short circuit operator
12291 -- Special case for Boolean EWAs: capture expression in a temporary,
12292 -- whose declaration will serve as the context around which to insert
12293 -- finalization code. The finalization thus remains local to the
12294 -- specific condition being evaluated.
12298 -- In this case, the finalization context is chosen so that
12299 -- we know at finalization point that the hook pointer is
12300 -- never null, so no need for a test, we can call the finalizer
12301 -- unconditionally, except in the case where the object is
12302 -- created in a specific branch of a conditional expression.
12304 Finalize_Always :=
12306 or else
12308 N_If_Expression));
12310 declare
12313 begin
12318 Object_Definition =>
12329 else
12335 -- Local variables
12346 -- Start of processing for Process_Transient_Object
12348 begin
12351 -- Step 1: Create the access type which provides a reference to the
12352 -- transient controlled object.
12356 else
12362 -- Generate:
12363 -- Ann : access [all] <Desig_Typ>;
12370 Type_Definition =>
12375 -- Step 2: Create a temporary which acts as a hook to the transient
12376 -- controlled object. Generate:
12378 -- Temp : Ptr_Id := null;
12387 -- Mark the temporary as created for the purposes of exporting the
12388 -- transient controlled object out of the expression_with_action or if
12389 -- expression. This signals the machinery in Build_Finalizer to treat
12390 -- this case specially.
12394 -- Step 3: Hook the transient object to the temporary
12396 -- This must be inserted right after the object declaration, so that
12397 -- the assignment is executed if, and only if, the object is actually
12398 -- created (whereas the declaration of the hook pointer, and the
12399 -- finalization call, may be inserted at an outer level, and may
12400 -- remain unused for some executions, if the actual creation of
12401 -- the object is conditional).
12403 -- The use of unchecked conversion / unrestricted access is needed to
12404 -- avoid an accessibility violation. Note that the finalization code is
12405 -- structured in such a way that the "hook" is processed only when it
12406 -- points to an existing object.
12410 else
12411 Expr :=
12417 -- Generate:
12418 -- Temp := Ptr_Id (Obj_Id);
12419 -- <or>
12420 -- Temp := Obj_Id'Unrestricted_Access;
12427 -- Step 4: Finalize the transient controlled object after the context
12428 -- has been evaluated/elaborated. Generate:
12430 -- if Temp /= null then
12431 -- [Deep_]Finalize (Temp.all);
12432 -- Temp := null;
12433 -- end if;
12435 -- When the node is part of a return statement, there is no need to
12436 -- insert a finalization call, as the general finalization mechanism
12437 -- (see Build_Finalizer) would take care of the transient controlled
12438 -- object on subprogram exit. Note that it would also be impossible to
12439 -- insert the finalization code after the return statement as this will
12440 -- render it unreachable.
12444 Make_Final_Call
12457 Condition =>
12468 ------------------------
12469 -- Rewrite_Comparison --
12470 ------------------------
12474 -- Set to True if first pass with Assume_Valid generates a warning in
12475 -- which case we skip the second pass to avoid warning overloaded.
12478 -- Set to Standard_True or Standard_False
12480 begin
12489 -- Now start looking at the comparison in detail. We potentially go
12490 -- through this loop twice. The first time, Assume_Valid is set False
12491 -- in the call to Compile_Time_Compare. If this call results in a
12492 -- clear result of always True or Always False, that's decisive and
12493 -- we are done. Otherwise we repeat the processing with Assume_Valid
12494 -- set to True to generate additional warnings. We can skip that step
12495 -- if Constant_Condition_Warnings is False.
12498 declare
12505 -- Res indicates if compare outcome can be compile time determined
12510 begin
12521 and then Constant_Condition_Warnings
12524 and then not In_Instance
12527 then
12528 Error_Msg_N
12530 N);
12547 and then Constant_Condition_Warnings
12550 and then not In_Instance
12553 then
12554 Error_Msg_N
12564 -- If this is the first iteration, then we actually convert the
12565 -- comparison into True or False, if the result is certain.
12578 -- If this is the second iteration (AV = True), and the original
12579 -- node comes from source and we are not in an instance, then give
12580 -- a warning if we know result would be True or False. Note: we
12581 -- know Constant_Condition_Warnings is set if we get here.
12584 and then not In_Instance
12585 then
12587 Error_Msg_N
12589 N);
12591 Error_Msg_N
12593 N);
12598 -- Skip second iteration if not warning on constant conditions or
12599 -- if the first iteration already generated a warning of some kind or
12600 -- if we are in any case assuming all values are valid (so that the
12601 -- first iteration took care of the valid case).
12609 ----------------------------
12610 -- Safe_In_Place_Array_Op --
12611 ----------------------------
12613 function Safe_In_Place_Array_Op
12617 is
12621 -- Operand is safe if it cannot overlap part of the target of the
12622 -- operation. If the operand and the target are identical, the operand
12623 -- is safe. The operand can be empty in the case of negation.
12626 -- Check that N is a stand-alone entity
12628 ------------------
12629 -- Is_Unaliased --
12630 ------------------
12633 begin
12634 return
12640 ---------------------
12641 -- Is_Safe_Operand --
12642 ---------------------
12645 begin
12656 return
12663 else
12668 -- Start of processing for Safe_In_Place_Array_Op
12670 begin
12671 -- Skip this processing if the component size is different from system
12672 -- storage unit (since at least for NOT this would cause problems).
12677 -- Cannot do in place stuff on VM_Target since cannot pass addresses
12682 -- Cannot do in place stuff if non-standard Boolean representation
12690 else
12696 -----------------------
12697 -- Tagged_Membership --
12698 -----------------------
12700 -- There are two different cases to consider depending on whether the right
12701 -- operand is a class-wide type or not. If not we just compare the actual
12702 -- tag of the left expr to the target type tag:
12703 --
12704 -- Left_Expr.Tag = Right_Type'Tag;
12705 --
12706 -- If it is a class-wide type we use the RT function CW_Membership which is
12707 -- usually implemented by looking in the ancestor tables contained in the
12708 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
12710 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
12711 -- function IW_Membership which is usually implemented by looking in the
12712 -- table of abstract interface types plus the ancestor table contained in
12713 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
12715 procedure Tagged_Membership
12719 is
12730 begin
12733 -- Handle entities from the limited view
12738 -- In the case where the type is an access type, the test is applied
12739 -- using the designated types (needed in Ada 2012 for implicit anonymous
12740 -- access conversions, for AI05-0149).
12753 else
12757 Obj_Tag :=
12760 Selector_Name =>
12765 -- No need to issue a run-time check if we statically know that the
12766 -- result of this membership test is always true. For example,
12767 -- considering the following declarations:
12769 -- type Iface is interface;
12770 -- type T is tagged null record;
12771 -- type DT is new T and Iface with null record;
12773 -- Obj1 : T;
12774 -- Obj2 : DT;
12776 -- These membership tests are always true:
12778 -- Obj1 in T'Class
12779 -- Obj2 in T'Class;
12780 -- Obj2 in Iface'Class;
12782 -- We do not need to handle cases where the membership is illegal.
12783 -- For example:
12785 -- Obj1 in DT'Class; -- Compile time error
12786 -- Obj1 in Iface'Class; -- Compile time error
12792 and then Interface_Present_In_Ancestor
12795 then
12800 -- Ada 2005 (AI-251): Class-wide applied to interfaces
12804 -- Support to: "Iface_CW_Typ in Typ'Class"
12807 then
12808 -- Issue error if IW_Membership operation not available in a
12809 -- configurable run time setting.
12812 Error_Msg_CRT
12818 Result :=
12825 New_Reference_To (
12827 Loc)));
12829 -- Ada 95: Normal case
12831 else
12834 Typ_Tag_Node =>
12835 New_Reference_To (
12840 -- Generate the SCIL node for this class-wide membership test.
12841 -- Done here because the previous call to Build_CW_Membership
12842 -- relocates Obj_Tag.
12853 -- Right_Type is not a class-wide type
12855 else
12856 -- No need to check the tag of the object if Right_Typ is abstract
12861 else
12862 Result :=
12865 Right_Opnd =>
12866 New_Reference_To
12872 ------------------------------
12873 -- Unary_Op_Validity_Checks --
12874 ------------------------------
12877 begin