1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Aggr
; use Exp_Aggr
;
33 with Exp_Atag
; use Exp_Atag
;
34 with Exp_Ch3
; use Exp_Ch3
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch7
; use Exp_Ch7
;
37 with Exp_Ch9
; use Exp_Ch9
;
38 with Exp_Disp
; use Exp_Disp
;
39 with Exp_Fixd
; use Exp_Fixd
;
40 with Exp_Intr
; use Exp_Intr
;
41 with Exp_Pakd
; use Exp_Pakd
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
45 with Inline
; use Inline
;
46 with Namet
; use Namet
;
47 with Nlists
; use Nlists
;
48 with Nmake
; use Nmake
;
50 with Par_SCO
; use Par_SCO
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Cat
; use Sem_Cat
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch13
; use Sem_Ch13
;
59 with Sem_Eval
; use Sem_Eval
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Type
; use Sem_Type
;
62 with Sem_Util
; use Sem_Util
;
63 with Sem_Warn
; use Sem_Warn
;
64 with Sinfo
; use Sinfo
;
65 with Snames
; use Snames
;
66 with Stand
; use Stand
;
67 with SCIL_LL
; use SCIL_LL
;
68 with Targparm
; use Targparm
;
69 with Tbuild
; use Tbuild
;
70 with Ttypes
; use Ttypes
;
71 with Uintp
; use Uintp
;
72 with Urealp
; use Urealp
;
73 with Validsw
; use Validsw
;
74 with Warnsw
; use Warnsw
;
76 package body Exp_Ch4
is
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
83 pragma Inline
(Binary_Op_Validity_Checks
);
84 -- Performs validity checks for a binary operator
86 procedure Build_Boolean_Array_Proc_Call
90 -- If a boolean array assignment can be done in place, build call to
91 -- corresponding library procedure.
93 procedure Displace_Allocator_Pointer
(N
: Node_Id
);
94 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
95 -- Expand_Allocator_Expression. Allocating class-wide interface objects
96 -- this routine displaces the pointer to the allocated object to reference
97 -- the component referencing the corresponding secondary dispatch table.
99 procedure Expand_Allocator_Expression
(N
: Node_Id
);
100 -- Subsidiary to Expand_N_Allocator, for the case when the expression
101 -- is a qualified expression.
103 procedure Expand_Array_Comparison
(N
: Node_Id
);
104 -- This routine handles expansion of the comparison operators (N_Op_Lt,
105 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
106 -- code for these operators is similar, differing only in the details of
107 -- the actual comparison call that is made. Special processing (call a
110 function Expand_Array_Equality
115 Typ
: Entity_Id
) return Node_Id
;
116 -- Expand an array equality into a call to a function implementing this
117 -- equality, and a call to it. Loc is the location for the generated nodes.
118 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
119 -- on which to attach bodies of local functions that are created in the
120 -- process. It is the responsibility of the caller to insert those bodies
121 -- at the right place. Nod provides the Sloc value for the generated code.
122 -- Normally the types used for the generated equality routine are taken
123 -- from Lhs and Rhs. However, in some situations of generated code, the
124 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
125 -- the type to be used for the formal parameters.
127 procedure Expand_Boolean_Operator
(N
: Node_Id
);
128 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
129 -- case of array type arguments.
131 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
);
132 -- When generating C code, convert nonbinary modular arithmetic operations
133 -- into code that relies on the front-end expansion of operator Mod. No
134 -- expansion is performed if N is not a nonbinary modular operand.
136 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
);
137 -- Common expansion processing for short-circuit boolean operators
139 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
);
140 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
141 -- where we allow comparison of "out of range" values.
143 function Expand_Composite_Equality
148 Bodies
: List_Id
) return Node_Id
;
149 -- Local recursive function used to expand equality for nested composite
150 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
151 -- to attach bodies of local functions that are created in the process. It
152 -- is the responsibility of the caller to insert those bodies at the right
153 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
154 -- the left and right sides for the comparison, and Typ is the type of the
155 -- objects to compare.
157 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
158 -- Routine to expand concatenation of a sequence of two or more operands
159 -- (in the list Operands) and replace node Cnode with the result of the
160 -- concatenation. The operands can be of any appropriate type, and can
161 -- include both arrays and singleton elements.
163 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
);
164 -- N is an N_In membership test mode, with the overflow check mode set to
165 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
166 -- integer type. This is a case where top level processing is required to
167 -- handle overflow checks in subtrees.
169 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
170 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
171 -- fixed. We do not have such a type at runtime, so the purpose of this
172 -- routine is to find the real type by looking up the tree. We also
173 -- determine if the operation must be rounded.
175 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
176 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
177 -- discriminants if it has a constrained nominal type, unless the object
178 -- is a component of an enclosing Unchecked_Union object that is subject
179 -- to a per-object constraint and the enclosing object lacks inferable
182 -- An expression of an Unchecked_Union type has inferable discriminants
183 -- if it is either a name of an object with inferable discriminants or a
184 -- qualified expression whose subtype mark denotes a constrained subtype.
186 procedure Insert_Dereference_Action
(N
: Node_Id
);
187 -- N is an expression whose type is an access. When the type of the
188 -- associated storage pool is derived from Checked_Pool, generate a
189 -- call to the 'Dereference' primitive operation.
191 function Make_Array_Comparison_Op
193 Nod
: Node_Id
) return Node_Id
;
194 -- Comparisons between arrays are expanded in line. This function produces
195 -- the body of the implementation of (a > b), where a and b are one-
196 -- dimensional arrays of some discrete type. The original node is then
197 -- expanded into the appropriate call to this function. Nod provides the
198 -- Sloc value for the generated code.
200 function Make_Boolean_Array_Op
202 N
: Node_Id
) return Node_Id
;
203 -- Boolean operations on boolean arrays are expanded in line. This function
204 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
205 -- b). It is used only the normal case and not the packed case. The type
206 -- involved, Typ, is the Boolean array type, and the logical operations in
207 -- the body are simple boolean operations. Note that Typ is always a
208 -- constrained type (the caller has ensured this by using
209 -- Convert_To_Actual_Subtype if necessary).
211 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean;
212 -- For signed arithmetic operations when the current overflow mode is
213 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
214 -- as the first thing we do. We then return. We count on the recursive
215 -- apparatus for overflow checks to call us back with an equivalent
216 -- operation that is in CHECKED mode, avoiding a recursive entry into this
217 -- routine, and that is when we will proceed with the expansion of the
218 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
219 -- these optimizations without first making this check, since there may be
220 -- operands further down the tree that are relying on the recursive calls
221 -- triggered by the top level nodes to properly process overflow checking
222 -- and remaining expansion on these nodes. Note that this call back may be
223 -- skipped if the operation is done in Bignum mode but that's fine, since
224 -- the Bignum call takes care of everything.
226 procedure Narrow_Large_Operation
(N
: Node_Id
);
227 -- Try to compute the result of a large operation in a narrower type than
228 -- its nominal type. This is mainly aimed at getting rid of operations done
229 -- in Universal_Integer that can be generated for attributes.
231 procedure Optimize_Length_Comparison
(N
: Node_Id
);
232 -- Given an expression, if it is of the form X'Length op N (or the other
233 -- way round), where N is known at compile time to be 0 or 1, or something
234 -- else where the value is known to be nonnegative and in the 32-bit range,
235 -- and X is a simple entity, and op is a comparison operator, optimizes it
236 -- into a comparison of X'First and X'Last.
238 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
);
239 -- Inspect and process statement list Stmt of if or case expression N for
240 -- transient objects. If such objects are found, the routine generates code
241 -- to clean them up when the context of the expression is evaluated.
243 procedure Process_Transient_In_Expression
247 -- Subsidiary routine to the expansion of expression_with_actions, if and
248 -- case expressions. Generate all necessary code to finalize a transient
249 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
250 -- denotes the declaration of the transient object, which is usually the
251 -- result of a controlled function call. Expr denotes the expression with
252 -- actions, if expression, or case expression node. Stmts denotes the
253 -- statement list which contains Decl, either at the top level or within a
256 procedure Rewrite_Comparison
(N
: Node_Id
);
257 -- If N is the node for a comparison whose outcome can be determined at
258 -- compile time, then the node N can be rewritten with True or False. If
259 -- the outcome cannot be determined at compile time, the call has no
260 -- effect. If N is a type conversion, then this processing is applied to
261 -- its expression. If N is neither comparison nor a type conversion, the
262 -- call has no effect.
264 procedure Tagged_Membership
266 SCIL_Node
: out Node_Id
;
267 Result
: out Node_Id
);
268 -- Construct the expression corresponding to the tagged membership test.
269 -- Deals with a second operand being (or not) a class-wide type.
271 function Safe_In_Place_Array_Op
274 Op2
: Node_Id
) return Boolean;
275 -- In the context of an assignment, where the right-hand side is a boolean
276 -- operation on arrays, check whether operation can be performed in place.
278 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
279 pragma Inline
(Unary_Op_Validity_Checks
);
280 -- Performs validity checks for a unary operator
282 -------------------------------
283 -- Binary_Op_Validity_Checks --
284 -------------------------------
286 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
288 if Validity_Checks_On
and Validity_Check_Operands
then
289 Ensure_Valid
(Left_Opnd
(N
));
290 Ensure_Valid
(Right_Opnd
(N
));
292 end Binary_Op_Validity_Checks
;
294 ------------------------------------
295 -- Build_Boolean_Array_Proc_Call --
296 ------------------------------------
298 procedure Build_Boolean_Array_Proc_Call
303 Loc
: constant Source_Ptr
:= Sloc
(N
);
304 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
305 Target
: constant Node_Id
:=
306 Make_Attribute_Reference
(Loc
,
308 Attribute_Name
=> Name_Address
);
310 Arg1
: Node_Id
:= Op1
;
311 Arg2
: Node_Id
:= Op2
;
313 Proc_Name
: Entity_Id
;
316 if Kind
= N_Op_Not
then
317 if Nkind
(Op1
) in N_Binary_Op
then
319 -- Use negated version of the binary operators
321 if Nkind
(Op1
) = N_Op_And
then
322 Proc_Name
:= RTE
(RE_Vector_Nand
);
324 elsif Nkind
(Op1
) = N_Op_Or
then
325 Proc_Name
:= RTE
(RE_Vector_Nor
);
327 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
328 Proc_Name
:= RTE
(RE_Vector_Xor
);
332 Make_Procedure_Call_Statement
(Loc
,
333 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
335 Parameter_Associations
=> New_List
(
337 Make_Attribute_Reference
(Loc
,
338 Prefix
=> Left_Opnd
(Op1
),
339 Attribute_Name
=> Name_Address
),
341 Make_Attribute_Reference
(Loc
,
342 Prefix
=> Right_Opnd
(Op1
),
343 Attribute_Name
=> Name_Address
),
345 Make_Attribute_Reference
(Loc
,
346 Prefix
=> Left_Opnd
(Op1
),
347 Attribute_Name
=> Name_Length
)));
350 Proc_Name
:= RTE
(RE_Vector_Not
);
353 Make_Procedure_Call_Statement
(Loc
,
354 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
355 Parameter_Associations
=> New_List
(
358 Make_Attribute_Reference
(Loc
,
360 Attribute_Name
=> Name_Address
),
362 Make_Attribute_Reference
(Loc
,
364 Attribute_Name
=> Name_Length
)));
368 -- We use the following equivalences:
370 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
371 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
372 -- (not X) xor (not Y) = X xor Y
373 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
375 if Nkind
(Op1
) = N_Op_Not
then
376 Arg1
:= Right_Opnd
(Op1
);
377 Arg2
:= Right_Opnd
(Op2
);
379 if Kind
= N_Op_And
then
380 Proc_Name
:= RTE
(RE_Vector_Nor
);
381 elsif Kind
= N_Op_Or
then
382 Proc_Name
:= RTE
(RE_Vector_Nand
);
384 Proc_Name
:= RTE
(RE_Vector_Xor
);
388 if Kind
= N_Op_And
then
389 Proc_Name
:= RTE
(RE_Vector_And
);
390 elsif Kind
= N_Op_Or
then
391 Proc_Name
:= RTE
(RE_Vector_Or
);
392 elsif Nkind
(Op2
) = N_Op_Not
then
393 Proc_Name
:= RTE
(RE_Vector_Nxor
);
394 Arg2
:= Right_Opnd
(Op2
);
396 Proc_Name
:= RTE
(RE_Vector_Xor
);
401 Make_Procedure_Call_Statement
(Loc
,
402 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
403 Parameter_Associations
=> New_List
(
405 Make_Attribute_Reference
(Loc
,
407 Attribute_Name
=> Name_Address
),
408 Make_Attribute_Reference
(Loc
,
410 Attribute_Name
=> Name_Address
),
411 Make_Attribute_Reference
(Loc
,
413 Attribute_Name
=> Name_Length
)));
416 Rewrite
(N
, Call_Node
);
420 when RE_Not_Available
=>
422 end Build_Boolean_Array_Proc_Call
;
424 -----------------------
426 -----------------------
428 function Build_Eq_Call
432 Rhs
: Node_Id
) return Node_Id
438 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
439 while Present
(Prim_E
) loop
440 Prim
:= Node
(Prim_E
);
442 -- Locate primitive equality with the right signature
444 if Chars
(Prim
) = Name_Op_Eq
445 and then Etype
(First_Formal
(Prim
)) =
446 Etype
(Next_Formal
(First_Formal
(Prim
)))
447 and then Etype
(Prim
) = Standard_Boolean
449 if Is_Abstract_Subprogram
(Prim
) then
451 Make_Raise_Program_Error
(Loc
,
452 Reason
=> PE_Explicit_Raise
);
456 Make_Function_Call
(Loc
,
457 Name
=> New_Occurrence_Of
(Prim
, Loc
),
458 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
465 -- If not found, predefined operation will be used
470 --------------------------------
471 -- Displace_Allocator_Pointer --
472 --------------------------------
474 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
475 Loc
: constant Source_Ptr
:= Sloc
(N
);
476 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
482 -- Do nothing in case of VM targets: the virtual machine will handle
483 -- interfaces directly.
485 if not Tagged_Type_Expansion
then
489 pragma Assert
(Nkind
(N
) = N_Identifier
490 and then Nkind
(Orig_Node
) = N_Allocator
);
492 PtrT
:= Etype
(Orig_Node
);
493 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
494 Etyp
:= Etype
(Expression
(Orig_Node
));
496 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
498 -- If the type of the allocator expression is not an interface type
499 -- we can generate code to reference the record component containing
500 -- the pointer to the secondary dispatch table.
502 if not Is_Interface
(Etyp
) then
504 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
507 -- 1) Get access to the allocated object
510 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
514 -- 2) Add the conversion to displace the pointer to reference
515 -- the secondary dispatch table.
517 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
518 Analyze_And_Resolve
(N
, Dtyp
);
520 -- 3) The 'access to the secondary dispatch table will be used
521 -- as the value returned by the allocator.
524 Make_Attribute_Reference
(Loc
,
525 Prefix
=> Relocate_Node
(N
),
526 Attribute_Name
=> Name_Access
));
527 Set_Etype
(N
, Saved_Typ
);
531 -- If the type of the allocator expression is an interface type we
532 -- generate a run-time call to displace "this" to reference the
533 -- component containing the pointer to the secondary dispatch table
534 -- or else raise Constraint_Error if the actual object does not
535 -- implement the target interface. This case corresponds to the
536 -- following example:
538 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
540 -- return new Iface_2'Class'(Obj);
545 Unchecked_Convert_To
(PtrT
,
546 Make_Function_Call
(Loc
,
547 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
548 Parameter_Associations
=> New_List
(
549 Unchecked_Convert_To
(RTE
(RE_Address
),
555 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
557 Analyze_And_Resolve
(N
, PtrT
);
560 end Displace_Allocator_Pointer
;
562 ---------------------------------
563 -- Expand_Allocator_Expression --
564 ---------------------------------
566 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
567 Loc
: constant Source_Ptr
:= Sloc
(N
);
568 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
569 PtrT
: constant Entity_Id
:= Etype
(N
);
570 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
572 procedure Apply_Accessibility_Check
574 Built_In_Place
: Boolean := False);
575 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
576 -- type, generate an accessibility check to verify that the level of the
577 -- type of the created object is not deeper than the level of the access
578 -- type. If the type of the qualified expression is class-wide, then
579 -- always generate the check (except in the case where it is known to be
580 -- unnecessary, see comment below). Otherwise, only generate the check
581 -- if the level of the qualified expression type is statically deeper
582 -- than the access type.
584 -- Although the static accessibility will generally have been performed
585 -- as a legality check, it won't have been done in cases where the
586 -- allocator appears in generic body, so a run-time check is needed in
587 -- general. One special case is when the access type is declared in the
588 -- same scope as the class-wide allocator, in which case the check can
589 -- never fail, so it need not be generated.
591 -- As an open issue, there seem to be cases where the static level
592 -- associated with the class-wide object's underlying type is not
593 -- sufficient to perform the proper accessibility check, such as for
594 -- allocators in nested subprograms or accept statements initialized by
595 -- class-wide formals when the actual originates outside at a deeper
596 -- static level. The nested subprogram case might require passing
597 -- accessibility levels along with class-wide parameters, and the task
598 -- case seems to be an actual gap in the language rules that needs to
599 -- be fixed by the ARG. ???
601 -------------------------------
602 -- Apply_Accessibility_Check --
603 -------------------------------
605 procedure Apply_Accessibility_Check
607 Built_In_Place
: Boolean := False)
609 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
617 if Ada_Version
>= Ada_2005
618 and then Is_Class_Wide_Type
(DesigT
)
619 and then Tagged_Type_Expansion
620 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
622 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
624 (Is_Class_Wide_Type
(Etype
(Exp
))
625 and then Scope
(PtrT
) /= Current_Scope
))
627 -- If the allocator was built in place, Ref is already a reference
628 -- to the access object initialized to the result of the allocator
629 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
630 -- Remove_Side_Effects for cases where the build-in-place call may
631 -- still be the prefix of the reference (to avoid generating
632 -- duplicate calls). Otherwise, it is the entity associated with
633 -- the object containing the address of the allocated object.
635 if Built_In_Place
then
636 Remove_Side_Effects
(Ref
);
637 Obj_Ref
:= New_Copy_Tree
(Ref
);
639 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
642 -- For access to interface types we must generate code to displace
643 -- the pointer to the base of the object since the subsequent code
644 -- references components located in the TSD of the object (which
645 -- is associated with the primary dispatch table --see a-tags.ads)
646 -- and also generates code invoking Free, which requires also a
647 -- reference to the base of the unallocated object.
649 if Is_Interface
(DesigT
) and then Tagged_Type_Expansion
then
651 Unchecked_Convert_To
(Etype
(Obj_Ref
),
652 Make_Function_Call
(Loc
,
654 New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
655 Parameter_Associations
=> New_List
(
656 Unchecked_Convert_To
(RTE
(RE_Address
),
657 New_Copy_Tree
(Obj_Ref
)))));
660 -- Step 1: Create the object clean up code
664 -- Deallocate the object if the accessibility check fails. This
665 -- is done only on targets or profiles that support deallocation.
669 if RTE_Available
(RE_Free
) then
670 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
671 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
673 Append_To
(Stmts
, Free_Stmt
);
675 -- The target or profile cannot deallocate objects
681 -- Finalize the object if applicable. Generate:
683 -- [Deep_]Finalize (Obj_Ref.all);
685 if Needs_Finalization
(DesigT
)
686 and then not No_Heap_Finalization
(PtrT
)
691 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
694 -- Guard against a missing [Deep_]Finalize when the designated
695 -- type was not properly frozen.
697 if No
(Fin_Call
) then
698 Fin_Call
:= Make_Null_Statement
(Loc
);
701 -- When the target or profile supports deallocation, wrap the
702 -- finalization call in a block to ensure proper deallocation
703 -- even if finalization fails. Generate:
713 if Present
(Free_Stmt
) then
715 Make_Block_Statement
(Loc
,
716 Handled_Statement_Sequence
=>
717 Make_Handled_Sequence_Of_Statements
(Loc
,
718 Statements
=> New_List
(Fin_Call
),
720 Exception_Handlers
=> New_List
(
721 Make_Exception_Handler
(Loc
,
722 Exception_Choices
=> New_List
(
723 Make_Others_Choice
(Loc
)),
724 Statements
=> New_List
(
725 New_Copy_Tree
(Free_Stmt
),
726 Make_Raise_Statement
(Loc
))))));
729 Prepend_To
(Stmts
, Fin_Call
);
732 -- Signal the accessibility failure through a Program_Error
735 Make_Raise_Program_Error
(Loc
,
736 Condition
=> New_Occurrence_Of
(Standard_True
, Loc
),
737 Reason
=> PE_Accessibility_Check_Failed
));
739 -- Step 2: Create the accessibility comparison
745 Make_Attribute_Reference
(Loc
,
747 Attribute_Name
=> Name_Tag
);
749 -- For tagged types, determine the accessibility level by looking
750 -- at the type specific data of the dispatch table. Generate:
752 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
754 if Tagged_Type_Expansion
then
755 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
757 -- Use a runtime call to determine the accessibility level when
758 -- compiling on virtual machine targets. Generate:
760 -- Get_Access_Level (Ref'Tag)
764 Make_Function_Call
(Loc
,
766 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
767 Parameter_Associations
=> New_List
(Obj_Ref
));
774 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
776 -- Due to the complexity and side effects of the check, utilize an
777 -- if statement instead of the regular Program_Error circuitry.
780 Make_Implicit_If_Statement
(N
,
782 Then_Statements
=> Stmts
));
784 end Apply_Accessibility_Check
;
788 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
789 T
: constant Entity_Id
:= Entity
(Indic
);
791 Aggr_In_Place
: Boolean;
793 Tag_Assign
: Node_Id
;
797 TagT
: Entity_Id
:= Empty
;
798 -- Type used as source for tag assignment
800 TagR
: Node_Id
:= Empty
;
801 -- Target reference for tag assignment
803 -- Start of processing for Expand_Allocator_Expression
806 -- Handle call to C++ constructor
808 if Is_CPP_Constructor_Call
(Exp
) then
809 Make_CPP_Constructor_Call_In_Allocator
811 Function_Call
=> Exp
);
816 -- type A is access T1;
817 -- X : A := new T2'(...);
818 -- T1 and T2 can be different subtypes, and we might need to check
819 -- both constraints. First check against the type of the qualified
822 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
824 Apply_Predicate_Check
(Exp
, T
);
826 -- Check that any anonymous access discriminants are suitable
827 -- for use in an allocator.
829 -- Note: This check is performed here instead of during analysis so that
830 -- we can check against the fully resolved etype of Exp.
832 if Is_Entity_Name
(Exp
)
833 and then Has_Anonymous_Access_Discriminant
(Etype
(Exp
))
834 and then Static_Accessibility_Level
(Exp
, Object_Decl_Level
)
835 > Static_Accessibility_Level
(N
, Object_Decl_Level
)
837 -- A dynamic check and a warning are generated when we are within
842 Make_Raise_Program_Error
(Loc
,
843 Reason
=> PE_Accessibility_Check_Failed
));
845 Error_Msg_N
("anonymous access discriminant is too deep for use"
846 & " in allocator<<", N
);
847 Error_Msg_N
("\Program_Error [<<", N
);
849 -- Otherwise, make the error static
852 Error_Msg_N
("anonymous access discriminant is too deep for use"
853 & " in allocator", N
);
857 if Do_Range_Check
(Exp
) then
858 Generate_Range_Check
(Exp
, T
, CE_Range_Check_Failed
);
861 -- A check is also needed in cases where the designated subtype is
862 -- constrained and differs from the subtype given in the qualified
863 -- expression. Note that the check on the qualified expression does
864 -- not allow sliding, but this check does (a relaxation from Ada 83).
866 if Is_Constrained
(DesigT
)
867 and then not Subtypes_Statically_Match
(T
, DesigT
)
869 Apply_Constraint_Check
(Exp
, DesigT
, No_Sliding
=> False);
871 Apply_Predicate_Check
(Exp
, DesigT
);
873 if Do_Range_Check
(Exp
) then
874 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
878 if Nkind
(Exp
) = N_Raise_Constraint_Error
then
879 Rewrite
(N
, New_Copy
(Exp
));
884 Aggr_In_Place
:= Is_Delayed_Aggregate
(Exp
);
886 -- Case of tagged type or type requiring finalization
888 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
890 -- Ada 2005 (AI-318-02): If the initialization expression is a call
891 -- to a build-in-place function, then access to the allocated object
892 -- must be passed to the function.
894 if Is_Build_In_Place_Function_Call
(Exp
) then
895 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
896 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
899 -- Ada 2005 (AI-318-02): Specialization of the previous case for
900 -- expressions containing a build-in-place function call whose
901 -- returned object covers interface types, and Expr has calls to
902 -- Ada.Tags.Displace to displace the pointer to the returned build-
903 -- in-place object to reference the secondary dispatch table of a
904 -- covered interface type.
906 elsif Present
(Unqual_BIP_Iface_Function_Call
(Exp
)) then
907 Make_Build_In_Place_Iface_Call_In_Allocator
(N
, Exp
);
908 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
912 -- Actions inserted before:
913 -- Temp : constant ptr_T := new T'(Expression);
914 -- Temp._tag = T'tag; -- when not class-wide
915 -- [Deep_]Adjust (Temp.all);
917 -- We analyze by hand the new internal allocator to avoid any
918 -- recursion and inappropriate call to Initialize.
920 -- We don't want to remove side effects when the expression must be
921 -- built in place. In the case of a build-in-place function call,
922 -- that could lead to a duplication of the call, which was already
923 -- substituted for the allocator.
925 if not Aggr_In_Place
then
926 Remove_Side_Effects
(Exp
);
929 Temp
:= Make_Temporary
(Loc
, 'P', N
);
931 -- For a class wide allocation generate the following code:
933 -- type Equiv_Record is record ... end record;
934 -- implicit subtype CW is <Class_Wide_Subytpe>;
935 -- temp : PtrT := new CW'(CW!(expr));
937 if Is_Class_Wide_Type
(T
) then
938 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
940 -- Ada 2005 (AI-251): If the expression is a class-wide interface
941 -- object we generate code to move up "this" to reference the
942 -- base of the object before allocating the new object.
944 -- Note that Exp'Address is recursively expanded into a call
945 -- to Base_Address (Exp.Tag)
947 if Is_Class_Wide_Type
(Etype
(Exp
))
948 and then Is_Interface
(Etype
(Exp
))
949 and then Tagged_Type_Expansion
953 Unchecked_Convert_To
(Entity
(Indic
),
954 Make_Explicit_Dereference
(Loc
,
955 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
956 Make_Attribute_Reference
(Loc
,
958 Attribute_Name
=> Name_Address
)))));
962 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
965 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
968 -- Processing for allocators returning non-interface types
970 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
971 if Aggr_In_Place
then
973 Make_Object_Declaration
(Loc
,
974 Defining_Identifier
=> Temp
,
975 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
979 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
981 -- Copy the Comes_From_Source flag for the allocator we just
982 -- built, since logically this allocator is a replacement of
983 -- the original allocator node. This is for proper handling of
984 -- restriction No_Implicit_Heap_Allocations.
986 Preserve_Comes_From_Source
987 (Expression
(Temp_Decl
), N
);
989 Set_No_Initialization
(Expression
(Temp_Decl
));
990 Insert_Action
(N
, Temp_Decl
);
992 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
993 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
996 Node
:= Relocate_Node
(N
);
1000 Make_Object_Declaration
(Loc
,
1001 Defining_Identifier
=> Temp
,
1002 Constant_Present
=> True,
1003 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1004 Expression
=> Node
);
1006 Insert_Action
(N
, Temp_Decl
);
1007 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1010 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1011 -- interface type. In this case we use the type of the qualified
1012 -- expression to allocate the object.
1016 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1021 Make_Full_Type_Declaration
(Loc
,
1022 Defining_Identifier
=> Def_Id
,
1024 Make_Access_To_Object_Definition
(Loc
,
1025 All_Present
=> True,
1026 Null_Exclusion_Present
=> False,
1028 Is_Access_Constant
(Etype
(N
)),
1029 Subtype_Indication
=>
1030 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1032 Insert_Action
(N
, New_Decl
);
1034 -- Inherit the allocation-related attributes from the original
1037 Set_Finalization_Master
1038 (Def_Id
, Finalization_Master
(PtrT
));
1040 Set_Associated_Storage_Pool
1041 (Def_Id
, Associated_Storage_Pool
(PtrT
));
1043 -- Declare the object using the previous type declaration
1045 if Aggr_In_Place
then
1047 Make_Object_Declaration
(Loc
,
1048 Defining_Identifier
=> Temp
,
1049 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1051 Make_Allocator
(Loc
,
1052 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1054 -- Copy the Comes_From_Source flag for the allocator we just
1055 -- built, since logically this allocator is a replacement of
1056 -- the original allocator node. This is for proper handling
1057 -- of restriction No_Implicit_Heap_Allocations.
1059 Set_Comes_From_Source
1060 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1062 Set_No_Initialization
(Expression
(Temp_Decl
));
1063 Insert_Action
(N
, Temp_Decl
);
1065 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1066 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1069 Node
:= Relocate_Node
(N
);
1070 Set_Analyzed
(Node
);
1073 Make_Object_Declaration
(Loc
,
1074 Defining_Identifier
=> Temp
,
1075 Constant_Present
=> True,
1076 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1077 Expression
=> Node
);
1079 Insert_Action
(N
, Temp_Decl
);
1080 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1083 -- Generate an additional object containing the address of the
1084 -- returned object. The type of this second object declaration
1085 -- is the correct type required for the common processing that
1086 -- is still performed by this subprogram. The displacement of
1087 -- this pointer to reference the component associated with the
1088 -- interface type will be done at the end of common processing.
1091 Make_Object_Declaration
(Loc
,
1092 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
1093 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1095 Unchecked_Convert_To
(PtrT
,
1096 New_Occurrence_Of
(Temp
, Loc
)));
1098 Insert_Action
(N
, New_Decl
);
1100 Temp_Decl
:= New_Decl
;
1101 Temp
:= Defining_Identifier
(New_Decl
);
1105 -- Generate the tag assignment
1107 -- Suppress the tag assignment for VM targets because VM tags are
1108 -- represented implicitly in objects.
1110 if not Tagged_Type_Expansion
then
1113 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1114 -- interface objects because in this case the tag does not change.
1116 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1117 pragma Assert
(Is_Class_Wide_Type
1118 (Directly_Designated_Type
(Etype
(N
))));
1121 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1124 Make_Explicit_Dereference
(Loc
,
1125 Prefix
=> New_Occurrence_Of
(Temp
, Loc
));
1127 elsif Is_Private_Type
(T
)
1128 and then Is_Tagged_Type
(Underlying_Type
(T
))
1130 TagT
:= Underlying_Type
(T
);
1132 Unchecked_Convert_To
(Underlying_Type
(T
),
1133 Make_Explicit_Dereference
(Loc
,
1134 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
1137 if Present
(TagT
) then
1139 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1143 Make_Assignment_Statement
(Loc
,
1145 Make_Selected_Component
(Loc
,
1149 (First_Tag_Component
(Full_T
), Loc
)),
1152 Unchecked_Convert_To
(RTE
(RE_Tag
),
1155 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1158 -- The previous assignment has to be done in any case
1160 Set_Assignment_OK
(Name
(Tag_Assign
));
1161 Insert_Action
(N
, Tag_Assign
);
1164 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1165 -- the object may be inherently limited, in which case there is no
1166 -- Adjust procedure, and the object is built in place. In Ada 95, the
1167 -- object can be limited but not inherently limited if this allocator
1168 -- came from a return statement (we're allocating the result on the
1169 -- secondary stack). In that case, the object will be moved, so we do
1170 -- want to Adjust. However, if it's a nonlimited build-in-place
1171 -- function call, Adjust is not wanted.
1173 if Needs_Finalization
(DesigT
)
1174 and then Needs_Finalization
(T
)
1175 and then not Aggr_In_Place
1176 and then not Is_Limited_View
(T
)
1177 and then not Alloc_For_BIP_Return
(N
)
1178 and then not Is_Build_In_Place_Function_Call
(Expression
(N
))
1180 -- An unchecked conversion is needed in the classwide case because
1181 -- the designated type can be an ancestor of the subtype mark of
1187 Unchecked_Convert_To
(T
,
1188 Make_Explicit_Dereference
(Loc
,
1189 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
1192 if Present
(Adj_Call
) then
1193 Insert_Action
(N
, Adj_Call
);
1197 -- Note: the accessibility check must be inserted after the call to
1198 -- [Deep_]Adjust to ensure proper completion of the assignment.
1200 Apply_Accessibility_Check
(Temp
);
1202 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1203 Analyze_And_Resolve
(N
, PtrT
);
1205 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1206 -- component containing the secondary dispatch table of the interface
1209 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1210 Displace_Allocator_Pointer
(N
);
1213 -- Always force the generation of a temporary for aggregates when
1214 -- generating C code, to simplify the work in the code generator.
1217 or else (Modify_Tree_For_C
and then Nkind
(Exp
) = N_Aggregate
)
1219 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1221 Make_Object_Declaration
(Loc
,
1222 Defining_Identifier
=> Temp
,
1223 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1225 Make_Allocator
(Loc
,
1226 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1228 -- Copy the Comes_From_Source flag for the allocator we just built,
1229 -- since logically this allocator is a replacement of the original
1230 -- allocator node. This is for proper handling of restriction
1231 -- No_Implicit_Heap_Allocations.
1233 Set_Comes_From_Source
1234 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1236 Set_No_Initialization
(Expression
(Temp_Decl
));
1237 Insert_Action
(N
, Temp_Decl
);
1239 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1240 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1242 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1243 Analyze_And_Resolve
(N
, PtrT
);
1245 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1246 Install_Null_Excluding_Check
(Exp
);
1248 elsif Is_Access_Type
(DesigT
)
1249 and then Nkind
(Exp
) = N_Allocator
1250 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1252 -- Apply constraint to designated subtype indication
1254 Apply_Constraint_Check
1255 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1257 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1259 -- Propagate constraint_error to enclosing allocator
1261 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1265 Build_Allocate_Deallocate_Proc
(N
, True);
1267 -- For an access to unconstrained packed array, GIGI needs to see an
1268 -- expression with a constrained subtype in order to compute the
1269 -- proper size for the allocator.
1271 if Is_Array_Type
(T
)
1272 and then not Is_Constrained
(T
)
1273 and then Is_Packed
(T
)
1276 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1277 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1280 Make_Subtype_Declaration
(Loc
,
1281 Defining_Identifier
=> ConstrT
,
1282 Subtype_Indication
=>
1283 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1284 Freeze_Itype
(ConstrT
, Exp
);
1285 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1289 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1290 -- to a build-in-place function, then access to the allocated object
1291 -- must be passed to the function.
1293 if Is_Build_In_Place_Function_Call
(Exp
) then
1294 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1299 when RE_Not_Available
=>
1301 end Expand_Allocator_Expression
;
1303 -----------------------------
1304 -- Expand_Array_Comparison --
1305 -----------------------------
1307 -- Expansion is only required in the case of array types. For the unpacked
1308 -- case, an appropriate runtime routine is called. For packed cases, and
1309 -- also in some other cases where a runtime routine cannot be called, the
1310 -- form of the expansion is:
1312 -- [body for greater_nn; boolean_expression]
1314 -- The body is built by Make_Array_Comparison_Op, and the form of the
1315 -- Boolean expression depends on the operator involved.
1317 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1318 Loc
: constant Source_Ptr
:= Sloc
(N
);
1319 Op1
: Node_Id
:= Left_Opnd
(N
);
1320 Op2
: Node_Id
:= Right_Opnd
(N
);
1321 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1322 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1325 Func_Body
: Node_Id
;
1326 Func_Name
: Entity_Id
;
1330 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1331 -- True for byte addressable target
1333 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1334 -- Returns True if the length of the given operand is known to be less
1335 -- than 4. Returns False if this length is known to be four or greater
1336 -- or is not known at compile time.
1338 ------------------------
1339 -- Length_Less_Than_4 --
1340 ------------------------
1342 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1343 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1346 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1347 return String_Literal_Length
(Otyp
) < 4;
1351 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1352 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1353 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1358 if Compile_Time_Known_Value
(Lo
) then
1359 Lov
:= Expr_Value
(Lo
);
1364 if Compile_Time_Known_Value
(Hi
) then
1365 Hiv
:= Expr_Value
(Hi
);
1370 return Hiv
< Lov
+ 3;
1373 end Length_Less_Than_4
;
1375 -- Start of processing for Expand_Array_Comparison
1378 -- Deal first with unpacked case, where we can call a runtime routine
1379 -- except that we avoid this for targets for which are not addressable
1382 if not Is_Bit_Packed_Array
(Typ1
) and then Byte_Addressable
then
1383 -- The call we generate is:
1385 -- Compare_Array_xn[_Unaligned]
1386 -- (left'address, right'address, left'length, right'length) <op> 0
1388 -- x = U for unsigned, S for signed
1389 -- n = 8,16,32,64,128 for component size
1390 -- Add _Unaligned if length < 4 and component size is 8.
1391 -- <op> is the standard comparison operator
1393 if Component_Size
(Typ1
) = 8 then
1394 if Length_Less_Than_4
(Op1
)
1396 Length_Less_Than_4
(Op2
)
1398 if Is_Unsigned_Type
(Ctyp
) then
1399 Comp
:= RE_Compare_Array_U8_Unaligned
;
1401 Comp
:= RE_Compare_Array_S8_Unaligned
;
1405 if Is_Unsigned_Type
(Ctyp
) then
1406 Comp
:= RE_Compare_Array_U8
;
1408 Comp
:= RE_Compare_Array_S8
;
1412 elsif Component_Size
(Typ1
) = 16 then
1413 if Is_Unsigned_Type
(Ctyp
) then
1414 Comp
:= RE_Compare_Array_U16
;
1416 Comp
:= RE_Compare_Array_S16
;
1419 elsif Component_Size
(Typ1
) = 32 then
1420 if Is_Unsigned_Type
(Ctyp
) then
1421 Comp
:= RE_Compare_Array_U32
;
1423 Comp
:= RE_Compare_Array_S32
;
1426 elsif Component_Size
(Typ1
) = 64 then
1427 if Is_Unsigned_Type
(Ctyp
) then
1428 Comp
:= RE_Compare_Array_U64
;
1430 Comp
:= RE_Compare_Array_S64
;
1433 else pragma Assert
(Component_Size
(Typ1
) = 128);
1434 if Is_Unsigned_Type
(Ctyp
) then
1435 Comp
:= RE_Compare_Array_U128
;
1437 Comp
:= RE_Compare_Array_S128
;
1441 if RTE_Available
(Comp
) then
1443 -- Expand to a call only if the runtime function is available,
1444 -- otherwise fall back to inline code.
1446 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1447 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1450 Make_Function_Call
(Sloc
(Op1
),
1451 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1453 Parameter_Associations
=> New_List
(
1454 Make_Attribute_Reference
(Loc
,
1455 Prefix
=> Relocate_Node
(Op1
),
1456 Attribute_Name
=> Name_Address
),
1458 Make_Attribute_Reference
(Loc
,
1459 Prefix
=> Relocate_Node
(Op2
),
1460 Attribute_Name
=> Name_Address
),
1462 Make_Attribute_Reference
(Loc
,
1463 Prefix
=> Relocate_Node
(Op1
),
1464 Attribute_Name
=> Name_Length
),
1466 Make_Attribute_Reference
(Loc
,
1467 Prefix
=> Relocate_Node
(Op2
),
1468 Attribute_Name
=> Name_Length
))));
1471 Make_Integer_Literal
(Sloc
(Op2
),
1474 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1475 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1480 -- Cases where we cannot make runtime call
1482 -- For (a <= b) we convert to not (a > b)
1484 if Chars
(N
) = Name_Op_Le
then
1490 Right_Opnd
=> Op2
)));
1491 Analyze_And_Resolve
(N
, Standard_Boolean
);
1494 -- For < the Boolean expression is
1495 -- greater__nn (op2, op1)
1497 elsif Chars
(N
) = Name_Op_Lt
then
1498 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1502 Op1
:= Right_Opnd
(N
);
1503 Op2
:= Left_Opnd
(N
);
1505 -- For (a >= b) we convert to not (a < b)
1507 elsif Chars
(N
) = Name_Op_Ge
then
1513 Right_Opnd
=> Op2
)));
1514 Analyze_And_Resolve
(N
, Standard_Boolean
);
1517 -- For > the Boolean expression is
1518 -- greater__nn (op1, op2)
1521 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1522 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1525 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1527 Make_Function_Call
(Loc
,
1528 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1529 Parameter_Associations
=> New_List
(Op1
, Op2
));
1531 Insert_Action
(N
, Func_Body
);
1533 Analyze_And_Resolve
(N
, Standard_Boolean
);
1534 end Expand_Array_Comparison
;
1536 ---------------------------
1537 -- Expand_Array_Equality --
1538 ---------------------------
1540 -- Expand an equality function for multi-dimensional arrays. Here is an
1541 -- example of such a function for Nb_Dimension = 2
1543 -- function Enn (A : atyp; B : btyp) return boolean is
1545 -- if (A'length (1) = 0 or else A'length (2) = 0)
1547 -- (B'length (1) = 0 or else B'length (2) = 0)
1549 -- return True; -- RM 4.5.2(22)
1552 -- if A'length (1) /= B'length (1)
1554 -- A'length (2) /= B'length (2)
1556 -- return False; -- RM 4.5.2(23)
1560 -- A1 : Index_T1 := A'first (1);
1561 -- B1 : Index_T1 := B'first (1);
1565 -- A2 : Index_T2 := A'first (2);
1566 -- B2 : Index_T2 := B'first (2);
1569 -- if A (A1, A2) /= B (B1, B2) then
1573 -- exit when A2 = A'last (2);
1574 -- A2 := Index_T2'succ (A2);
1575 -- B2 := Index_T2'succ (B2);
1579 -- exit when A1 = A'last (1);
1580 -- A1 := Index_T1'succ (A1);
1581 -- B1 := Index_T1'succ (B1);
1588 -- Note on the formal types used (atyp and btyp). If either of the arrays
1589 -- is of a private type, we use the underlying type, and do an unchecked
1590 -- conversion of the actual. If either of the arrays has a bound depending
1591 -- on a discriminant, then we use the base type since otherwise we have an
1592 -- escaped discriminant in the function.
1594 -- If both arrays are constrained and have the same bounds, we can generate
1595 -- a loop with an explicit iteration scheme using a 'Range attribute over
1598 function Expand_Array_Equality
1603 Typ
: Entity_Id
) return Node_Id
1605 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1606 Decls
: constant List_Id
:= New_List
;
1607 Index_List1
: constant List_Id
:= New_List
;
1608 Index_List2
: constant List_Id
:= New_List
;
1610 First_Idx
: Node_Id
;
1612 Func_Name
: Entity_Id
;
1613 Func_Body
: Node_Id
;
1615 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1616 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1620 -- The parameter types to be used for the formals
1624 -- The LHS and RHS converted to the parameter types
1629 Num
: Int
) return Node_Id
;
1630 -- This builds the attribute reference Arr'Nam (Expr)
1632 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1633 -- Create one statement to compare corresponding components, designated
1634 -- by a full set of indexes.
1636 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1637 -- Given one of the arguments, computes the appropriate type to be used
1638 -- for that argument in the corresponding function formal
1640 function Handle_One_Dimension
1642 Index
: Node_Id
) return Node_Id
;
1643 -- This procedure returns the following code
1646 -- Bn : Index_T := B'First (N);
1650 -- exit when An = A'Last (N);
1651 -- An := Index_T'Succ (An)
1652 -- Bn := Index_T'Succ (Bn)
1656 -- If both indexes are constrained and identical, the procedure
1657 -- returns a simpler loop:
1659 -- for An in A'Range (N) loop
1663 -- N is the dimension for which we are generating a loop. Index is the
1664 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1665 -- xxx statement is either the loop or declare for the next dimension
1666 -- or if this is the last dimension the comparison of corresponding
1667 -- components of the arrays.
1669 -- The actual way the code works is to return the comparison of
1670 -- corresponding components for the N+1 call. That's neater.
1672 function Test_Empty_Arrays
return Node_Id
;
1673 -- This function constructs the test for both arrays being empty
1674 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1676 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1678 function Test_Lengths_Correspond
return Node_Id
;
1679 -- This function constructs the test for arrays having different lengths
1680 -- in at least one index position, in which case the resulting code is:
1682 -- A'length (1) /= B'length (1)
1684 -- A'length (2) /= B'length (2)
1695 Num
: Int
) return Node_Id
1699 Make_Attribute_Reference
(Loc
,
1700 Attribute_Name
=> Nam
,
1701 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1702 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1705 ------------------------
1706 -- Component_Equality --
1707 ------------------------
1709 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1714 -- if a(i1...) /= b(j1...) then return false; end if;
1717 Make_Indexed_Component
(Loc
,
1718 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1719 Expressions
=> Index_List1
);
1722 Make_Indexed_Component
(Loc
,
1723 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1724 Expressions
=> Index_List2
);
1726 Test
:= Expand_Composite_Equality
1727 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1729 -- If some (sub)component is an unchecked_union, the whole operation
1730 -- will raise program error.
1732 if Nkind
(Test
) = N_Raise_Program_Error
then
1734 -- This node is going to be inserted at a location where a
1735 -- statement is expected: clear its Etype so analysis will set
1736 -- it to the expected Standard_Void_Type.
1738 Set_Etype
(Test
, Empty
);
1743 Make_Implicit_If_Statement
(Nod
,
1744 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1745 Then_Statements
=> New_List
(
1746 Make_Simple_Return_Statement
(Loc
,
1747 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1749 end Component_Equality
;
1755 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1766 T
:= Underlying_Type
(T
);
1768 X
:= First_Index
(T
);
1769 while Present
(X
) loop
1770 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1772 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1785 --------------------------
1786 -- Handle_One_Dimension --
1787 ---------------------------
1789 function Handle_One_Dimension
1791 Index
: Node_Id
) return Node_Id
1793 Need_Separate_Indexes
: constant Boolean :=
1794 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1795 -- If the index types are identical, and we are working with
1796 -- constrained types, then we can use the same index for both
1799 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1802 Index_T
: Entity_Id
;
1807 if N
> Number_Dimensions
(Ltyp
) then
1808 return Component_Equality
(Ltyp
);
1811 -- Case where we generate a loop
1813 Index_T
:= Base_Type
(Etype
(Index
));
1815 if Need_Separate_Indexes
then
1816 Bn
:= Make_Temporary
(Loc
, 'B');
1821 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1822 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1824 Stm_List
:= New_List
(
1825 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1827 if Need_Separate_Indexes
then
1829 -- Generate guard for loop, followed by increments of indexes
1831 Append_To
(Stm_List
,
1832 Make_Exit_Statement
(Loc
,
1835 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1836 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1838 Append_To
(Stm_List
,
1839 Make_Assignment_Statement
(Loc
,
1840 Name
=> New_Occurrence_Of
(An
, Loc
),
1842 Make_Attribute_Reference
(Loc
,
1843 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1844 Attribute_Name
=> Name_Succ
,
1845 Expressions
=> New_List
(
1846 New_Occurrence_Of
(An
, Loc
)))));
1848 Append_To
(Stm_List
,
1849 Make_Assignment_Statement
(Loc
,
1850 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1852 Make_Attribute_Reference
(Loc
,
1853 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1854 Attribute_Name
=> Name_Succ
,
1855 Expressions
=> New_List
(
1856 New_Occurrence_Of
(Bn
, Loc
)))));
1859 -- If separate indexes, we need a declare block for An and Bn, and a
1860 -- loop without an iteration scheme.
1862 if Need_Separate_Indexes
then
1864 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1867 Make_Block_Statement
(Loc
,
1868 Declarations
=> New_List
(
1869 Make_Object_Declaration
(Loc
,
1870 Defining_Identifier
=> An
,
1871 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1872 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1874 Make_Object_Declaration
(Loc
,
1875 Defining_Identifier
=> Bn
,
1876 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1877 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1879 Handled_Statement_Sequence
=>
1880 Make_Handled_Sequence_Of_Statements
(Loc
,
1881 Statements
=> New_List
(Loop_Stm
)));
1883 -- If no separate indexes, return loop statement with explicit
1884 -- iteration scheme on its own.
1888 Make_Implicit_Loop_Statement
(Nod
,
1889 Statements
=> Stm_List
,
1891 Make_Iteration_Scheme
(Loc
,
1892 Loop_Parameter_Specification
=>
1893 Make_Loop_Parameter_Specification
(Loc
,
1894 Defining_Identifier
=> An
,
1895 Discrete_Subtype_Definition
=>
1896 Arr_Attr
(A
, Name_Range
, N
))));
1899 end Handle_One_Dimension
;
1901 -----------------------
1902 -- Test_Empty_Arrays --
1903 -----------------------
1905 function Test_Empty_Arrays
return Node_Id
is
1915 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1918 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1919 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1923 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1924 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1933 Left_Opnd
=> Relocate_Node
(Alist
),
1934 Right_Opnd
=> Atest
);
1938 Left_Opnd
=> Relocate_Node
(Blist
),
1939 Right_Opnd
=> Btest
);
1946 Right_Opnd
=> Blist
);
1947 end Test_Empty_Arrays
;
1949 -----------------------------
1950 -- Test_Lengths_Correspond --
1951 -----------------------------
1953 function Test_Lengths_Correspond
return Node_Id
is
1959 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1962 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1963 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
1970 Left_Opnd
=> Relocate_Node
(Result
),
1971 Right_Opnd
=> Rtest
);
1976 end Test_Lengths_Correspond
;
1978 -- Start of processing for Expand_Array_Equality
1981 Ltyp
:= Get_Arg_Type
(Lhs
);
1982 Rtyp
:= Get_Arg_Type
(Rhs
);
1984 -- For now, if the argument types are not the same, go to the base type,
1985 -- since the code assumes that the formals have the same type. This is
1986 -- fixable in future ???
1988 if Ltyp
/= Rtyp
then
1989 Ltyp
:= Base_Type
(Ltyp
);
1990 Rtyp
:= Base_Type
(Rtyp
);
1991 pragma Assert
(Ltyp
= Rtyp
);
1994 -- If the array type is distinct from the type of the arguments, it
1995 -- is the full view of a private type. Apply an unchecked conversion
1996 -- to ensure that analysis of the code below succeeds.
1999 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
2001 New_Lhs
:= OK_Convert_To
(Ltyp
, Lhs
);
2007 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
2009 New_Rhs
:= OK_Convert_To
(Rtyp
, Rhs
);
2014 First_Idx
:= First_Index
(Ltyp
);
2016 -- If optimization is enabled and the array boils down to a couple of
2017 -- consecutive elements, generate a simple conjunction of comparisons
2018 -- which should be easier to optimize by the code generator.
2020 if Optimization_Level
> 0
2021 and then Ltyp
= Rtyp
2022 and then Is_Constrained
(Ltyp
)
2023 and then Number_Dimensions
(Ltyp
) = 1
2024 and then Nkind
(First_Idx
) = N_Range
2025 and then Compile_Time_Known_Value
(Low_Bound
(First_Idx
))
2026 and then Compile_Time_Known_Value
(High_Bound
(First_Idx
))
2027 and then Expr_Value
(High_Bound
(First_Idx
)) =
2028 Expr_Value
(Low_Bound
(First_Idx
)) + 1
2031 Ctyp
: constant Entity_Id
:= Component_Type
(Ltyp
);
2033 TestL
, TestH
: Node_Id
;
2037 Make_Indexed_Component
(Loc
,
2038 Prefix
=> New_Copy_Tree
(New_Lhs
),
2040 New_List
(New_Copy_Tree
(Low_Bound
(First_Idx
))));
2043 Make_Indexed_Component
(Loc
,
2044 Prefix
=> New_Copy_Tree
(New_Rhs
),
2046 New_List
(New_Copy_Tree
(Low_Bound
(First_Idx
))));
2048 TestL
:= Expand_Composite_Equality
(Nod
, Ctyp
, L
, R
, Bodies
);
2051 Make_Indexed_Component
(Loc
,
2054 New_List
(New_Copy_Tree
(High_Bound
(First_Idx
))));
2057 Make_Indexed_Component
(Loc
,
2060 New_List
(New_Copy_Tree
(High_Bound
(First_Idx
))));
2062 TestH
:= Expand_Composite_Equality
(Nod
, Ctyp
, L
, R
, Bodies
);
2065 Make_And_Then
(Loc
, Left_Opnd
=> TestL
, Right_Opnd
=> TestH
);
2069 -- Build list of formals for function
2071 Formals
:= New_List
(
2072 Make_Parameter_Specification
(Loc
,
2073 Defining_Identifier
=> A
,
2074 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
2076 Make_Parameter_Specification
(Loc
,
2077 Defining_Identifier
=> B
,
2078 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
2080 Func_Name
:= Make_Temporary
(Loc
, 'E');
2082 -- Build statement sequence for function
2085 Make_Subprogram_Body
(Loc
,
2087 Make_Function_Specification
(Loc
,
2088 Defining_Unit_Name
=> Func_Name
,
2089 Parameter_Specifications
=> Formals
,
2090 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2092 Declarations
=> Decls
,
2094 Handled_Statement_Sequence
=>
2095 Make_Handled_Sequence_Of_Statements
(Loc
,
2096 Statements
=> New_List
(
2098 Make_Implicit_If_Statement
(Nod
,
2099 Condition
=> Test_Empty_Arrays
,
2100 Then_Statements
=> New_List
(
2101 Make_Simple_Return_Statement
(Loc
,
2103 New_Occurrence_Of
(Standard_True
, Loc
)))),
2105 Make_Implicit_If_Statement
(Nod
,
2106 Condition
=> Test_Lengths_Correspond
,
2107 Then_Statements
=> New_List
(
2108 Make_Simple_Return_Statement
(Loc
,
2109 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
2111 Handle_One_Dimension
(1, First_Idx
),
2113 Make_Simple_Return_Statement
(Loc
,
2114 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2116 Set_Has_Completion
(Func_Name
, True);
2117 Set_Is_Inlined
(Func_Name
);
2119 Append_To
(Bodies
, Func_Body
);
2122 Make_Function_Call
(Loc
,
2123 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2124 Parameter_Associations
=> New_List
(New_Lhs
, New_Rhs
));
2125 end Expand_Array_Equality
;
2127 -----------------------------
2128 -- Expand_Boolean_Operator --
2129 -----------------------------
2131 -- Note that we first get the actual subtypes of the operands, since we
2132 -- always want to deal with types that have bounds.
2134 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2135 Typ
: constant Entity_Id
:= Etype
(N
);
2138 -- Special case of bit packed array where both operands are known to be
2139 -- properly aligned. In this case we use an efficient run time routine
2140 -- to carry out the operation (see System.Bit_Ops).
2142 if Is_Bit_Packed_Array
(Typ
)
2143 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2144 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2146 Expand_Packed_Boolean_Operator
(N
);
2150 -- For the normal non-packed case, the general expansion is to build
2151 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2152 -- and then inserting it into the tree. The original operator node is
2153 -- then rewritten as a call to this function. We also use this in the
2154 -- packed case if either operand is a possibly unaligned object.
2157 Loc
: constant Source_Ptr
:= Sloc
(N
);
2158 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2159 R
: Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2160 Func_Body
: Node_Id
;
2161 Func_Name
: Entity_Id
;
2164 Convert_To_Actual_Subtype
(L
);
2165 Convert_To_Actual_Subtype
(R
);
2166 Ensure_Defined
(Etype
(L
), N
);
2167 Ensure_Defined
(Etype
(R
), N
);
2168 Apply_Length_Check
(R
, Etype
(L
));
2170 if Nkind
(N
) = N_Op_Xor
then
2171 R
:= Duplicate_Subexpr
(R
);
2172 Silly_Boolean_Array_Xor_Test
(N
, R
, Etype
(L
));
2175 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2176 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2178 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2180 elsif Nkind
(Parent
(N
)) = N_Op_Not
2181 and then Nkind
(N
) = N_Op_And
2182 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2183 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2188 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2189 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2190 Insert_Action
(N
, Func_Body
);
2192 -- Now rewrite the expression with a call
2195 Make_Function_Call
(Loc
,
2196 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2197 Parameter_Associations
=>
2200 Make_Type_Conversion
2201 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2203 Analyze_And_Resolve
(N
, Typ
);
2206 end Expand_Boolean_Operator
;
2208 ------------------------------------------------
2209 -- Expand_Compare_Minimize_Eliminate_Overflow --
2210 ------------------------------------------------
2212 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2213 Loc
: constant Source_Ptr
:= Sloc
(N
);
2215 Result_Type
: constant Entity_Id
:= Etype
(N
);
2216 -- Capture result type (could be a derived boolean type)
2221 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2222 -- Entity for Long_Long_Integer'Base
2224 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2225 -- Current overflow checking mode
2228 procedure Set_False
;
2229 -- These procedures rewrite N with an occurrence of Standard_True or
2230 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2236 procedure Set_False
is
2238 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2239 Warn_On_Known_Condition
(N
);
2246 procedure Set_True
is
2248 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2249 Warn_On_Known_Condition
(N
);
2252 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2255 -- Nothing to do unless we have a comparison operator with operands
2256 -- that are signed integer types, and we are operating in either
2257 -- MINIMIZED or ELIMINATED overflow checking mode.
2259 if Nkind
(N
) not in N_Op_Compare
2260 or else Check
not in Minimized_Or_Eliminated
2261 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2266 -- OK, this is the case we are interested in. First step is to process
2267 -- our operands using the Minimize_Eliminate circuitry which applies
2268 -- this processing to the two operand subtrees.
2270 Minimize_Eliminate_Overflows
2271 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2272 Minimize_Eliminate_Overflows
2273 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2275 -- See if the range information decides the result of the comparison.
2276 -- We can only do this if we in fact have full range information (which
2277 -- won't be the case if either operand is bignum at this stage).
2279 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2280 case N_Op_Compare
(Nkind
(N
)) is
2282 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2284 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2291 elsif Lhi
< Rlo
then
2298 elsif Lhi
<= Rlo
then
2305 elsif Lhi
<= Rlo
then
2312 elsif Lhi
< Rlo
then
2317 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2319 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2324 -- All done if we did the rewrite
2326 if Nkind
(N
) not in N_Op_Compare
then
2331 -- Otherwise, time to do the comparison
2334 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2335 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2338 -- If the two operands have the same signed integer type we are
2339 -- all set, nothing more to do. This is the case where either
2340 -- both operands were unchanged, or we rewrote both of them to
2341 -- be Long_Long_Integer.
2343 -- Note: Entity for the comparison may be wrong, but it's not worth
2344 -- the effort to change it, since the back end does not use it.
2346 if Is_Signed_Integer_Type
(Ltype
)
2347 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2351 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2353 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2355 Left
: Node_Id
:= Left_Opnd
(N
);
2356 Right
: Node_Id
:= Right_Opnd
(N
);
2357 -- Bignum references for left and right operands
2360 if not Is_RTE
(Ltype
, RE_Bignum
) then
2361 Left
:= Convert_To_Bignum
(Left
);
2362 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2363 Right
:= Convert_To_Bignum
(Right
);
2366 -- We rewrite our node with:
2369 -- Bnn : Result_Type;
2371 -- M : Mark_Id := SS_Mark;
2373 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2381 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2382 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2386 case N_Op_Compare
(Nkind
(N
)) is
2387 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2388 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2389 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2390 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2391 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2392 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2395 -- Insert assignment to Bnn into the bignum block
2398 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2399 Make_Assignment_Statement
(Loc
,
2400 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2402 Make_Function_Call
(Loc
,
2404 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2405 Parameter_Associations
=> New_List
(Left
, Right
))));
2407 -- Now do the rewrite with expression actions
2410 Make_Expression_With_Actions
(Loc
,
2411 Actions
=> New_List
(
2412 Make_Object_Declaration
(Loc
,
2413 Defining_Identifier
=> Bnn
,
2414 Object_Definition
=>
2415 New_Occurrence_Of
(Result_Type
, Loc
)),
2417 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2418 Analyze_And_Resolve
(N
, Result_Type
);
2422 -- No bignums involved, but types are different, so we must have
2423 -- rewritten one of the operands as a Long_Long_Integer but not
2426 -- If left operand is Long_Long_Integer, convert right operand
2427 -- and we are done (with a comparison of two Long_Long_Integers).
2429 elsif Ltype
= LLIB
then
2430 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2431 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2434 -- If right operand is Long_Long_Integer, convert left operand
2435 -- and we are done (with a comparison of two Long_Long_Integers).
2437 -- This is the only remaining possibility
2439 else pragma Assert
(Rtype
= LLIB
);
2440 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2441 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2445 end Expand_Compare_Minimize_Eliminate_Overflow
;
2447 -------------------------------
2448 -- Expand_Composite_Equality --
2449 -------------------------------
2451 -- This function is only called for comparing internal fields of composite
2452 -- types when these fields are themselves composites. This is a special
2453 -- case because it is not possible to respect normal Ada visibility rules.
2455 function Expand_Composite_Equality
2460 Bodies
: List_Id
) return Node_Id
2462 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2463 Full_Type
: Entity_Id
;
2466 -- Start of processing for Expand_Composite_Equality
2469 if Is_Private_Type
(Typ
) then
2470 Full_Type
:= Underlying_Type
(Typ
);
2475 -- If the private type has no completion the context may be the
2476 -- expansion of a composite equality for a composite type with some
2477 -- still incomplete components. The expression will not be analyzed
2478 -- until the enclosing type is completed, at which point this will be
2479 -- properly expanded, unless there is a bona fide completion error.
2481 if No
(Full_Type
) then
2482 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2485 Full_Type
:= Base_Type
(Full_Type
);
2487 -- When the base type itself is private, use the full view to expand
2488 -- the composite equality.
2490 if Is_Private_Type
(Full_Type
) then
2491 Full_Type
:= Underlying_Type
(Full_Type
);
2494 -- Case of array types
2496 if Is_Array_Type
(Full_Type
) then
2498 -- If the operand is an elementary type other than a floating-point
2499 -- type, then we can simply use the built-in block bitwise equality,
2500 -- since the predefined equality operators always apply and bitwise
2501 -- equality is fine for all these cases.
2503 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2504 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2506 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2508 -- For composite component types, and floating-point types, use the
2509 -- expansion. This deals with tagged component types (where we use
2510 -- the applicable equality routine) and floating-point (where we
2511 -- need to worry about negative zeroes), and also the case of any
2512 -- composite type recursively containing such fields.
2516 Comp_Typ
: Entity_Id
;
2523 -- Do the comparison in the type (or its full view) and not in
2524 -- its unconstrained base type, because the latter operation is
2525 -- more complex and would also require an unchecked conversion.
2527 if Is_Private_Type
(Typ
) then
2528 Comp_Typ
:= Underlying_Type
(Typ
);
2533 -- Except for the case where the bounds of the type depend on a
2534 -- discriminant, or else we would run into scoping issues.
2536 Indx
:= First_Index
(Comp_Typ
);
2537 while Present
(Indx
) loop
2538 Ityp
:= Etype
(Indx
);
2540 Lo
:= Type_Low_Bound
(Ityp
);
2541 Hi
:= Type_High_Bound
(Ityp
);
2543 if (Nkind
(Lo
) = N_Identifier
2544 and then Ekind
(Entity
(Lo
)) = E_Discriminant
)
2546 (Nkind
(Hi
) = N_Identifier
2547 and then Ekind
(Entity
(Hi
)) = E_Discriminant
)
2549 Comp_Typ
:= Full_Type
;
2556 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Comp_Typ
);
2560 -- Case of tagged record types
2562 elsif Is_Tagged_Type
(Full_Type
) then
2563 Eq_Op
:= Find_Primitive_Eq
(Typ
);
2564 pragma Assert
(Present
(Eq_Op
));
2567 Make_Function_Call
(Loc
,
2568 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2569 Parameter_Associations
=>
2571 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2572 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2574 -- Case of untagged record types
2576 elsif Is_Record_Type
(Full_Type
) then
2577 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2579 if Present
(Eq_Op
) then
2580 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2582 -- Inherited equality from parent type. Convert the actuals to
2583 -- match signature of operation.
2586 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2590 Make_Function_Call
(Loc
,
2591 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2592 Parameter_Associations
=> New_List
(
2593 OK_Convert_To
(T
, Lhs
),
2594 OK_Convert_To
(T
, Rhs
)));
2598 -- Comparison between Unchecked_Union components
2600 if Is_Unchecked_Union
(Full_Type
) then
2602 Lhs_Type
: Node_Id
:= Full_Type
;
2603 Rhs_Type
: Node_Id
:= Full_Type
;
2604 Lhs_Discr_Val
: Node_Id
;
2605 Rhs_Discr_Val
: Node_Id
;
2610 if Nkind
(Lhs
) = N_Selected_Component
then
2611 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2616 if Nkind
(Rhs
) = N_Selected_Component
then
2617 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2620 -- Lhs of the composite equality
2622 if Is_Constrained
(Lhs_Type
) then
2624 -- Since the enclosing record type can never be an
2625 -- Unchecked_Union (this code is executed for records
2626 -- that do not have variants), we may reference its
2629 if Nkind
(Lhs
) = N_Selected_Component
2630 and then Has_Per_Object_Constraint
2631 (Entity
(Selector_Name
(Lhs
)))
2634 Make_Selected_Component
(Loc
,
2635 Prefix
=> Prefix
(Lhs
),
2638 (Get_Discriminant_Value
2639 (First_Discriminant
(Lhs_Type
),
2641 Stored_Constraint
(Lhs_Type
))));
2646 (Get_Discriminant_Value
2647 (First_Discriminant
(Lhs_Type
),
2649 Stored_Constraint
(Lhs_Type
)));
2653 -- It is not possible to infer the discriminant since
2654 -- the subtype is not constrained.
2657 Make_Raise_Program_Error
(Loc
,
2658 Reason
=> PE_Unchecked_Union_Restriction
);
2661 -- Rhs of the composite equality
2663 if Is_Constrained
(Rhs_Type
) then
2664 if Nkind
(Rhs
) = N_Selected_Component
2665 and then Has_Per_Object_Constraint
2666 (Entity
(Selector_Name
(Rhs
)))
2669 Make_Selected_Component
(Loc
,
2670 Prefix
=> Prefix
(Rhs
),
2673 (Get_Discriminant_Value
2674 (First_Discriminant
(Rhs_Type
),
2676 Stored_Constraint
(Rhs_Type
))));
2681 (Get_Discriminant_Value
2682 (First_Discriminant
(Rhs_Type
),
2684 Stored_Constraint
(Rhs_Type
)));
2689 Make_Raise_Program_Error
(Loc
,
2690 Reason
=> PE_Unchecked_Union_Restriction
);
2693 -- Call the TSS equality function with the inferred
2694 -- discriminant values.
2697 Make_Function_Call
(Loc
,
2698 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2699 Parameter_Associations
=> New_List
(
2706 -- All cases other than comparing Unchecked_Union types
2710 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2713 Make_Function_Call
(Loc
,
2715 New_Occurrence_Of
(Eq_Op
, Loc
),
2716 Parameter_Associations
=> New_List
(
2717 OK_Convert_To
(T
, Lhs
),
2718 OK_Convert_To
(T
, Rhs
)));
2723 -- Equality composes in Ada 2012 for untagged record types. It also
2724 -- composes for bounded strings, because they are part of the
2725 -- predefined environment. We could make it compose for bounded
2726 -- strings by making them tagged, or by making sure all subcomponents
2727 -- are set to the same value, even when not used. Instead, we have
2728 -- this special case in the compiler, because it's more efficient.
2730 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2732 -- If no TSS has been created for the type, check whether there is
2733 -- a primitive equality declared for it.
2736 Op
: constant Node_Id
:= Build_Eq_Call
(Typ
, Loc
, Lhs
, Rhs
);
2739 -- Use user-defined primitive if it exists, otherwise use
2740 -- predefined equality.
2742 if Present
(Op
) then
2745 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2750 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2753 -- Non-composite types (always use predefined equality)
2756 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2758 end Expand_Composite_Equality
;
2760 ------------------------
2761 -- Expand_Concatenate --
2762 ------------------------
2764 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2765 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2767 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2768 -- Result type of concatenation
2770 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2771 -- Component type. Elements of this component type can appear as one
2772 -- of the operands of concatenation as well as arrays.
2774 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2777 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2778 -- Index type. This is the base type of the index subtype, and is used
2779 -- for all computed bounds (which may be out of range of Istyp in the
2780 -- case of null ranges).
2783 -- This is the type we use to do arithmetic to compute the bounds and
2784 -- lengths of operands. The choice of this type is a little subtle and
2785 -- is discussed in a separate section at the start of the body code.
2787 Concatenation_Error
: exception;
2788 -- Raised if concatenation is sure to raise a CE
2790 Result_May_Be_Null
: Boolean := True;
2791 -- Reset to False if at least one operand is encountered which is known
2792 -- at compile time to be non-null. Used for handling the special case
2793 -- of setting the high bound to the last operand high bound for a null
2794 -- result, thus ensuring a proper high bound in the super-flat case.
2796 N
: constant Nat
:= List_Length
(Opnds
);
2797 -- Number of concatenation operands including possibly null operands
2800 -- Number of operands excluding any known to be null, except that the
2801 -- last operand is always retained, in case it provides the bounds for
2804 Opnd
: Node_Id
:= Empty
;
2805 -- Current operand being processed in the loop through operands. After
2806 -- this loop is complete, always contains the last operand (which is not
2807 -- the same as Operands (NN), since null operands are skipped).
2809 -- Arrays describing the operands, only the first NN entries of each
2810 -- array are set (NN < N when we exclude known null operands).
2812 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2813 -- True if length of corresponding operand known at compile time
2815 Operands
: array (1 .. N
) of Node_Id
;
2816 -- Set to the corresponding entry in the Opnds list (but note that null
2817 -- operands are excluded, so not all entries in the list are stored).
2819 Fixed_Length
: array (1 .. N
) of Uint
;
2820 -- Set to length of operand. Entries in this array are set only if the
2821 -- corresponding entry in Is_Fixed_Length is True.
2823 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2824 -- Set to lower bound of operand. Either an integer literal in the case
2825 -- where the bound is known at compile time, else actual lower bound.
2826 -- The operand low bound is of type Ityp.
2828 Var_Length
: array (1 .. N
) of Entity_Id
;
2829 -- Set to an entity of type Natural that contains the length of an
2830 -- operand whose length is not known at compile time. Entries in this
2831 -- array are set only if the corresponding entry in Is_Fixed_Length
2832 -- is False. The entity is of type Artyp.
2834 Aggr_Length
: array (0 .. N
) of Node_Id
;
2835 -- The J'th entry in an expression node that represents the total length
2836 -- of operands 1 through J. It is either an integer literal node, or a
2837 -- reference to a constant entity with the right value, so it is fine
2838 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth
2839 -- entry always is set to zero. The length is of type Artyp.
2841 Low_Bound
: Node_Id
:= Empty
;
2842 -- A tree node representing the low bound of the result (of type Ityp).
2843 -- This is either an integer literal node, or an identifier reference to
2844 -- a constant entity initialized to the appropriate value.
2846 Last_Opnd_Low_Bound
: Node_Id
:= Empty
;
2847 -- A tree node representing the low bound of the last operand. This
2848 -- need only be set if the result could be null. It is used for the
2849 -- special case of setting the right low bound for a null result.
2850 -- This is of type Ityp.
2852 Last_Opnd_High_Bound
: Node_Id
:= Empty
;
2853 -- A tree node representing the high bound of the last operand. This
2854 -- need only be set if the result could be null. It is used for the
2855 -- special case of setting the right high bound for a null result.
2856 -- This is of type Ityp.
2858 High_Bound
: Node_Id
:= Empty
;
2859 -- A tree node representing the high bound of the result (of type Ityp)
2861 Result
: Node_Id
:= Empty
;
2862 -- Result of the concatenation (of type Ityp)
2864 Actions
: constant List_Id
:= New_List
;
2865 -- Collect actions to be inserted
2867 Known_Non_Null_Operand_Seen
: Boolean;
2868 -- Set True during generation of the assignments of operands into
2869 -- result once an operand known to be non-null has been seen.
2871 function Library_Level_Target
return Boolean;
2872 -- Return True if the concatenation is within the expression of the
2873 -- declaration of a library-level object.
2875 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2876 -- This function makes an N_Integer_Literal node that is returned in
2877 -- analyzed form with the type set to Artyp. Importantly this literal
2878 -- is not flagged as static, so that if we do computations with it that
2879 -- result in statically detected out of range conditions, we will not
2880 -- generate error messages but instead warning messages.
2882 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2883 -- Given a node of type Ityp, returns the corresponding value of type
2884 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2885 -- For enum types, the Pos of the value is returned.
2887 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2888 -- The inverse function (uses Val in the case of enumeration types)
2890 --------------------------
2891 -- Library_Level_Target --
2892 --------------------------
2894 function Library_Level_Target
return Boolean is
2895 P
: Node_Id
:= Parent
(Cnode
);
2898 while Present
(P
) loop
2899 if Nkind
(P
) = N_Object_Declaration
then
2900 return Is_Library_Level_Entity
(Defining_Identifier
(P
));
2902 -- Prevent the search from going too far
2904 elsif Is_Body_Or_Package_Declaration
(P
) then
2912 end Library_Level_Target
;
2914 ------------------------
2915 -- Make_Artyp_Literal --
2916 ------------------------
2918 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2919 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2921 Set_Etype
(Result
, Artyp
);
2922 Set_Analyzed
(Result
, True);
2923 Set_Is_Static_Expression
(Result
, False);
2925 end Make_Artyp_Literal
;
2931 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2933 if Ityp
= Base_Type
(Artyp
) then
2936 elsif Is_Enumeration_Type
(Ityp
) then
2938 Make_Attribute_Reference
(Loc
,
2939 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2940 Attribute_Name
=> Name_Pos
,
2941 Expressions
=> New_List
(X
));
2944 return Convert_To
(Artyp
, X
);
2952 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2954 if Is_Enumeration_Type
(Ityp
) then
2956 Make_Attribute_Reference
(Loc
,
2957 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2958 Attribute_Name
=> Name_Val
,
2959 Expressions
=> New_List
(X
));
2961 -- Case where we will do a type conversion
2964 if Ityp
= Base_Type
(Artyp
) then
2967 return Convert_To
(Ityp
, X
);
2972 -- Local Declarations
2974 Opnd_Typ
: Entity_Id
;
2975 Subtyp_Ind
: Entity_Id
;
2982 -- Start of processing for Expand_Concatenate
2985 -- Choose an appropriate computational type
2987 -- We will be doing calculations of lengths and bounds in this routine
2988 -- and computing one from the other in some cases, e.g. getting the high
2989 -- bound by adding the length-1 to the low bound.
2991 -- We can't just use the index type, or even its base type for this
2992 -- purpose for two reasons. First it might be an enumeration type which
2993 -- is not suitable for computations of any kind, and second it may
2994 -- simply not have enough range. For example if the index type is
2995 -- -128..+127 then lengths can be up to 256, which is out of range of
2998 -- For enumeration types, we can simply use Standard_Integer, this is
2999 -- sufficient since the actual number of enumeration literals cannot
3000 -- possibly exceed the range of integer (remember we will be doing the
3001 -- arithmetic with POS values, not representation values).
3003 if Is_Enumeration_Type
(Ityp
) then
3004 Artyp
:= Standard_Integer
;
3006 -- If index type is Positive, we use the standard unsigned type, to give
3007 -- more room on the top of the range, obviating the need for an overflow
3008 -- check when creating the upper bound. This is needed to avoid junk
3009 -- overflow checks in the common case of String types.
3011 -- ??? Disabled for now
3013 -- elsif Istyp = Standard_Positive then
3014 -- Artyp := Standard_Unsigned;
3016 -- For modular types, we use a 32-bit modular type for types whose size
3017 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3018 -- identity type, and for larger unsigned types we use a 64-bit type.
3020 elsif Is_Modular_Integer_Type
(Ityp
) then
3021 if RM_Size
(Ityp
) < Standard_Integer_Size
then
3022 Artyp
:= Standard_Unsigned
;
3023 elsif RM_Size
(Ityp
) = Standard_Integer_Size
then
3026 Artyp
:= Standard_Long_Long_Unsigned
;
3029 -- Similar treatment for signed types
3032 if RM_Size
(Ityp
) < Standard_Integer_Size
then
3033 Artyp
:= Standard_Integer
;
3034 elsif RM_Size
(Ityp
) = Standard_Integer_Size
then
3037 Artyp
:= Standard_Long_Long_Integer
;
3041 -- Supply dummy entry at start of length array
3043 Aggr_Length
(0) := Make_Artyp_Literal
(0);
3045 -- Go through operands setting up the above arrays
3049 Opnd
:= Remove_Head
(Opnds
);
3050 Opnd_Typ
:= Etype
(Opnd
);
3052 -- The parent got messed up when we put the operands in a list,
3053 -- so now put back the proper parent for the saved operand, that
3054 -- is to say the concatenation node, to make sure that each operand
3055 -- is seen as a subexpression, e.g. if actions must be inserted.
3057 Set_Parent
(Opnd
, Cnode
);
3059 -- Set will be True when we have setup one entry in the array
3063 -- Singleton element (or character literal) case
3065 if Base_Type
(Opnd_Typ
) = Ctyp
then
3067 Operands
(NN
) := Opnd
;
3068 Is_Fixed_Length
(NN
) := True;
3069 Fixed_Length
(NN
) := Uint_1
;
3070 Result_May_Be_Null
:= False;
3072 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3073 -- since we know that the result cannot be null).
3075 Opnd_Low_Bound
(NN
) :=
3076 Make_Attribute_Reference
(Loc
,
3077 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
3078 Attribute_Name
=> Name_First
);
3082 -- String literal case (can only occur for strings of course)
3084 elsif Nkind
(Opnd
) = N_String_Literal
then
3085 Len
:= String_Literal_Length
(Opnd_Typ
);
3088 Result_May_Be_Null
:= False;
3091 -- Capture last operand low and high bound if result could be null
3093 if J
= N
and then Result_May_Be_Null
then
3094 Last_Opnd_Low_Bound
:=
3095 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3097 Last_Opnd_High_Bound
:=
3098 Make_Op_Subtract
(Loc
,
3100 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3101 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3104 -- Skip null string literal
3106 if J
< N
and then Len
= 0 then
3111 Operands
(NN
) := Opnd
;
3112 Is_Fixed_Length
(NN
) := True;
3114 -- Set length and bounds
3116 Fixed_Length
(NN
) := Len
;
3118 Opnd_Low_Bound
(NN
) :=
3119 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3126 -- Check constrained case with known bounds
3128 if Is_Constrained
(Opnd_Typ
) then
3130 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3131 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3132 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3133 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3136 -- Fixed length constrained array type with known at compile
3137 -- time bounds is last case of fixed length operand.
3139 if Compile_Time_Known_Value
(Lo
)
3141 Compile_Time_Known_Value
(Hi
)
3144 Loval
: constant Uint
:= Expr_Value
(Lo
);
3145 Hival
: constant Uint
:= Expr_Value
(Hi
);
3146 Len
: constant Uint
:=
3147 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3151 Result_May_Be_Null
:= False;
3154 -- Capture last operand bounds if result could be null
3156 if J
= N
and then Result_May_Be_Null
then
3157 Last_Opnd_Low_Bound
:=
3159 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3161 Last_Opnd_High_Bound
:=
3163 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3166 -- Exclude null length case unless last operand
3168 if J
< N
and then Len
= 0 then
3173 Operands
(NN
) := Opnd
;
3174 Is_Fixed_Length
(NN
) := True;
3175 Fixed_Length
(NN
) := Len
;
3177 Opnd_Low_Bound
(NN
) :=
3179 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3186 -- All cases where the length is not known at compile time, or the
3187 -- special case of an operand which is known to be null but has a
3188 -- lower bound other than 1 or is other than a string type.
3193 -- Capture operand bounds
3195 Opnd_Low_Bound
(NN
) :=
3196 Make_Attribute_Reference
(Loc
,
3198 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3199 Attribute_Name
=> Name_First
);
3201 -- Capture last operand bounds if result could be null
3203 if J
= N
and Result_May_Be_Null
then
3204 Last_Opnd_Low_Bound
:=
3206 Make_Attribute_Reference
(Loc
,
3208 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3209 Attribute_Name
=> Name_First
));
3211 Last_Opnd_High_Bound
:=
3213 Make_Attribute_Reference
(Loc
,
3215 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3216 Attribute_Name
=> Name_Last
));
3219 -- Capture length of operand in entity
3221 Operands
(NN
) := Opnd
;
3222 Is_Fixed_Length
(NN
) := False;
3224 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3227 Make_Object_Declaration
(Loc
,
3228 Defining_Identifier
=> Var_Length
(NN
),
3229 Constant_Present
=> True,
3230 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3232 Make_Attribute_Reference
(Loc
,
3234 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3235 Attribute_Name
=> Name_Length
)));
3239 -- Set next entry in aggregate length array
3241 -- For first entry, make either integer literal for fixed length
3242 -- or a reference to the saved length for variable length.
3245 if Is_Fixed_Length
(1) then
3246 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3248 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
3251 -- If entry is fixed length and only fixed lengths so far, make
3252 -- appropriate new integer literal adding new length.
3254 elsif Is_Fixed_Length
(NN
)
3255 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3258 Make_Integer_Literal
(Loc
,
3259 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3261 -- All other cases, construct an addition node for the length and
3262 -- create an entity initialized to this length.
3265 Ent
:= Make_Temporary
(Loc
, 'L');
3267 if Is_Fixed_Length
(NN
) then
3268 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3270 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3274 Make_Object_Declaration
(Loc
,
3275 Defining_Identifier
=> Ent
,
3276 Constant_Present
=> True,
3277 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3280 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
- 1)),
3281 Right_Opnd
=> Clen
)));
3283 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3290 -- If we have only skipped null operands, return the last operand
3297 -- If we have only one non-null operand, return it and we are done.
3298 -- There is one case in which this cannot be done, and that is when
3299 -- the sole operand is of the element type, in which case it must be
3300 -- converted to an array, and the easiest way of doing that is to go
3301 -- through the normal general circuit.
3303 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3304 Result
:= Operands
(1);
3308 -- Cases where we have a real concatenation
3310 -- Next step is to find the low bound for the result array that we
3311 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3313 -- If the ultimate ancestor of the index subtype is a constrained array
3314 -- definition, then the lower bound is that of the index subtype as
3315 -- specified by (RM 4.5.3(6)).
3317 -- The right test here is to go to the root type, and then the ultimate
3318 -- ancestor is the first subtype of this root type.
3320 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3322 Make_Attribute_Reference
(Loc
,
3324 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3325 Attribute_Name
=> Name_First
);
3327 -- If the first operand in the list has known length we know that
3328 -- the lower bound of the result is the lower bound of this operand.
3330 elsif Is_Fixed_Length
(1) then
3331 Low_Bound
:= Opnd_Low_Bound
(1);
3333 -- OK, we don't know the lower bound, we have to build a horrible
3334 -- if expression node of the form
3336 -- if Cond1'Length /= 0 then
3339 -- if Opnd2'Length /= 0 then
3344 -- The nesting ends either when we hit an operand whose length is known
3345 -- at compile time, or on reaching the last operand, whose low bound we
3346 -- take unconditionally whether or not it is null. It's easiest to do
3347 -- this with a recursive procedure:
3351 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3352 -- Returns the lower bound determined by operands J .. NN
3354 ---------------------
3355 -- Get_Known_Bound --
3356 ---------------------
3358 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3360 if Is_Fixed_Length
(J
) or else J
= NN
then
3361 return New_Copy_Tree
(Opnd_Low_Bound
(J
));
3365 Make_If_Expression
(Loc
,
3366 Expressions
=> New_List
(
3370 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3372 Make_Integer_Literal
(Loc
, 0)),
3374 New_Copy_Tree
(Opnd_Low_Bound
(J
)),
3375 Get_Known_Bound
(J
+ 1)));
3377 end Get_Known_Bound
;
3380 Ent
:= Make_Temporary
(Loc
, 'L');
3383 Make_Object_Declaration
(Loc
,
3384 Defining_Identifier
=> Ent
,
3385 Constant_Present
=> True,
3386 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3387 Expression
=> Get_Known_Bound
(1)));
3389 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3393 pragma Assert
(Present
(Low_Bound
));
3395 -- Now we can safely compute the upper bound, normally
3396 -- Low_Bound + Length - 1.
3401 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3403 Make_Op_Subtract
(Loc
,
3404 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3405 Right_Opnd
=> Make_Artyp_Literal
(1))));
3407 -- Note that calculation of the high bound may cause overflow in some
3408 -- very weird cases, so in the general case we need an overflow check on
3409 -- the high bound. We can avoid this for the common case of string types
3410 -- and other types whose index is Positive, since we chose a wider range
3411 -- for the arithmetic type. If checks are suppressed we do not set the
3412 -- flag, and possibly superfluous warnings will be omitted.
3414 if Istyp
/= Standard_Positive
3415 and then not Overflow_Checks_Suppressed
(Istyp
)
3417 Activate_Overflow_Check
(High_Bound
);
3420 -- Handle the exceptional case where the result is null, in which case
3421 -- case the bounds come from the last operand (so that we get the proper
3422 -- bounds if the last operand is super-flat).
3424 if Result_May_Be_Null
then
3426 Make_If_Expression
(Loc
,
3427 Expressions
=> New_List
(
3429 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3430 Right_Opnd
=> Make_Artyp_Literal
(0)),
3431 Last_Opnd_Low_Bound
,
3435 Make_If_Expression
(Loc
,
3436 Expressions
=> New_List
(
3438 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3439 Right_Opnd
=> Make_Artyp_Literal
(0)),
3440 Last_Opnd_High_Bound
,
3444 -- Here is where we insert the saved up actions
3446 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3448 -- Now we construct an array object with appropriate bounds. We mark
3449 -- the target as internal to prevent useless initialization when
3450 -- Initialize_Scalars is enabled. Also since this is the actual result
3451 -- entity, we make sure we have debug information for the result.
3454 Make_Subtype_Indication
(Loc
,
3455 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3457 Make_Index_Or_Discriminant_Constraint
(Loc
,
3458 Constraints
=> New_List
(
3460 Low_Bound
=> Low_Bound
,
3461 High_Bound
=> High_Bound
))));
3463 Ent
:= Make_Temporary
(Loc
, 'S');
3464 Set_Is_Internal
(Ent
);
3465 Set_Debug_Info_Needed
(Ent
);
3467 -- If we are concatenating strings and the current scope already uses
3468 -- the secondary stack, allocate the resulting string also on the
3469 -- secondary stack to avoid putting too much pressure on the primary
3471 -- Don't do this if -gnatd.h is set, as this will break the wrapping of
3472 -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat.
3474 if Atyp
= Standard_String
3475 and then Uses_Sec_Stack
(Current_Scope
)
3476 and then RTE_Available
(RE_SS_Pool
)
3477 and then not Debug_Flag_Dot_H
3480 -- subtype Axx is ...;
3481 -- type Ayy is access Axx;
3482 -- Rxx : Ayy := new <subtype> [storage_pool = ss_pool];
3483 -- Sxx : <subtype> renames Rxx.all;
3487 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3488 Acc_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3492 Insert_Action
(Cnode
,
3493 Make_Subtype_Declaration
(Loc
,
3494 Defining_Identifier
=> ConstrT
,
3495 Subtype_Indication
=> Subtyp_Ind
),
3496 Suppress
=> All_Checks
);
3497 Freeze_Itype
(ConstrT
, Cnode
);
3499 Insert_Action
(Cnode
,
3500 Make_Full_Type_Declaration
(Loc
,
3501 Defining_Identifier
=> Acc_Typ
,
3503 Make_Access_To_Object_Definition
(Loc
,
3504 Subtype_Indication
=> New_Occurrence_Of
(ConstrT
, Loc
))),
3505 Suppress
=> All_Checks
);
3507 Make_Allocator
(Loc
,
3508 Expression
=> New_Occurrence_Of
(ConstrT
, Loc
));
3509 Set_Storage_Pool
(Alloc
, RTE
(RE_SS_Pool
));
3510 Set_Procedure_To_Call
(Alloc
, RTE
(RE_SS_Allocate
));
3512 Temp
:= Make_Temporary
(Loc
, 'R', Alloc
);
3513 Insert_Action
(Cnode
,
3514 Make_Object_Declaration
(Loc
,
3515 Defining_Identifier
=> Temp
,
3516 Object_Definition
=> New_Occurrence_Of
(Acc_Typ
, Loc
),
3517 Expression
=> Alloc
),
3518 Suppress
=> All_Checks
);
3520 Insert_Action
(Cnode
,
3521 Make_Object_Renaming_Declaration
(Loc
,
3522 Defining_Identifier
=> Ent
,
3523 Subtype_Mark
=> New_Occurrence_Of
(ConstrT
, Loc
),
3525 Make_Explicit_Dereference
(Loc
,
3526 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
3527 Suppress
=> All_Checks
);
3530 -- If the bound is statically known to be out of range, we do not
3531 -- want to abort, we want a warning and a runtime constraint error.
3532 -- Note that we have arranged that the result will not be treated as
3533 -- a static constant, so we won't get an illegality during this
3535 -- We also enable checks (in particular range checks) in case the
3536 -- bounds of Subtyp_Ind are out of range.
3538 Insert_Action
(Cnode
,
3539 Make_Object_Declaration
(Loc
,
3540 Defining_Identifier
=> Ent
,
3541 Object_Definition
=> Subtyp_Ind
));
3544 -- If the result of the concatenation appears as the initializing
3545 -- expression of an object declaration, we can just rename the
3546 -- result, rather than copying it.
3548 Set_OK_To_Rename
(Ent
);
3550 -- Catch the static out of range case now
3552 if Raises_Constraint_Error
(High_Bound
) then
3553 raise Concatenation_Error
;
3556 -- Now we will generate the assignments to do the actual concatenation
3558 -- There is one case in which we will not do this, namely when all the
3559 -- following conditions are met:
3561 -- The result type is Standard.String
3563 -- There are nine or fewer retained (non-null) operands
3565 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3566 -- and the debug flag gnatd.c is not set.
3568 -- The corresponding System.Concat_n.Str_Concat_n routine is
3569 -- available in the run time.
3571 -- If all these conditions are met then we generate a call to the
3572 -- relevant concatenation routine. The purpose of this is to avoid
3573 -- undesirable code bloat at -O0.
3575 -- If the concatenation is within the declaration of a library-level
3576 -- object, we call the built-in concatenation routines to prevent code
3577 -- bloat, regardless of the optimization level. This is space efficient
3578 -- and prevents linking problems when units are compiled with different
3579 -- optimization levels.
3581 if Atyp
= Standard_String
3582 and then NN
in 2 .. 9
3583 and then (((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3584 and then not Debug_Flag_Dot_C
)
3585 or else Library_Level_Target
)
3588 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3599 if RTE_Available
(RR
(NN
)) then
3601 Opnds
: constant List_Id
:=
3602 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3605 for J
in 1 .. NN
loop
3606 if Is_List_Member
(Operands
(J
)) then
3607 Remove
(Operands
(J
));
3610 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3612 Make_Aggregate
(Loc
,
3613 Component_Associations
=> New_List
(
3614 Make_Component_Association
(Loc
,
3615 Choices
=> New_List
(
3616 Make_Integer_Literal
(Loc
, 1)),
3617 Expression
=> Operands
(J
)))));
3620 Append_To
(Opnds
, Operands
(J
));
3624 Insert_Action
(Cnode
,
3625 Make_Procedure_Call_Statement
(Loc
,
3626 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3627 Parameter_Associations
=> Opnds
));
3629 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3636 -- Not special case so generate the assignments
3638 Known_Non_Null_Operand_Seen
:= False;
3640 for J
in 1 .. NN
loop
3642 Lo
: constant Node_Id
:=
3644 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3645 Right_Opnd
=> Aggr_Length
(J
- 1));
3647 Hi
: constant Node_Id
:=
3649 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3651 Make_Op_Subtract
(Loc
,
3652 Left_Opnd
=> Aggr_Length
(J
),
3653 Right_Opnd
=> Make_Artyp_Literal
(1)));
3656 -- Singleton case, simple assignment
3658 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3659 Known_Non_Null_Operand_Seen
:= True;
3660 Insert_Action
(Cnode
,
3661 Make_Assignment_Statement
(Loc
,
3663 Make_Indexed_Component
(Loc
,
3664 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3665 Expressions
=> New_List
(To_Ityp
(Lo
))),
3666 Expression
=> Operands
(J
)),
3667 Suppress
=> All_Checks
);
3669 -- Array case, slice assignment, skipped when argument is fixed
3670 -- length and known to be null.
3672 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3675 Make_Assignment_Statement
(Loc
,
3679 New_Occurrence_Of
(Ent
, Loc
),
3682 Low_Bound
=> To_Ityp
(Lo
),
3683 High_Bound
=> To_Ityp
(Hi
))),
3684 Expression
=> Operands
(J
));
3686 if Is_Fixed_Length
(J
) then
3687 Known_Non_Null_Operand_Seen
:= True;
3689 elsif not Known_Non_Null_Operand_Seen
then
3691 -- Here if operand length is not statically known and no
3692 -- operand known to be non-null has been processed yet.
3693 -- If operand length is 0, we do not need to perform the
3694 -- assignment, and we must avoid the evaluation of the
3695 -- high bound of the slice, since it may underflow if the
3696 -- low bound is Ityp'First.
3699 Make_Implicit_If_Statement
(Cnode
,
3703 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3704 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3705 Then_Statements
=> New_List
(Assign
));
3708 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3714 -- Finally we build the result, which is a reference to the array object
3716 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3719 pragma Assert
(Present
(Result
));
3720 Rewrite
(Cnode
, Result
);
3721 Analyze_And_Resolve
(Cnode
, Atyp
);
3724 when Concatenation_Error
=>
3726 -- Kill warning generated for the declaration of the static out of
3727 -- range high bound, and instead generate a Constraint_Error with
3728 -- an appropriate specific message.
3730 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3731 Apply_Compile_Time_Constraint_Error
3733 Msg
=> "concatenation result upper bound out of range??",
3734 Reason
=> CE_Range_Check_Failed
);
3735 end Expand_Concatenate
;
3737 ---------------------------------------------------
3738 -- Expand_Membership_Minimize_Eliminate_Overflow --
3739 ---------------------------------------------------
3741 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3742 pragma Assert
(Nkind
(N
) = N_In
);
3743 -- Despite the name, this routine applies only to N_In, not to
3744 -- N_Not_In. The latter is always rewritten as not (X in Y).
3746 Result_Type
: constant Entity_Id
:= Etype
(N
);
3747 -- Capture result type, may be a derived boolean type
3749 Loc
: constant Source_Ptr
:= Sloc
(N
);
3750 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3751 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3753 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3754 -- is thus tempting to capture these values, but due to the rewrites
3755 -- that occur as a result of overflow checking, these values change
3756 -- as we go along, and it is safe just to always use Etype explicitly.
3758 Restype
: constant Entity_Id
:= Etype
(N
);
3762 -- Bounds in Minimize calls, not used currently
3764 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3765 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3768 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3770 -- If right operand is a subtype name, and the subtype name has no
3771 -- predicate, then we can just replace the right operand with an
3772 -- explicit range T'First .. T'Last, and use the explicit range code.
3774 if Nkind
(Rop
) /= N_Range
3775 and then No
(Predicate_Function
(Etype
(Rop
)))
3778 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3783 Make_Attribute_Reference
(Loc
,
3784 Attribute_Name
=> Name_First
,
3785 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3787 Make_Attribute_Reference
(Loc
,
3788 Attribute_Name
=> Name_Last
,
3789 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3790 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3794 -- Here for the explicit range case. Note that the bounds of the range
3795 -- have not been processed for minimized or eliminated checks.
3797 if Nkind
(Rop
) = N_Range
then
3798 Minimize_Eliminate_Overflows
3799 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3800 Minimize_Eliminate_Overflows
3801 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3803 -- We have A in B .. C, treated as A >= B and then A <= C
3807 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3808 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3809 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3812 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3813 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3814 L
: constant Entity_Id
:=
3815 Make_Defining_Identifier
(Loc
, Name_uL
);
3816 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3817 Lbound
: constant Node_Id
:=
3818 Convert_To_Bignum
(Low_Bound
(Rop
));
3819 Hbound
: constant Node_Id
:=
3820 Convert_To_Bignum
(High_Bound
(Rop
));
3822 -- Now we rewrite the membership test node to look like
3825 -- Bnn : Result_Type;
3827 -- M : Mark_Id := SS_Mark;
3828 -- L : Bignum := Lopnd;
3830 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3838 -- Insert declaration of L into declarations of bignum block
3841 (Last
(Declarations
(Blk
)),
3842 Make_Object_Declaration
(Loc
,
3843 Defining_Identifier
=> L
,
3844 Object_Definition
=>
3845 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3846 Expression
=> Lopnd
));
3848 -- Insert assignment to Bnn into expressions of bignum block
3851 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3852 Make_Assignment_Statement
(Loc
,
3853 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3857 Make_Function_Call
(Loc
,
3859 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3860 Parameter_Associations
=> New_List
(
3861 New_Occurrence_Of
(L
, Loc
),
3865 Make_Function_Call
(Loc
,
3867 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3868 Parameter_Associations
=> New_List
(
3869 New_Occurrence_Of
(L
, Loc
),
3872 -- Now rewrite the node
3875 Make_Expression_With_Actions
(Loc
,
3876 Actions
=> New_List
(
3877 Make_Object_Declaration
(Loc
,
3878 Defining_Identifier
=> Bnn
,
3879 Object_Definition
=>
3880 New_Occurrence_Of
(Result_Type
, Loc
)),
3882 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3883 Analyze_And_Resolve
(N
, Result_Type
);
3887 -- Here if no bignums around
3890 -- Case where types are all the same
3892 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3894 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3898 -- If types are not all the same, it means that we have rewritten
3899 -- at least one of them to be of type Long_Long_Integer, and we
3900 -- will convert the other operands to Long_Long_Integer.
3903 Convert_To_And_Rewrite
(LLIB
, Lop
);
3904 Set_Analyzed
(Lop
, False);
3905 Analyze_And_Resolve
(Lop
, LLIB
);
3907 -- For the right operand, avoid unnecessary recursion into
3908 -- this routine, we know that overflow is not possible.
3910 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3911 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3912 Set_Analyzed
(Rop
, False);
3913 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3916 -- Now the three operands are of the same signed integer type,
3917 -- so we can use the normal expansion routine for membership,
3918 -- setting the flag to prevent recursion into this procedure.
3920 Set_No_Minimize_Eliminate
(N
);
3924 -- Right operand is a subtype name and the subtype has a predicate. We
3925 -- have to make sure the predicate is checked, and for that we need to
3926 -- use the standard N_In circuitry with appropriate types.
3929 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3931 -- If types are "right", just call Expand_N_In preventing recursion
3933 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3934 Set_No_Minimize_Eliminate
(N
);
3939 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3941 -- For X in T, we want to rewrite our node as
3944 -- Bnn : Result_Type;
3947 -- M : Mark_Id := SS_Mark;
3948 -- Lnn : Long_Long_Integer'Base
3954 -- if not Bignum_In_LLI_Range (Nnn) then
3957 -- Lnn := From_Bignum (Nnn);
3959 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3960 -- and then T'Base (Lnn) in T;
3969 -- A bit gruesome, but there doesn't seem to be a simpler way
3972 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3973 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3974 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3975 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3976 T
: constant Entity_Id
:= Etype
(Rop
);
3977 TB
: constant Entity_Id
:= Base_Type
(T
);
3981 -- Mark the last membership operation to prevent recursion
3985 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3986 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3987 Set_No_Minimize_Eliminate
(Nin
);
3989 -- Now decorate the block
3992 (Last
(Declarations
(Blk
)),
3993 Make_Object_Declaration
(Loc
,
3994 Defining_Identifier
=> Lnn
,
3995 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3998 (Last
(Declarations
(Blk
)),
3999 Make_Object_Declaration
(Loc
,
4000 Defining_Identifier
=> Nnn
,
4001 Object_Definition
=>
4002 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
4005 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
4007 Make_Assignment_Statement
(Loc
,
4008 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
4009 Expression
=> Relocate_Node
(Lop
)),
4011 Make_Implicit_If_Statement
(N
,
4015 Make_Function_Call
(Loc
,
4018 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
4019 Parameter_Associations
=> New_List
(
4020 New_Occurrence_Of
(Nnn
, Loc
)))),
4022 Then_Statements
=> New_List
(
4023 Make_Assignment_Statement
(Loc
,
4024 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4026 New_Occurrence_Of
(Standard_False
, Loc
))),
4028 Else_Statements
=> New_List
(
4029 Make_Assignment_Statement
(Loc
,
4030 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4032 Make_Function_Call
(Loc
,
4034 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4035 Parameter_Associations
=> New_List
(
4036 New_Occurrence_Of
(Nnn
, Loc
)))),
4038 Make_Assignment_Statement
(Loc
,
4039 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4044 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4049 Make_Attribute_Reference
(Loc
,
4050 Attribute_Name
=> Name_First
,
4052 New_Occurrence_Of
(TB
, Loc
))),
4056 Make_Attribute_Reference
(Loc
,
4057 Attribute_Name
=> Name_Last
,
4059 New_Occurrence_Of
(TB
, Loc
))))),
4061 Right_Opnd
=> Nin
))))));
4063 -- Now we can do the rewrite
4066 Make_Expression_With_Actions
(Loc
,
4067 Actions
=> New_List
(
4068 Make_Object_Declaration
(Loc
,
4069 Defining_Identifier
=> Bnn
,
4070 Object_Definition
=>
4071 New_Occurrence_Of
(Result_Type
, Loc
)),
4073 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
4074 Analyze_And_Resolve
(N
, Result_Type
);
4078 -- Not bignum case, but types don't match (this means we rewrote the
4079 -- left operand to be Long_Long_Integer).
4082 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
4084 -- We rewrite the membership test as (where T is the type with
4085 -- the predicate, i.e. the type of the right operand)
4087 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4088 -- and then T'Base (Lop) in T
4091 T
: constant Entity_Id
:= Etype
(Rop
);
4092 TB
: constant Entity_Id
:= Base_Type
(T
);
4096 -- The last membership test is marked to prevent recursion
4100 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
4101 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4102 Set_No_Minimize_Eliminate
(Nin
);
4104 -- Now do the rewrite
4115 Make_Attribute_Reference
(Loc
,
4116 Attribute_Name
=> Name_First
,
4118 New_Occurrence_Of
(TB
, Loc
))),
4121 Make_Attribute_Reference
(Loc
,
4122 Attribute_Name
=> Name_Last
,
4124 New_Occurrence_Of
(TB
, Loc
))))),
4125 Right_Opnd
=> Nin
));
4126 Set_Analyzed
(N
, False);
4127 Analyze_And_Resolve
(N
, Restype
);
4131 end Expand_Membership_Minimize_Eliminate_Overflow
;
4133 ---------------------------------
4134 -- Expand_Nonbinary_Modular_Op --
4135 ---------------------------------
4137 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
) is
4138 Loc
: constant Source_Ptr
:= Sloc
(N
);
4139 Typ
: constant Entity_Id
:= Etype
(N
);
4141 procedure Expand_Modular_Addition
;
4142 -- Expand the modular addition, handling the special case of adding a
4145 procedure Expand_Modular_Op
;
4146 -- Compute the general rule: (lhs OP rhs) mod Modulus
4148 procedure Expand_Modular_Subtraction
;
4149 -- Expand the modular addition, handling the special case of subtracting
4152 -----------------------------
4153 -- Expand_Modular_Addition --
4154 -----------------------------
4156 procedure Expand_Modular_Addition
is
4158 -- If this is not the addition of a constant then compute it using
4159 -- the general rule: (lhs + rhs) mod Modulus
4161 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4164 -- If this is an addition of a constant, convert it to a subtraction
4165 -- plus a conditional expression since we can compute it faster than
4166 -- computing the modulus.
4168 -- modMinusRhs = Modulus - rhs
4169 -- if lhs < modMinusRhs then lhs + rhs
4170 -- else lhs - modMinusRhs
4174 Mod_Minus_Right
: constant Uint
:=
4175 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4177 Exprs
: constant List_Id
:= New_List
;
4178 Cond_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Lt
, Loc
);
4179 Then_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Add
, Loc
);
4180 Else_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Subtract
,
4183 -- To prevent spurious visibility issues, convert all
4184 -- operands to Standard.Unsigned.
4186 Set_Left_Opnd
(Cond_Expr
,
4187 Unchecked_Convert_To
(Standard_Unsigned
,
4188 New_Copy_Tree
(Left_Opnd
(N
))));
4189 Set_Right_Opnd
(Cond_Expr
,
4190 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4191 Append_To
(Exprs
, Cond_Expr
);
4193 Set_Left_Opnd
(Then_Expr
,
4194 Unchecked_Convert_To
(Standard_Unsigned
,
4195 New_Copy_Tree
(Left_Opnd
(N
))));
4196 Set_Right_Opnd
(Then_Expr
,
4197 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4198 Append_To
(Exprs
, Then_Expr
);
4200 Set_Left_Opnd
(Else_Expr
,
4201 Unchecked_Convert_To
(Standard_Unsigned
,
4202 New_Copy_Tree
(Left_Opnd
(N
))));
4203 Set_Right_Opnd
(Else_Expr
,
4204 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4205 Append_To
(Exprs
, Else_Expr
);
4208 Unchecked_Convert_To
(Typ
,
4209 Make_If_Expression
(Loc
, Expressions
=> Exprs
)));
4212 end Expand_Modular_Addition
;
4214 -----------------------
4215 -- Expand_Modular_Op --
4216 -----------------------
4218 procedure Expand_Modular_Op
is
4219 Op_Expr
: constant Node_Id
:= New_Op_Node
(Nkind
(N
), Loc
);
4220 Mod_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Mod
, Loc
);
4222 Target_Type
: Entity_Id
;
4225 -- Convert nonbinary modular type operands into integer values. Thus
4226 -- we avoid never-ending loops expanding them, and we also ensure
4227 -- the back end never receives nonbinary modular type expressions.
4229 if Nkind
(N
) in N_Op_And | N_Op_Or | N_Op_Xor
then
4230 Set_Left_Opnd
(Op_Expr
,
4231 Unchecked_Convert_To
(Standard_Unsigned
,
4232 New_Copy_Tree
(Left_Opnd
(N
))));
4233 Set_Right_Opnd
(Op_Expr
,
4234 Unchecked_Convert_To
(Standard_Unsigned
,
4235 New_Copy_Tree
(Right_Opnd
(N
))));
4236 Set_Left_Opnd
(Mod_Expr
,
4237 Unchecked_Convert_To
(Standard_Integer
, Op_Expr
));
4240 -- If the modulus of the type is larger than Integer'Last use a
4241 -- larger type for the operands, to prevent spurious constraint
4242 -- errors on large legal literals of the type.
4244 if Modulus
(Etype
(N
)) > UI_From_Int
(Int
(Integer'Last)) then
4245 Target_Type
:= Standard_Long_Long_Integer
;
4247 Target_Type
:= Standard_Integer
;
4250 Set_Left_Opnd
(Op_Expr
,
4251 Unchecked_Convert_To
(Target_Type
,
4252 New_Copy_Tree
(Left_Opnd
(N
))));
4253 Set_Right_Opnd
(Op_Expr
,
4254 Unchecked_Convert_To
(Target_Type
,
4255 New_Copy_Tree
(Right_Opnd
(N
))));
4257 -- Link this node to the tree to analyze it
4259 -- If the parent node is an expression with actions we link it to
4260 -- N since otherwise Force_Evaluation cannot identify if this node
4261 -- comes from the Expression and rejects generating the temporary.
4263 if Nkind
(Parent
(N
)) = N_Expression_With_Actions
then
4264 Set_Parent
(Op_Expr
, N
);
4269 Set_Parent
(Op_Expr
, Parent
(N
));
4274 -- Force generating a temporary because in the expansion of this
4275 -- expression we may generate code that performs this computation
4278 Force_Evaluation
(Op_Expr
, Mode
=> Strict
);
4280 Set_Left_Opnd
(Mod_Expr
, Op_Expr
);
4283 Set_Right_Opnd
(Mod_Expr
,
4284 Make_Integer_Literal
(Loc
, Modulus
(Typ
)));
4287 Unchecked_Convert_To
(Typ
, Mod_Expr
));
4288 end Expand_Modular_Op
;
4290 --------------------------------
4291 -- Expand_Modular_Subtraction --
4292 --------------------------------
4294 procedure Expand_Modular_Subtraction
is
4296 -- If this is not the addition of a constant then compute it using
4297 -- the general rule: (lhs + rhs) mod Modulus
4299 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4302 -- If this is an addition of a constant, convert it to a subtraction
4303 -- plus a conditional expression since we can compute it faster than
4304 -- computing the modulus.
4306 -- modMinusRhs = Modulus - rhs
4307 -- if lhs < rhs then lhs + modMinusRhs
4312 Mod_Minus_Right
: constant Uint
:=
4313 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4315 Exprs
: constant List_Id
:= New_List
;
4316 Cond_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Lt
, Loc
);
4317 Then_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Add
, Loc
);
4318 Else_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Subtract
,
4321 Set_Left_Opnd
(Cond_Expr
,
4322 Unchecked_Convert_To
(Standard_Unsigned
,
4323 New_Copy_Tree
(Left_Opnd
(N
))));
4324 Set_Right_Opnd
(Cond_Expr
,
4325 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4326 Append_To
(Exprs
, Cond_Expr
);
4328 Set_Left_Opnd
(Then_Expr
,
4329 Unchecked_Convert_To
(Standard_Unsigned
,
4330 New_Copy_Tree
(Left_Opnd
(N
))));
4331 Set_Right_Opnd
(Then_Expr
,
4332 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4333 Append_To
(Exprs
, Then_Expr
);
4335 Set_Left_Opnd
(Else_Expr
,
4336 Unchecked_Convert_To
(Standard_Unsigned
,
4337 New_Copy_Tree
(Left_Opnd
(N
))));
4338 Set_Right_Opnd
(Else_Expr
,
4339 Unchecked_Convert_To
(Standard_Unsigned
,
4340 New_Copy_Tree
(Right_Opnd
(N
))));
4341 Append_To
(Exprs
, Else_Expr
);
4344 Unchecked_Convert_To
(Typ
,
4345 Make_If_Expression
(Loc
, Expressions
=> Exprs
)));
4348 end Expand_Modular_Subtraction
;
4350 -- Start of processing for Expand_Nonbinary_Modular_Op
4353 -- No action needed if front-end expansion is not required or if we
4354 -- have a binary modular operand.
4356 if not Expand_Nonbinary_Modular_Ops
4357 or else not Non_Binary_Modulus
(Typ
)
4364 Expand_Modular_Addition
;
4366 when N_Op_Subtract
=>
4367 Expand_Modular_Subtraction
;
4371 -- Expand -expr into (0 - expr)
4374 Make_Op_Subtract
(Loc
,
4375 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
4376 Right_Opnd
=> Right_Opnd
(N
)));
4377 Analyze_And_Resolve
(N
, Typ
);
4383 Analyze_And_Resolve
(N
, Typ
);
4384 end Expand_Nonbinary_Modular_Op
;
4386 ------------------------
4387 -- Expand_N_Allocator --
4388 ------------------------
4390 procedure Expand_N_Allocator
(N
: Node_Id
) is
4391 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4392 Loc
: constant Source_Ptr
:= Sloc
(N
);
4393 PtrT
: constant Entity_Id
:= Etype
(N
);
4395 procedure Rewrite_Coextension
(N
: Node_Id
);
4396 -- Static coextensions have the same lifetime as the entity they
4397 -- constrain. Such occurrences can be rewritten as aliased objects
4398 -- and their unrestricted access used instead of the coextension.
4400 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4401 -- Given a constrained array type E, returns a node representing the
4402 -- code to compute a close approximation of the size in storage elements
4403 -- for the given type; for indexes that are modular types we compute
4404 -- 'Last - First (instead of 'Length) because for large arrays computing
4405 -- 'Last -'First + 1 causes overflow. This is done without using the
4406 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4409 -------------------------
4410 -- Rewrite_Coextension --
4411 -------------------------
4413 procedure Rewrite_Coextension
(N
: Node_Id
) is
4414 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4415 Temp_Decl
: Node_Id
;
4419 -- Cnn : aliased Etyp;
4422 Make_Object_Declaration
(Loc
,
4423 Defining_Identifier
=> Temp_Id
,
4424 Aliased_Present
=> True,
4425 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4427 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4428 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4431 Insert_Action
(N
, Temp_Decl
);
4433 Make_Attribute_Reference
(Loc
,
4434 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4435 Attribute_Name
=> Name_Unrestricted_Access
));
4437 Analyze_And_Resolve
(N
, PtrT
);
4438 end Rewrite_Coextension
;
4440 ------------------------------
4441 -- Size_In_Storage_Elements --
4442 ------------------------------
4444 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4446 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4447 -- However, the reason for the existence of this function is
4448 -- to construct a test for sizes too large, which means near the
4449 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4450 -- is that we get overflows when sizes are greater than 2**31.
4452 -- So what we end up doing for array types is to use the expression:
4454 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4456 -- which avoids this problem. All this is a bit bogus, but it does
4457 -- mean we catch common cases of trying to allocate arrays that
4458 -- are too large, and which in the absence of a check results in
4459 -- undetected chaos ???
4461 -- Note in particular that this is a pessimistic estimate in the
4462 -- case of packed array types, where an array element might occupy
4463 -- just a fraction of a storage element???
4466 Idx
: Node_Id
:= First_Index
(E
);
4468 Res
: Node_Id
:= Empty
;
4471 for J
in 1 .. Number_Dimensions
(E
) loop
4473 if not Is_Modular_Integer_Type
(Etype
(Idx
)) then
4475 Make_Attribute_Reference
(Loc
,
4476 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4477 Attribute_Name
=> Name_Length
,
4478 Expressions
=> New_List
4479 (Make_Integer_Literal
(Loc
, J
)));
4481 -- For indexes that are modular types we cannot generate code
4482 -- to compute 'Length since for large arrays 'Last -'First + 1
4483 -- causes overflow; therefore we compute 'Last - 'First (which
4484 -- is not the exact number of components but it is valid for
4485 -- the purpose of this runtime check on 32-bit targets).
4489 Len_Minus_1_Expr
: Node_Id
;
4495 Make_Attribute_Reference
(Loc
,
4496 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4497 Attribute_Name
=> Name_Last
,
4499 New_List
(Make_Integer_Literal
(Loc
, J
))),
4500 Make_Attribute_Reference
(Loc
,
4501 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4502 Attribute_Name
=> Name_First
,
4504 New_List
(Make_Integer_Literal
(Loc
, J
))));
4507 Convert_To
(Standard_Unsigned
,
4508 Make_Op_Subtract
(Loc
,
4509 Make_Attribute_Reference
(Loc
,
4510 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4511 Attribute_Name
=> Name_Last
,
4514 (Make_Integer_Literal
(Loc
, J
))),
4515 Make_Attribute_Reference
(Loc
,
4516 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4517 Attribute_Name
=> Name_First
,
4520 (Make_Integer_Literal
(Loc
, J
)))));
4522 -- Handle superflat arrays, i.e. arrays with such bounds
4523 -- as 4 .. 2, to ensure that the result is correct.
4526 -- (if X'Last > X'First then X'Last - X'First else 0)
4529 Make_If_Expression
(Loc
,
4530 Expressions
=> New_List
(
4533 Make_Integer_Literal
(Loc
, Uint_0
)));
4541 pragma Assert
(Present
(Res
));
4543 Make_Op_Multiply
(Loc
,
4552 Make_Op_Multiply
(Loc
,
4555 Make_Attribute_Reference
(Loc
,
4556 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4557 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4559 end Size_In_Storage_Elements
;
4563 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4567 Rel_Typ
: Entity_Id
;
4570 -- Start of processing for Expand_N_Allocator
4573 -- Warn on the presence of an allocator of an anonymous access type when
4574 -- enabled, except when it's an object declaration at library level.
4576 if Warn_On_Anonymous_Allocators
4577 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
4578 and then not (Is_Library_Level_Entity
(PtrT
)
4579 and then Nkind
(Associated_Node_For_Itype
(PtrT
)) =
4580 N_Object_Declaration
)
4582 Error_Msg_N
("??use of an anonymous access type allocator", N
);
4585 -- RM E.2.2(17). We enforce that the expected type of an allocator
4586 -- shall not be a remote access-to-class-wide-limited-private type
4588 -- Why is this being done at expansion time, seems clearly wrong ???
4590 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4592 -- Processing for anonymous access-to-controlled types. These access
4593 -- types receive a special finalization master which appears in the
4594 -- declarations of the enclosing semantic unit. This expansion is done
4595 -- now to ensure that any additional types generated by this routine or
4596 -- Expand_Allocator_Expression inherit the proper type attributes.
4598 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4599 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4600 and then Needs_Finalization
(Dtyp
)
4602 -- Detect the allocation of an anonymous controlled object where the
4603 -- type of the context is named. For example:
4605 -- procedure Proc (Ptr : Named_Access_Typ);
4606 -- Proc (new Designated_Typ);
4608 -- Regardless of the anonymous-to-named access type conversion, the
4609 -- lifetime of the object must be associated with the named access
4610 -- type. Use the finalization-related attributes of this type.
4612 if Nkind
(Parent
(N
)) in N_Type_Conversion
4613 | N_Unchecked_Type_Conversion
4614 and then Ekind
(Etype
(Parent
(N
))) in E_Access_Subtype
4616 | E_General_Access_Type
4618 Rel_Typ
:= Etype
(Parent
(N
));
4623 -- Anonymous access-to-controlled types allocate on the global pool.
4624 -- Note that this is a "root type only" attribute.
4626 if No
(Associated_Storage_Pool
(PtrT
)) then
4627 if Present
(Rel_Typ
) then
4628 Set_Associated_Storage_Pool
4629 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4631 Set_Associated_Storage_Pool
4632 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4636 -- The finalization master must be inserted and analyzed as part of
4637 -- the current semantic unit. Note that the master is updated when
4638 -- analysis changes current units. Note that this is a "root type
4641 if Present
(Rel_Typ
) then
4642 Set_Finalization_Master
4643 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4645 Build_Anonymous_Master
(Root_Type
(PtrT
));
4649 -- Set the storage pool and find the appropriate version of Allocate to
4650 -- call. Do not overwrite the storage pool if it is already set, which
4651 -- can happen for build-in-place function returns (see
4652 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4654 if No
(Storage_Pool
(N
)) then
4655 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4657 if Present
(Pool
) then
4658 Set_Storage_Pool
(N
, Pool
);
4660 if Is_RTE
(Pool
, RE_SS_Pool
) then
4661 Check_Restriction
(No_Secondary_Stack
, N
);
4662 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4664 -- In the case of an allocator for a simple storage pool, locate
4665 -- and save a reference to the pool type's Allocate routine.
4667 elsif Present
(Get_Rep_Pragma
4668 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4671 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4672 Alloc_Op
: Entity_Id
;
4674 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4675 while Present
(Alloc_Op
) loop
4676 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4677 and then Present
(First_Formal
(Alloc_Op
))
4678 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4680 Set_Procedure_To_Call
(N
, Alloc_Op
);
4683 Alloc_Op
:= Homonym
(Alloc_Op
);
4688 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4689 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4692 Set_Procedure_To_Call
(N
,
4693 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4698 -- Under certain circumstances we can replace an allocator by an access
4699 -- to statically allocated storage. The conditions, as noted in AARM
4700 -- 3.10 (10c) are as follows:
4702 -- Size and initial value is known at compile time
4703 -- Access type is access-to-constant
4705 -- The allocator is not part of a constraint on a record component,
4706 -- because in that case the inserted actions are delayed until the
4707 -- record declaration is fully analyzed, which is too late for the
4708 -- analysis of the rewritten allocator.
4710 if Is_Access_Constant
(PtrT
)
4711 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4712 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4713 and then Size_Known_At_Compile_Time
4714 (Etype
(Expression
(Expression
(N
))))
4715 and then not Is_Record_Type
(Current_Scope
)
4717 -- Here we can do the optimization. For the allocator
4721 -- We insert an object declaration
4723 -- Tnn : aliased x := y;
4725 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4726 -- marked as requiring static allocation.
4728 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4729 Desig
:= Subtype_Mark
(Expression
(N
));
4731 -- If context is constrained, use constrained subtype directly,
4732 -- so that the constant is not labelled as having a nominally
4733 -- unconstrained subtype.
4735 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4736 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4740 Make_Object_Declaration
(Loc
,
4741 Defining_Identifier
=> Temp
,
4742 Aliased_Present
=> True,
4743 Constant_Present
=> Is_Access_Constant
(PtrT
),
4744 Object_Definition
=> Desig
,
4745 Expression
=> Expression
(Expression
(N
))));
4748 Make_Attribute_Reference
(Loc
,
4749 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4750 Attribute_Name
=> Name_Unrestricted_Access
));
4752 Analyze_And_Resolve
(N
, PtrT
);
4754 -- We set the variable as statically allocated, since we don't want
4755 -- it going on the stack of the current procedure.
4757 Set_Is_Statically_Allocated
(Temp
);
4761 -- Same if the allocator is an access discriminant for a local object:
4762 -- instead of an allocator we create a local value and constrain the
4763 -- enclosing object with the corresponding access attribute.
4765 if Is_Static_Coextension
(N
) then
4766 Rewrite_Coextension
(N
);
4770 -- Check for size too large, we do this because the back end misses
4771 -- proper checks here and can generate rubbish allocation calls when
4772 -- we are near the limit. We only do this for the 32-bit address case
4773 -- since that is from a practical point of view where we see a problem.
4775 if System_Address_Size
= 32
4776 and then not Storage_Checks_Suppressed
(PtrT
)
4777 and then not Storage_Checks_Suppressed
(Dtyp
)
4778 and then not Storage_Checks_Suppressed
(Etyp
)
4780 -- The check we want to generate should look like
4782 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4783 -- raise Storage_Error;
4786 -- where 3.5 gigabytes is a constant large enough to accommodate any
4787 -- reasonable request for. But we can't do it this way because at
4788 -- least at the moment we don't compute this attribute right, and
4789 -- can silently give wrong results when the result gets large. Since
4790 -- this is all about large results, that's bad, so instead we only
4791 -- apply the check for constrained arrays, and manually compute the
4792 -- value of the attribute ???
4794 -- The check on No_Initialization is used here to prevent generating
4795 -- this runtime check twice when the allocator is locally replaced by
4796 -- the expander with another one.
4798 if Is_Array_Type
(Etyp
) and then not No_Initialization
(N
) then
4801 Ins_Nod
: Node_Id
:= N
;
4802 Siz_Typ
: Entity_Id
:= Etyp
;
4806 -- For unconstrained array types initialized with a qualified
4807 -- expression we use its type to perform this check
4809 if not Is_Constrained
(Etyp
)
4810 and then not No_Initialization
(N
)
4811 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4813 Expr
:= Expression
(Expression
(N
));
4814 Siz_Typ
:= Etype
(Expression
(Expression
(N
)));
4816 -- If the qualified expression has been moved to an internal
4817 -- temporary (to remove side effects) then we must insert
4818 -- the runtime check before its declaration to ensure that
4819 -- the check is performed before the execution of the code
4820 -- computing the qualified expression.
4822 if Nkind
(Expr
) = N_Identifier
4823 and then Is_Internal_Name
(Chars
(Expr
))
4825 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
4827 Ins_Nod
:= Parent
(Entity
(Expr
));
4833 if Is_Constrained
(Siz_Typ
)
4834 and then Ekind
(Siz_Typ
) /= E_String_Literal_Subtype
4836 -- For CCG targets, the largest array may have up to 2**31-1
4837 -- components (i.e. 2 gigabytes if each array component is
4838 -- one byte). This ensures that fat pointer fields do not
4839 -- overflow, since they are 32-bit integer types, and also
4840 -- ensures that 'Length can be computed at run time.
4842 if Modify_Tree_For_C
then
4845 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4846 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4847 Uint_2
** 31 - Uint_1
));
4849 -- For native targets the largest object is 3.5 gigabytes
4854 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4855 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4856 Uint_7
* (Uint_2
** 29)));
4859 Insert_Action
(Ins_Nod
,
4860 Make_Raise_Storage_Error
(Loc
,
4862 Reason
=> SE_Object_Too_Large
));
4864 if Entity
(Cond
) = Standard_True
then
4866 ("object too large: Storage_Error will be raised at "
4874 -- If no storage pool has been specified, or the storage pool
4875 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4876 -- No_Standard_Allocators_After_Elaboration is present, then generate
4877 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4879 if Nkind
(N
) = N_Allocator
4880 and then (No
(Storage_Pool
(N
))
4881 or else Is_RTE
(Storage_Pool
(N
), RE_Global_Pool_Object
))
4882 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4885 Make_Procedure_Call_Statement
(Loc
,
4887 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4890 -- Handle case of qualified expression (other than optimization above)
4892 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4893 Expand_Allocator_Expression
(N
);
4897 -- If the allocator is for a type which requires initialization, and
4898 -- there is no initial value (i.e. operand is a subtype indication
4899 -- rather than a qualified expression), then we must generate a call to
4900 -- the initialization routine using an expressions action node:
4902 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4904 -- Here ptr_T is the pointer type for the allocator, and T is the
4905 -- subtype of the allocator. A special case arises if the designated
4906 -- type of the access type is a task or contains tasks. In this case
4907 -- the call to Init (Temp.all ...) is replaced by code that ensures
4908 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4909 -- for details). In addition, if the type T is a task type, then the
4910 -- first argument to Init must be converted to the task record type.
4913 T
: constant Entity_Id
:= Etype
(Expression
(N
));
4919 Init_Arg1
: Node_Id
;
4920 Init_Call
: Node_Id
;
4921 Temp_Decl
: Node_Id
;
4922 Temp_Type
: Entity_Id
;
4925 -- Apply constraint checks against designated subtype (RM 4.8(10/2))
4926 -- but ignore the expression if the No_Initialization flag is set.
4927 -- Discriminant checks will be generated by the expansion below.
4929 if Is_Array_Type
(Dtyp
) and then not No_Initialization
(N
) then
4930 Apply_Constraint_Check
(Expression
(N
), Dtyp
, No_Sliding
=> True);
4932 Apply_Predicate_Check
(Expression
(N
), Dtyp
);
4934 if Nkind
(Expression
(N
)) = N_Raise_Constraint_Error
then
4935 Rewrite
(N
, New_Copy
(Expression
(N
)));
4936 Set_Etype
(N
, PtrT
);
4941 if No_Initialization
(N
) then
4943 -- Even though this might be a simple allocation, create a custom
4944 -- Allocate if the context requires it.
4946 if Present
(Finalization_Master
(PtrT
)) then
4947 Build_Allocate_Deallocate_Proc
4949 Is_Allocate
=> True);
4952 -- Optimize the default allocation of an array object when pragma
4953 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4954 -- in-place initialization aggregate which may be convert into a fast
4955 -- memset by the backend.
4957 elsif Init_Or_Norm_Scalars
4958 and then Is_Array_Type
(T
)
4960 -- The array must lack atomic components because they are treated
4961 -- as non-static, and as a result the backend will not initialize
4962 -- the memory in one go.
4964 and then not Has_Atomic_Components
(T
)
4966 -- The array must not be packed because the invalid values in
4967 -- System.Scalar_Values are multiples of Storage_Unit.
4969 and then not Is_Packed
(T
)
4971 -- The array must have static non-empty ranges, otherwise the
4972 -- backend cannot initialize the memory in one go.
4974 and then Has_Static_Non_Empty_Array_Bounds
(T
)
4976 -- The optimization is only relevant for arrays of scalar types
4978 and then Is_Scalar_Type
(Component_Type
(T
))
4980 -- Similar to regular array initialization using a type init proc,
4981 -- predicate checks are not performed because the initialization
4982 -- values are intentionally invalid, and may violate the predicate.
4984 and then not Has_Predicates
(Component_Type
(T
))
4986 -- The component type must have a single initialization value
4988 and then Needs_Simple_Initialization
4989 (Typ
=> Component_Type
(T
),
4990 Consider_IS
=> True)
4993 Temp
:= Make_Temporary
(Loc
, 'P');
4996 -- Temp : Ptr_Typ := new ...;
5001 Make_Object_Declaration
(Loc
,
5002 Defining_Identifier
=> Temp
,
5003 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
5004 Expression
=> Relocate_Node
(N
)),
5005 Suppress
=> All_Checks
);
5008 -- Temp.all := (others => ...);
5013 Make_Assignment_Statement
(Loc
,
5015 Make_Explicit_Dereference
(Loc
,
5016 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
5021 Size
=> Esize
(Component_Type
(T
)))),
5022 Suppress
=> All_Checks
);
5024 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5025 Analyze_And_Resolve
(N
, PtrT
);
5027 -- Case of no initialization procedure present
5029 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
5031 -- Case of simple initialization required
5033 if Needs_Simple_Initialization
(T
) then
5034 Check_Restriction
(No_Default_Initialization
, N
);
5035 Rewrite
(Expression
(N
),
5036 Make_Qualified_Expression
(Loc
,
5037 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
5038 Expression
=> Get_Simple_Init_Val
(T
, N
)));
5040 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
5041 Analyze_And_Resolve
(Expression
(N
), T
);
5042 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
5043 Expand_N_Allocator
(N
);
5045 -- No initialization required
5048 Build_Allocate_Deallocate_Proc
5050 Is_Allocate
=> True);
5053 -- Case of initialization procedure present, must be called
5055 -- NOTE: There is a *huge* amount of code duplication here from
5056 -- Build_Initialization_Call. We should probably refactor???
5059 Check_Restriction
(No_Default_Initialization
, N
);
5061 if not Restriction_Active
(No_Default_Initialization
) then
5062 Init
:= Base_Init_Proc
(T
);
5064 Temp
:= Make_Temporary
(Loc
, 'P');
5066 -- Construct argument list for the initialization routine call
5069 Make_Explicit_Dereference
(Loc
,
5071 New_Occurrence_Of
(Temp
, Loc
));
5073 Set_Assignment_OK
(Init_Arg1
);
5076 -- The initialization procedure expects a specific type. if the
5077 -- context is access to class wide, indicate that the object
5078 -- being allocated has the right specific type.
5080 if Is_Class_Wide_Type
(Dtyp
) then
5081 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
5084 -- If designated type is a concurrent type or if it is private
5085 -- type whose definition is a concurrent type, the first
5086 -- argument in the Init routine has to be unchecked conversion
5087 -- to the corresponding record type. If the designated type is
5088 -- a derived type, also convert the argument to its root type.
5090 if Is_Concurrent_Type
(T
) then
5092 Unchecked_Convert_To
(
5093 Corresponding_Record_Type
(T
), Init_Arg1
);
5095 elsif Is_Private_Type
(T
)
5096 and then Present
(Full_View
(T
))
5097 and then Is_Concurrent_Type
(Full_View
(T
))
5100 Unchecked_Convert_To
5101 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
5103 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
5105 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
5108 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
5109 Set_Etype
(Init_Arg1
, Ftyp
);
5113 Args
:= New_List
(Init_Arg1
);
5115 -- For the task case, pass the Master_Id of the access type as
5116 -- the value of the _Master parameter, and _Chain as the value
5117 -- of the _Chain parameter (_Chain will be defined as part of
5118 -- the generated code for the allocator).
5120 -- In Ada 2005, the context may be a function that returns an
5121 -- anonymous access type. In that case the Master_Id has been
5122 -- created when expanding the function declaration.
5124 if Has_Task
(T
) then
5125 if No
(Master_Id
(Base_Type
(PtrT
))) then
5127 -- The designated type was an incomplete type, and the
5128 -- access type did not get expanded. Salvage it now.
5130 if Present
(Parent
(Base_Type
(PtrT
))) then
5131 Expand_N_Full_Type_Declaration
5132 (Parent
(Base_Type
(PtrT
)));
5134 -- The only other possibility is an itype. For this
5135 -- case, the master must exist in the context. This is
5136 -- the case when the allocator initializes an access
5137 -- component in an init-proc.
5140 pragma Assert
(Is_Itype
(PtrT
));
5141 Build_Master_Renaming
(PtrT
, N
);
5145 -- If the context of the allocator is a declaration or an
5146 -- assignment, we can generate a meaningful image for it,
5147 -- even though subsequent assignments might remove the
5148 -- connection between task and entity. We build this image
5149 -- when the left-hand side is a simple variable, a simple
5150 -- indexed assignment or a simple selected component.
5152 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
5154 Nam
: constant Node_Id
:= Name
(Parent
(N
));
5157 if Is_Entity_Name
(Nam
) then
5159 Build_Task_Image_Decls
5162 (Entity
(Nam
), Sloc
(Nam
)), T
);
5164 elsif Nkind
(Nam
) in N_Indexed_Component
5165 | N_Selected_Component
5166 and then Is_Entity_Name
(Prefix
(Nam
))
5169 Build_Task_Image_Decls
5170 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
5172 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
5176 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
5178 Build_Task_Image_Decls
5179 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
5182 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
5185 if Restriction_Active
(No_Task_Hierarchy
) then
5187 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
5191 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
5194 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
5196 Decl
:= Last
(Decls
);
5198 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
5200 -- Has_Task is false, Decls not used
5206 -- Add discriminants if discriminated type
5209 Dis
: Boolean := False;
5210 Typ
: Entity_Id
:= Empty
;
5213 if Has_Discriminants
(T
) then
5217 -- Type may be a private type with no visible discriminants
5218 -- in which case check full view if in scope, or the
5219 -- underlying_full_view if dealing with a type whose full
5220 -- view may be derived from a private type whose own full
5221 -- view has discriminants.
5223 elsif Is_Private_Type
(T
) then
5224 if Present
(Full_View
(T
))
5225 and then Has_Discriminants
(Full_View
(T
))
5228 Typ
:= Full_View
(T
);
5230 elsif Present
(Underlying_Full_View
(T
))
5231 and then Has_Discriminants
(Underlying_Full_View
(T
))
5234 Typ
:= Underlying_Full_View
(T
);
5240 -- If the allocated object will be constrained by the
5241 -- default values for discriminants, then build a subtype
5242 -- with those defaults, and change the allocated subtype
5243 -- to that. Note that this happens in fewer cases in Ada
5246 if not Is_Constrained
(Typ
)
5247 and then Present
(Discriminant_Default_Value
5248 (First_Discriminant
(Typ
)))
5249 and then (Ada_Version
< Ada_2005
5251 Object_Type_Has_Constrained_Partial_View
5252 (Typ
, Current_Scope
))
5254 Typ
:= Build_Default_Subtype
(Typ
, N
);
5255 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
5258 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
5259 while Present
(Discr
) loop
5260 Nod
:= Node
(Discr
);
5261 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
5263 -- AI-416: when the discriminant constraint is an
5264 -- anonymous access type make sure an accessibility
5265 -- check is inserted if necessary (3.10.2(22.q/2))
5267 if Ada_Version
>= Ada_2005
5269 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
5271 Apply_Accessibility_Check
5272 (Nod
, Typ
, Insert_Node
=> Nod
);
5280 -- We set the allocator as analyzed so that when we analyze
5281 -- the if expression node, we do not get an unwanted recursive
5282 -- expansion of the allocator expression.
5284 Set_Analyzed
(N
, True);
5285 Nod
:= Relocate_Node
(N
);
5287 -- Here is the transformation:
5288 -- input: new Ctrl_Typ
5289 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5290 -- Ctrl_TypIP (Temp.all, ...);
5291 -- [Deep_]Initialize (Temp.all);
5293 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5294 -- is the subtype of the allocator.
5297 Make_Object_Declaration
(Loc
,
5298 Defining_Identifier
=> Temp
,
5299 Constant_Present
=> True,
5300 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
5303 Set_Assignment_OK
(Temp_Decl
);
5304 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
5306 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
5308 -- If the designated type is a task type or contains tasks,
5309 -- create block to activate created tasks, and insert
5310 -- declaration for Task_Image variable ahead of call.
5312 if Has_Task
(T
) then
5314 L
: constant List_Id
:= New_List
;
5317 Build_Task_Allocate_Block
(L
, Nod
, Args
);
5319 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
5320 Insert_Actions
(N
, L
);
5325 Make_Procedure_Call_Statement
(Loc
,
5326 Name
=> New_Occurrence_Of
(Init
, Loc
),
5327 Parameter_Associations
=> Args
));
5330 if Needs_Finalization
(T
) then
5333 -- [Deep_]Initialize (Init_Arg1);
5337 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
5340 -- Guard against a missing [Deep_]Initialize when the
5341 -- designated type was not properly frozen.
5343 if Present
(Init_Call
) then
5344 Insert_Action
(N
, Init_Call
);
5348 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5349 Analyze_And_Resolve
(N
, PtrT
);
5354 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5355 -- object that has been rewritten as a reference, we displace "this"
5356 -- to reference properly its secondary dispatch table.
5358 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
5359 Displace_Allocator_Pointer
(N
);
5363 when RE_Not_Available
=>
5365 end Expand_N_Allocator
;
5367 -----------------------
5368 -- Expand_N_And_Then --
5369 -----------------------
5371 procedure Expand_N_And_Then
(N
: Node_Id
)
5372 renames Expand_Short_Circuit_Operator
;
5374 ------------------------------
5375 -- Expand_N_Case_Expression --
5376 ------------------------------
5378 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
5379 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean;
5380 -- Return True if we can copy objects of this type when expanding a case
5387 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean is
5389 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5390 -- large objects, as long as they are constrained and not limited.
5393 Is_Elementary_Type
(Underlying_Type
(Typ
))
5395 (Minimize_Expression_With_Actions
5396 and then Is_Constrained
(Underlying_Type
(Typ
))
5397 and then not Is_Limited_Type
(Underlying_Type
(Typ
)));
5402 Loc
: constant Source_Ptr
:= Sloc
(N
);
5403 Par
: constant Node_Id
:= Parent
(N
);
5404 Typ
: constant Entity_Id
:= Etype
(N
);
5408 Case_Stmt
: Node_Id
;
5411 Target
: Entity_Id
:= Empty
;
5412 Target_Typ
: Entity_Id
;
5414 In_Predicate
: Boolean := False;
5415 -- Flag set when the case expression appears within a predicate
5417 Optimize_Return_Stmt
: Boolean := False;
5418 -- Flag set when the case expression can be optimized in the context of
5419 -- a simple return statement.
5421 -- Start of processing for Expand_N_Case_Expression
5424 -- Check for MINIMIZED/ELIMINATED overflow mode
5426 if Minimized_Eliminated_Overflow_Check
(N
) then
5427 Apply_Arithmetic_Overflow_Check
(N
);
5431 -- If the case expression is a predicate specification, and the type
5432 -- to which it applies has a static predicate aspect, do not expand,
5433 -- because it will be converted to the proper predicate form later.
5435 if Ekind
(Current_Scope
) in E_Function | E_Procedure
5436 and then Is_Predicate_Function
(Current_Scope
)
5438 In_Predicate
:= True;
5440 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
5446 -- When the type of the case expression is elementary, expand
5448 -- (case X is when A => AX, when B => BX ...)
5463 -- In all other cases expand into
5466 -- type Ptr_Typ is access all Typ;
5467 -- Target : Ptr_Typ;
5470 -- Target := AX'Unrestricted_Access;
5472 -- Target := BX'Unrestricted_Access;
5475 -- in Target.all end;
5477 -- This approach avoids extra copies of potentially large objects. It
5478 -- also allows handling of values of limited or unconstrained types.
5479 -- Note that we do the copy also for constrained, nonlimited types
5480 -- when minimizing expressions with actions (e.g. when generating C
5481 -- code) since it allows us to do the optimization below in more cases.
5483 -- Small optimization: when the case expression appears in the context
5484 -- of a simple return statement, expand into
5495 Make_Case_Statement
(Loc
,
5496 Expression
=> Expression
(N
),
5497 Alternatives
=> New_List
);
5499 -- Preserve the original context for which the case statement is being
5500 -- generated. This is needed by the finalization machinery to prevent
5501 -- the premature finalization of controlled objects found within the
5504 Set_From_Conditional_Expression
(Case_Stmt
);
5509 if Is_Copy_Type
(Typ
) then
5512 -- ??? Do not perform the optimization when the return statement is
5513 -- within a predicate function, as this causes spurious errors. Could
5514 -- this be a possible mismatch in handling this case somewhere else
5515 -- in semantic analysis?
5517 Optimize_Return_Stmt
:=
5518 Nkind
(Par
) = N_Simple_Return_Statement
and then not In_Predicate
;
5520 -- Otherwise create an access type to handle the general case using
5521 -- 'Unrestricted_Access.
5524 -- type Ptr_Typ is access all Typ;
5527 if Generate_C_Code
then
5529 -- We cannot ensure that correct C code will be generated if any
5530 -- temporary is created down the line (to e.g. handle checks or
5531 -- capture values) since we might end up with dangling references
5532 -- to local variables, so better be safe and reject the construct.
5535 ("case expression too complex, use case statement instead", N
);
5538 Target_Typ
:= Make_Temporary
(Loc
, 'P');
5541 Make_Full_Type_Declaration
(Loc
,
5542 Defining_Identifier
=> Target_Typ
,
5544 Make_Access_To_Object_Definition
(Loc
,
5545 All_Present
=> True,
5546 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5549 -- Create the declaration of the target which captures the value of the
5553 -- Target : [Ptr_]Typ;
5555 if not Optimize_Return_Stmt
then
5556 Target
:= Make_Temporary
(Loc
, 'T');
5559 Make_Object_Declaration
(Loc
,
5560 Defining_Identifier
=> Target
,
5561 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
5562 Set_No_Initialization
(Decl
);
5564 Append_To
(Acts
, Decl
);
5567 -- Process the alternatives
5569 Alt
:= First
(Alternatives
(N
));
5570 while Present
(Alt
) loop
5572 Alt_Expr
: Node_Id
:= Expression
(Alt
);
5573 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
5578 -- Take the unrestricted access of the expression value for non-
5579 -- scalar types. This approach avoids big copies and covers the
5580 -- limited and unconstrained cases.
5583 -- AX'Unrestricted_Access
5585 if not Is_Copy_Type
(Typ
) then
5587 Make_Attribute_Reference
(Alt_Loc
,
5588 Prefix
=> Relocate_Node
(Alt_Expr
),
5589 Attribute_Name
=> Name_Unrestricted_Access
);
5593 -- return AX['Unrestricted_Access];
5595 if Optimize_Return_Stmt
then
5597 Make_Simple_Return_Statement
(Alt_Loc
,
5598 Expression
=> Alt_Expr
));
5601 -- Target := AX['Unrestricted_Access];
5604 LHS
:= New_Occurrence_Of
(Target
, Loc
);
5605 Set_Assignment_OK
(LHS
);
5608 Make_Assignment_Statement
(Alt_Loc
,
5610 Expression
=> Alt_Expr
));
5613 -- Propagate declarations inserted in the node by Insert_Actions
5614 -- (for example, temporaries generated to remove side effects).
5615 -- These actions must remain attached to the alternative, given
5616 -- that they are generated by the corresponding expression.
5618 if Present
(Actions
(Alt
)) then
5619 Prepend_List
(Actions
(Alt
), Stmts
);
5622 -- Finalize any transient objects on exit from the alternative.
5623 -- This is done only in the return optimization case because
5624 -- otherwise the case expression is converted into an expression
5625 -- with actions which already contains this form of processing.
5627 if Optimize_Return_Stmt
then
5628 Process_If_Case_Statements
(N
, Stmts
);
5632 (Alternatives
(Case_Stmt
),
5633 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5634 Discrete_Choices
=> Discrete_Choices
(Alt
),
5635 Statements
=> Stmts
));
5641 -- Rewrite the parent return statement as a case statement
5643 if Optimize_Return_Stmt
then
5644 Rewrite
(Par
, Case_Stmt
);
5647 -- Otherwise convert the case expression into an expression with actions
5650 Append_To
(Acts
, Case_Stmt
);
5652 if Is_Copy_Type
(Typ
) then
5653 Expr
:= New_Occurrence_Of
(Target
, Loc
);
5657 Make_Explicit_Dereference
(Loc
,
5658 Prefix
=> New_Occurrence_Of
(Target
, Loc
));
5664 -- in Target[.all] end;
5667 Make_Expression_With_Actions
(Loc
,
5671 Analyze_And_Resolve
(N
, Typ
);
5673 end Expand_N_Case_Expression
;
5675 -----------------------------------
5676 -- Expand_N_Explicit_Dereference --
5677 -----------------------------------
5679 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5681 -- Insert explicit dereference call for the checked storage pool case
5683 Insert_Dereference_Action
(Prefix
(N
));
5685 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5686 -- we set the atomic sync flag.
5688 if Is_Atomic
(Etype
(N
))
5689 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5691 Activate_Atomic_Synchronization
(N
);
5693 end Expand_N_Explicit_Dereference
;
5695 --------------------------------------
5696 -- Expand_N_Expression_With_Actions --
5697 --------------------------------------
5699 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5700 Acts
: constant List_Id
:= Actions
(N
);
5702 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
5703 -- Force the evaluation of Boolean expression Expr
5705 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5706 -- Inspect and process a single action of an expression_with_actions for
5707 -- transient objects. If such objects are found, the routine generates
5708 -- code to clean them up when the context of the expression is evaluated
5711 ------------------------------
5712 -- Force_Boolean_Evaluation --
5713 ------------------------------
5715 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
5716 Loc
: constant Source_Ptr
:= Sloc
(N
);
5717 Flag_Decl
: Node_Id
;
5718 Flag_Id
: Entity_Id
;
5721 -- Relocate the expression to the actions list by capturing its value
5722 -- in a Boolean flag. Generate:
5723 -- Flag : constant Boolean := Expr;
5725 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5728 Make_Object_Declaration
(Loc
,
5729 Defining_Identifier
=> Flag_Id
,
5730 Constant_Present
=> True,
5731 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5732 Expression
=> Relocate_Node
(Expr
));
5734 Append
(Flag_Decl
, Acts
);
5735 Analyze
(Flag_Decl
);
5737 -- Replace the expression with a reference to the flag
5739 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
5740 Analyze
(Expression
(N
));
5741 end Force_Boolean_Evaluation
;
5743 --------------------
5744 -- Process_Action --
5745 --------------------
5747 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5749 if Nkind
(Act
) = N_Object_Declaration
5750 and then Is_Finalizable_Transient
(Act
, N
)
5752 Process_Transient_In_Expression
(Act
, N
, Acts
);
5755 -- Avoid processing temporary function results multiple times when
5756 -- dealing with nested expression_with_actions.
5758 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5761 -- Do not process temporary function results in loops. This is done
5762 -- by Expand_N_Loop_Statement and Build_Finalizer.
5764 elsif Nkind
(Act
) = N_Loop_Statement
then
5771 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5777 -- Start of processing for Expand_N_Expression_With_Actions
5780 -- Do not evaluate the expression when it denotes an entity because the
5781 -- expression_with_actions node will be replaced by the reference.
5783 if Is_Entity_Name
(Expression
(N
)) then
5786 -- Do not evaluate the expression when there are no actions because the
5787 -- expression_with_actions node will be replaced by the expression.
5789 elsif No
(Acts
) or else Is_Empty_List
(Acts
) then
5792 -- Force the evaluation of the expression by capturing its value in a
5793 -- temporary. This ensures that aliases of transient objects do not leak
5794 -- to the expression of the expression_with_actions node:
5797 -- Trans_Id : Ctrl_Typ := ...;
5798 -- Alias : ... := Trans_Id;
5799 -- in ... Alias ... end;
5801 -- In the example above, Trans_Id cannot be finalized at the end of the
5802 -- actions list because this may affect the alias and the final value of
5803 -- the expression_with_actions. Forcing the evaluation encapsulates the
5804 -- reference to the Alias within the actions list:
5807 -- Trans_Id : Ctrl_Typ := ...;
5808 -- Alias : ... := Trans_Id;
5809 -- Val : constant Boolean := ... Alias ...;
5810 -- <finalize Trans_Id>
5813 -- Once this transformation is performed, it is safe to finalize the
5814 -- transient object at the end of the actions list.
5816 -- Note that Force_Evaluation does not remove side effects in operators
5817 -- because it assumes that all operands are evaluated and side effect
5818 -- free. This is not the case when an operand depends implicitly on the
5819 -- transient object through the use of access types.
5821 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5822 Force_Boolean_Evaluation
(Expression
(N
));
5824 -- The expression of an expression_with_actions node may not necessarily
5825 -- be Boolean when the node appears in an if expression. In this case do
5826 -- the usual forced evaluation to encapsulate potential aliasing.
5829 Force_Evaluation
(Expression
(N
));
5832 -- Process all transient objects found within the actions of the EWA
5835 Act
:= First
(Acts
);
5836 while Present
(Act
) loop
5837 Process_Single_Action
(Act
);
5841 -- Deal with case where there are no actions. In this case we simply
5842 -- rewrite the node with its expression since we don't need the actions
5843 -- and the specification of this node does not allow a null action list.
5845 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5846 -- the expanded tree and relying on being able to retrieve the original
5847 -- tree in cases like this. This raises a whole lot of issues of whether
5848 -- we have problems elsewhere, which will be addressed in the future???
5850 if Is_Empty_List
(Acts
) then
5851 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5853 end Expand_N_Expression_With_Actions
;
5855 ----------------------------
5856 -- Expand_N_If_Expression --
5857 ----------------------------
5859 -- Deal with limited types and condition actions
5861 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5862 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5863 Loc
: constant Source_Ptr
:= Sloc
(N
);
5864 Thenx
: constant Node_Id
:= Next
(Cond
);
5865 Elsex
: constant Node_Id
:= Next
(Thenx
);
5866 Typ
: constant Entity_Id
:= Etype
(N
);
5874 -- Determine if we are dealing with a special case of a conditional
5875 -- expression used as an actual for an anonymous access type which
5876 -- forces us to transform the if expression into an expression with
5877 -- actions in order to create a temporary to capture the level of the
5878 -- expression in each branch.
5880 Force_Expand
: constant Boolean := Is_Anonymous_Access_Actual
(N
);
5882 -- Start of processing for Expand_N_If_Expression
5885 -- Check for MINIMIZED/ELIMINATED overflow mode
5887 if Minimized_Eliminated_Overflow_Check
(N
) then
5888 Apply_Arithmetic_Overflow_Check
(N
);
5892 -- Fold at compile time if condition known. We have already folded
5893 -- static if expressions, but it is possible to fold any case in which
5894 -- the condition is known at compile time, even though the result is
5897 -- Note that we don't do the fold of such cases in Sem_Elab because
5898 -- it can cause infinite loops with the expander adding a conditional
5899 -- expression, and Sem_Elab circuitry removing it repeatedly.
5901 if Compile_Time_Known_Value
(Cond
) then
5903 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5904 -- Fold at compile time. Assumes condition known. Return True if
5905 -- folding occurred, meaning we're done.
5907 ----------------------
5908 -- Fold_Known_Value --
5909 ----------------------
5911 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5913 if Is_True
(Expr_Value
(Cond
)) then
5915 Actions
:= Then_Actions
(N
);
5918 Actions
:= Else_Actions
(N
);
5923 if Present
(Actions
) then
5925 -- To minimize the use of Expression_With_Actions, just skip
5926 -- the optimization as it is not critical for correctness.
5928 if Minimize_Expression_With_Actions
then
5933 Make_Expression_With_Actions
(Loc
,
5934 Expression
=> Relocate_Node
(Expr
),
5935 Actions
=> Actions
));
5936 Analyze_And_Resolve
(N
, Typ
);
5939 Rewrite
(N
, Relocate_Node
(Expr
));
5942 -- Note that the result is never static (legitimate cases of
5943 -- static if expressions were folded in Sem_Eval).
5945 Set_Is_Static_Expression
(N
, False);
5947 end Fold_Known_Value
;
5950 if Fold_Known_Value
(Cond
) then
5956 -- If the type is limited, and the back end does not handle limited
5957 -- types, then we expand as follows to avoid the possibility of
5958 -- improper copying.
5960 -- type Ptr is access all Typ;
5964 -- Cnn := then-expr'Unrestricted_Access;
5967 -- Cnn := else-expr'Unrestricted_Access;
5970 -- and replace the if expression by a reference to Cnn.all.
5972 -- This special case can be skipped if the back end handles limited
5973 -- types properly and ensures that no incorrect copies are made.
5975 if Is_By_Reference_Type
(Typ
)
5976 and then not Back_End_Handles_Limited_Types
5978 -- When the "then" or "else" expressions involve controlled function
5979 -- calls, generated temporaries are chained on the corresponding list
5980 -- of actions. These temporaries need to be finalized after the if
5981 -- expression is evaluated.
5983 Process_If_Case_Statements
(N
, Then_Actions
(N
));
5984 Process_If_Case_Statements
(N
, Else_Actions
(N
));
5987 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C', N
);
5988 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5992 -- type Ann is access all Typ;
5995 Make_Full_Type_Declaration
(Loc
,
5996 Defining_Identifier
=> Ptr_Typ
,
5998 Make_Access_To_Object_Definition
(Loc
,
5999 All_Present
=> True,
6000 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
6006 Make_Object_Declaration
(Loc
,
6007 Defining_Identifier
=> Cnn
,
6008 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
6012 -- Cnn := <Thenx>'Unrestricted_Access;
6014 -- Cnn := <Elsex>'Unrestricted_Access;
6018 Make_Implicit_If_Statement
(N
,
6019 Condition
=> Relocate_Node
(Cond
),
6020 Then_Statements
=> New_List
(
6021 Make_Assignment_Statement
(Sloc
(Thenx
),
6022 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6024 Make_Attribute_Reference
(Loc
,
6025 Prefix
=> Relocate_Node
(Thenx
),
6026 Attribute_Name
=> Name_Unrestricted_Access
))),
6028 Else_Statements
=> New_List
(
6029 Make_Assignment_Statement
(Sloc
(Elsex
),
6030 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6032 Make_Attribute_Reference
(Loc
,
6033 Prefix
=> Relocate_Node
(Elsex
),
6034 Attribute_Name
=> Name_Unrestricted_Access
))));
6036 -- Preserve the original context for which the if statement is
6037 -- being generated. This is needed by the finalization machinery
6038 -- to prevent the premature finalization of controlled objects
6039 -- found within the if statement.
6041 Set_From_Conditional_Expression
(New_If
);
6044 Make_Explicit_Dereference
(Loc
,
6045 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
6048 -- If the result is an unconstrained array and the if expression is in a
6049 -- context other than the initializing expression of the declaration of
6050 -- an object, then we pull out the if expression as follows:
6052 -- Cnn : constant typ := if-expression
6054 -- and then replace the if expression with an occurrence of Cnn. This
6055 -- avoids the need in the back end to create on-the-fly variable length
6056 -- temporaries (which it cannot do!)
6058 -- Note that the test for being in an object declaration avoids doing an
6059 -- unnecessary expansion, and also avoids infinite recursion.
6061 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
)
6062 and then (Nkind
(Parent
(N
)) /= N_Object_Declaration
6063 or else Expression
(Parent
(N
)) /= N
)
6066 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6070 Make_Object_Declaration
(Loc
,
6071 Defining_Identifier
=> Cnn
,
6072 Constant_Present
=> True,
6073 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6074 Expression
=> Relocate_Node
(N
),
6075 Has_Init_Expression
=> True));
6077 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
6081 -- For other types, we only need to expand if there are other actions
6082 -- associated with either branch or we need to force expansion to deal
6083 -- with if expressions used as an actual of an anonymous access type.
6085 elsif Present
(Then_Actions
(N
))
6086 or else Present
(Else_Actions
(N
))
6087 or else Force_Expand
6090 -- We now wrap the actions into the appropriate expression
6092 if Minimize_Expression_With_Actions
6093 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
6094 or else Is_Constrained
(Underlying_Type
(Typ
)))
6096 -- If we can't use N_Expression_With_Actions nodes, then we insert
6097 -- the following sequence of actions (using Insert_Actions):
6102 -- Cnn := then-expr;
6108 -- and replace the if expression by a reference to Cnn
6111 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6115 Make_Object_Declaration
(Loc
,
6116 Defining_Identifier
=> Cnn
,
6117 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6120 Make_Implicit_If_Statement
(N
,
6121 Condition
=> Relocate_Node
(Cond
),
6123 Then_Statements
=> New_List
(
6124 Make_Assignment_Statement
(Sloc
(Thenx
),
6125 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6126 Expression
=> Relocate_Node
(Thenx
))),
6128 Else_Statements
=> New_List
(
6129 Make_Assignment_Statement
(Sloc
(Elsex
),
6130 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6131 Expression
=> Relocate_Node
(Elsex
))));
6133 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
6134 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
6136 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
6139 -- Regular path using Expression_With_Actions
6142 if Present
(Then_Actions
(N
)) then
6144 Make_Expression_With_Actions
(Sloc
(Thenx
),
6145 Actions
=> Then_Actions
(N
),
6146 Expression
=> Relocate_Node
(Thenx
)));
6148 Set_Then_Actions
(N
, No_List
);
6149 Analyze_And_Resolve
(Thenx
, Typ
);
6152 if Present
(Else_Actions
(N
)) then
6154 Make_Expression_With_Actions
(Sloc
(Elsex
),
6155 Actions
=> Else_Actions
(N
),
6156 Expression
=> Relocate_Node
(Elsex
)));
6158 Set_Else_Actions
(N
, No_List
);
6159 Analyze_And_Resolve
(Elsex
, Typ
);
6162 -- We must force expansion into an expression with actions when
6163 -- an if expression gets used directly as an actual for an
6164 -- anonymous access type.
6166 if Force_Expand
then
6168 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
6177 Make_Object_Declaration
(Loc
,
6178 Defining_Identifier
=> Cnn
,
6179 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6180 Append_To
(Acts
, Decl
);
6182 Set_No_Initialization
(Decl
);
6192 Make_Implicit_If_Statement
(N
,
6193 Condition
=> Relocate_Node
(Cond
),
6194 Then_Statements
=> New_List
(
6195 Make_Assignment_Statement
(Sloc
(Thenx
),
6196 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6197 Expression
=> Relocate_Node
(Thenx
))),
6199 Else_Statements
=> New_List
(
6200 Make_Assignment_Statement
(Sloc
(Elsex
),
6201 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6202 Expression
=> Relocate_Node
(Elsex
))));
6203 Append_To
(Acts
, New_If
);
6211 Make_Expression_With_Actions
(Loc
,
6212 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6214 Analyze_And_Resolve
(N
, Typ
);
6221 -- If no actions then no expansion needed, gigi will handle it using the
6222 -- same approach as a C conditional expression.
6228 -- Fall through here for either the limited expansion, or the case of
6229 -- inserting actions for nonlimited types. In both these cases, we must
6230 -- move the SLOC of the parent If statement to the newly created one and
6231 -- change it to the SLOC of the expression which, after expansion, will
6232 -- correspond to what is being evaluated.
6234 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
6235 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
6236 Set_Sloc
(Parent
(N
), Loc
);
6239 -- Make sure Then_Actions and Else_Actions are appropriately moved
6240 -- to the new if statement.
6242 if Present
(Then_Actions
(N
)) then
6244 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
6247 if Present
(Else_Actions
(N
)) then
6249 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
6252 Insert_Action
(N
, Decl
);
6253 Insert_Action
(N
, New_If
);
6255 Analyze_And_Resolve
(N
, Typ
);
6256 end Expand_N_If_Expression
;
6262 procedure Expand_N_In
(N
: Node_Id
) is
6263 Loc
: constant Source_Ptr
:= Sloc
(N
);
6264 Restyp
: constant Entity_Id
:= Etype
(N
);
6265 Lop
: constant Node_Id
:= Left_Opnd
(N
);
6266 Rop
: constant Node_Id
:= Right_Opnd
(N
);
6267 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
6269 procedure Substitute_Valid_Check
;
6270 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6271 -- test for the left operand being in range of its subtype.
6273 ----------------------------
6274 -- Substitute_Valid_Check --
6275 ----------------------------
6277 procedure Substitute_Valid_Check
is
6278 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
6279 -- Determine whether arbitrary node Nod denotes a source object that
6280 -- may safely act as prefix of attribute 'Valid.
6282 ----------------------------
6283 -- Is_OK_Object_Reference --
6284 ----------------------------
6286 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
6290 -- Inspect the original operand
6292 Obj_Ref
:= Original_Node
(Nod
);
6294 -- The object reference must be a source construct, otherwise the
6295 -- codefix suggestion may refer to nonexistent code from a user
6298 if Comes_From_Source
(Obj_Ref
) then
6300 -- Recover the actual object reference. There may be more cases
6304 if Nkind
(Obj_Ref
) in
6305 N_Type_Conversion | N_Unchecked_Type_Conversion
6307 Obj_Ref
:= Expression
(Obj_Ref
);
6313 return Is_Object_Reference
(Obj_Ref
);
6317 end Is_OK_Object_Reference
;
6319 -- Start of processing for Substitute_Valid_Check
6323 Make_Attribute_Reference
(Loc
,
6324 Prefix
=> Relocate_Node
(Lop
),
6325 Attribute_Name
=> Name_Valid
));
6327 Analyze_And_Resolve
(N
, Restyp
);
6329 -- Emit a warning when the left-hand operand of the membership test
6330 -- is a source object, otherwise the use of attribute 'Valid would be
6331 -- illegal. The warning is not given when overflow checking is either
6332 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6333 -- eliminated above.
6335 if Is_OK_Object_Reference
(Lop
)
6336 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
6339 ("??explicit membership test may be optimized away", N
);
6340 Error_Msg_N
-- CODEFIX
6341 ("\??use ''Valid attribute instead", N
);
6343 end Substitute_Valid_Check
;
6350 -- Start of processing for Expand_N_In
6353 -- If set membership case, expand with separate procedure
6355 if Present
(Alternatives
(N
)) then
6356 Expand_Set_Membership
(N
);
6360 -- Not set membership, proceed with expansion
6362 Ltyp
:= Etype
(Left_Opnd
(N
));
6363 Rtyp
:= Etype
(Right_Opnd
(N
));
6365 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6366 -- type, then expand with a separate procedure. Note the use of the
6367 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6369 if Overflow_Check_Mode
in Minimized_Or_Eliminated
6370 and then Is_Signed_Integer_Type
(Ltyp
)
6371 and then not No_Minimize_Eliminate
(N
)
6373 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
6377 -- Check case of explicit test for an expression in range of its
6378 -- subtype. This is suspicious usage and we replace it with a 'Valid
6379 -- test and give a warning for scalar types.
6381 if Is_Scalar_Type
(Ltyp
)
6383 -- Only relevant for source comparisons
6385 and then Comes_From_Source
(N
)
6387 -- In floating-point this is a standard way to check for finite values
6388 -- and using 'Valid would typically be a pessimization.
6390 and then not Is_Floating_Point_Type
(Ltyp
)
6392 -- Don't give the message unless right operand is a type entity and
6393 -- the type of the left operand matches this type. Note that this
6394 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6395 -- checks have changed the type of the left operand.
6397 and then Nkind
(Rop
) in N_Has_Entity
6398 and then Ltyp
= Entity
(Rop
)
6400 -- Skip this for predicated types, where such expressions are a
6401 -- reasonable way of testing if something meets the predicate.
6403 and then not Present
(Predicate_Function
(Ltyp
))
6405 Substitute_Valid_Check
;
6409 -- Do validity check on operands
6411 if Validity_Checks_On
and Validity_Check_Operands
then
6412 Ensure_Valid
(Left_Opnd
(N
));
6413 Validity_Check_Range
(Right_Opnd
(N
));
6416 -- Case of explicit range
6418 if Nkind
(Rop
) = N_Range
then
6420 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
6421 Hi
: constant Node_Id
:= High_Bound
(Rop
);
6423 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
6424 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
6426 Lcheck
: Compare_Result
;
6427 Ucheck
: Compare_Result
;
6429 Warn1
: constant Boolean :=
6430 Constant_Condition_Warnings
6431 and then Comes_From_Source
(N
)
6432 and then not In_Instance
;
6433 -- This must be true for any of the optimization warnings, we
6434 -- clearly want to give them only for source with the flag on. We
6435 -- also skip these warnings in an instance since it may be the
6436 -- case that different instantiations have different ranges.
6438 Warn2
: constant Boolean :=
6440 and then Nkind
(Original_Node
(Rop
)) = N_Range
6441 and then Is_Integer_Type
(Etype
(Lo
));
6442 -- For the case where only one bound warning is elided, we also
6443 -- insist on an explicit range and an integer type. The reason is
6444 -- that the use of enumeration ranges including an end point is
6445 -- common, as is the use of a subtype name, one of whose bounds is
6446 -- the same as the type of the expression.
6449 -- If test is explicit x'First .. x'Last, replace by valid check
6451 -- Could use some individual comments for this complex test ???
6453 if Is_Scalar_Type
(Ltyp
)
6455 -- And left operand is X'First where X matches left operand
6456 -- type (this eliminates cases of type mismatch, including
6457 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6458 -- type of the left operand.
6460 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
6461 and then Attribute_Name
(Lo_Orig
) = Name_First
6462 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
6463 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
6465 -- Same tests for right operand
6467 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
6468 and then Attribute_Name
(Hi_Orig
) = Name_Last
6469 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
6470 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
6472 -- Relevant only for source cases
6474 and then Comes_From_Source
(N
)
6476 Substitute_Valid_Check
;
6480 -- If bounds of type are known at compile time, and the end points
6481 -- are known at compile time and identical, this is another case
6482 -- for substituting a valid test. We only do this for discrete
6483 -- types, since it won't arise in practice for float types.
6485 if Comes_From_Source
(N
)
6486 and then Is_Discrete_Type
(Ltyp
)
6487 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
6488 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
6489 and then Compile_Time_Known_Value
(Lo
)
6490 and then Compile_Time_Known_Value
(Hi
)
6491 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
6492 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
6494 -- Kill warnings in instances, since they may be cases where we
6495 -- have a test in the generic that makes sense with some types
6496 -- and not with other types.
6498 -- Similarly, do not rewrite membership as a validity check if
6499 -- within the predicate function for the type.
6501 -- Finally, if the original bounds are type conversions, even
6502 -- if they have been folded into constants, there are different
6503 -- types involved and 'Valid is not appropriate.
6507 or else (Ekind
(Current_Scope
) = E_Function
6508 and then Is_Predicate_Function
(Current_Scope
))
6512 elsif Nkind
(Lo_Orig
) = N_Type_Conversion
6513 or else Nkind
(Hi_Orig
) = N_Type_Conversion
6518 Substitute_Valid_Check
;
6523 -- If we have an explicit range, do a bit of optimization based on
6524 -- range analysis (we may be able to kill one or both checks).
6526 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
6527 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
6529 -- If either check is known to fail, replace result by False since
6530 -- the other check does not matter. Preserve the static flag for
6531 -- legality checks, because we are constant-folding beyond RM 4.9.
6533 if Lcheck
= LT
or else Ucheck
= GT
then
6535 Error_Msg_N
("?c?range test optimized away", N
);
6536 Error_Msg_N
("\?c?value is known to be out of range", N
);
6539 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6540 Analyze_And_Resolve
(N
, Restyp
);
6541 Set_Is_Static_Expression
(N
, Static
);
6544 -- If both checks are known to succeed, replace result by True,
6545 -- since we know we are in range.
6547 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6549 Error_Msg_N
("?c?range test optimized away", N
);
6550 Error_Msg_N
("\?c?value is known to be in range", N
);
6553 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6554 Analyze_And_Resolve
(N
, Restyp
);
6555 Set_Is_Static_Expression
(N
, Static
);
6558 -- If lower bound check succeeds and upper bound check is not
6559 -- known to succeed or fail, then replace the range check with
6560 -- a comparison against the upper bound.
6562 elsif Lcheck
in Compare_GE
then
6563 if Warn2
and then not In_Instance
then
6564 Error_Msg_N
("??lower bound test optimized away", Lo
);
6565 Error_Msg_N
("\??value is known to be in range", Lo
);
6571 Right_Opnd
=> High_Bound
(Rop
)));
6572 Analyze_And_Resolve
(N
, Restyp
);
6575 -- If upper bound check succeeds and lower bound check is not
6576 -- known to succeed or fail, then replace the range check with
6577 -- a comparison against the lower bound.
6579 elsif Ucheck
in Compare_LE
then
6580 if Warn2
and then not In_Instance
then
6581 Error_Msg_N
("??upper bound test optimized away", Hi
);
6582 Error_Msg_N
("\??value is known to be in range", Hi
);
6588 Right_Opnd
=> Low_Bound
(Rop
)));
6589 Analyze_And_Resolve
(N
, Restyp
);
6593 -- We couldn't optimize away the range check, but there is one
6594 -- more issue. If we are checking constant conditionals, then we
6595 -- see if we can determine the outcome assuming everything is
6596 -- valid, and if so give an appropriate warning.
6598 if Warn1
and then not Assume_No_Invalid_Values
then
6599 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
6600 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
6602 -- Result is out of range for valid value
6604 if Lcheck
= LT
or else Ucheck
= GT
then
6606 ("?c?value can only be in range if it is invalid", N
);
6608 -- Result is in range for valid value
6610 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6612 ("?c?value can only be out of range if it is invalid", N
);
6614 -- Lower bound check succeeds if value is valid
6616 elsif Warn2
and then Lcheck
in Compare_GE
then
6618 ("?c?lower bound check only fails if it is invalid", Lo
);
6620 -- Upper bound check succeeds if value is valid
6622 elsif Warn2
and then Ucheck
in Compare_LE
then
6624 ("?c?upper bound check only fails for invalid values", Hi
);
6629 -- Try to narrow the operation
6631 if Ltyp
= Universal_Integer
and then Nkind
(N
) = N_In
then
6632 Narrow_Large_Operation
(N
);
6635 -- For all other cases of an explicit range, nothing to be done
6639 -- Here right operand is a subtype mark
6643 Typ
: Entity_Id
:= Etype
(Rop
);
6644 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
6645 Check_Null_Exclusion
: Boolean;
6646 Cond
: Node_Id
:= Empty
;
6648 Obj
: Node_Id
:= Lop
;
6649 SCIL_Node
: Node_Id
;
6652 Remove_Side_Effects
(Obj
);
6654 -- For tagged type, do tagged membership operation
6656 if Is_Tagged_Type
(Typ
) then
6658 -- No expansion will be performed for VM targets, as the VM
6659 -- back ends will handle the membership tests directly.
6661 if Tagged_Type_Expansion
then
6662 Tagged_Membership
(N
, SCIL_Node
, New_N
);
6664 Analyze_And_Resolve
(N
, Restyp
, Suppress
=> All_Checks
);
6666 -- Update decoration of relocated node referenced by the
6669 if Generate_SCIL
and then Present
(SCIL_Node
) then
6670 Set_SCIL_Node
(N
, SCIL_Node
);
6676 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6677 -- This reason we do this is that the bounds may have the wrong
6678 -- type if they come from the original type definition. Also this
6679 -- way we get all the processing above for an explicit range.
6681 -- Don't do this for predicated types, since in this case we
6682 -- want to check the predicate.
6684 elsif Is_Scalar_Type
(Typ
) then
6685 if No
(Predicate_Function
(Typ
)) then
6689 Make_Attribute_Reference
(Loc
,
6690 Attribute_Name
=> Name_First
,
6691 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
6694 Make_Attribute_Reference
(Loc
,
6695 Attribute_Name
=> Name_Last
,
6696 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
6697 Analyze_And_Resolve
(N
, Restyp
);
6702 -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is
6703 -- raised when evaluating an individual membership test if the
6704 -- subtype mark denotes a constrained Unchecked_Union subtype
6705 -- and the expression lacks inferable discriminants.
6707 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
6708 and then Is_Constrained
(Typ
)
6709 and then not Has_Inferable_Discriminants
(Lop
)
6712 Make_Expression_With_Actions
(Loc
,
6714 New_List
(Make_Raise_Program_Error
(Loc
,
6715 Reason
=> PE_Unchecked_Union_Restriction
)),
6717 New_Occurrence_Of
(Standard_False
, Loc
)));
6718 Analyze_And_Resolve
(N
, Restyp
);
6723 -- Here we have a non-scalar type
6727 -- If the null exclusion checks are not compatible, need to
6728 -- perform further checks. In other words, we cannot have
6729 -- Ltyp including null and Typ excluding null. All other cases
6732 Check_Null_Exclusion
:=
6733 Can_Never_Be_Null
(Typ
) and then not Can_Never_Be_Null
(Ltyp
);
6734 Typ
:= Designated_Type
(Typ
);
6737 if not Is_Constrained
(Typ
) then
6738 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6740 -- For the constrained array case, we have to check the subscripts
6741 -- for an exact match if the lengths are non-zero (the lengths
6742 -- must match in any case).
6744 elsif Is_Array_Type
(Typ
) then
6745 Check_Subscripts
: declare
6746 function Build_Attribute_Reference
6749 Dim
: Nat
) return Node_Id
;
6750 -- Build attribute reference E'Nam (Dim)
6752 -------------------------------
6753 -- Build_Attribute_Reference --
6754 -------------------------------
6756 function Build_Attribute_Reference
6759 Dim
: Nat
) return Node_Id
6763 Make_Attribute_Reference
(Loc
,
6765 Attribute_Name
=> Nam
,
6766 Expressions
=> New_List
(
6767 Make_Integer_Literal
(Loc
, Dim
)));
6768 end Build_Attribute_Reference
;
6770 -- Start of processing for Check_Subscripts
6773 for J
in 1 .. Number_Dimensions
(Typ
) loop
6774 Evolve_And_Then
(Cond
,
6777 Build_Attribute_Reference
6778 (Duplicate_Subexpr_No_Checks
(Obj
),
6781 Build_Attribute_Reference
6782 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
6784 Evolve_And_Then
(Cond
,
6787 Build_Attribute_Reference
6788 (Duplicate_Subexpr_No_Checks
(Obj
),
6791 Build_Attribute_Reference
6792 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
6794 end Check_Subscripts
;
6796 -- These are the cases where constraint checks may be required,
6797 -- e.g. records with possible discriminants
6800 -- Expand the test into a series of discriminant comparisons.
6801 -- The expression that is built is the negation of the one that
6802 -- is used for checking discriminant constraints.
6804 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6806 if Has_Discriminants
(Typ
) then
6807 Cond
:= Make_Op_Not
(Loc
,
6808 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6810 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6815 if Check_Null_Exclusion
then
6816 Cond
:= Make_And_Then
(Loc
,
6820 Right_Opnd
=> Make_Null
(Loc
)),
6821 Right_Opnd
=> Cond
);
6823 Cond
:= Make_Or_Else
(Loc
,
6827 Right_Opnd
=> Make_Null
(Loc
)),
6828 Right_Opnd
=> Cond
);
6833 Analyze_And_Resolve
(N
, Restyp
);
6835 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6836 -- expression of an anonymous access type. This can involve an
6837 -- accessibility test and a tagged type membership test in the
6838 -- case of tagged designated types.
6840 if Ada_Version
>= Ada_2012
6842 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6845 Expr_Entity
: Entity_Id
:= Empty
;
6847 Param_Level
: Node_Id
;
6848 Type_Level
: Node_Id
;
6851 if Is_Entity_Name
(Lop
) then
6852 Expr_Entity
:= Param_Entity
(Lop
);
6854 if not Present
(Expr_Entity
) then
6855 Expr_Entity
:= Entity
(Lop
);
6859 -- If a conversion of the anonymous access value to the
6860 -- tested type would be illegal, then the result is False.
6862 if not Valid_Conversion
6863 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6865 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6866 Analyze_And_Resolve
(N
, Restyp
);
6868 -- Apply an accessibility check if the access object has an
6869 -- associated access level and when the level of the type is
6870 -- less deep than the level of the access parameter. This
6871 -- can only occur for access parameters and stand-alone
6872 -- objects of an anonymous access type.
6875 Param_Level
:= Accessibility_Level
6876 (Expr_Entity
, Dynamic_Level
);
6879 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6881 -- Return True only if the accessibility level of the
6882 -- expression entity is not deeper than the level of
6883 -- the tested access type.
6887 Left_Opnd
=> Relocate_Node
(N
),
6888 Right_Opnd
=> Make_Op_Le
(Loc
,
6889 Left_Opnd
=> Param_Level
,
6890 Right_Opnd
=> Type_Level
)));
6892 Analyze_And_Resolve
(N
);
6894 -- If the designated type is tagged, do tagged membership
6897 if Is_Tagged_Type
(Typ
) then
6899 -- No expansion will be performed for VM targets, as
6900 -- the VM back ends will handle the membership tests
6903 if Tagged_Type_Expansion
then
6905 -- Note that we have to pass Original_Node, because
6906 -- the membership test might already have been
6907 -- rewritten by earlier parts of membership test.
6910 (Original_Node
(N
), SCIL_Node
, New_N
);
6912 -- Update decoration of relocated node referenced
6913 -- by the SCIL node.
6915 if Generate_SCIL
and then Present
(SCIL_Node
) then
6916 Set_SCIL_Node
(New_N
, SCIL_Node
);
6921 Left_Opnd
=> Relocate_Node
(N
),
6922 Right_Opnd
=> New_N
));
6924 Analyze_And_Resolve
(N
, Restyp
);
6933 -- At this point, we have done the processing required for the basic
6934 -- membership test, but not yet dealt with the predicate.
6938 -- If a predicate is present, then we do the predicate test, but we
6939 -- most certainly want to omit this if we are within the predicate
6940 -- function itself, since otherwise we have an infinite recursion.
6941 -- The check should also not be emitted when testing against a range
6942 -- (the check is only done when the right operand is a subtype; see
6943 -- RM12-4.5.2 (28.1/3-30/3)).
6945 Predicate_Check
: declare
6946 function In_Range_Check
return Boolean;
6947 -- Within an expanded range check that may raise Constraint_Error do
6948 -- not generate a predicate check as well. It is redundant because
6949 -- the context will add an explicit predicate check, and it will
6950 -- raise the wrong exception if it fails.
6952 --------------------
6953 -- In_Range_Check --
6954 --------------------
6956 function In_Range_Check
return Boolean is
6960 while Present
(P
) loop
6961 if Nkind
(P
) = N_Raise_Constraint_Error
then
6964 elsif Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6965 or else Nkind
(P
) = N_Procedure_Call_Statement
6966 or else Nkind
(P
) in N_Declaration
6979 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6982 -- Start of processing for Predicate_Check
6986 and then Current_Scope
/= PFunc
6987 and then Nkind
(Rop
) /= N_Range
6989 if not In_Range_Check
then
6990 R_Op
:= Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True);
6992 R_Op
:= New_Occurrence_Of
(Standard_True
, Loc
);
6997 Left_Opnd
=> Relocate_Node
(N
),
6998 Right_Opnd
=> R_Op
));
7000 -- Analyze new expression, mark left operand as analyzed to
7001 -- avoid infinite recursion adding predicate calls. Similarly,
7002 -- suppress further range checks on the call.
7004 Set_Analyzed
(Left_Opnd
(N
));
7005 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7007 -- All done, skip attempt at compile time determination of result
7011 end Predicate_Check
;
7014 --------------------------------
7015 -- Expand_N_Indexed_Component --
7016 --------------------------------
7018 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
7019 Loc
: constant Source_Ptr
:= Sloc
(N
);
7020 Typ
: constant Entity_Id
:= Etype
(N
);
7021 P
: constant Node_Id
:= Prefix
(N
);
7022 T
: constant Entity_Id
:= Etype
(P
);
7025 -- A special optimization, if we have an indexed component that is
7026 -- selecting from a slice, then we can eliminate the slice, since, for
7027 -- example, x (i .. j)(k) is identical to x(k). The only difference is
7028 -- the range check required by the slice. The range check for the slice
7029 -- itself has already been generated. The range check for the
7030 -- subscripting operation is ensured by converting the subject to
7031 -- the subtype of the slice.
7033 -- This optimization not only generates better code, avoiding slice
7034 -- messing especially in the packed case, but more importantly bypasses
7035 -- some problems in handling this peculiar case, for example, the issue
7036 -- of dealing specially with object renamings.
7038 if Nkind
(P
) = N_Slice
7040 -- This optimization is disabled for CodePeer because it can transform
7041 -- an index-check constraint_error into a range-check constraint_error
7042 -- and CodePeer cares about that distinction.
7044 and then not CodePeer_Mode
7047 Make_Indexed_Component
(Loc
,
7048 Prefix
=> Prefix
(P
),
7049 Expressions
=> New_List
(
7051 (Etype
(First_Index
(Etype
(P
))),
7052 First
(Expressions
(N
))))));
7053 Analyze_And_Resolve
(N
, Typ
);
7057 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7058 -- function, then additional actuals must be passed.
7060 if Is_Build_In_Place_Function_Call
(P
) then
7061 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
7063 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
7064 -- containing build-in-place function calls whose returned object covers
7067 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
7068 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
7071 -- Generate index and validity checks
7073 Generate_Index_Checks
(N
);
7075 if Validity_Checks_On
and then Validity_Check_Subscripts
then
7076 Apply_Subscript_Validity_Checks
(N
);
7079 -- If selecting from an array with atomic components, and atomic sync
7080 -- is not suppressed for this array type, set atomic sync flag.
7082 if (Has_Atomic_Components
(T
)
7083 and then not Atomic_Synchronization_Disabled
(T
))
7084 or else (Is_Atomic
(Typ
)
7085 and then not Atomic_Synchronization_Disabled
(Typ
))
7086 or else (Is_Entity_Name
(P
)
7087 and then Has_Atomic_Components
(Entity
(P
))
7088 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
7090 Activate_Atomic_Synchronization
(N
);
7093 -- All done if the prefix is not a packed array implemented specially
7095 if not (Is_Packed
(Etype
(Prefix
(N
)))
7096 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(N
)))))
7101 -- For packed arrays that are not bit-packed (i.e. the case of an array
7102 -- with one or more index types with a non-contiguous enumeration type),
7103 -- we can always use the normal packed element get circuit.
7105 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
7106 Expand_Packed_Element_Reference
(N
);
7110 -- For a reference to a component of a bit packed array, we convert it
7111 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
7112 -- want to do this for simple references, and not for:
7114 -- Left side of assignment, or prefix of left side of assignment, or
7115 -- prefix of the prefix, to handle packed arrays of packed arrays,
7116 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
7118 -- Renaming objects in renaming associations
7119 -- This case is handled when a use of the renamed variable occurs
7121 -- Actual parameters for a subprogram call
7122 -- This case is handled in Exp_Ch6.Expand_Actuals
7124 -- The second expression in a 'Read attribute reference
7126 -- The prefix of an address or bit or size attribute reference
7128 -- The following circuit detects these exceptions. Note that we need to
7129 -- deal with implicit dereferences when climbing up the parent chain,
7130 -- with the additional difficulty that the type of parents may have yet
7131 -- to be resolved since prefixes are usually resolved first.
7134 Child
: Node_Id
:= N
;
7135 Parnt
: Node_Id
:= Parent
(N
);
7139 if Nkind
(Parnt
) = N_Unchecked_Expression
then
7142 elsif Nkind
(Parnt
) = N_Object_Renaming_Declaration
then
7145 elsif Nkind
(Parnt
) in N_Subprogram_Call
7146 or else (Nkind
(Parnt
) = N_Parameter_Association
7147 and then Nkind
(Parent
(Parnt
)) in N_Subprogram_Call
)
7151 elsif Nkind
(Parnt
) = N_Attribute_Reference
7152 and then Attribute_Name
(Parnt
) in Name_Address
7155 and then Prefix
(Parnt
) = Child
7159 elsif Nkind
(Parnt
) = N_Assignment_Statement
7160 and then Name
(Parnt
) = Child
7164 -- If the expression is an index of an indexed component, it must
7165 -- be expanded regardless of context.
7167 elsif Nkind
(Parnt
) = N_Indexed_Component
7168 and then Child
/= Prefix
(Parnt
)
7170 Expand_Packed_Element_Reference
(N
);
7173 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
7174 and then Name
(Parent
(Parnt
)) = Parnt
7178 elsif Nkind
(Parnt
) = N_Attribute_Reference
7179 and then Attribute_Name
(Parnt
) = Name_Read
7180 and then Next
(First
(Expressions
(Parnt
))) = Child
7184 elsif Nkind
(Parnt
) = N_Indexed_Component
7185 and then Prefix
(Parnt
) = Child
7189 elsif Nkind
(Parnt
) = N_Selected_Component
7190 and then Prefix
(Parnt
) = Child
7191 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
7193 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
7197 -- If the parent is a dereference, either implicit or explicit,
7198 -- then the packed reference needs to be expanded.
7201 Expand_Packed_Element_Reference
(N
);
7205 -- Keep looking up tree for unchecked expression, or if we are the
7206 -- prefix of a possible assignment left side.
7209 Parnt
:= Parent
(Child
);
7212 end Expand_N_Indexed_Component
;
7214 ---------------------
7215 -- Expand_N_Not_In --
7216 ---------------------
7218 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7219 -- can be done. This avoids needing to duplicate this expansion code.
7221 procedure Expand_N_Not_In
(N
: Node_Id
) is
7222 Loc
: constant Source_Ptr
:= Sloc
(N
);
7223 Typ
: constant Entity_Id
:= Etype
(N
);
7224 Cfs
: constant Boolean := Comes_From_Source
(N
);
7231 Left_Opnd
=> Left_Opnd
(N
),
7232 Right_Opnd
=> Right_Opnd
(N
))));
7234 -- If this is a set membership, preserve list of alternatives
7236 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
7238 -- We want this to appear as coming from source if original does (see
7239 -- transformations in Expand_N_In).
7241 Set_Comes_From_Source
(N
, Cfs
);
7242 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
7244 -- Now analyze transformed node
7246 Analyze_And_Resolve
(N
, Typ
);
7247 end Expand_N_Not_In
;
7253 -- The only replacement required is for the case of a null of a type that
7254 -- is an access to protected subprogram, or a subtype thereof. We represent
7255 -- such access values as a record, and so we must replace the occurrence of
7256 -- null by the equivalent record (with a null address and a null pointer in
7257 -- it), so that the back end creates the proper value.
7259 procedure Expand_N_Null
(N
: Node_Id
) is
7260 Loc
: constant Source_Ptr
:= Sloc
(N
);
7261 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
7265 if Is_Access_Protected_Subprogram_Type
(Typ
) then
7267 Make_Aggregate
(Loc
,
7268 Expressions
=> New_List
(
7269 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
7273 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
7275 -- For subsequent semantic analysis, the node must retain its type.
7276 -- Gigi in any case replaces this type by the corresponding record
7277 -- type before processing the node.
7283 when RE_Not_Available
=>
7287 ---------------------
7288 -- Expand_N_Op_Abs --
7289 ---------------------
7291 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
7292 Loc
: constant Source_Ptr
:= Sloc
(N
);
7293 Expr
: constant Node_Id
:= Right_Opnd
(N
);
7294 Typ
: constant Entity_Id
:= Etype
(N
);
7297 Unary_Op_Validity_Checks
(N
);
7299 -- Check for MINIMIZED/ELIMINATED overflow mode
7301 if Minimized_Eliminated_Overflow_Check
(N
) then
7302 Apply_Arithmetic_Overflow_Check
(N
);
7306 -- Try to narrow the operation
7308 if Typ
= Universal_Integer
then
7309 Narrow_Large_Operation
(N
);
7311 if Nkind
(N
) /= N_Op_Abs
then
7316 -- Deal with software overflow checking
7318 if Is_Signed_Integer_Type
(Typ
)
7319 and then Do_Overflow_Check
(N
)
7321 -- The only case to worry about is when the argument is equal to the
7322 -- largest negative number, so what we do is to insert the check:
7324 -- [constraint_error when Expr = typ'Base'First]
7326 -- with the usual Duplicate_Subexpr use coding for expr
7329 Make_Raise_Constraint_Error
(Loc
,
7332 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
7334 Make_Attribute_Reference
(Loc
,
7336 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
7337 Attribute_Name
=> Name_First
)),
7338 Reason
=> CE_Overflow_Check_Failed
));
7340 Set_Do_Overflow_Check
(N
, False);
7342 end Expand_N_Op_Abs
;
7344 ---------------------
7345 -- Expand_N_Op_Add --
7346 ---------------------
7348 procedure Expand_N_Op_Add
(N
: Node_Id
) is
7349 Typ
: constant Entity_Id
:= Etype
(N
);
7352 Binary_Op_Validity_Checks
(N
);
7354 -- Check for MINIMIZED/ELIMINATED overflow mode
7356 if Minimized_Eliminated_Overflow_Check
(N
) then
7357 Apply_Arithmetic_Overflow_Check
(N
);
7361 -- N + 0 = 0 + N = N for integer types
7363 if Is_Integer_Type
(Typ
) then
7364 if Compile_Time_Known_Value
(Right_Opnd
(N
))
7365 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
7367 Rewrite
(N
, Left_Opnd
(N
));
7370 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
7371 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
7373 Rewrite
(N
, Right_Opnd
(N
));
7378 -- Try to narrow the operation
7380 if Typ
= Universal_Integer
then
7381 Narrow_Large_Operation
(N
);
7383 if Nkind
(N
) /= N_Op_Add
then
7388 -- Arithmetic overflow checks for signed integer/fixed point types
7390 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
7391 Apply_Arithmetic_Overflow_Check
(N
);
7395 -- Overflow checks for floating-point if -gnateF mode active
7397 Check_Float_Op_Overflow
(N
);
7399 Expand_Nonbinary_Modular_Op
(N
);
7400 end Expand_N_Op_Add
;
7402 ---------------------
7403 -- Expand_N_Op_And --
7404 ---------------------
7406 procedure Expand_N_Op_And
(N
: Node_Id
) is
7407 Typ
: constant Entity_Id
:= Etype
(N
);
7410 Binary_Op_Validity_Checks
(N
);
7412 if Is_Array_Type
(Etype
(N
)) then
7413 Expand_Boolean_Operator
(N
);
7415 elsif Is_Boolean_Type
(Etype
(N
)) then
7416 Adjust_Condition
(Left_Opnd
(N
));
7417 Adjust_Condition
(Right_Opnd
(N
));
7418 Set_Etype
(N
, Standard_Boolean
);
7419 Adjust_Result_Type
(N
, Typ
);
7421 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
7422 Expand_Intrinsic_Call
(N
, Entity
(N
));
7425 Expand_Nonbinary_Modular_Op
(N
);
7426 end Expand_N_Op_And
;
7428 ------------------------
7429 -- Expand_N_Op_Concat --
7430 ------------------------
7432 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
7434 -- List of operands to be concatenated
7437 -- Node which is to be replaced by the result of concatenating the nodes
7438 -- in the list Opnds.
7441 -- Ensure validity of both operands
7443 Binary_Op_Validity_Checks
(N
);
7445 -- If we are the left operand of a concatenation higher up the tree,
7446 -- then do nothing for now, since we want to deal with a series of
7447 -- concatenations as a unit.
7449 if Nkind
(Parent
(N
)) = N_Op_Concat
7450 and then N
= Left_Opnd
(Parent
(N
))
7455 -- We get here with a concatenation whose left operand may be a
7456 -- concatenation itself with a consistent type. We need to process
7457 -- these concatenation operands from left to right, which means
7458 -- from the deepest node in the tree to the highest node.
7461 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
7462 Cnode
:= Left_Opnd
(Cnode
);
7465 -- Now Cnode is the deepest concatenation, and its parents are the
7466 -- concatenation nodes above, so now we process bottom up, doing the
7469 -- The outer loop runs more than once if more than one concatenation
7470 -- type is involved.
7473 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
7474 Set_Parent
(Opnds
, N
);
7476 -- The inner loop gathers concatenation operands
7478 Inner
: while Cnode
/= N
7479 and then Base_Type
(Etype
(Cnode
)) =
7480 Base_Type
(Etype
(Parent
(Cnode
)))
7482 Cnode
:= Parent
(Cnode
);
7483 Append
(Right_Opnd
(Cnode
), Opnds
);
7486 -- Note: The following code is a temporary workaround for N731-034
7487 -- and N829-028 and will be kept until the general issue of internal
7488 -- symbol serialization is addressed. The workaround is kept under a
7489 -- debug switch to avoid permiating into the general case.
7491 -- Wrap the node to concatenate into an expression actions node to
7492 -- keep it nicely packaged. This is useful in the case of an assert
7493 -- pragma with a concatenation where we want to be able to delete
7494 -- the concatenation and all its expansion stuff.
7496 if Debug_Flag_Dot_H
then
7498 Cnod
: constant Node_Id
:= New_Copy_Tree
(Cnode
);
7499 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
7502 -- Note: use Rewrite rather than Replace here, so that for
7503 -- example Why_Not_Static can find the original concatenation
7507 Make_Expression_With_Actions
(Sloc
(Cnode
),
7508 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
7509 Expression
=> Cnod
));
7511 Expand_Concatenate
(Cnod
, Opnds
);
7512 Analyze_And_Resolve
(Cnode
, Typ
);
7518 Expand_Concatenate
(Cnode
, Opnds
);
7521 exit Outer
when Cnode
= N
;
7522 Cnode
:= Parent
(Cnode
);
7524 end Expand_N_Op_Concat
;
7526 ------------------------
7527 -- Expand_N_Op_Divide --
7528 ------------------------
7530 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
7531 Loc
: constant Source_Ptr
:= Sloc
(N
);
7532 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
7533 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
7534 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
7535 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
7536 Typ
: Entity_Id
:= Etype
(N
);
7537 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
7539 Compile_Time_Known_Value
(Ropnd
);
7543 Binary_Op_Validity_Checks
(N
);
7545 -- Check for MINIMIZED/ELIMINATED overflow mode
7547 if Minimized_Eliminated_Overflow_Check
(N
) then
7548 Apply_Arithmetic_Overflow_Check
(N
);
7552 -- Otherwise proceed with expansion of division
7555 Rval
:= Expr_Value
(Ropnd
);
7558 -- N / 1 = N for integer types
7560 if Rknow
and then Rval
= Uint_1
then
7565 -- Try to narrow the operation
7567 if Typ
= Universal_Integer
then
7568 Narrow_Large_Operation
(N
);
7570 if Nkind
(N
) /= N_Op_Divide
then
7575 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7576 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7577 -- operand is an unsigned integer, as required for this to work.
7579 if Nkind
(Ropnd
) = N_Op_Expon
7580 and then Is_Power_Of_2_For_Shift
(Ropnd
)
7582 -- We cannot do this transformation in configurable run time mode if we
7583 -- have 64-bit integers and long shifts are not available.
7585 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
7588 Make_Op_Shift_Right
(Loc
,
7591 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
7592 Analyze_And_Resolve
(N
, Typ
);
7596 -- Do required fixup of universal fixed operation
7598 if Typ
= Universal_Fixed
then
7599 Fixup_Universal_Fixed_Operation
(N
);
7603 -- Divisions with fixed-point results
7605 if Is_Fixed_Point_Type
(Typ
) then
7607 if Is_Integer_Type
(Rtyp
) then
7608 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
7610 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
7613 -- Deal with divide-by-zero check if back end cannot handle them
7614 -- and the flag is set indicating that we need such a check. Note
7615 -- that we don't need to bother here with the case of mixed-mode
7616 -- (Right operand an integer type), since these will be rewritten
7617 -- with conversions to a divide with a fixed-point right operand.
7619 if Nkind
(N
) = N_Op_Divide
7620 and then Do_Division_Check
(N
)
7621 and then not Backend_Divide_Checks_On_Target
7622 and then not Is_Integer_Type
(Rtyp
)
7624 Set_Do_Division_Check
(N
, False);
7626 Make_Raise_Constraint_Error
(Loc
,
7629 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
7630 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
7631 Reason
=> CE_Divide_By_Zero
));
7634 -- Other cases of division of fixed-point operands
7636 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
7637 if Is_Integer_Type
(Typ
) then
7638 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
7640 pragma Assert
(Is_Floating_Point_Type
(Typ
));
7641 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
7644 -- Mixed-mode operations can appear in a non-static universal context,
7645 -- in which case the integer argument must be converted explicitly.
7647 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
7649 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
7651 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
7653 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
7655 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
7657 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
7659 -- Non-fixed point cases, do integer zero divide and overflow checks
7661 elsif Is_Integer_Type
(Typ
) then
7662 Apply_Divide_Checks
(N
);
7665 -- Overflow checks for floating-point if -gnateF mode active
7667 Check_Float_Op_Overflow
(N
);
7669 Expand_Nonbinary_Modular_Op
(N
);
7670 end Expand_N_Op_Divide
;
7672 --------------------
7673 -- Expand_N_Op_Eq --
7674 --------------------
7676 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
7677 Loc
: constant Source_Ptr
:= Sloc
(N
);
7678 Typ
: constant Entity_Id
:= Etype
(N
);
7679 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
7680 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
7681 Bodies
: constant List_Id
:= New_List
;
7682 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
7684 procedure Build_Equality_Call
(Eq
: Entity_Id
);
7685 -- If a constructed equality exists for the type or for its parent,
7686 -- build and analyze call, adding conversions if the operation is
7689 function Is_Equality
(Subp
: Entity_Id
;
7690 Typ
: Entity_Id
:= Empty
) return Boolean;
7691 -- Determine whether arbitrary Entity_Id denotes a function with the
7692 -- right name and profile for an equality op, specifically for the
7693 -- base type Typ if Typ is nonempty.
7695 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
;
7696 -- Find a primitive equality function within primitive operation list
7699 function User_Defined_Primitive_Equality_Op
7700 (Typ
: Entity_Id
) return Entity_Id
;
7701 -- Find a user-defined primitive equality function for a given untagged
7702 -- record type, ignoring visibility. Return Empty if no such op found.
7704 function Has_Unconstrained_UU_Component
(Typ
: Entity_Id
) return Boolean;
7705 -- Determines whether a type has a subcomponent of an unconstrained
7706 -- Unchecked_Union subtype. Typ is a record type.
7708 -------------------------
7709 -- Build_Equality_Call --
7710 -------------------------
7712 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
7713 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
7714 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
7715 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
7718 -- Adjust operands if necessary to comparison type
7720 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
7721 and then not Is_Class_Wide_Type
(A_Typ
)
7723 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
7724 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
7727 -- If we have an Unchecked_Union, we need to add the inferred
7728 -- discriminant values as actuals in the function call. At this
7729 -- point, the expansion has determined that both operands have
7730 -- inferable discriminants.
7732 if Is_Unchecked_Union
(Op_Type
) then
7734 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
7735 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
7737 Lhs_Discr_Vals
: Elist_Id
;
7738 -- List of inferred discriminant values for left operand.
7740 Rhs_Discr_Vals
: Elist_Id
;
7741 -- List of inferred discriminant values for right operand.
7746 Lhs_Discr_Vals
:= New_Elmt_List
;
7747 Rhs_Discr_Vals
:= New_Elmt_List
;
7749 -- Per-object constrained selected components require special
7750 -- attention. If the enclosing scope of the component is an
7751 -- Unchecked_Union, we cannot reference its discriminants
7752 -- directly. This is why we use the extra parameters of the
7753 -- equality function of the enclosing Unchecked_Union.
7755 -- type UU_Type (Discr : Integer := 0) is
7758 -- pragma Unchecked_Union (UU_Type);
7760 -- 1. Unchecked_Union enclosing record:
7762 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
7764 -- Comp : UU_Type (Discr);
7766 -- end Enclosing_UU_Type;
7767 -- pragma Unchecked_Union (Enclosing_UU_Type);
7769 -- Obj1 : Enclosing_UU_Type;
7770 -- Obj2 : Enclosing_UU_Type (1);
7772 -- [. . .] Obj1 = Obj2 [. . .]
7776 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
7778 -- A and B are the formal parameters of the equality function
7779 -- of Enclosing_UU_Type. The function always has two extra
7780 -- formals to capture the inferred discriminant values for
7781 -- each discriminant of the type.
7783 -- 2. Non-Unchecked_Union enclosing record:
7786 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
7789 -- Comp : UU_Type (Discr);
7791 -- end Enclosing_Non_UU_Type;
7793 -- Obj1 : Enclosing_Non_UU_Type;
7794 -- Obj2 : Enclosing_Non_UU_Type (1);
7796 -- ... Obj1 = Obj2 ...
7800 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
7801 -- obj1.discr, obj2.discr)) then
7803 -- In this case we can directly reference the discriminants of
7804 -- the enclosing record.
7806 -- Process left operand of equality
7808 if Nkind
(Lhs
) = N_Selected_Component
7810 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
7812 -- If enclosing record is an Unchecked_Union, use formals
7813 -- corresponding to each discriminant. The name of the
7814 -- formal is that of the discriminant, with added suffix,
7815 -- see Exp_Ch3.Build_Record_Equality for details.
7817 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Lhs
))))
7821 (Scope
(Entity
(Selector_Name
(Lhs
))));
7822 while Present
(Discr
) loop
7824 (Make_Identifier
(Loc
,
7825 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
7826 To
=> Lhs_Discr_Vals
);
7827 Next_Discriminant
(Discr
);
7830 -- If enclosing record is of a non-Unchecked_Union type, it
7831 -- is possible to reference its discriminants directly.
7834 Discr
:= First_Discriminant
(Lhs_Type
);
7835 while Present
(Discr
) loop
7837 (Make_Selected_Component
(Loc
,
7838 Prefix
=> Prefix
(Lhs
),
7841 (Get_Discriminant_Value
(Discr
,
7843 Stored_Constraint
(Lhs_Type
)))),
7844 To
=> Lhs_Discr_Vals
);
7845 Next_Discriminant
(Discr
);
7849 -- Otherwise operand is on object with a constrained type.
7850 -- Infer the discriminant values from the constraint.
7853 Discr
:= First_Discriminant
(Lhs_Type
);
7854 while Present
(Discr
) loop
7857 (Get_Discriminant_Value
(Discr
,
7859 Stored_Constraint
(Lhs_Type
))),
7860 To
=> Lhs_Discr_Vals
);
7861 Next_Discriminant
(Discr
);
7865 -- Similar processing for right operand of equality
7867 if Nkind
(Rhs
) = N_Selected_Component
7869 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
7871 if Is_Unchecked_Union
7872 (Scope
(Entity
(Selector_Name
(Rhs
))))
7876 (Scope
(Entity
(Selector_Name
(Rhs
))));
7877 while Present
(Discr
) loop
7879 (Make_Identifier
(Loc
,
7880 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
7881 To
=> Rhs_Discr_Vals
);
7882 Next_Discriminant
(Discr
);
7886 Discr
:= First_Discriminant
(Rhs_Type
);
7887 while Present
(Discr
) loop
7889 (Make_Selected_Component
(Loc
,
7890 Prefix
=> Prefix
(Rhs
),
7892 New_Copy
(Get_Discriminant_Value
7895 Stored_Constraint
(Rhs_Type
)))),
7896 To
=> Rhs_Discr_Vals
);
7897 Next_Discriminant
(Discr
);
7902 Discr
:= First_Discriminant
(Rhs_Type
);
7903 while Present
(Discr
) loop
7905 (New_Copy
(Get_Discriminant_Value
7908 Stored_Constraint
(Rhs_Type
))),
7909 To
=> Rhs_Discr_Vals
);
7910 Next_Discriminant
(Discr
);
7914 -- Now merge the list of discriminant values so that values
7915 -- of corresponding discriminants are adjacent.
7923 Params
:= New_List
(L_Exp
, R_Exp
);
7924 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
7925 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
7926 while Present
(L_Elmt
) loop
7927 Append_To
(Params
, Node
(L_Elmt
));
7928 Append_To
(Params
, Node
(R_Elmt
));
7934 Make_Function_Call
(Loc
,
7935 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7936 Parameter_Associations
=> Params
));
7940 -- Normal case, not an unchecked union
7944 Make_Function_Call
(Loc
,
7945 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7946 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7949 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7950 end Build_Equality_Call
;
7956 function Is_Equality
(Subp
: Entity_Id
;
7957 Typ
: Entity_Id
:= Empty
) return Boolean is
7958 Formal_1
: Entity_Id
;
7959 Formal_2
: Entity_Id
;
7961 -- The equality function carries name "=", returns Boolean, and has
7962 -- exactly two formal parameters of an identical type.
7964 if Ekind
(Subp
) = E_Function
7965 and then Chars
(Subp
) = Name_Op_Eq
7966 and then Base_Type
(Etype
(Subp
)) = Standard_Boolean
7968 Formal_1
:= First_Formal
(Subp
);
7971 if Present
(Formal_1
) then
7972 Formal_2
:= Next_Formal
(Formal_1
);
7977 and then Present
(Formal_2
)
7978 and then No
(Next_Formal
(Formal_2
))
7979 and then Base_Type
(Etype
(Formal_1
)) =
7980 Base_Type
(Etype
(Formal_2
))
7983 or else Implementation_Base_Type
(Etype
(Formal_1
)) = Typ
);
7993 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
is
7994 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
;
7995 -- Find an equality in a possible alias chain starting from primitive
7998 ---------------------------
7999 -- Find_Aliased_Equality --
8000 ---------------------------
8002 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
is
8006 -- Inspect each candidate in the alias chain, checking whether it
8007 -- denotes an equality.
8010 while Present
(Candid
) loop
8011 if Is_Equality
(Candid
) then
8015 Candid
:= Alias
(Candid
);
8019 end Find_Aliased_Equality
;
8023 Eq_Prim
: Entity_Id
;
8024 Prim_Elmt
: Elmt_Id
;
8026 -- Start of processing for Find_Equality
8029 -- Assume that the tagged type lacks an equality
8033 -- Inspect the list of primitives looking for a suitable equality
8034 -- within a possible chain of aliases.
8036 Prim_Elmt
:= First_Elmt
(Prims
);
8037 while Present
(Prim_Elmt
) and then No
(Eq_Prim
) loop
8038 Eq_Prim
:= Find_Aliased_Equality
(Node
(Prim_Elmt
));
8040 Next_Elmt
(Prim_Elmt
);
8043 -- A tagged type should always have an equality
8045 pragma Assert
(Present
(Eq_Prim
));
8050 ----------------------------------------
8051 -- User_Defined_Primitive_Equality_Op --
8052 ----------------------------------------
8054 function User_Defined_Primitive_Equality_Op
8055 (Typ
: Entity_Id
) return Entity_Id
8057 Enclosing_Scope
: constant Node_Id
:= Scope
(Typ
);
8060 -- Prune this search by somehow not looking at decls that precede
8061 -- the declaration of the first view of Typ (which might be a partial
8064 for Private_Entities
in Boolean loop
8065 if Private_Entities
then
8066 if Ekind
(Enclosing_Scope
) /= E_Package
then
8069 E
:= First_Private_Entity
(Enclosing_Scope
);
8072 E
:= First_Entity
(Enclosing_Scope
);
8075 while Present
(E
) loop
8076 if Is_Equality
(E
, Typ
) then
8083 if Is_Derived_Type
(Typ
) then
8084 return User_Defined_Primitive_Equality_Op
8085 (Implementation_Base_Type
(Etype
(Typ
)));
8089 end User_Defined_Primitive_Equality_Op
;
8091 ------------------------------------
8092 -- Has_Unconstrained_UU_Component --
8093 ------------------------------------
8095 function Has_Unconstrained_UU_Component
8096 (Typ
: Entity_Id
) return Boolean
8098 Tdef
: constant Node_Id
:=
8099 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
8103 function Component_Is_Unconstrained_UU
8104 (Comp
: Node_Id
) return Boolean;
8105 -- Determines whether the subtype of the component is an
8106 -- unconstrained Unchecked_Union.
8108 function Variant_Is_Unconstrained_UU
8109 (Variant
: Node_Id
) return Boolean;
8110 -- Determines whether a component of the variant has an unconstrained
8111 -- Unchecked_Union subtype.
8113 -----------------------------------
8114 -- Component_Is_Unconstrained_UU --
8115 -----------------------------------
8117 function Component_Is_Unconstrained_UU
8118 (Comp
: Node_Id
) return Boolean
8121 if Nkind
(Comp
) /= N_Component_Declaration
then
8126 Sindic
: constant Node_Id
:=
8127 Subtype_Indication
(Component_Definition
(Comp
));
8130 -- Unconstrained nominal type. In the case of a constraint
8131 -- present, the node kind would have been N_Subtype_Indication.
8133 if Nkind
(Sindic
) = N_Identifier
then
8134 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
8139 end Component_Is_Unconstrained_UU
;
8141 ---------------------------------
8142 -- Variant_Is_Unconstrained_UU --
8143 ---------------------------------
8145 function Variant_Is_Unconstrained_UU
8146 (Variant
: Node_Id
) return Boolean
8148 Clist
: constant Node_Id
:= Component_List
(Variant
);
8151 if Is_Empty_List
(Component_Items
(Clist
)) then
8155 -- We only need to test one component
8158 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
8161 while Present
(Comp
) loop
8162 if Component_Is_Unconstrained_UU
(Comp
) then
8170 -- None of the components withing the variant were of
8171 -- unconstrained Unchecked_Union type.
8174 end Variant_Is_Unconstrained_UU
;
8176 -- Start of processing for Has_Unconstrained_UU_Component
8179 if Null_Present
(Tdef
) then
8183 Clist
:= Component_List
(Tdef
);
8184 Vpart
:= Variant_Part
(Clist
);
8186 -- Inspect available components
8188 if Present
(Component_Items
(Clist
)) then
8190 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
8193 while Present
(Comp
) loop
8195 -- One component is sufficient
8197 if Component_Is_Unconstrained_UU
(Comp
) then
8206 -- Inspect available components withing variants
8208 if Present
(Vpart
) then
8210 Variant
: Node_Id
:= First
(Variants
(Vpart
));
8213 while Present
(Variant
) loop
8215 -- One component within a variant is sufficient
8217 if Variant_Is_Unconstrained_UU
(Variant
) then
8226 -- Neither the available components, nor the components inside the
8227 -- variant parts were of an unconstrained Unchecked_Union subtype.
8230 end Has_Unconstrained_UU_Component
;
8236 -- Start of processing for Expand_N_Op_Eq
8239 Binary_Op_Validity_Checks
(N
);
8241 -- Deal with private types
8245 if Ekind
(Typl
) = E_Private_Type
then
8246 Typl
:= Underlying_Type
(Typl
);
8248 elsif Ekind
(Typl
) = E_Private_Subtype
then
8249 Typl
:= Underlying_Type
(Base_Type
(Typl
));
8252 -- It may happen in error situations that the underlying type is not
8253 -- set. The error will be detected later, here we just defend the
8260 -- Now get the implementation base type (note that plain Base_Type here
8261 -- might lead us back to the private type, which is not what we want!)
8263 Typl
:= Implementation_Base_Type
(Typl
);
8265 -- Equality between variant records results in a call to a routine
8266 -- that has conditional tests of the discriminant value(s), and hence
8267 -- violates the No_Implicit_Conditionals restriction.
8269 if Has_Variant_Part
(Typl
) then
8274 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
8278 ("\comparison of variant records tests discriminants", N
);
8284 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8285 -- means we no longer have a comparison operation, we are all done.
8287 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8289 if Nkind
(N
) /= N_Op_Eq
then
8293 -- Boolean types (requiring handling of non-standard case)
8295 if Is_Boolean_Type
(Typl
) then
8296 Adjust_Condition
(Left_Opnd
(N
));
8297 Adjust_Condition
(Right_Opnd
(N
));
8298 Set_Etype
(N
, Standard_Boolean
);
8299 Adjust_Result_Type
(N
, Typ
);
8303 elsif Is_Array_Type
(Typl
) then
8305 -- If we are doing full validity checking, and it is possible for the
8306 -- array elements to be invalid then expand out array comparisons to
8307 -- make sure that we check the array elements.
8309 if Validity_Check_Operands
8310 and then not Is_Known_Valid
(Component_Type
(Typl
))
8313 Save_Force_Validity_Checks
: constant Boolean :=
8314 Force_Validity_Checks
;
8316 Force_Validity_Checks
:= True;
8318 Expand_Array_Equality
8320 Relocate_Node
(Lhs
),
8321 Relocate_Node
(Rhs
),
8324 Insert_Actions
(N
, Bodies
);
8325 Analyze_And_Resolve
(N
, Standard_Boolean
);
8326 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
8329 -- Packed case where both operands are known aligned
8331 elsif Is_Bit_Packed_Array
(Typl
)
8332 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8333 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8335 Expand_Packed_Eq
(N
);
8337 -- Where the component type is elementary we can use a block bit
8338 -- comparison (if supported on the target) exception in the case
8339 -- of floating-point (negative zero issues require element by
8340 -- element comparison), and full access types (where we must be sure
8341 -- to load elements independently) and possibly unaligned arrays.
8343 elsif Is_Elementary_Type
(Component_Type
(Typl
))
8344 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
8345 and then not Is_Full_Access
(Component_Type
(Typl
))
8346 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8347 and then not Is_Possibly_Unaligned_Slice
(Lhs
)
8348 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8349 and then not Is_Possibly_Unaligned_Slice
(Rhs
)
8350 and then Support_Composite_Compare_On_Target
8354 -- For composite and floating-point cases, expand equality loop to
8355 -- make sure of using proper comparisons for tagged types, and
8356 -- correctly handling the floating-point case.
8360 Expand_Array_Equality
8362 Relocate_Node
(Lhs
),
8363 Relocate_Node
(Rhs
),
8366 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8367 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8372 elsif Is_Record_Type
(Typl
) then
8374 -- For tagged types, use the primitive "="
8376 if Is_Tagged_Type
(Typl
) then
8378 -- No need to do anything else compiling under restriction
8379 -- No_Dispatching_Calls. During the semantic analysis we
8380 -- already notified such violation.
8382 if Restriction_Active
(No_Dispatching_Calls
) then
8386 -- If this is an untagged private type completed with a derivation
8387 -- of an untagged private type whose full view is a tagged type,
8388 -- we use the primitive operations of the private type (since it
8389 -- does not have a full view, and also because its equality
8390 -- primitive may have been overridden in its untagged full view).
8392 if Inherits_From_Tagged_Full_View
(A_Typ
) then
8394 (Find_Equality
(Collect_Primitive_Operations
(A_Typ
)));
8396 -- Find the type's predefined equality or an overriding
8397 -- user-defined equality. The reason for not simply calling
8398 -- Find_Prim_Op here is that there may be a user-defined
8399 -- overloaded equality op that precedes the equality that we
8400 -- want, so we have to explicitly search (e.g., there could be
8401 -- an equality with two different parameter types).
8404 if Is_Class_Wide_Type
(Typl
) then
8405 Typl
:= Find_Specific_Type
(Typl
);
8409 (Find_Equality
(Primitive_Operations
(Typl
)));
8412 -- See AI12-0101 (which only removes a legality rule) and then
8413 -- AI05-0123 (which then applies in the previously illegal case).
8414 -- AI12-0101 is a binding interpretation.
8416 elsif Ada_Version
>= Ada_2012
8417 and then Present
(User_Defined_Primitive_Equality_Op
(Typl
))
8419 Build_Equality_Call
(User_Defined_Primitive_Equality_Op
(Typl
));
8421 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8422 -- predefined equality operator for a type which has a subcomponent
8423 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
8425 elsif Has_Unconstrained_UU_Component
(Typl
) then
8427 Make_Raise_Program_Error
(Loc
,
8428 Reason
=> PE_Unchecked_Union_Restriction
));
8430 -- Prevent Gigi from generating incorrect code by rewriting the
8431 -- equality as a standard False. (is this documented somewhere???)
8434 New_Occurrence_Of
(Standard_False
, Loc
));
8436 elsif Is_Unchecked_Union
(Typl
) then
8438 -- If we can infer the discriminants of the operands, we make a
8439 -- call to the TSS equality function.
8441 if Has_Inferable_Discriminants
(Lhs
)
8443 Has_Inferable_Discriminants
(Rhs
)
8446 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8449 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
8450 -- the predefined equality operator for an Unchecked_Union type
8451 -- if either of the operands lack inferable discriminants.
8454 Make_Raise_Program_Error
(Loc
,
8455 Reason
=> PE_Unchecked_Union_Restriction
));
8457 -- Emit a warning on source equalities only, otherwise the
8458 -- message may appear out of place due to internal use. The
8459 -- warning is unconditional because it is required by the
8462 if Comes_From_Source
(N
) then
8464 ("Unchecked_Union discriminants cannot be determined??",
8467 ("\Program_Error will be raised for equality operation??",
8471 -- Prevent Gigi from generating incorrect code by rewriting
8472 -- the equality as a standard False (documented where???).
8475 New_Occurrence_Of
(Standard_False
, Loc
));
8478 -- If a type support function is present (for complex cases), use it
8480 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
8482 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8484 -- When comparing two Bounded_Strings, use the primitive equality of
8485 -- the root Super_String type.
8487 elsif Is_Bounded_String
(Typl
) then
8490 (Collect_Primitive_Operations
(Root_Type
(Typl
))));
8492 -- Otherwise expand the component by component equality. Note that
8493 -- we never use block-bit comparisons for records, because of the
8494 -- problems with gaps. The back end will often be able to recombine
8495 -- the separate comparisons that we generate here.
8498 Remove_Side_Effects
(Lhs
);
8499 Remove_Side_Effects
(Rhs
);
8501 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
8503 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8504 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8507 -- If unnesting, handle elementary types whose Equivalent_Types are
8508 -- records because there may be padding or undefined fields.
8510 elsif Unnest_Subprogram_Mode
8511 and then Ekind
(Typl
) in E_Class_Wide_Type
8512 | E_Class_Wide_Subtype
8513 | E_Access_Subprogram_Type
8514 | E_Access_Protected_Subprogram_Type
8515 | E_Anonymous_Access_Protected_Subprogram_Type
8517 and then Present
(Equivalent_Type
(Typl
))
8518 and then Is_Record_Type
(Equivalent_Type
(Typl
))
8520 Typl
:= Equivalent_Type
(Typl
);
8521 Remove_Side_Effects
(Lhs
);
8522 Remove_Side_Effects
(Rhs
);
8524 Expand_Record_Equality
(N
, Typl
,
8525 Unchecked_Convert_To
(Typl
, Lhs
),
8526 Unchecked_Convert_To
(Typl
, Rhs
),
8529 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8530 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8533 -- Test if result is known at compile time
8535 Rewrite_Comparison
(N
);
8537 -- Try to narrow the operation
8539 if Typl
= Universal_Integer
and then Nkind
(N
) = N_Op_Eq
then
8540 Narrow_Large_Operation
(N
);
8543 -- Special optimization of length comparison
8545 Optimize_Length_Comparison
(N
);
8547 -- One more special case: if we have a comparison of X'Result = expr
8548 -- in floating-point, then if not already there, change expr to be
8549 -- f'Machine (expr) to eliminate surprise from extra precision.
8551 if Is_Floating_Point_Type
(Typl
)
8552 and then Nkind
(Original_Node
(Lhs
)) = N_Attribute_Reference
8553 and then Attribute_Name
(Original_Node
(Lhs
)) = Name_Result
8555 -- Stick in the Typ'Machine call if not already there
8557 if Nkind
(Rhs
) /= N_Attribute_Reference
8558 or else Attribute_Name
(Rhs
) /= Name_Machine
8561 Make_Attribute_Reference
(Loc
,
8562 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
8563 Attribute_Name
=> Name_Machine
,
8564 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
8565 Analyze_And_Resolve
(Rhs
, Typl
);
8570 -----------------------
8571 -- Expand_N_Op_Expon --
8572 -----------------------
8574 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
8575 Loc
: constant Source_Ptr
:= Sloc
(N
);
8576 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
8577 Typ
: constant Entity_Id
:= Etype
(N
);
8578 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
8582 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
8583 -- Given an expression Exp, if the root type is Float or Long_Float,
8584 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8585 -- extra precision. This is done to ensure that X**A = X**B when A is
8586 -- a static constant and B is a variable with the same value. For any
8587 -- other type, the node Exp is returned unchanged.
8593 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
8594 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
8597 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
8599 Make_Attribute_Reference
(Loc
,
8600 Attribute_Name
=> Name_Machine
,
8601 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
8602 Expressions
=> New_List
(Relocate_Node
(Exp
)));
8620 -- Start of processing for Expand_N_Op_Expon
8623 Binary_Op_Validity_Checks
(N
);
8625 -- CodePeer wants to see the unexpanded N_Op_Expon node
8627 if CodePeer_Mode
then
8631 -- Relocation of left and right operands must be done after performing
8632 -- the validity checks since the generation of validation checks may
8633 -- remove side effects.
8635 Base
:= Relocate_Node
(Left_Opnd
(N
));
8636 Bastyp
:= Etype
(Base
);
8637 Exp
:= Relocate_Node
(Right_Opnd
(N
));
8638 Exptyp
:= Etype
(Exp
);
8640 -- If either operand is of a private type, then we have the use of an
8641 -- intrinsic operator, and we get rid of the privateness, by using root
8642 -- types of underlying types for the actual operation. Otherwise the
8643 -- private types will cause trouble if we expand multiplications or
8644 -- shifts etc. We also do this transformation if the result type is
8645 -- different from the base type.
8647 if Is_Private_Type
(Etype
(Base
))
8648 or else Is_Private_Type
(Typ
)
8649 or else Is_Private_Type
(Exptyp
)
8650 or else Rtyp
/= Root_Type
(Bastyp
)
8653 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
8654 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
8657 Unchecked_Convert_To
(Typ
,
8659 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
8660 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
8661 Analyze_And_Resolve
(N
, Typ
);
8666 -- Check for MINIMIZED/ELIMINATED overflow mode
8668 if Minimized_Eliminated_Overflow_Check
(N
) then
8669 Apply_Arithmetic_Overflow_Check
(N
);
8673 -- Test for case of known right argument where we can replace the
8674 -- exponentiation by an equivalent expression using multiplication.
8676 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8677 -- configurable run-time mode, we may not have the exponentiation
8678 -- routine available, and we don't want the legality of the program
8679 -- to depend on how clever the compiler is in knowing values.
8681 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
8682 Expv
:= Expr_Value
(Exp
);
8684 -- We only fold small non-negative exponents. You might think we
8685 -- could fold small negative exponents for the real case, but we
8686 -- can't because we are required to raise Constraint_Error for
8687 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8688 -- See ACVC test C4A012B, and it is not worth generating the test.
8690 -- For small negative exponents, we return the reciprocal of
8691 -- the folding of the exponentiation for the opposite (positive)
8692 -- exponent, as required by Ada RM 4.5.6(11/3).
8694 if abs Expv
<= 4 then
8696 -- X ** 0 = 1 (or 1.0)
8700 -- Call Remove_Side_Effects to ensure that any side effects
8701 -- in the ignored left operand (in particular function calls
8702 -- to user defined functions) are properly executed.
8704 Remove_Side_Effects
(Base
);
8706 if Ekind
(Typ
) in Integer_Kind
then
8707 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
8709 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
8722 Make_Op_Multiply
(Loc
,
8723 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8724 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8726 -- X ** 3 = X * X * X
8731 Make_Op_Multiply
(Loc
,
8733 Make_Op_Multiply
(Loc
,
8734 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8735 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
8736 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8741 -- En : constant base'type := base * base;
8746 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
8749 Make_Expression_With_Actions
(Loc
,
8750 Actions
=> New_List
(
8751 Make_Object_Declaration
(Loc
,
8752 Defining_Identifier
=> Temp
,
8753 Constant_Present
=> True,
8754 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8757 Make_Op_Multiply
(Loc
,
8759 Duplicate_Subexpr
(Base
),
8761 Duplicate_Subexpr_No_Checks
(Base
))))),
8765 Make_Op_Multiply
(Loc
,
8766 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
8767 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
8769 -- X ** N = 1.0 / X ** (-N)
8774 (Expv
= -1 or Expv
= -2 or Expv
= -3 or Expv
= -4);
8777 Make_Op_Divide
(Loc
,
8779 Make_Float_Literal
(Loc
,
8781 Significand
=> Uint_1
,
8782 Exponent
=> Uint_0
),
8785 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8787 Make_Integer_Literal
(Loc
,
8792 Analyze_And_Resolve
(N
, Typ
);
8797 -- Deal with optimizing 2 ** expression to shift where possible
8799 -- Note: we used to check that Exptyp was an unsigned type. But that is
8800 -- an unnecessary check, since if Exp is negative, we have a run-time
8801 -- error that is either caught (so we get the right result) or we have
8802 -- suppressed the check, in which case the code is erroneous anyway.
8804 if Is_Integer_Type
(Rtyp
)
8806 -- The base value must be "safe compile-time known", and exactly 2
8808 and then Nkind
(Base
) = N_Integer_Literal
8809 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
8810 and then Expr_Value
(Base
) = Uint_2
8812 -- We only handle cases where the right type is a integer
8814 and then Is_Integer_Type
(Root_Type
(Exptyp
))
8815 and then Esize
(Root_Type
(Exptyp
)) <= Standard_Integer_Size
8817 -- This transformation is not applicable for a modular type with a
8818 -- nonbinary modulus because we do not handle modular reduction in
8819 -- a correct manner if we attempt this transformation in this case.
8821 and then not Non_Binary_Modulus
(Typ
)
8823 -- Handle the cases where our parent is a division or multiplication
8824 -- specially. In these cases we can convert to using a shift at the
8825 -- parent level if we are not doing overflow checking, since it is
8826 -- too tricky to combine the overflow check at the parent level.
8829 and then Nkind
(Parent
(N
)) in N_Op_Divide | N_Op_Multiply
8832 P
: constant Node_Id
:= Parent
(N
);
8833 L
: constant Node_Id
:= Left_Opnd
(P
);
8834 R
: constant Node_Id
:= Right_Opnd
(P
);
8837 if (Nkind
(P
) = N_Op_Multiply
8839 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
8841 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
8842 and then not Do_Overflow_Check
(P
))
8845 (Nkind
(P
) = N_Op_Divide
8846 and then Is_Integer_Type
(Etype
(L
))
8847 and then Is_Unsigned_Type
(Etype
(L
))
8849 and then not Do_Overflow_Check
(P
))
8851 Set_Is_Power_Of_2_For_Shift
(N
);
8856 -- Here we just have 2 ** N on its own, so we can convert this to a
8857 -- shift node. We are prepared to deal with overflow here, and we
8858 -- also have to handle proper modular reduction for binary modular.
8867 -- Maximum shift count with no overflow
8870 -- Set True if we must test the shift count
8873 -- Node for test against TestS
8876 -- Compute maximum shift based on the underlying size. For a
8877 -- modular type this is one less than the size.
8879 if Is_Modular_Integer_Type
(Typ
) then
8881 -- For modular integer types, this is the size of the value
8882 -- being shifted minus one. Any larger values will cause
8883 -- modular reduction to a result of zero. Note that we do
8884 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
8885 -- of 6, since 2**7 should be reduced to zero).
8887 MaxS
:= RM_Size
(Rtyp
) - 1;
8889 -- For signed integer types, we use the size of the value
8890 -- being shifted minus 2. Larger values cause overflow.
8893 MaxS
:= Esize
(Rtyp
) - 2;
8896 -- Determine range to see if it can be larger than MaxS
8898 Determine_Range
(Exp
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8899 TestS
:= (not OK
) or else Hi
> MaxS
;
8901 -- Signed integer case
8903 if Is_Signed_Integer_Type
(Typ
) then
8905 -- Generate overflow check if overflow is active. Note that
8906 -- we can simply ignore the possibility of overflow if the
8907 -- flag is not set (means that overflow cannot happen or
8908 -- that overflow checks are suppressed).
8910 if Ovflo
and TestS
then
8912 Make_Raise_Constraint_Error
(Loc
,
8915 Left_Opnd
=> Duplicate_Subexpr
(Exp
),
8916 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
8917 Reason
=> CE_Overflow_Check_Failed
));
8920 -- Now rewrite node as Shift_Left (1, right-operand)
8923 Make_Op_Shift_Left
(Loc
,
8924 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8925 Right_Opnd
=> Exp
));
8927 -- Modular integer case
8929 else pragma Assert
(Is_Modular_Integer_Type
(Typ
));
8931 -- If shift count can be greater than MaxS, we need to wrap
8932 -- the shift in a test that will reduce the result value to
8933 -- zero if this shift count is exceeded.
8937 -- Note: build node for the comparison first, before we
8938 -- reuse the Right_Opnd, so that we have proper parents
8939 -- in place for the Duplicate_Subexpr call.
8943 Left_Opnd
=> Duplicate_Subexpr
(Exp
),
8944 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
));
8947 Make_If_Expression
(Loc
,
8948 Expressions
=> New_List
(
8950 Make_Integer_Literal
(Loc
, Uint_0
),
8951 Make_Op_Shift_Left
(Loc
,
8952 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8953 Right_Opnd
=> Exp
))));
8955 -- If we know shift count cannot be greater than MaxS, then
8956 -- it is safe to just rewrite as a shift with no test.
8960 Make_Op_Shift_Left
(Loc
,
8961 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8962 Right_Opnd
=> Exp
));
8966 Analyze_And_Resolve
(N
, Typ
);
8972 -- Fall through if exponentiation must be done using a runtime routine
8974 -- First deal with modular case
8976 if Is_Modular_Integer_Type
(Rtyp
) then
8978 -- Nonbinary modular case, we call the special exponentiation
8979 -- routine for the nonbinary case, converting the argument to
8980 -- Long_Long_Integer and passing the modulus value. Then the
8981 -- result is converted back to the base type.
8983 if Non_Binary_Modulus
(Rtyp
) then
8986 Make_Function_Call
(Loc
,
8988 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
8989 Parameter_Associations
=> New_List
(
8990 Convert_To
(RTE
(RE_Unsigned
), Base
),
8991 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
8994 -- Binary modular case, in this case, we call one of three routines,
8995 -- either the unsigned integer case, or the unsigned long long
8996 -- integer case, or the unsigned long long long integer case, with a
8997 -- final "and" operation to do the required mod.
9000 if Esize
(Rtyp
) <= Standard_Integer_Size
then
9001 Ent
:= RTE
(RE_Exp_Unsigned
);
9002 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
9003 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
9005 Ent
:= RTE
(RE_Exp_Long_Long_Long_Unsigned
);
9012 Make_Function_Call
(Loc
,
9013 Name
=> New_Occurrence_Of
(Ent
, Loc
),
9014 Parameter_Associations
=> New_List
(
9015 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
9018 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
9022 -- Common exit point for modular type case
9024 Analyze_And_Resolve
(N
, Typ
);
9027 -- Signed integer cases, using either Integer, Long_Long_Integer or
9028 -- Long_Long_Long_Integer. It is not worth also having routines for
9029 -- Short_[Short_]Integer, since for most machines it would not help,
9030 -- and it would generate more code that might need certification when
9031 -- a certified run time is required.
9033 -- In the integer cases, we have two routines, one for when overflow
9034 -- checks are required, and one when they are not required, since there
9035 -- is a real gain in omitting checks on many machines.
9037 elsif Is_Signed_Integer_Type
(Rtyp
) then
9038 if Esize
(Rtyp
) <= Standard_Integer_Size
then
9039 Etyp
:= Standard_Integer
;
9042 Rent
:= RE_Exp_Integer
;
9044 Rent
:= RE_Exn_Integer
;
9047 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
9048 Etyp
:= Standard_Long_Long_Integer
;
9051 Rent
:= RE_Exp_Long_Long_Integer
;
9053 Rent
:= RE_Exn_Long_Long_Integer
;
9057 Etyp
:= Standard_Long_Long_Long_Integer
;
9060 Rent
:= RE_Exp_Long_Long_Long_Integer
;
9062 Rent
:= RE_Exn_Long_Long_Long_Integer
;
9066 -- Floating-point cases. We do not need separate routines for the
9067 -- overflow case here, since in the case of floating-point, we generate
9068 -- infinities anyway as a rule (either that or we automatically trap
9069 -- overflow), and if there is an infinity generated and a range check
9070 -- is required, the check will fail anyway.
9072 -- Historical note: we used to convert everything to Long_Long_Float
9073 -- and call a single common routine, but this had the undesirable effect
9074 -- of giving different results for small static exponent values and the
9075 -- same dynamic values.
9078 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
9080 if Rtyp
= Standard_Float
then
9081 Etyp
:= Standard_Float
;
9082 Rent
:= RE_Exn_Float
;
9084 elsif Rtyp
= Standard_Long_Float
then
9085 Etyp
:= Standard_Long_Float
;
9086 Rent
:= RE_Exn_Long_Float
;
9089 Etyp
:= Standard_Long_Long_Float
;
9090 Rent
:= RE_Exn_Long_Long_Float
;
9094 -- Common processing for integer cases and floating-point cases.
9095 -- If we are in the right type, we can call runtime routine directly
9098 and then Rtyp
/= Universal_Integer
9099 and then Rtyp
/= Universal_Real
9103 Make_Function_Call
(Loc
,
9104 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
9105 Parameter_Associations
=> New_List
(Base
, Exp
))));
9107 -- Otherwise we have to introduce conversions (conversions are also
9108 -- required in the universal cases, since the runtime routine is
9109 -- typed using one of the standard types).
9114 Make_Function_Call
(Loc
,
9115 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
9116 Parameter_Associations
=> New_List
(
9117 Convert_To
(Etyp
, Base
),
9121 Analyze_And_Resolve
(N
, Typ
);
9125 when RE_Not_Available
=>
9127 end Expand_N_Op_Expon
;
9129 --------------------
9130 -- Expand_N_Op_Ge --
9131 --------------------
9133 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
9134 Typ
: constant Entity_Id
:= Etype
(N
);
9135 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9136 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9137 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9140 Binary_Op_Validity_Checks
(N
);
9142 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9143 -- means we no longer have a comparison operation, we are all done.
9145 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9147 if Nkind
(N
) /= N_Op_Ge
then
9153 if Is_Array_Type
(Typ1
) then
9154 Expand_Array_Comparison
(N
);
9158 -- Deal with boolean operands
9160 if Is_Boolean_Type
(Typ1
) then
9161 Adjust_Condition
(Op1
);
9162 Adjust_Condition
(Op2
);
9163 Set_Etype
(N
, Standard_Boolean
);
9164 Adjust_Result_Type
(N
, Typ
);
9167 Rewrite_Comparison
(N
);
9169 -- Try to narrow the operation
9171 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Ge
then
9172 Narrow_Large_Operation
(N
);
9175 Optimize_Length_Comparison
(N
);
9178 --------------------
9179 -- Expand_N_Op_Gt --
9180 --------------------
9182 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
9183 Typ
: constant Entity_Id
:= Etype
(N
);
9184 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9185 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9186 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9189 Binary_Op_Validity_Checks
(N
);
9191 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9192 -- means we no longer have a comparison operation, we are all done.
9194 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9196 if Nkind
(N
) /= N_Op_Gt
then
9200 -- Deal with array type operands
9202 if Is_Array_Type
(Typ1
) then
9203 Expand_Array_Comparison
(N
);
9207 -- Deal with boolean type operands
9209 if Is_Boolean_Type
(Typ1
) then
9210 Adjust_Condition
(Op1
);
9211 Adjust_Condition
(Op2
);
9212 Set_Etype
(N
, Standard_Boolean
);
9213 Adjust_Result_Type
(N
, Typ
);
9216 Rewrite_Comparison
(N
);
9218 -- Try to narrow the operation
9220 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Gt
then
9221 Narrow_Large_Operation
(N
);
9224 Optimize_Length_Comparison
(N
);
9227 --------------------
9228 -- Expand_N_Op_Le --
9229 --------------------
9231 procedure Expand_N_Op_Le
(N
: Node_Id
) is
9232 Typ
: constant Entity_Id
:= Etype
(N
);
9233 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9234 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9235 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9238 Binary_Op_Validity_Checks
(N
);
9240 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9241 -- means we no longer have a comparison operation, we are all done.
9243 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9245 if Nkind
(N
) /= N_Op_Le
then
9249 -- Deal with array type operands
9251 if Is_Array_Type
(Typ1
) then
9252 Expand_Array_Comparison
(N
);
9256 -- Deal with Boolean type operands
9258 if Is_Boolean_Type
(Typ1
) then
9259 Adjust_Condition
(Op1
);
9260 Adjust_Condition
(Op2
);
9261 Set_Etype
(N
, Standard_Boolean
);
9262 Adjust_Result_Type
(N
, Typ
);
9265 Rewrite_Comparison
(N
);
9267 -- Try to narrow the operation
9269 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Le
then
9270 Narrow_Large_Operation
(N
);
9273 Optimize_Length_Comparison
(N
);
9276 --------------------
9277 -- Expand_N_Op_Lt --
9278 --------------------
9280 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
9281 Typ
: constant Entity_Id
:= Etype
(N
);
9282 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9283 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9284 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9287 Binary_Op_Validity_Checks
(N
);
9289 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9290 -- means we no longer have a comparison operation, we are all done.
9292 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9294 if Nkind
(N
) /= N_Op_Lt
then
9298 -- Deal with array type operands
9300 if Is_Array_Type
(Typ1
) then
9301 Expand_Array_Comparison
(N
);
9305 -- Deal with Boolean type operands
9307 if Is_Boolean_Type
(Typ1
) then
9308 Adjust_Condition
(Op1
);
9309 Adjust_Condition
(Op2
);
9310 Set_Etype
(N
, Standard_Boolean
);
9311 Adjust_Result_Type
(N
, Typ
);
9314 Rewrite_Comparison
(N
);
9316 -- Try to narrow the operation
9318 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Lt
then
9319 Narrow_Large_Operation
(N
);
9322 Optimize_Length_Comparison
(N
);
9325 -----------------------
9326 -- Expand_N_Op_Minus --
9327 -----------------------
9329 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
9330 Loc
: constant Source_Ptr
:= Sloc
(N
);
9331 Typ
: constant Entity_Id
:= Etype
(N
);
9334 Unary_Op_Validity_Checks
(N
);
9336 -- Check for MINIMIZED/ELIMINATED overflow mode
9338 if Minimized_Eliminated_Overflow_Check
(N
) then
9339 Apply_Arithmetic_Overflow_Check
(N
);
9343 -- Try to narrow the operation
9345 if Typ
= Universal_Integer
then
9346 Narrow_Large_Operation
(N
);
9348 if Nkind
(N
) /= N_Op_Minus
then
9353 if not Backend_Overflow_Checks_On_Target
9354 and then Is_Signed_Integer_Type
(Typ
)
9355 and then Do_Overflow_Check
(N
)
9357 -- Software overflow checking expands -expr into (0 - expr)
9360 Make_Op_Subtract
(Loc
,
9361 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
9362 Right_Opnd
=> Right_Opnd
(N
)));
9364 Analyze_And_Resolve
(N
, Typ
);
9367 Expand_Nonbinary_Modular_Op
(N
);
9368 end Expand_N_Op_Minus
;
9370 ---------------------
9371 -- Expand_N_Op_Mod --
9372 ---------------------
9374 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
9375 Loc
: constant Source_Ptr
:= Sloc
(N
);
9376 Typ
: constant Entity_Id
:= Etype
(N
);
9377 DDC
: constant Boolean := Do_Division_Check
(N
);
9390 pragma Warnings
(Off
, Lhi
);
9393 Binary_Op_Validity_Checks
(N
);
9395 -- Check for MINIMIZED/ELIMINATED overflow mode
9397 if Minimized_Eliminated_Overflow_Check
(N
) then
9398 Apply_Arithmetic_Overflow_Check
(N
);
9402 -- Try to narrow the operation
9404 if Typ
= Universal_Integer
then
9405 Narrow_Large_Operation
(N
);
9407 if Nkind
(N
) /= N_Op_Mod
then
9412 if Is_Integer_Type
(Typ
) then
9413 Apply_Divide_Checks
(N
);
9415 -- All done if we don't have a MOD any more, which can happen as a
9416 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9418 if Nkind
(N
) /= N_Op_Mod
then
9423 -- Proceed with expansion of mod operator
9425 Left
:= Left_Opnd
(N
);
9426 Right
:= Right_Opnd
(N
);
9428 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
9429 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
9431 -- Convert mod to rem if operands are both known to be non-negative, or
9432 -- both known to be non-positive (these are the cases in which rem and
9433 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9434 -- likely that this will improve the quality of code, (the operation now
9435 -- corresponds to the hardware remainder), and it does not seem likely
9436 -- that it could be harmful. It also avoids some cases of the elaborate
9437 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9440 and then ((Llo
>= 0 and then Rlo
>= 0)
9442 (Lhi
<= 0 and then Rhi
<= 0))
9445 Make_Op_Rem
(Sloc
(N
),
9446 Left_Opnd
=> Left_Opnd
(N
),
9447 Right_Opnd
=> Right_Opnd
(N
)));
9449 -- Instead of reanalyzing the node we do the analysis manually. This
9450 -- avoids anomalies when the replacement is done in an instance and
9451 -- is epsilon more efficient.
9453 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
9455 Set_Do_Division_Check
(N
, DDC
);
9456 Expand_N_Op_Rem
(N
);
9460 -- Otherwise, normal mod processing
9463 -- Apply optimization x mod 1 = 0. We don't really need that with
9464 -- gcc, but it is useful with other back ends and is certainly
9467 if Is_Integer_Type
(Etype
(N
))
9468 and then Compile_Time_Known_Value
(Right
)
9469 and then Expr_Value
(Right
) = Uint_1
9471 -- Call Remove_Side_Effects to ensure that any side effects in
9472 -- the ignored left operand (in particular function calls to
9473 -- user defined functions) are properly executed.
9475 Remove_Side_Effects
(Left
);
9477 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9478 Analyze_And_Resolve
(N
, Typ
);
9482 -- If we still have a mod operator and we are in Modify_Tree_For_C
9483 -- mode, and we have a signed integer type, then here is where we do
9484 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9485 -- for the special handling of the annoying case of largest negative
9486 -- number mod minus one.
9488 if Nkind
(N
) = N_Op_Mod
9489 and then Is_Signed_Integer_Type
(Typ
)
9490 and then Modify_Tree_For_C
9492 -- In the general case, we expand A mod B as
9494 -- Tnn : constant typ := A rem B;
9496 -- (if (A >= 0) = (B >= 0) then Tnn
9497 -- elsif Tnn = 0 then 0
9500 -- The comparison can be written simply as A >= 0 if we know that
9501 -- B >= 0 which is a very common case.
9503 -- An important optimization is when B is known at compile time
9504 -- to be 2**K for some constant. In this case we can simply AND
9505 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9506 -- and that works for both the positive and negative cases.
9509 P2
: constant Nat
:= Power_Of_Two
(Right
);
9514 Unchecked_Convert_To
(Typ
,
9517 Unchecked_Convert_To
9518 (Corresponding_Unsigned_Type
(Typ
), Left
),
9520 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
9521 Analyze_And_Resolve
(N
, Typ
);
9526 -- Here for the full rewrite
9529 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
9535 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9536 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
9538 if not LOK
or else Rlo
< 0 then
9544 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
9545 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
9549 Make_Object_Declaration
(Loc
,
9550 Defining_Identifier
=> Tnn
,
9551 Constant_Present
=> True,
9552 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9556 Right_Opnd
=> Right
)));
9559 Make_If_Expression
(Loc
,
9560 Expressions
=> New_List
(
9562 New_Occurrence_Of
(Tnn
, Loc
),
9563 Make_If_Expression
(Loc
,
9565 Expressions
=> New_List
(
9567 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9568 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9569 Make_Integer_Literal
(Loc
, 0),
9571 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9573 Duplicate_Subexpr_No_Checks
(Right
)))))));
9575 Analyze_And_Resolve
(N
, Typ
);
9580 -- Deal with annoying case of largest negative number mod minus one.
9581 -- Gigi may not handle this case correctly, because on some targets,
9582 -- the mod value is computed using a divide instruction which gives
9583 -- an overflow trap for this case.
9585 -- It would be a bit more efficient to figure out which targets
9586 -- this is really needed for, but in practice it is reasonable
9587 -- to do the following special check in all cases, since it means
9588 -- we get a clearer message, and also the overhead is minimal given
9589 -- that division is expensive in any case.
9591 -- In fact the check is quite easy, if the right operand is -1, then
9592 -- the mod value is always 0, and we can just ignore the left operand
9593 -- completely in this case.
9595 -- This only applies if we still have a mod operator. Skip if we
9596 -- have already rewritten this (e.g. in the case of eliminated
9597 -- overflow checks which have driven us into bignum mode).
9599 if Nkind
(N
) = N_Op_Mod
then
9601 -- The operand type may be private (e.g. in the expansion of an
9602 -- intrinsic operation) so we must use the underlying type to get
9603 -- the bounds, and convert the literals explicitly.
9607 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
9609 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
9610 and then ((not LOK
) or else (Llo
= LLB
))
9613 Make_If_Expression
(Loc
,
9614 Expressions
=> New_List
(
9616 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9618 Unchecked_Convert_To
(Typ
,
9619 Make_Integer_Literal
(Loc
, -1))),
9620 Unchecked_Convert_To
(Typ
,
9621 Make_Integer_Literal
(Loc
, Uint_0
)),
9622 Relocate_Node
(N
))));
9624 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9625 Analyze_And_Resolve
(N
, Typ
);
9629 end Expand_N_Op_Mod
;
9631 --------------------------
9632 -- Expand_N_Op_Multiply --
9633 --------------------------
9635 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
9636 Loc
: constant Source_Ptr
:= Sloc
(N
);
9637 Lop
: constant Node_Id
:= Left_Opnd
(N
);
9638 Rop
: constant Node_Id
:= Right_Opnd
(N
);
9640 Lp2
: constant Boolean :=
9641 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
9642 Rp2
: constant Boolean :=
9643 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
9645 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
9646 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
9647 Typ
: Entity_Id
:= Etype
(N
);
9650 Binary_Op_Validity_Checks
(N
);
9652 -- Check for MINIMIZED/ELIMINATED overflow mode
9654 if Minimized_Eliminated_Overflow_Check
(N
) then
9655 Apply_Arithmetic_Overflow_Check
(N
);
9659 -- Special optimizations for integer types
9661 if Is_Integer_Type
(Typ
) then
9663 -- N * 0 = 0 for integer types
9665 if Compile_Time_Known_Value
(Rop
)
9666 and then Expr_Value
(Rop
) = Uint_0
9668 -- Call Remove_Side_Effects to ensure that any side effects in
9669 -- the ignored left operand (in particular function calls to
9670 -- user defined functions) are properly executed.
9672 Remove_Side_Effects
(Lop
);
9674 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9675 Analyze_And_Resolve
(N
, Typ
);
9679 -- Similar handling for 0 * N = 0
9681 if Compile_Time_Known_Value
(Lop
)
9682 and then Expr_Value
(Lop
) = Uint_0
9684 Remove_Side_Effects
(Rop
);
9685 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9686 Analyze_And_Resolve
(N
, Typ
);
9690 -- N * 1 = 1 * N = N for integer types
9692 -- This optimisation is not done if we are going to
9693 -- rewrite the product 1 * 2 ** N to a shift.
9695 if Compile_Time_Known_Value
(Rop
)
9696 and then Expr_Value
(Rop
) = Uint_1
9702 elsif Compile_Time_Known_Value
(Lop
)
9703 and then Expr_Value
(Lop
) = Uint_1
9711 -- Try to narrow the operation
9713 if Typ
= Universal_Integer
then
9714 Narrow_Large_Operation
(N
);
9716 if Nkind
(N
) /= N_Op_Multiply
then
9721 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9722 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9723 -- operand is an integer, as required for this to work.
9728 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9732 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
9735 Left_Opnd
=> Right_Opnd
(Lop
),
9736 Right_Opnd
=> Right_Opnd
(Rop
))));
9737 Analyze_And_Resolve
(N
, Typ
);
9741 -- If the result is modular, perform the reduction of the result
9744 if Is_Modular_Integer_Type
(Typ
)
9745 and then not Non_Binary_Modulus
(Typ
)
9750 Make_Op_Shift_Left
(Loc
,
9753 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
9755 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9759 Make_Op_Shift_Left
(Loc
,
9762 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
9765 Analyze_And_Resolve
(N
, Typ
);
9769 -- Same processing for the operands the other way round
9772 if Is_Modular_Integer_Type
(Typ
)
9773 and then not Non_Binary_Modulus
(Typ
)
9778 Make_Op_Shift_Left
(Loc
,
9781 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
9783 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9787 Make_Op_Shift_Left
(Loc
,
9790 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
9793 Analyze_And_Resolve
(N
, Typ
);
9797 -- Do required fixup of universal fixed operation
9799 if Typ
= Universal_Fixed
then
9800 Fixup_Universal_Fixed_Operation
(N
);
9804 -- Multiplications with fixed-point results
9806 if Is_Fixed_Point_Type
(Typ
) then
9808 -- Case of fixed * integer => fixed
9810 if Is_Integer_Type
(Rtyp
) then
9811 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
9813 -- Case of integer * fixed => fixed
9815 elsif Is_Integer_Type
(Ltyp
) then
9816 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
9818 -- Case of fixed * fixed => fixed
9821 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
9824 -- Other cases of multiplication of fixed-point operands
9826 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
9827 if Is_Integer_Type
(Typ
) then
9828 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
9830 pragma Assert
(Is_Floating_Point_Type
(Typ
));
9831 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
9834 -- Mixed-mode operations can appear in a non-static universal context,
9835 -- in which case the integer argument must be converted explicitly.
9837 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
9838 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
9839 Analyze_And_Resolve
(Rop
, Universal_Real
);
9841 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
9842 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
9843 Analyze_And_Resolve
(Lop
, Universal_Real
);
9845 -- Non-fixed point cases, check software overflow checking required
9847 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
9848 Apply_Arithmetic_Overflow_Check
(N
);
9851 -- Overflow checks for floating-point if -gnateF mode active
9853 Check_Float_Op_Overflow
(N
);
9855 Expand_Nonbinary_Modular_Op
(N
);
9856 end Expand_N_Op_Multiply
;
9858 --------------------
9859 -- Expand_N_Op_Ne --
9860 --------------------
9862 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
9863 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
9866 -- Case of elementary type with standard operator. But if unnesting,
9867 -- handle elementary types whose Equivalent_Types are records because
9868 -- there may be padding or undefined fields.
9870 if Is_Elementary_Type
(Typ
)
9871 and then Sloc
(Entity
(N
)) = Standard_Location
9872 and then not (Ekind
(Typ
) in E_Class_Wide_Type
9873 | E_Class_Wide_Subtype
9874 | E_Access_Subprogram_Type
9875 | E_Access_Protected_Subprogram_Type
9876 | E_Anonymous_Access_Protected_Subprogram_Type
9878 and then Present
(Equivalent_Type
(Typ
))
9879 and then Is_Record_Type
(Equivalent_Type
(Typ
)))
9881 Binary_Op_Validity_Checks
(N
);
9883 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9884 -- means we no longer have a /= operation, we are all done.
9886 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9888 if Nkind
(N
) /= N_Op_Ne
then
9892 -- Boolean types (requiring handling of non-standard case)
9894 if Is_Boolean_Type
(Typ
) then
9895 Adjust_Condition
(Left_Opnd
(N
));
9896 Adjust_Condition
(Right_Opnd
(N
));
9897 Set_Etype
(N
, Standard_Boolean
);
9898 Adjust_Result_Type
(N
, Typ
);
9901 Rewrite_Comparison
(N
);
9903 -- Try to narrow the operation
9905 if Typ
= Universal_Integer
and then Nkind
(N
) = N_Op_Ne
then
9906 Narrow_Large_Operation
(N
);
9909 -- For all cases other than elementary types, we rewrite node as the
9910 -- negation of an equality operation, and reanalyze. The equality to be
9911 -- used is defined in the same scope and has the same signature. This
9912 -- signature must be set explicitly since in an instance it may not have
9913 -- the same visibility as in the generic unit. This avoids duplicating
9914 -- or factoring the complex code for record/array equality tests etc.
9916 -- This case is also used for the minimal expansion performed in
9921 Loc
: constant Source_Ptr
:= Sloc
(N
);
9923 Ne
: constant Entity_Id
:= Entity
(N
);
9926 Binary_Op_Validity_Checks
(N
);
9932 Left_Opnd
=> Left_Opnd
(N
),
9933 Right_Opnd
=> Right_Opnd
(N
)));
9935 -- The level of parentheses is useless in GNATprove mode, and
9936 -- bumping its level here leads to wrong columns being used in
9937 -- check messages, hence skip it in this mode.
9939 if not GNATprove_Mode
then
9940 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
9943 if Scope
(Ne
) /= Standard_Standard
then
9944 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
9947 -- For navigation purposes, we want to treat the inequality as an
9948 -- implicit reference to the corresponding equality. Preserve the
9949 -- Comes_From_ source flag to generate proper Xref entries.
9951 Preserve_Comes_From_Source
(Neg
, N
);
9952 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
9954 Analyze_And_Resolve
(N
, Standard_Boolean
);
9958 -- No need for optimization in GNATprove mode, where we would rather see
9959 -- the original source expression.
9961 if not GNATprove_Mode
then
9962 Optimize_Length_Comparison
(N
);
9966 ---------------------
9967 -- Expand_N_Op_Not --
9968 ---------------------
9970 -- If the argument is other than a Boolean array type, there is no special
9971 -- expansion required, except for dealing with validity checks, and non-
9972 -- standard boolean representations.
9974 -- For the packed array case, we call the special routine in Exp_Pakd,
9975 -- except that if the component size is greater than one, we use the
9976 -- standard routine generating a gruesome loop (it is so peculiar to have
9977 -- packed arrays with non-standard Boolean representations anyway, so it
9978 -- does not matter that we do not handle this case efficiently).
9980 -- For the unpacked array case (and for the special packed case where we
9981 -- have non standard Booleans, as discussed above), we generate and insert
9982 -- into the tree the following function definition:
9984 -- function Nnnn (A : arr) is
9987 -- for J in a'range loop
9988 -- B (J) := not A (J);
9993 -- Here arr is the actual subtype of the parameter (and hence always
9994 -- constrained). Then we replace the not with a call to this function.
9996 procedure Expand_N_Op_Not
(N
: Node_Id
) is
9997 Loc
: constant Source_Ptr
:= Sloc
(N
);
9998 Typ
: constant Entity_Id
:= Etype
(N
);
10007 Func_Name
: Entity_Id
;
10008 Loop_Statement
: Node_Id
;
10011 Unary_Op_Validity_Checks
(N
);
10013 -- For boolean operand, deal with non-standard booleans
10015 if Is_Boolean_Type
(Typ
) then
10016 Adjust_Condition
(Right_Opnd
(N
));
10017 Set_Etype
(N
, Standard_Boolean
);
10018 Adjust_Result_Type
(N
, Typ
);
10022 -- Only array types need any other processing
10024 if not Is_Array_Type
(Typ
) then
10028 -- Case of array operand. If bit packed with a component size of 1,
10029 -- handle it in Exp_Pakd if the operand is known to be aligned.
10031 if Is_Bit_Packed_Array
(Typ
)
10032 and then Component_Size
(Typ
) = 1
10033 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
10035 Expand_Packed_Not
(N
);
10039 -- Case of array operand which is not bit-packed. If the context is
10040 -- a safe assignment, call in-place operation, If context is a larger
10041 -- boolean expression in the context of a safe assignment, expansion is
10042 -- done by enclosing operation.
10044 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
10045 Convert_To_Actual_Subtype
(Opnd
);
10046 Arr
:= Etype
(Opnd
);
10047 Ensure_Defined
(Arr
, N
);
10048 Silly_Boolean_Array_Not_Test
(N
, Arr
);
10050 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
10051 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
10052 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
10055 -- Special case the negation of a binary operation
10057 elsif Nkind
(Opnd
) in N_Op_And | N_Op_Or | N_Op_Xor
10058 and then Safe_In_Place_Array_Op
10059 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
10061 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
10065 elsif Nkind
(Parent
(N
)) in N_Binary_Op
10066 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
10069 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
10070 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
10071 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
10074 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
10076 -- (not A) op (not B) can be reduced to a single call
10078 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
10081 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
10084 -- A xor (not B) can also be special-cased
10086 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
10093 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
10094 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
10095 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
10098 Make_Indexed_Component
(Loc
,
10099 Prefix
=> New_Occurrence_Of
(A
, Loc
),
10100 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
10103 Make_Indexed_Component
(Loc
,
10104 Prefix
=> New_Occurrence_Of
(B
, Loc
),
10105 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
10108 Make_Implicit_Loop_Statement
(N
,
10109 Identifier
=> Empty
,
10111 Iteration_Scheme
=>
10112 Make_Iteration_Scheme
(Loc
,
10113 Loop_Parameter_Specification
=>
10114 Make_Loop_Parameter_Specification
(Loc
,
10115 Defining_Identifier
=> J
,
10116 Discrete_Subtype_Definition
=>
10117 Make_Attribute_Reference
(Loc
,
10118 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
10119 Attribute_Name
=> Name_Range
))),
10121 Statements
=> New_List
(
10122 Make_Assignment_Statement
(Loc
,
10124 Expression
=> Make_Op_Not
(Loc
, A_J
))));
10126 Func_Name
:= Make_Temporary
(Loc
, 'N');
10127 Set_Is_Inlined
(Func_Name
);
10130 Make_Subprogram_Body
(Loc
,
10132 Make_Function_Specification
(Loc
,
10133 Defining_Unit_Name
=> Func_Name
,
10134 Parameter_Specifications
=> New_List
(
10135 Make_Parameter_Specification
(Loc
,
10136 Defining_Identifier
=> A
,
10137 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
10138 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
10140 Declarations
=> New_List
(
10141 Make_Object_Declaration
(Loc
,
10142 Defining_Identifier
=> B
,
10143 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
10145 Handled_Statement_Sequence
=>
10146 Make_Handled_Sequence_Of_Statements
(Loc
,
10147 Statements
=> New_List
(
10149 Make_Simple_Return_Statement
(Loc
,
10150 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
10153 Make_Function_Call
(Loc
,
10154 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
10155 Parameter_Associations
=> New_List
(Opnd
)));
10157 Analyze_And_Resolve
(N
, Typ
);
10158 end Expand_N_Op_Not
;
10160 --------------------
10161 -- Expand_N_Op_Or --
10162 --------------------
10164 procedure Expand_N_Op_Or
(N
: Node_Id
) is
10165 Typ
: constant Entity_Id
:= Etype
(N
);
10168 Binary_Op_Validity_Checks
(N
);
10170 if Is_Array_Type
(Etype
(N
)) then
10171 Expand_Boolean_Operator
(N
);
10173 elsif Is_Boolean_Type
(Etype
(N
)) then
10174 Adjust_Condition
(Left_Opnd
(N
));
10175 Adjust_Condition
(Right_Opnd
(N
));
10176 Set_Etype
(N
, Standard_Boolean
);
10177 Adjust_Result_Type
(N
, Typ
);
10179 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10180 Expand_Intrinsic_Call
(N
, Entity
(N
));
10183 Expand_Nonbinary_Modular_Op
(N
);
10184 end Expand_N_Op_Or
;
10186 ----------------------
10187 -- Expand_N_Op_Plus --
10188 ----------------------
10190 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
10191 Typ
: constant Entity_Id
:= Etype
(N
);
10194 Unary_Op_Validity_Checks
(N
);
10196 -- Check for MINIMIZED/ELIMINATED overflow mode
10198 if Minimized_Eliminated_Overflow_Check
(N
) then
10199 Apply_Arithmetic_Overflow_Check
(N
);
10203 -- Try to narrow the operation
10205 if Typ
= Universal_Integer
then
10206 Narrow_Large_Operation
(N
);
10208 end Expand_N_Op_Plus
;
10210 ---------------------
10211 -- Expand_N_Op_Rem --
10212 ---------------------
10214 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
10215 Loc
: constant Source_Ptr
:= Sloc
(N
);
10216 Typ
: constant Entity_Id
:= Etype
(N
);
10227 -- Set if corresponding operand can be negative
10229 pragma Unreferenced
(Hi
);
10232 Binary_Op_Validity_Checks
(N
);
10234 -- Check for MINIMIZED/ELIMINATED overflow mode
10236 if Minimized_Eliminated_Overflow_Check
(N
) then
10237 Apply_Arithmetic_Overflow_Check
(N
);
10241 -- Try to narrow the operation
10243 if Typ
= Universal_Integer
then
10244 Narrow_Large_Operation
(N
);
10246 if Nkind
(N
) /= N_Op_Rem
then
10251 if Is_Integer_Type
(Etype
(N
)) then
10252 Apply_Divide_Checks
(N
);
10254 -- All done if we don't have a REM any more, which can happen as a
10255 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
10257 if Nkind
(N
) /= N_Op_Rem
then
10262 -- Proceed with expansion of REM
10264 Left
:= Left_Opnd
(N
);
10265 Right
:= Right_Opnd
(N
);
10267 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
10268 -- but it is useful with other back ends, and is certainly harmless.
10270 if Is_Integer_Type
(Etype
(N
))
10271 and then Compile_Time_Known_Value
(Right
)
10272 and then Expr_Value
(Right
) = Uint_1
10274 -- Call Remove_Side_Effects to ensure that any side effects in the
10275 -- ignored left operand (in particular function calls to user defined
10276 -- functions) are properly executed.
10278 Remove_Side_Effects
(Left
);
10280 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10281 Analyze_And_Resolve
(N
, Typ
);
10285 -- Deal with annoying case of largest negative number remainder minus
10286 -- one. Gigi may not handle this case correctly, because on some
10287 -- targets, the mod value is computed using a divide instruction
10288 -- which gives an overflow trap for this case.
10290 -- It would be a bit more efficient to figure out which targets this
10291 -- is really needed for, but in practice it is reasonable to do the
10292 -- following special check in all cases, since it means we get a clearer
10293 -- message, and also the overhead is minimal given that division is
10294 -- expensive in any case.
10296 -- In fact the check is quite easy, if the right operand is -1, then
10297 -- the remainder is always 0, and we can just ignore the left operand
10298 -- completely in this case.
10300 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10301 Lneg
:= (not OK
) or else Lo
< 0;
10303 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10304 Rneg
:= (not OK
) or else Lo
< 0;
10306 -- We won't mess with trying to find out if the left operand can really
10307 -- be the largest negative number (that's a pain in the case of private
10308 -- types and this is really marginal). We will just assume that we need
10309 -- the test if the left operand can be negative at all.
10311 if Lneg
and Rneg
then
10313 Make_If_Expression
(Loc
,
10314 Expressions
=> New_List
(
10316 Left_Opnd
=> Duplicate_Subexpr
(Right
),
10318 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
10320 Unchecked_Convert_To
(Typ
,
10321 Make_Integer_Literal
(Loc
, Uint_0
)),
10323 Relocate_Node
(N
))));
10325 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
10326 Analyze_And_Resolve
(N
, Typ
);
10328 end Expand_N_Op_Rem
;
10330 -----------------------------
10331 -- Expand_N_Op_Rotate_Left --
10332 -----------------------------
10334 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
10336 Binary_Op_Validity_Checks
(N
);
10338 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10339 -- so we rewrite in terms of logical shifts
10341 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10343 -- where Bits is the shift count mod Esize (the mod operation here
10344 -- deals with ludicrous large shift counts, which are apparently OK).
10346 if Modify_Tree_For_C
then
10348 Loc
: constant Source_Ptr
:= Sloc
(N
);
10349 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10350 Typ
: constant Entity_Id
:= Etype
(N
);
10353 -- Sem_Intr should prevent getting there with a non binary modulus
10355 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10357 Rewrite
(Right_Opnd
(N
),
10359 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10360 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10362 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10367 Make_Op_Shift_Left
(Loc
,
10368 Left_Opnd
=> Left_Opnd
(N
),
10369 Right_Opnd
=> Right_Opnd
(N
)),
10372 Make_Op_Shift_Right
(Loc
,
10373 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10375 Make_Op_Subtract
(Loc
,
10376 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10378 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10380 Analyze_And_Resolve
(N
, Typ
);
10383 end Expand_N_Op_Rotate_Left
;
10385 ------------------------------
10386 -- Expand_N_Op_Rotate_Right --
10387 ------------------------------
10389 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
10391 Binary_Op_Validity_Checks
(N
);
10393 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10394 -- so we rewrite in terms of logical shifts
10396 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10398 -- where Bits is the shift count mod Esize (the mod operation here
10399 -- deals with ludicrous large shift counts, which are apparently OK).
10401 if Modify_Tree_For_C
then
10403 Loc
: constant Source_Ptr
:= Sloc
(N
);
10404 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10405 Typ
: constant Entity_Id
:= Etype
(N
);
10408 -- Sem_Intr should prevent getting there with a non binary modulus
10410 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10412 Rewrite
(Right_Opnd
(N
),
10414 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10415 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10417 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10422 Make_Op_Shift_Right
(Loc
,
10423 Left_Opnd
=> Left_Opnd
(N
),
10424 Right_Opnd
=> Right_Opnd
(N
)),
10427 Make_Op_Shift_Left
(Loc
,
10428 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10430 Make_Op_Subtract
(Loc
,
10431 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10433 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10435 Analyze_And_Resolve
(N
, Typ
);
10438 end Expand_N_Op_Rotate_Right
;
10440 ----------------------------
10441 -- Expand_N_Op_Shift_Left --
10442 ----------------------------
10444 -- Note: nothing in this routine depends on left as opposed to right shifts
10445 -- so we share the routine for expanding shift right operations.
10447 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
10449 Binary_Op_Validity_Checks
(N
);
10451 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10452 -- operand is not greater than the word size (since that would not
10453 -- be defined properly by the corresponding C shift operator).
10455 if Modify_Tree_For_C
then
10457 Right
: constant Node_Id
:= Right_Opnd
(N
);
10458 Loc
: constant Source_Ptr
:= Sloc
(Right
);
10459 Typ
: constant Entity_Id
:= Etype
(N
);
10460 Siz
: constant Uint
:= Esize
(Typ
);
10467 -- Sem_Intr should prevent getting there with a non binary modulus
10469 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10471 if Compile_Time_Known_Value
(Right
) then
10472 if Expr_Value
(Right
) >= Siz
then
10473 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10474 Analyze_And_Resolve
(N
, Typ
);
10477 -- Not compile time known, find range
10480 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10482 -- Nothing to do if known to be OK range, otherwise expand
10484 if not OK
or else Hi
>= Siz
then
10486 -- Prevent recursion on copy of shift node
10488 Orig
:= Relocate_Node
(N
);
10489 Set_Analyzed
(Orig
);
10491 -- Now do the rewrite
10494 Make_If_Expression
(Loc
,
10495 Expressions
=> New_List
(
10497 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
10498 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
10499 Make_Integer_Literal
(Loc
, 0),
10501 Analyze_And_Resolve
(N
, Typ
);
10506 end Expand_N_Op_Shift_Left
;
10508 -----------------------------
10509 -- Expand_N_Op_Shift_Right --
10510 -----------------------------
10512 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
10514 -- Share shift left circuit
10516 Expand_N_Op_Shift_Left
(N
);
10517 end Expand_N_Op_Shift_Right
;
10519 ----------------------------------------
10520 -- Expand_N_Op_Shift_Right_Arithmetic --
10521 ----------------------------------------
10523 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
10525 Binary_Op_Validity_Checks
(N
);
10527 -- If we are in Modify_Tree_For_C mode, there is no shift right
10528 -- arithmetic in C, so we rewrite in terms of logical shifts for
10529 -- modular integers, and keep the Shift_Right intrinsic for signed
10530 -- integers: even though doing a shift on a signed integer is not
10531 -- fully guaranteed by the C standard, this is what C compilers
10532 -- implement in practice.
10533 -- Consider also taking advantage of this for modular integers by first
10534 -- performing an unchecked conversion of the modular integer to a signed
10535 -- integer of the same sign, and then convert back.
10537 -- Shift_Right (Num, Bits) or
10539 -- then not (Shift_Right (Mask, bits))
10542 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10544 -- Note: the above works fine for shift counts greater than or equal
10545 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10546 -- generates all 1'bits.
10548 if Modify_Tree_For_C
and then Is_Modular_Integer_Type
(Etype
(N
)) then
10550 Loc
: constant Source_Ptr
:= Sloc
(N
);
10551 Typ
: constant Entity_Id
:= Etype
(N
);
10552 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
10553 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
10554 Left
: constant Node_Id
:= Left_Opnd
(N
);
10555 Right
: constant Node_Id
:= Right_Opnd
(N
);
10559 -- Sem_Intr should prevent getting there with a non binary modulus
10561 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10563 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10564 -- compile time as a single constant.
10566 if Compile_Time_Known_Value
(Right
) then
10568 Val
: constant Uint
:= Expr_Value
(Right
);
10571 if Val
>= Esize
(Typ
) then
10572 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
10576 Make_Integer_Literal
(Loc
,
10577 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
10585 Make_Op_Shift_Right
(Loc
,
10586 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
10587 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
10590 -- Now do the rewrite
10595 Make_Op_Shift_Right
(Loc
,
10597 Right_Opnd
=> Right
),
10599 Make_If_Expression
(Loc
,
10600 Expressions
=> New_List
(
10602 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
10603 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
10605 Make_Integer_Literal
(Loc
, 0)))));
10606 Analyze_And_Resolve
(N
, Typ
);
10609 end Expand_N_Op_Shift_Right_Arithmetic
;
10611 --------------------------
10612 -- Expand_N_Op_Subtract --
10613 --------------------------
10615 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
10616 Typ
: constant Entity_Id
:= Etype
(N
);
10619 Binary_Op_Validity_Checks
(N
);
10621 -- Check for MINIMIZED/ELIMINATED overflow mode
10623 if Minimized_Eliminated_Overflow_Check
(N
) then
10624 Apply_Arithmetic_Overflow_Check
(N
);
10628 -- Try to narrow the operation
10630 if Typ
= Universal_Integer
then
10631 Narrow_Large_Operation
(N
);
10633 if Nkind
(N
) /= N_Op_Subtract
then
10638 -- N - 0 = N for integer types
10640 if Is_Integer_Type
(Typ
)
10641 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
10642 and then Expr_Value
(Right_Opnd
(N
)) = 0
10644 Rewrite
(N
, Left_Opnd
(N
));
10648 -- Arithmetic overflow checks for signed integer/fixed point types
10650 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
10651 Apply_Arithmetic_Overflow_Check
(N
);
10654 -- Overflow checks for floating-point if -gnateF mode active
10656 Check_Float_Op_Overflow
(N
);
10658 Expand_Nonbinary_Modular_Op
(N
);
10659 end Expand_N_Op_Subtract
;
10661 ---------------------
10662 -- Expand_N_Op_Xor --
10663 ---------------------
10665 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
10666 Typ
: constant Entity_Id
:= Etype
(N
);
10669 Binary_Op_Validity_Checks
(N
);
10671 if Is_Array_Type
(Etype
(N
)) then
10672 Expand_Boolean_Operator
(N
);
10674 elsif Is_Boolean_Type
(Etype
(N
)) then
10675 Adjust_Condition
(Left_Opnd
(N
));
10676 Adjust_Condition
(Right_Opnd
(N
));
10677 Set_Etype
(N
, Standard_Boolean
);
10678 Adjust_Result_Type
(N
, Typ
);
10680 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10681 Expand_Intrinsic_Call
(N
, Entity
(N
));
10684 Expand_Nonbinary_Modular_Op
(N
);
10685 end Expand_N_Op_Xor
;
10687 ----------------------
10688 -- Expand_N_Or_Else --
10689 ----------------------
10691 procedure Expand_N_Or_Else
(N
: Node_Id
)
10692 renames Expand_Short_Circuit_Operator
;
10694 -----------------------------------
10695 -- Expand_N_Qualified_Expression --
10696 -----------------------------------
10698 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
10699 Operand
: constant Node_Id
:= Expression
(N
);
10700 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
10703 -- Do validity check if validity checking operands
10705 if Validity_Checks_On
and Validity_Check_Operands
then
10706 Ensure_Valid
(Operand
);
10709 -- Apply possible constraint check
10711 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
10713 -- Apply possible predicate check
10715 Apply_Predicate_Check
(Operand
, Target_Type
);
10717 if Do_Range_Check
(Operand
) then
10718 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
10720 end Expand_N_Qualified_Expression
;
10722 ------------------------------------
10723 -- Expand_N_Quantified_Expression --
10724 ------------------------------------
10728 -- for all X in range => Cond
10733 -- for X in range loop
10734 -- if not Cond then
10740 -- Similarly, an existentially quantified expression:
10742 -- for some X in range => Cond
10747 -- for X in range loop
10754 -- In both cases, the iteration may be over a container in which case it is
10755 -- given by an iterator specification, not a loop parameter specification.
10757 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
10758 Actions
: constant List_Id
:= New_List
;
10759 For_All
: constant Boolean := All_Present
(N
);
10760 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
10761 Loc
: constant Source_Ptr
:= Sloc
(N
);
10762 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
10770 -- Ensure that the bound variable is properly frozen. We must do
10771 -- this before expansion because the expression is about to be
10772 -- converted into a loop, and resulting freeze nodes may end up
10773 -- in the wrong place in the tree.
10775 if Present
(Iter_Spec
) then
10776 Var
:= Defining_Identifier
(Iter_Spec
);
10778 Var
:= Defining_Identifier
(Loop_Spec
);
10782 P
: Node_Id
:= Parent
(N
);
10784 while Nkind
(P
) in N_Subexpr
loop
10788 Freeze_Before
(P
, Etype
(Var
));
10791 -- Create the declaration of the flag which tracks the status of the
10792 -- quantified expression. Generate:
10794 -- Flag : Boolean := (True | False);
10796 Flag
:= Make_Temporary
(Loc
, 'T', N
);
10798 Append_To
(Actions
,
10799 Make_Object_Declaration
(Loc
,
10800 Defining_Identifier
=> Flag
,
10801 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
10803 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
10805 -- Construct the circuitry which tracks the status of the quantified
10806 -- expression. Generate:
10808 -- if [not] Cond then
10809 -- Flag := (False | True);
10813 Cond
:= Relocate_Node
(Condition
(N
));
10816 Cond
:= Make_Op_Not
(Loc
, Cond
);
10819 Stmts
:= New_List
(
10820 Make_Implicit_If_Statement
(N
,
10822 Then_Statements
=> New_List
(
10823 Make_Assignment_Statement
(Loc
,
10824 Name
=> New_Occurrence_Of
(Flag
, Loc
),
10826 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
10827 Make_Exit_Statement
(Loc
))));
10829 -- Build the loop equivalent of the quantified expression
10831 if Present
(Iter_Spec
) then
10833 Make_Iteration_Scheme
(Loc
,
10834 Iterator_Specification
=> Iter_Spec
);
10837 Make_Iteration_Scheme
(Loc
,
10838 Loop_Parameter_Specification
=> Loop_Spec
);
10841 Append_To
(Actions
,
10842 Make_Loop_Statement
(Loc
,
10843 Iteration_Scheme
=> Scheme
,
10844 Statements
=> Stmts
,
10845 End_Label
=> Empty
));
10847 -- Transform the quantified expression
10850 Make_Expression_With_Actions
(Loc
,
10851 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
10852 Actions
=> Actions
));
10853 Analyze_And_Resolve
(N
, Standard_Boolean
);
10854 end Expand_N_Quantified_Expression
;
10856 ---------------------------------
10857 -- Expand_N_Selected_Component --
10858 ---------------------------------
10860 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
10861 Loc
: constant Source_Ptr
:= Sloc
(N
);
10862 Par
: constant Node_Id
:= Parent
(N
);
10863 P
: constant Node_Id
:= Prefix
(N
);
10864 S
: constant Node_Id
:= Selector_Name
(N
);
10865 Ptyp
: constant Entity_Id
:= Underlying_Type
(Etype
(P
));
10871 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
10872 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10873 -- unless the context of an assignment can provide size information.
10874 -- Don't we have a general routine that does this???
10876 function Is_Subtype_Declaration
return Boolean;
10877 -- The replacement of a discriminant reference by its value is required
10878 -- if this is part of the initialization of an temporary generated by a
10879 -- change of representation. This shows up as the construction of a
10880 -- discriminant constraint for a subtype declared at the same point as
10881 -- the entity in the prefix of the selected component. We recognize this
10882 -- case when the context of the reference is:
10883 -- subtype ST is T(Obj.D);
10884 -- where the entity for Obj comes from source, and ST has the same sloc.
10886 -----------------------
10887 -- In_Left_Hand_Side --
10888 -----------------------
10890 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
10892 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
10893 and then Comp
= Name
(Parent
(Comp
)))
10894 or else (Present
(Parent
(Comp
))
10895 and then Nkind
(Parent
(Comp
)) in N_Subexpr
10896 and then In_Left_Hand_Side
(Parent
(Comp
)));
10897 end In_Left_Hand_Side
;
10899 -----------------------------
10900 -- Is_Subtype_Declaration --
10901 -----------------------------
10903 function Is_Subtype_Declaration
return Boolean is
10904 Par
: constant Node_Id
:= Parent
(N
);
10907 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
10908 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
10909 and then Comes_From_Source
(Entity
(Prefix
(N
)))
10910 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
10911 end Is_Subtype_Declaration
;
10913 -- Start of processing for Expand_N_Selected_Component
10916 -- Deal with discriminant check required
10918 if Do_Discriminant_Check
(N
) then
10919 if Present
(Discriminant_Checking_Func
10920 (Original_Record_Component
(Entity
(S
))))
10922 -- Present the discriminant checking function to the backend, so
10923 -- that it can inline the call to the function.
10926 (Discriminant_Checking_Func
10927 (Original_Record_Component
(Entity
(S
))),
10930 -- Now reset the flag and generate the call
10932 Set_Do_Discriminant_Check
(N
, False);
10933 Generate_Discriminant_Check
(N
);
10935 -- In the case of Unchecked_Union, no discriminant checking is
10936 -- actually performed.
10939 Set_Do_Discriminant_Check
(N
, False);
10943 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10944 -- function, then additional actuals must be passed.
10946 if Is_Build_In_Place_Function_Call
(P
) then
10947 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
10949 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10950 -- containing build-in-place function calls whose returned object covers
10951 -- interface types.
10953 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
10954 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
10957 -- Gigi cannot handle unchecked conversions that are the prefix of a
10958 -- selected component with discriminants. This must be checked during
10959 -- expansion, because during analysis the type of the selector is not
10960 -- known at the point the prefix is analyzed. If the conversion is the
10961 -- target of an assignment, then we cannot force the evaluation.
10963 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
10964 and then Has_Discriminants
(Etype
(N
))
10965 and then not In_Left_Hand_Side
(N
)
10967 Force_Evaluation
(Prefix
(N
));
10970 -- Remaining processing applies only if selector is a discriminant
10972 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
10974 -- If the selector is a discriminant of a constrained record type,
10975 -- we may be able to rewrite the expression with the actual value
10976 -- of the discriminant, a useful optimization in some cases.
10978 if Is_Record_Type
(Ptyp
)
10979 and then Has_Discriminants
(Ptyp
)
10980 and then Is_Constrained
(Ptyp
)
10982 -- Do this optimization for discrete types only, and not for
10983 -- access types (access discriminants get us into trouble).
10985 if not Is_Discrete_Type
(Etype
(N
)) then
10988 -- Don't do this on the left-hand side of an assignment statement.
10989 -- Normally one would think that references like this would not
10990 -- occur, but they do in generated code, and mean that we really
10991 -- do want to assign the discriminant.
10993 elsif Nkind
(Par
) = N_Assignment_Statement
10994 and then Name
(Par
) = N
10998 -- Don't do this optimization for the prefix of an attribute or
10999 -- the name of an object renaming declaration since these are
11000 -- contexts where we do not want the value anyway.
11002 elsif (Nkind
(Par
) = N_Attribute_Reference
11003 and then Prefix
(Par
) = N
)
11004 or else Is_Renamed_Object
(N
)
11008 -- Don't do this optimization if we are within the code for a
11009 -- discriminant check, since the whole point of such a check may
11010 -- be to verify the condition on which the code below depends.
11012 elsif Is_In_Discriminant_Check
(N
) then
11015 -- Green light to see if we can do the optimization. There is
11016 -- still one condition that inhibits the optimization below but
11017 -- now is the time to check the particular discriminant.
11020 -- Loop through discriminants to find the matching discriminant
11021 -- constraint to see if we can copy it.
11023 Disc
:= First_Discriminant
(Ptyp
);
11024 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
11025 Discr_Loop
: while Present
(Dcon
) loop
11026 Dval
:= Node
(Dcon
);
11028 -- Check if this is the matching discriminant and if the
11029 -- discriminant value is simple enough to make sense to
11030 -- copy. We don't want to copy complex expressions, and
11031 -- indeed to do so can cause trouble (before we put in
11032 -- this guard, a discriminant expression containing an
11033 -- AND THEN was copied, causing problems for coverage
11034 -- analysis tools).
11036 -- However, if the reference is part of the initialization
11037 -- code generated for an object declaration, we must use
11038 -- the discriminant value from the subtype constraint,
11039 -- because the selected component may be a reference to the
11040 -- object being initialized, whose discriminant is not yet
11041 -- set. This only happens in complex cases involving changes
11042 -- or representation.
11044 if Disc
= Entity
(Selector_Name
(N
))
11045 and then (Is_Entity_Name
(Dval
)
11046 or else Compile_Time_Known_Value
(Dval
)
11047 or else Is_Subtype_Declaration
)
11049 -- Here we have the matching discriminant. Check for
11050 -- the case of a discriminant of a component that is
11051 -- constrained by an outer discriminant, which cannot
11052 -- be optimized away.
11054 if Denotes_Discriminant
11055 (Dval
, Check_Concurrent
=> True)
11059 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
11061 Denotes_Discriminant
11062 (Selector_Name
(Original_Node
(Dval
)), True)
11066 -- Do not retrieve value if constraint is not static. It
11067 -- is generally not useful, and the constraint may be a
11068 -- rewritten outer discriminant in which case it is in
11071 elsif Is_Entity_Name
(Dval
)
11073 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
11074 and then Present
(Expression
(Parent
(Entity
(Dval
))))
11076 Is_OK_Static_Expression
11077 (Expression
(Parent
(Entity
(Dval
))))
11081 -- In the context of a case statement, the expression may
11082 -- have the base type of the discriminant, and we need to
11083 -- preserve the constraint to avoid spurious errors on
11086 elsif Nkind
(Parent
(N
)) = N_Case_Statement
11087 and then Etype
(Dval
) /= Etype
(Disc
)
11090 Make_Qualified_Expression
(Loc
,
11092 New_Occurrence_Of
(Etype
(Disc
), Loc
),
11094 New_Copy_Tree
(Dval
)));
11095 Analyze_And_Resolve
(N
, Etype
(Disc
));
11097 -- In case that comes out as a static expression,
11098 -- reset it (a selected component is never static).
11100 Set_Is_Static_Expression
(N
, False);
11103 -- Otherwise we can just copy the constraint, but the
11104 -- result is certainly not static. In some cases the
11105 -- discriminant constraint has been analyzed in the
11106 -- context of the original subtype indication, but for
11107 -- itypes the constraint might not have been analyzed
11108 -- yet, and this must be done now.
11111 Rewrite
(N
, New_Copy_Tree
(Dval
));
11112 Analyze_And_Resolve
(N
);
11113 Set_Is_Static_Expression
(N
, False);
11119 Next_Discriminant
(Disc
);
11120 end loop Discr_Loop
;
11122 -- Note: the above loop should always find a matching
11123 -- discriminant, but if it does not, we just missed an
11124 -- optimization due to some glitch (perhaps a previous
11125 -- error), so ignore.
11130 -- The only remaining processing is in the case of a discriminant of
11131 -- a concurrent object, where we rewrite the prefix to denote the
11132 -- corresponding record type. If the type is derived and has renamed
11133 -- discriminants, use corresponding discriminant, which is the one
11134 -- that appears in the corresponding record.
11136 if not Is_Concurrent_Type
(Ptyp
) then
11140 Disc
:= Entity
(Selector_Name
(N
));
11142 if Is_Derived_Type
(Ptyp
)
11143 and then Present
(Corresponding_Discriminant
(Disc
))
11145 Disc
:= Corresponding_Discriminant
(Disc
);
11149 Make_Selected_Component
(Loc
,
11151 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
11152 New_Copy_Tree
(P
)),
11153 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
11155 Rewrite
(N
, New_N
);
11159 -- Set Atomic_Sync_Required if necessary for atomic component
11161 if Nkind
(N
) = N_Selected_Component
then
11163 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
11167 -- If component is atomic, but type is not, setting depends on
11168 -- disable/enable state for the component.
11170 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
11171 Set
:= not Atomic_Synchronization_Disabled
(E
);
11173 -- If component is not atomic, but its type is atomic, setting
11174 -- depends on disable/enable state for the type.
11176 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
11177 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
11179 -- If both component and type are atomic, we disable if either
11180 -- component or its type have sync disabled.
11182 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
11183 Set
:= (not Atomic_Synchronization_Disabled
(E
))
11185 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
11191 -- Set flag if required
11194 Activate_Atomic_Synchronization
(N
);
11198 end Expand_N_Selected_Component
;
11200 --------------------
11201 -- Expand_N_Slice --
11202 --------------------
11204 procedure Expand_N_Slice
(N
: Node_Id
) is
11205 Loc
: constant Source_Ptr
:= Sloc
(N
);
11206 Typ
: constant Entity_Id
:= Etype
(N
);
11208 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
11209 -- Check whether the argument is an actual for a procedure call, in
11210 -- which case the expansion of a bit-packed slice is deferred until the
11211 -- call itself is expanded. The reason this is required is that we might
11212 -- have an IN OUT or OUT parameter, and the copy out is essential, and
11213 -- that copy out would be missed if we created a temporary here in
11214 -- Expand_N_Slice. Note that we don't bother to test specifically for an
11215 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
11216 -- is harmless to defer expansion in the IN case, since the call
11217 -- processing will still generate the appropriate copy in operation,
11218 -- which will take care of the slice.
11220 procedure Make_Temporary_For_Slice
;
11221 -- Create a named variable for the value of the slice, in cases where
11222 -- the back end cannot handle it properly, e.g. when packed types or
11223 -- unaligned slices are involved.
11225 -------------------------
11226 -- Is_Procedure_Actual --
11227 -------------------------
11229 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
11230 Par
: Node_Id
:= Parent
(N
);
11234 -- If our parent is a procedure call we can return
11236 if Nkind
(Par
) = N_Procedure_Call_Statement
then
11239 -- If our parent is a type conversion, keep climbing the tree,
11240 -- since a type conversion can be a procedure actual. Also keep
11241 -- climbing if parameter association or a qualified expression,
11242 -- since these are additional cases that do can appear on
11243 -- procedure actuals.
11245 elsif Nkind
(Par
) in N_Type_Conversion
11246 | N_Parameter_Association
11247 | N_Qualified_Expression
11249 Par
:= Parent
(Par
);
11251 -- Any other case is not what we are looking for
11257 end Is_Procedure_Actual
;
11259 ------------------------------
11260 -- Make_Temporary_For_Slice --
11261 ------------------------------
11263 procedure Make_Temporary_For_Slice
is
11264 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
11269 Make_Object_Declaration
(Loc
,
11270 Defining_Identifier
=> Ent
,
11271 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
11273 Set_No_Initialization
(Decl
);
11275 Insert_Actions
(N
, New_List
(
11277 Make_Assignment_Statement
(Loc
,
11278 Name
=> New_Occurrence_Of
(Ent
, Loc
),
11279 Expression
=> Relocate_Node
(N
))));
11281 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
11282 Analyze_And_Resolve
(N
, Typ
);
11283 end Make_Temporary_For_Slice
;
11287 Pref
: constant Node_Id
:= Prefix
(N
);
11289 -- Start of processing for Expand_N_Slice
11292 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11293 -- function, then additional actuals must be passed.
11295 if Is_Build_In_Place_Function_Call
(Pref
) then
11296 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
11298 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11299 -- containing build-in-place function calls whose returned object covers
11300 -- interface types.
11302 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
11303 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
11306 -- The remaining case to be handled is packed slices. We can leave
11307 -- packed slices as they are in the following situations:
11309 -- 1. Right or left side of an assignment (we can handle this
11310 -- situation correctly in the assignment statement expansion).
11312 -- 2. Prefix of indexed component (the slide is optimized away in this
11313 -- case, see the start of Expand_N_Slice.)
11315 -- 3. Object renaming declaration, since we want the name of the
11316 -- slice, not the value.
11318 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11319 -- be required, and this is handled in the expansion of call
11322 -- 5. Prefix of an address attribute (this is an error which is caught
11323 -- elsewhere, and the expansion would interfere with generating the
11324 -- error message) or of a size attribute (because 'Size may change
11325 -- when applied to the temporary instead of the slice directly).
11327 if not Is_Packed
(Typ
) then
11329 -- Apply transformation for actuals of a function call, where
11330 -- Expand_Actuals is not used.
11332 if Nkind
(Parent
(N
)) = N_Function_Call
11333 and then Is_Possibly_Unaligned_Slice
(N
)
11335 Make_Temporary_For_Slice
;
11338 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
11339 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
11340 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
11344 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
11345 or else Is_Renamed_Object
(N
)
11346 or else Is_Procedure_Actual
(N
)
11350 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
11351 and then (Attribute_Name
(Parent
(N
)) = Name_Address
11352 or else Attribute_Name
(Parent
(N
)) = Name_Size
)
11357 Make_Temporary_For_Slice
;
11359 end Expand_N_Slice
;
11361 ------------------------------
11362 -- Expand_N_Type_Conversion --
11363 ------------------------------
11365 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
11366 Loc
: constant Source_Ptr
:= Sloc
(N
);
11367 Operand
: constant Node_Id
:= Expression
(N
);
11368 Operand_Acc
: Node_Id
:= Operand
;
11369 Target_Type
: Entity_Id
:= Etype
(N
);
11370 Operand_Type
: Entity_Id
:= Etype
(Operand
);
11372 procedure Discrete_Range_Check
;
11373 -- Handles generation of range check for discrete target value
11375 procedure Handle_Changed_Representation
;
11376 -- This is called in the case of record and array type conversions to
11377 -- see if there is a change of representation to be handled. Change of
11378 -- representation is actually handled at the assignment statement level,
11379 -- and what this procedure does is rewrite node N conversion as an
11380 -- assignment to temporary. If there is no change of representation,
11381 -- then the conversion node is unchanged.
11383 procedure Raise_Accessibility_Error
;
11384 -- Called when we know that an accessibility check will fail. Rewrites
11385 -- node N to an appropriate raise statement and outputs warning msgs.
11386 -- The Etype of the raise node is set to Target_Type. Note that in this
11387 -- case the rest of the processing should be skipped (i.e. the call to
11388 -- this procedure will be followed by "goto Done").
11390 procedure Real_Range_Check
;
11391 -- Handles generation of range check for real target value
11393 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
11394 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11395 -- evaluates to True.
11397 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
11399 -- Given a target type for a conversion, determine whether the
11400 -- statically deeper accessibility rules apply to it.
11402 --------------------------
11403 -- Discrete_Range_Check --
11404 --------------------------
11406 -- Case of conversions to a discrete type. We let Generate_Range_Check
11407 -- do the heavy lifting, after converting a fixed-point operand to an
11408 -- appropriate integer type.
11410 procedure Discrete_Range_Check
is
11414 procedure Generate_Temporary
;
11415 -- Generate a temporary to facilitate in the C backend the code
11416 -- generation of the unchecked conversion since the size of the
11417 -- source type may differ from the size of the target type.
11419 ------------------------
11420 -- Generate_Temporary --
11421 ------------------------
11423 procedure Generate_Temporary
is
11425 if Esize
(Etype
(Expr
)) < Esize
(Etype
(Ityp
)) then
11427 Exp_Type
: constant Entity_Id
:= Ityp
;
11428 Def_Id
: constant Entity_Id
:=
11429 Make_Temporary
(Loc
, 'R', Expr
);
11434 Set_Is_Internal
(Def_Id
);
11435 Set_Etype
(Def_Id
, Exp_Type
);
11436 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
11439 Make_Object_Declaration
(Loc
,
11440 Defining_Identifier
=> Def_Id
,
11441 Object_Definition
=> New_Occurrence_Of
11443 Constant_Present
=> True,
11444 Expression
=> Relocate_Node
(Expr
));
11446 Set_Assignment_OK
(E
);
11447 Insert_Action
(Expr
, E
);
11449 Set_Assignment_OK
(Res
, Assignment_OK
(Expr
));
11451 Rewrite
(Expr
, Res
);
11452 Analyze_And_Resolve
(Expr
, Exp_Type
);
11455 end Generate_Temporary
;
11457 -- Start of processing for Discrete_Range_Check
11460 -- Clear the Do_Range_Check flag on N if needed: this can occur when
11461 -- e.g. a trivial type conversion is rewritten by its expression.
11463 Set_Do_Range_Check
(N
, False);
11465 -- Nothing more to do if conversion was rewritten
11467 if Nkind
(N
) /= N_Type_Conversion
then
11471 Expr
:= Expression
(N
);
11473 -- Nothing to do if no range check flag set
11475 if not Do_Range_Check
(Expr
) then
11479 -- Clear the Do_Range_Check flag on Expr
11481 Set_Do_Range_Check
(Expr
, False);
11483 -- Nothing to do if range checks suppressed
11485 if Range_Checks_Suppressed
(Target_Type
) then
11489 -- Nothing to do if expression is an entity on which checks have been
11492 if Is_Entity_Name
(Expr
)
11493 and then Range_Checks_Suppressed
(Entity
(Expr
))
11498 -- Before we do a range check, we have to deal with treating
11499 -- a fixed-point operand as an integer. The way we do this
11500 -- is simply to do an unchecked conversion to an appropriate
11501 -- integer type with the smallest size, so that we can suppress
11504 if Is_Fixed_Point_Type
(Etype
(Expr
)) then
11505 Ityp
:= Small_Integer_Type_For
11506 (Esize
(Base_Type
(Etype
(Expr
))), False);
11508 -- Generate a temporary with the integer type to facilitate in the
11509 -- C backend the code generation for the unchecked conversion.
11511 if Modify_Tree_For_C
then
11512 Generate_Temporary
;
11515 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11518 -- Reset overflow flag, since the range check will include
11519 -- dealing with possible overflow, and generate the check.
11521 Set_Do_Overflow_Check
(N
, False);
11523 Generate_Range_Check
(Expr
, Target_Type
, CE_Range_Check_Failed
);
11524 end Discrete_Range_Check
;
11526 -----------------------------------
11527 -- Handle_Changed_Representation --
11528 -----------------------------------
11530 procedure Handle_Changed_Representation
is
11538 -- Nothing else to do if no change of representation
11540 if Has_Compatible_Representation
(Target_Type
, Operand_Type
) then
11543 -- The real change of representation work is done by the assignment
11544 -- statement processing. So if this type conversion is appearing as
11545 -- the expression of an assignment statement, nothing needs to be
11546 -- done to the conversion.
11548 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
11551 -- Otherwise we need to generate a temporary variable, and do the
11552 -- change of representation assignment into that temporary variable.
11553 -- The conversion is then replaced by a reference to this variable.
11558 -- If type is unconstrained we have to add a constraint, copied
11559 -- from the actual value of the left-hand side.
11561 if not Is_Constrained
(Target_Type
) then
11562 if Has_Discriminants
(Operand_Type
) then
11564 -- A change of representation can only apply to untagged
11565 -- types. We need to build the constraint that applies to
11566 -- the target type, using the constraints of the operand.
11567 -- The analysis is complicated if there are both inherited
11568 -- discriminants and constrained discriminants.
11569 -- We iterate over the discriminants of the target, and
11570 -- find the discriminant of the same name:
11572 -- a) If there is a corresponding discriminant in the object
11573 -- then the value is a selected component of the operand.
11575 -- b) Otherwise the value of a constrained discriminant is
11576 -- found in the stored constraint of the operand.
11579 Stored
: constant Elist_Id
:=
11580 Stored_Constraint
(Operand_Type
);
11584 Disc_O
: Entity_Id
;
11585 -- Discriminant of the operand type. Its value in the
11586 -- object is captured in a selected component.
11588 Disc_S
: Entity_Id
;
11589 -- Stored discriminant of the operand. If present, it
11590 -- corresponds to a constrained discriminant of the
11593 Disc_T
: Entity_Id
;
11594 -- Discriminant of the target type
11597 Disc_T
:= First_Discriminant
(Target_Type
);
11598 Disc_O
:= First_Discriminant
(Operand_Type
);
11599 Disc_S
:= First_Stored_Discriminant
(Operand_Type
);
11601 if Present
(Stored
) then
11602 Elmt
:= First_Elmt
(Stored
);
11604 Elmt
:= No_Elmt
; -- init to avoid warning
11608 while Present
(Disc_T
) loop
11609 if Present
(Disc_O
)
11610 and then Chars
(Disc_T
) = Chars
(Disc_O
)
11613 Make_Selected_Component
(Loc
,
11615 Duplicate_Subexpr_Move_Checks
(Operand
),
11617 Make_Identifier
(Loc
, Chars
(Disc_O
))));
11618 Next_Discriminant
(Disc_O
);
11620 elsif Present
(Disc_S
) then
11621 Append_To
(Cons
, New_Copy_Tree
(Node
(Elmt
)));
11625 Next_Discriminant
(Disc_T
);
11629 elsif Is_Array_Type
(Operand_Type
) then
11630 N_Ix
:= First_Index
(Target_Type
);
11633 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
11635 -- We convert the bounds explicitly. We use an unchecked
11636 -- conversion because bounds checks are done elsewhere.
11641 Unchecked_Convert_To
(Etype
(N_Ix
),
11642 Make_Attribute_Reference
(Loc
,
11644 Duplicate_Subexpr_No_Checks
11645 (Operand
, Name_Req
=> True),
11646 Attribute_Name
=> Name_First
,
11647 Expressions
=> New_List
(
11648 Make_Integer_Literal
(Loc
, J
)))),
11651 Unchecked_Convert_To
(Etype
(N_Ix
),
11652 Make_Attribute_Reference
(Loc
,
11654 Duplicate_Subexpr_No_Checks
11655 (Operand
, Name_Req
=> True),
11656 Attribute_Name
=> Name_Last
,
11657 Expressions
=> New_List
(
11658 Make_Integer_Literal
(Loc
, J
))))));
11665 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
11667 if Present
(Cons
) then
11669 Make_Subtype_Indication
(Loc
,
11670 Subtype_Mark
=> Odef
,
11672 Make_Index_Or_Discriminant_Constraint
(Loc
,
11673 Constraints
=> Cons
));
11676 Temp
:= Make_Temporary
(Loc
, 'C');
11678 Make_Object_Declaration
(Loc
,
11679 Defining_Identifier
=> Temp
,
11680 Object_Definition
=> Odef
);
11682 Set_No_Initialization
(Decl
, True);
11684 -- Insert required actions. It is essential to suppress checks
11685 -- since we have suppressed default initialization, which means
11686 -- that the variable we create may have no discriminants.
11691 Make_Assignment_Statement
(Loc
,
11692 Name
=> New_Occurrence_Of
(Temp
, Loc
),
11693 Expression
=> Relocate_Node
(N
))),
11694 Suppress
=> All_Checks
);
11696 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
11699 end Handle_Changed_Representation
;
11701 -------------------------------
11702 -- Raise_Accessibility_Error --
11703 -------------------------------
11705 procedure Raise_Accessibility_Error
is
11707 Error_Msg_Warn
:= SPARK_Mode
/= On
;
11709 Make_Raise_Program_Error
(Sloc
(N
),
11710 Reason
=> PE_Accessibility_Check_Failed
));
11711 Set_Etype
(N
, Target_Type
);
11713 Error_Msg_N
("<<accessibility check failure", N
);
11714 Error_Msg_NE
("\<<& [", N
, Standard_Program_Error
);
11715 end Raise_Accessibility_Error
;
11717 ----------------------
11718 -- Real_Range_Check --
11719 ----------------------
11721 -- Case of conversions to floating-point or fixed-point. If range checks
11722 -- are enabled and the target type has a range constraint, we convert:
11728 -- Tnn : typ'Base := typ'Base (x);
11729 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11732 -- This is necessary when there is a conversion of integer to float or
11733 -- to fixed-point to ensure that the correct checks are made. It is not
11734 -- necessary for the float-to-float case where it is enough to just set
11735 -- the Do_Range_Check flag on the expression.
11737 procedure Real_Range_Check
is
11738 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
11739 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
11740 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
11751 -- Clear the Do_Range_Check flag on N if needed: this can occur when
11752 -- e.g. a trivial type conversion is rewritten by its expression.
11754 Set_Do_Range_Check
(N
, False);
11756 -- Nothing more to do if conversion was rewritten
11758 if Nkind
(N
) /= N_Type_Conversion
then
11762 Expr
:= Expression
(N
);
11764 -- Clear the Do_Range_Check flag on Expr
11766 Set_Do_Range_Check
(Expr
, False);
11768 -- Nothing to do if range checks suppressed, or target has the same
11769 -- range as the base type (or is the base type).
11771 if Range_Checks_Suppressed
(Target_Type
)
11772 or else (Lo
= Type_Low_Bound
(Btyp
)
11774 Hi
= Type_High_Bound
(Btyp
))
11779 -- Nothing to do if expression is an entity on which checks have been
11782 if Is_Entity_Name
(Expr
)
11783 and then Range_Checks_Suppressed
(Entity
(Expr
))
11788 -- Nothing to do if expression was rewritten into a float-to-float
11789 -- conversion, since this kind of conversion is handled elsewhere.
11791 if Is_Floating_Point_Type
(Etype
(Expr
))
11792 and then Is_Floating_Point_Type
(Target_Type
)
11797 -- Nothing to do if bounds are all static and we can tell that the
11798 -- expression is within the bounds of the target. Note that if the
11799 -- operand is of an unconstrained floating-point type, then we do
11800 -- not trust it to be in range (might be infinite)
11803 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Expr
));
11804 S_Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Expr
));
11807 if (not Is_Floating_Point_Type
(Etype
(Expr
))
11808 or else Is_Constrained
(Etype
(Expr
)))
11809 and then Compile_Time_Known_Value
(S_Lo
)
11810 and then Compile_Time_Known_Value
(S_Hi
)
11811 and then Compile_Time_Known_Value
(Hi
)
11812 and then Compile_Time_Known_Value
(Lo
)
11815 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
11816 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
11821 if Is_Real_Type
(Etype
(Expr
)) then
11822 S_Lov
:= Expr_Value_R
(S_Lo
);
11823 S_Hiv
:= Expr_Value_R
(S_Hi
);
11825 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
11826 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
11830 and then S_Lov
>= D_Lov
11831 and then S_Hiv
<= D_Hiv
11839 -- Otherwise rewrite the conversion as described above
11841 Conv
:= Convert_To
(Btyp
, Expr
);
11843 -- If a conversion is necessary, then copy the specific flags from
11844 -- the original one and also move the Do_Overflow_Check flag since
11845 -- this new conversion is to the base type.
11847 if Nkind
(Conv
) = N_Type_Conversion
then
11848 Set_Conversion_OK
(Conv
, Conversion_OK
(N
));
11849 Set_Float_Truncate
(Conv
, Float_Truncate
(N
));
11850 Set_Rounded_Result
(Conv
, Rounded_Result
(N
));
11852 if Do_Overflow_Check
(N
) then
11853 Set_Do_Overflow_Check
(Conv
);
11854 Set_Do_Overflow_Check
(N
, False);
11858 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
11860 -- For a conversion from Float to Fixed where the bounds of the
11861 -- fixed-point type are static, we can obtain a more accurate
11862 -- fixed-point value by converting the result of the floating-
11863 -- point expression to an appropriate integer type, and then
11864 -- performing an unchecked conversion to the target fixed-point
11865 -- type. The range check can then use the corresponding integer
11866 -- value of the bounds instead of requiring further conversions.
11867 -- This preserves the identity:
11869 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11871 -- which used to fail when Fix_Val was a bound of the type and
11872 -- the 'Small was not a representable number.
11873 -- This transformation requires an integer type large enough to
11874 -- accommodate a fixed-point value. This will not be the case
11875 -- in systems where Duration is larger than Long_Integer.
11877 if Is_Ordinary_Fixed_Point_Type
(Target_Type
)
11878 and then Is_Floating_Point_Type
(Etype
(Expr
))
11879 and then RM_Size
(Btyp
) <= RM_Size
(Standard_Long_Integer
)
11880 and then Nkind
(Lo
) = N_Real_Literal
11881 and then Nkind
(Hi
) = N_Real_Literal
11884 Expr_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Conv
);
11885 Int_Type
: Entity_Id
;
11888 -- Find an integer type of the appropriate size to perform an
11889 -- unchecked conversion to the target fixed-point type.
11891 if RM_Size
(Btyp
) > RM_Size
(Standard_Integer
) then
11892 Int_Type
:= Standard_Long_Integer
;
11894 elsif RM_Size
(Btyp
) > RM_Size
(Standard_Short_Integer
) then
11895 Int_Type
:= Standard_Integer
;
11898 Int_Type
:= Standard_Short_Integer
;
11901 -- Generate a temporary with the integer value. Required in the
11902 -- CCG compiler to ensure that run-time checks reference this
11903 -- integer expression (instead of the resulting fixed-point
11904 -- value because fixed-point values are handled by means of
11905 -- unsigned integer types).
11908 Make_Object_Declaration
(Loc
,
11909 Defining_Identifier
=> Expr_Id
,
11910 Object_Definition
=> New_Occurrence_Of
(Int_Type
, Loc
),
11911 Constant_Present
=> True,
11913 Convert_To
(Int_Type
, Expression
(Conv
))));
11915 -- Create integer objects for range checking of result.
11918 Unchecked_Convert_To
11919 (Int_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11922 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Lo
));
11925 Unchecked_Convert_To
11926 (Int_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11929 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Hi
));
11931 -- Rewrite conversion as an integer conversion of the
11932 -- original floating-point expression, followed by an
11933 -- unchecked conversion to the target fixed-point type.
11936 Make_Unchecked_Type_Conversion
(Loc
,
11937 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
11938 Expression
=> New_Occurrence_Of
(Expr_Id
, Loc
));
11941 -- All other conversions
11944 Lo_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11946 Make_Attribute_Reference
(Loc
,
11947 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11948 Attribute_Name
=> Name_First
);
11950 Hi_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11952 Make_Attribute_Reference
(Loc
,
11953 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11954 Attribute_Name
=> Name_Last
);
11957 -- Build code for range checking. Note that checks are suppressed
11958 -- here since we don't want a recursive range check popping up.
11960 Insert_Actions
(N
, New_List
(
11961 Make_Object_Declaration
(Loc
,
11962 Defining_Identifier
=> Tnn
,
11963 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
11964 Constant_Present
=> True,
11965 Expression
=> Conv
),
11967 Make_Raise_Constraint_Error
(Loc
,
11972 Left_Opnd
=> Lo_Arg
,
11973 Right_Opnd
=> Lo_Val
),
11977 Left_Opnd
=> Hi_Arg
,
11978 Right_Opnd
=> Hi_Val
)),
11979 Reason
=> CE_Range_Check_Failed
)),
11980 Suppress
=> All_Checks
);
11982 Rewrite
(Expr
, New_Occurrence_Of
(Tnn
, Loc
));
11983 end Real_Range_Check
;
11985 -----------------------------
11986 -- Has_Extra_Accessibility --
11987 -----------------------------
11989 -- Returns true for a formal of an anonymous access type or for an Ada
11990 -- 2012-style stand-alone object of an anonymous access type.
11992 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
11994 if Is_Formal
(Id
) or else Ekind
(Id
) in E_Constant | E_Variable
then
11995 return Present
(Effective_Extra_Accessibility
(Id
));
11999 end Has_Extra_Accessibility
;
12001 ----------------------------------------
12002 -- Statically_Deeper_Relation_Applies --
12003 ----------------------------------------
12005 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
12009 -- The case where the target type is an anonymous access type is
12010 -- ignored since they have different semantics and get covered by
12011 -- various runtime checks depending on context.
12013 -- Note, the current implementation of this predicate is incomplete
12014 -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
12017 return Ekind
(Targ_Typ
) /= E_Anonymous_Access_Type
;
12018 end Statically_Deeper_Relation_Applies
;
12020 -- Start of processing for Expand_N_Type_Conversion
12023 -- First remove check marks put by the semantic analysis on the type
12024 -- conversion between array types. We need these checks, and they will
12025 -- be generated by this expansion routine, but we do not depend on these
12026 -- flags being set, and since we do intend to expand the checks in the
12027 -- front end, we don't want them on the tree passed to the back end.
12029 if Is_Array_Type
(Target_Type
) then
12030 if Is_Constrained
(Target_Type
) then
12031 Set_Do_Length_Check
(N
, False);
12033 Set_Do_Range_Check
(Operand
, False);
12037 -- Nothing at all to do if conversion is to the identical type so remove
12038 -- the conversion completely, it is useless, except that it may carry
12039 -- an Assignment_OK attribute, which must be propagated to the operand
12040 -- and the Do_Range_Check flag on Operand should be taken into account.
12042 if Operand_Type
= Target_Type
then
12043 if Assignment_OK
(N
) then
12044 Set_Assignment_OK
(Operand
);
12047 Rewrite
(N
, Relocate_Node
(Operand
));
12049 if Do_Range_Check
(Operand
) then
12050 pragma Assert
(Is_Discrete_Type
(Operand_Type
));
12052 Discrete_Range_Check
;
12058 -- Nothing to do if this is the second argument of read. This is a
12059 -- "backwards" conversion that will be handled by the specialized code
12060 -- in attribute processing.
12062 if Nkind
(Parent
(N
)) = N_Attribute_Reference
12063 and then Attribute_Name
(Parent
(N
)) = Name_Read
12064 and then Next
(First
(Expressions
(Parent
(N
)))) = N
12069 -- Check for case of converting to a type that has an invariant
12070 -- associated with it. This requires an invariant check. We insert
12073 -- invariant_check (typ (expr))
12075 -- in the code, after removing side effects from the expression.
12076 -- This is clearer than replacing the conversion into an expression
12077 -- with actions, because the context may impose additional actions
12078 -- (tag checks, membership tests, etc.) that conflict with this
12079 -- rewriting (used previously).
12081 -- Note: the Comes_From_Source check, and then the resetting of this
12082 -- flag prevents what would otherwise be an infinite recursion.
12084 if Has_Invariants
(Target_Type
)
12085 and then Present
(Invariant_Procedure
(Target_Type
))
12086 and then Comes_From_Source
(N
)
12088 Set_Comes_From_Source
(N
, False);
12089 Remove_Side_Effects
(N
);
12090 Insert_Action
(N
, Make_Invariant_Call
(Duplicate_Subexpr
(N
)));
12093 -- AI12-0042: For a view conversion to a class-wide type occurring
12094 -- within the immediate scope of T, from a specific type that is
12095 -- a descendant of T (including T itself), an invariant check is
12096 -- performed on the part of the object that is of type T. (We don't
12097 -- need to explicitly check for the operand type being a descendant,
12098 -- just that it's a specific type, because the conversion would be
12099 -- illegal if it's specific and not a descendant -- downward conversion
12100 -- is not allowed).
12102 elsif Is_Class_Wide_Type
(Target_Type
)
12103 and then not Is_Class_Wide_Type
(Etype
(Expression
(N
)))
12104 and then Present
(Invariant_Procedure
(Root_Type
(Target_Type
)))
12105 and then Comes_From_Source
(N
)
12106 and then Within_Scope
(Find_Enclosing_Scope
(N
), Scope
(Target_Type
))
12108 Remove_Side_Effects
(N
);
12110 -- Perform the invariant check on a conversion to the class-wide
12111 -- type's root type.
12114 Root_Conv
: constant Node_Id
:=
12115 Make_Type_Conversion
(Loc
,
12117 New_Occurrence_Of
(Root_Type
(Target_Type
), Loc
),
12118 Expression
=> Duplicate_Subexpr
(Expression
(N
)));
12120 Set_Etype
(Root_Conv
, Root_Type
(Target_Type
));
12122 Insert_Action
(N
, Make_Invariant_Call
(Root_Conv
));
12127 -- Here if we may need to expand conversion
12129 -- If the operand of the type conversion is an arithmetic operation on
12130 -- signed integers, and the based type of the signed integer type in
12131 -- question is smaller than Standard.Integer, we promote both of the
12132 -- operands to type Integer.
12134 -- For example, if we have
12136 -- target-type (opnd1 + opnd2)
12138 -- and opnd1 and opnd2 are of type short integer, then we rewrite
12141 -- target-type (integer(opnd1) + integer(opnd2))
12143 -- We do this because we are always allowed to compute in a larger type
12144 -- if we do the right thing with the result, and in this case we are
12145 -- going to do a conversion which will do an appropriate check to make
12146 -- sure that things are in range of the target type in any case. This
12147 -- avoids some unnecessary intermediate overflows.
12149 -- We might consider a similar transformation in the case where the
12150 -- target is a real type or a 64-bit integer type, and the operand
12151 -- is an arithmetic operation using a 32-bit integer type. However,
12152 -- we do not bother with this case, because it could cause significant
12153 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
12154 -- much cheaper, but we don't want different behavior on 32-bit and
12155 -- 64-bit machines. Note that the exclusion of the 64-bit case also
12156 -- handles the configurable run-time cases where 64-bit arithmetic
12157 -- may simply be unavailable.
12159 -- Note: this circuit is partially redundant with respect to the circuit
12160 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
12161 -- the processing here. Also we still need the Checks circuit, since we
12162 -- have to be sure not to generate junk overflow checks in the first
12163 -- place, since it would be tricky to remove them here.
12165 if Integer_Promotion_Possible
(N
) then
12167 -- All conditions met, go ahead with transformation
12174 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
12176 R
:= Convert_To
(Standard_Integer
, Right_Opnd
(Operand
));
12177 Set_Right_Opnd
(Opnd
, R
);
12179 if Nkind
(Operand
) in N_Binary_Op
then
12180 L
:= Convert_To
(Standard_Integer
, Left_Opnd
(Operand
));
12181 Set_Left_Opnd
(Opnd
, L
);
12185 Make_Type_Conversion
(Loc
,
12186 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
12187 Expression
=> Opnd
));
12189 Analyze_And_Resolve
(N
, Target_Type
);
12194 -- Do validity check if validity checking operands
12196 if Validity_Checks_On
and Validity_Check_Operands
then
12197 Ensure_Valid
(Operand
);
12200 -- Special case of converting from non-standard boolean type
12202 if Is_Boolean_Type
(Operand_Type
)
12203 and then (Nonzero_Is_True
(Operand_Type
))
12205 Adjust_Condition
(Operand
);
12206 Set_Etype
(Operand
, Standard_Boolean
);
12207 Operand_Type
:= Standard_Boolean
;
12210 -- Case of converting to an access type
12212 if Is_Access_Type
(Target_Type
) then
12213 -- In terms of accessibility rules, an anonymous access discriminant
12214 -- is not considered separate from its parent object.
12216 if Nkind
(Operand
) = N_Selected_Component
12217 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
12218 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
12220 Operand_Acc
:= Original_Node
(Prefix
(Operand
));
12223 -- If this type conversion was internally generated by the front end
12224 -- to displace the pointer to the object to reference an interface
12225 -- type and the original node was an Unrestricted_Access attribute,
12226 -- then skip applying accessibility checks (because, according to the
12227 -- GNAT Reference Manual, this attribute is similar to 'Access except
12228 -- that all accessibility and aliased view checks are omitted).
12230 if not Comes_From_Source
(N
)
12231 and then Is_Interface
(Designated_Type
(Target_Type
))
12232 and then Nkind
(Original_Node
(N
)) = N_Attribute_Reference
12233 and then Attribute_Name
(Original_Node
(N
)) =
12234 Name_Unrestricted_Access
12238 -- Apply an accessibility check when the conversion operand is an
12239 -- access parameter (or a renaming thereof), unless conversion was
12240 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
12241 -- or for the actual of a class-wide interface parameter. Note that
12242 -- other checks may still need to be applied below (such as tagged
12245 elsif Is_Entity_Name
(Operand_Acc
)
12246 and then Has_Extra_Accessibility
(Entity
(Operand_Acc
))
12247 and then Ekind
(Etype
(Operand_Acc
)) = E_Anonymous_Access_Type
12248 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
12249 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
12251 if not Comes_From_Source
(N
)
12252 and then Nkind
(Parent
(N
)) in N_Function_Call
12253 | N_Parameter_Association
12254 | N_Procedure_Call_Statement
12255 and then Is_Interface
(Designated_Type
(Target_Type
))
12256 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
12261 Apply_Accessibility_Check
12262 (Operand_Acc
, Target_Type
, Insert_Node
=> Operand
);
12265 -- If the level of the operand type is statically deeper than the
12266 -- level of the target type, then force Program_Error. Note that this
12267 -- can only occur for cases where the attribute is within the body of
12268 -- an instantiation, otherwise the conversion will already have been
12269 -- rejected as illegal.
12271 -- Note: warnings are issued by the analyzer for the instance cases
12273 elsif In_Instance_Body
12274 and then Statically_Deeper_Relation_Applies
(Target_Type
)
12276 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
12278 Raise_Accessibility_Error
;
12281 -- When the operand is a selected access discriminant the check needs
12282 -- to be made against the level of the object denoted by the prefix
12283 -- of the selected name. Force Program_Error for this case as well
12284 -- (this accessibility violation can only happen if within the body
12285 -- of an instantiation).
12287 elsif In_Instance_Body
12288 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
12289 and then Nkind
(Operand
) = N_Selected_Component
12290 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
12291 and then Static_Accessibility_Level
(Operand
, Zero_On_Dynamic_Level
)
12292 > Type_Access_Level
(Target_Type
)
12294 Raise_Accessibility_Error
;
12299 -- Case of conversions of tagged types and access to tagged types
12301 -- When needed, that is to say when the expression is class-wide, Add
12302 -- runtime a tag check for (strict) downward conversion by using the
12303 -- membership test, generating:
12305 -- [constraint_error when Operand not in Target_Type'Class]
12307 -- or in the access type case
12309 -- [constraint_error
12310 -- when Operand /= null
12311 -- and then Operand.all not in
12312 -- Designated_Type (Target_Type)'Class]
12314 if (Is_Access_Type
(Target_Type
)
12315 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
12316 or else Is_Tagged_Type
(Target_Type
)
12318 -- Do not do any expansion in the access type case if the parent is a
12319 -- renaming, since this is an error situation which will be caught by
12320 -- Sem_Ch8, and the expansion can interfere with this error check.
12322 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
12326 -- Otherwise, proceed with processing tagged conversion
12328 Tagged_Conversion
: declare
12329 Actual_Op_Typ
: Entity_Id
;
12330 Actual_Targ_Typ
: Entity_Id
;
12331 Root_Op_Typ
: Entity_Id
;
12333 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
12334 -- Create a membership check to test whether Operand is a member
12335 -- of Targ_Typ. If the original Target_Type is an access, include
12336 -- a test for null value. The check is inserted at N.
12338 --------------------
12339 -- Make_Tag_Check --
12340 --------------------
12342 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
12347 -- [Constraint_Error
12348 -- when Operand /= null
12349 -- and then Operand.all not in Targ_Typ]
12351 if Is_Access_Type
(Target_Type
) then
12353 Make_And_Then
(Loc
,
12356 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12357 Right_Opnd
=> Make_Null
(Loc
)),
12362 Make_Explicit_Dereference
(Loc
,
12363 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
12364 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
12367 -- [Constraint_Error when Operand not in Targ_Typ]
12372 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12373 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
12377 Make_Raise_Constraint_Error
(Loc
,
12379 Reason
=> CE_Tag_Check_Failed
),
12380 Suppress
=> All_Checks
);
12381 end Make_Tag_Check
;
12383 -- Start of processing for Tagged_Conversion
12386 -- Handle entities from the limited view
12388 if Is_Access_Type
(Operand_Type
) then
12390 Available_View
(Designated_Type
(Operand_Type
));
12392 Actual_Op_Typ
:= Operand_Type
;
12395 if Is_Access_Type
(Target_Type
) then
12397 Available_View
(Designated_Type
(Target_Type
));
12399 Actual_Targ_Typ
:= Target_Type
;
12402 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
12404 -- Ada 2005 (AI-251): Handle interface type conversion
12406 if Is_Interface
(Actual_Op_Typ
)
12408 Is_Interface
(Actual_Targ_Typ
)
12410 Expand_Interface_Conversion
(N
);
12414 -- Create a runtime tag check for a downward CW type conversion
12416 if Is_Class_Wide_Type
(Actual_Op_Typ
)
12417 and then Actual_Op_Typ
/= Actual_Targ_Typ
12418 and then Root_Op_Typ
/= Actual_Targ_Typ
12419 and then Is_Ancestor
12420 (Root_Op_Typ
, Actual_Targ_Typ
, Use_Full_View
=> True)
12421 and then not Tag_Checks_Suppressed
(Actual_Targ_Typ
)
12426 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
12428 Make_Unchecked_Type_Conversion
(Loc
,
12429 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
12430 Expression
=> Relocate_Node
(Expression
(N
)));
12432 Analyze_And_Resolve
(N
, Target_Type
);
12435 end Tagged_Conversion
;
12437 -- Case of other access type conversions
12439 elsif Is_Access_Type
(Target_Type
) then
12440 Apply_Constraint_Check
(Operand
, Target_Type
);
12442 -- Case of conversions from a fixed-point type
12444 -- These conversions require special expansion and processing, found in
12445 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12446 -- since from a semantic point of view, these are simple integer
12447 -- conversions, which do not need further processing except for the
12448 -- generation of range checks, which is performed at the end of this
12451 elsif Is_Fixed_Point_Type
(Operand_Type
)
12452 and then not Conversion_OK
(N
)
12454 -- We should never see universal fixed at this case, since the
12455 -- expansion of the constituent divide or multiply should have
12456 -- eliminated the explicit mention of universal fixed.
12458 pragma Assert
(Operand_Type
/= Universal_Fixed
);
12460 -- Check for special case of the conversion to universal real that
12461 -- occurs as a result of the use of a round attribute. In this case,
12462 -- the real type for the conversion is taken from the target type of
12463 -- the Round attribute and the result must be marked as rounded.
12465 if Target_Type
= Universal_Real
12466 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
12467 and then Attribute_Name
(Parent
(N
)) = Name_Round
12469 Set_Rounded_Result
(N
);
12470 Set_Etype
(N
, Etype
(Parent
(N
)));
12471 Target_Type
:= Etype
(N
);
12474 if Is_Fixed_Point_Type
(Target_Type
) then
12475 Expand_Convert_Fixed_To_Fixed
(N
);
12478 elsif Is_Integer_Type
(Target_Type
) then
12479 Expand_Convert_Fixed_To_Integer
(N
);
12480 Discrete_Range_Check
;
12483 pragma Assert
(Is_Floating_Point_Type
(Target_Type
));
12484 Expand_Convert_Fixed_To_Float
(N
);
12488 -- Case of conversions to a fixed-point type
12490 -- These conversions require special expansion and processing, found in
12491 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12492 -- since from a semantic point of view, these are simple integer
12493 -- conversions, which do not need further processing.
12495 elsif Is_Fixed_Point_Type
(Target_Type
)
12496 and then not Conversion_OK
(N
)
12498 if Is_Integer_Type
(Operand_Type
) then
12499 Expand_Convert_Integer_To_Fixed
(N
);
12502 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
12503 Expand_Convert_Float_To_Fixed
(N
);
12507 -- Case of array conversions
12509 -- Expansion of array conversions, add required length/range checks but
12510 -- only do this if there is no change of representation. For handling of
12511 -- this case, see Handle_Changed_Representation.
12513 elsif Is_Array_Type
(Target_Type
) then
12514 if Is_Constrained
(Target_Type
) then
12515 Apply_Length_Check
(Operand
, Target_Type
);
12517 Apply_Range_Check
(Operand
, Target_Type
);
12520 Handle_Changed_Representation
;
12522 -- Case of conversions of discriminated types
12524 -- Add required discriminant checks if target is constrained. Again this
12525 -- change is skipped if we have a change of representation.
12527 elsif Has_Discriminants
(Target_Type
)
12528 and then Is_Constrained
(Target_Type
)
12530 Apply_Discriminant_Check
(Operand
, Target_Type
);
12531 Handle_Changed_Representation
;
12533 -- Case of all other record conversions. The only processing required
12534 -- is to check for a change of representation requiring the special
12535 -- assignment processing.
12537 elsif Is_Record_Type
(Target_Type
) then
12539 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12540 -- a derived Unchecked_Union type to an unconstrained type that is
12541 -- not Unchecked_Union if the operand lacks inferable discriminants.
12543 if Is_Derived_Type
(Operand_Type
)
12544 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
12545 and then not Is_Constrained
(Target_Type
)
12546 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
12547 and then not Has_Inferable_Discriminants
(Operand
)
12549 -- To prevent Gigi from generating illegal code, we generate a
12550 -- Program_Error node, but we give it the target type of the
12551 -- conversion (is this requirement documented somewhere ???)
12554 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
12555 Reason
=> PE_Unchecked_Union_Restriction
);
12558 Set_Etype
(PE
, Target_Type
);
12563 Handle_Changed_Representation
;
12566 -- Case of conversions of enumeration types
12568 elsif Is_Enumeration_Type
(Target_Type
) then
12570 -- Special processing is required if there is a change of
12571 -- representation (from enumeration representation clauses).
12573 if not Has_Compatible_Representation
(Target_Type
, Operand_Type
)
12574 and then not Conversion_OK
(N
)
12577 -- Convert: x(y) to x'val (ytyp'pos (y))
12580 Make_Attribute_Reference
(Loc
,
12581 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
12582 Attribute_Name
=> Name_Val
,
12583 Expressions
=> New_List
(
12584 Make_Attribute_Reference
(Loc
,
12585 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
12586 Attribute_Name
=> Name_Pos
,
12587 Expressions
=> New_List
(Operand
)))));
12589 Analyze_And_Resolve
(N
, Target_Type
);
12593 -- At this stage, either the conversion node has been transformed into
12594 -- some other equivalent expression, or left as a conversion that can be
12595 -- handled by Gigi, in the following cases:
12597 -- Conversions with no change of representation or type
12599 -- Numeric conversions involving integer, floating- and fixed-point
12600 -- values. Fixed-point values are allowed only if Conversion_OK is
12601 -- set, i.e. if the fixed-point values are to be treated as integers.
12603 -- No other conversions should be passed to Gigi
12605 -- Check: are these rules stated in sinfo??? if so, why restate here???
12607 -- The only remaining step is to generate a range check if we still have
12608 -- a type conversion at this stage and Do_Range_Check is set. Note that
12609 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12610 -- conversions here, because the float-to-integer case is entirely dealt
12611 -- with by Apply_Float_Conversion_Check.
12613 if Nkind
(N
) = N_Type_Conversion
12614 and then Do_Range_Check
(Expression
(N
))
12616 -- Float-to-float conversions
12618 if Is_Floating_Point_Type
(Target_Type
)
12619 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
12621 -- Reset overflow flag, since the range check will include
12622 -- dealing with possible overflow, and generate the check.
12624 Set_Do_Overflow_Check
(N
, False);
12626 Generate_Range_Check
12627 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
12629 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12630 -- conversions when Conversion_OK is set.
12632 elsif Is_Discrete_Type
(Target_Type
)
12633 and then (Is_Discrete_Type
(Etype
(Expression
(N
)))
12634 or else (Is_Fixed_Point_Type
(Etype
(Expression
(N
)))
12635 and then Conversion_OK
(N
)))
12637 -- If Address is either a source type or target type,
12638 -- suppress range check to avoid typing anomalies when
12639 -- it is a visible integer type.
12641 if Is_Descendant_Of_Address
(Etype
(Expression
(N
)))
12642 or else Is_Descendant_Of_Address
(Target_Type
)
12644 Set_Do_Range_Check
(Expression
(N
), False);
12646 Discrete_Range_Check
;
12649 -- Conversions to floating- or fixed-point when Conversion_OK is set
12651 elsif Is_Floating_Point_Type
(Target_Type
)
12652 or else (Is_Fixed_Point_Type
(Target_Type
)
12653 and then Conversion_OK
(N
))
12658 pragma Assert
(not Do_Range_Check
(Expression
(N
)));
12661 -- Here at end of processing
12664 pragma Assert
(not Do_Range_Check
(N
));
12666 -- Apply predicate check if required. Note that we can't just call
12667 -- Apply_Predicate_Check here, because the type looks right after
12668 -- the conversion and it would omit the check. The Comes_From_Source
12669 -- guard is necessary to prevent infinite recursions when we generate
12670 -- internal conversions for the purpose of checking predicates.
12672 if Predicate_Enabled
(Target_Type
)
12673 and then Target_Type
/= Operand_Type
12674 and then Comes_From_Source
(N
)
12677 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
12680 -- Avoid infinite recursion on the subsequent expansion of the
12681 -- copy of the original type conversion. When needed, a range
12682 -- check has already been applied to the expression.
12684 Set_Comes_From_Source
(New_Expr
, False);
12686 Make_Predicate_Check
(Target_Type
, New_Expr
),
12687 Suppress
=> Range_Check
);
12690 end Expand_N_Type_Conversion
;
12692 -----------------------------------
12693 -- Expand_N_Unchecked_Expression --
12694 -----------------------------------
12696 -- Remove the unchecked expression node from the tree. Its job was simply
12697 -- to make sure that its constituent expression was handled with checks
12698 -- off, and now that is done, we can remove it from the tree, and indeed
12699 -- must, since Gigi does not expect to see these nodes.
12701 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
12702 Exp
: constant Node_Id
:= Expression
(N
);
12704 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
12706 end Expand_N_Unchecked_Expression
;
12708 ----------------------------------------
12709 -- Expand_N_Unchecked_Type_Conversion --
12710 ----------------------------------------
12712 -- If this cannot be handled by Gigi and we haven't already made a
12713 -- temporary for it, do it now.
12715 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
12716 Target_Type
: constant Entity_Id
:= Etype
(N
);
12717 Operand
: constant Node_Id
:= Expression
(N
);
12718 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12721 -- Nothing at all to do if conversion is to the identical type so remove
12722 -- the conversion completely, it is useless, except that it may carry
12723 -- an Assignment_OK indication which must be propagated to the operand.
12725 if Operand_Type
= Target_Type
then
12727 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
12729 if Assignment_OK
(N
) then
12730 Set_Assignment_OK
(Operand
);
12733 Rewrite
(N
, Relocate_Node
(Operand
));
12737 -- If we have a conversion of a compile time known value to a target
12738 -- type and the value is in range of the target type, then we can simply
12739 -- replace the construct by an integer literal of the correct type. We
12740 -- only apply this to discrete types being converted. Possibly it may
12741 -- apply in other cases, but it is too much trouble to worry about.
12743 -- Note that we do not do this transformation if the Kill_Range_Check
12744 -- flag is set, since then the value may be outside the expected range.
12745 -- This happens in the Normalize_Scalars case.
12747 -- We also skip this if either the target or operand type is biased
12748 -- because in this case, the unchecked conversion is supposed to
12749 -- preserve the bit pattern, not the integer value.
12751 if Is_Integer_Type
(Target_Type
)
12752 and then not Has_Biased_Representation
(Target_Type
)
12753 and then Is_Discrete_Type
(Operand_Type
)
12754 and then not Has_Biased_Representation
(Operand_Type
)
12755 and then Compile_Time_Known_Value
(Operand
)
12756 and then not Kill_Range_Check
(N
)
12759 Val
: constant Uint
:= Expr_Rep_Value
(Operand
);
12762 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
12764 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
12766 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
12768 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
12770 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
12772 -- If Address is the target type, just set the type to avoid a
12773 -- spurious type error on the literal when Address is a visible
12776 if Is_Descendant_Of_Address
(Target_Type
) then
12777 Set_Etype
(N
, Target_Type
);
12779 Analyze_And_Resolve
(N
, Target_Type
);
12787 -- Generate an extra temporary for cases unsupported by the C backend
12789 if Modify_Tree_For_C
then
12791 Source
: constant Node_Id
:= Unqual_Conv
(Expression
(N
));
12792 Source_Typ
: Entity_Id
:= Get_Full_View
(Etype
(Source
));
12795 if Is_Packed_Array
(Source_Typ
) then
12796 Source_Typ
:= Packed_Array_Impl_Type
(Source_Typ
);
12799 if Nkind
(Source
) = N_Function_Call
12800 and then (Is_Composite_Type
(Etype
(Source
))
12801 or else Is_Composite_Type
(Target_Type
))
12803 Force_Evaluation
(Source
);
12808 -- Nothing to do if conversion is safe
12810 if Safe_Unchecked_Type_Conversion
(N
) then
12814 -- Otherwise force evaluation unless Assignment_OK flag is set (this
12815 -- flag indicates ??? More comments needed here)
12817 if Assignment_OK
(N
) then
12820 Force_Evaluation
(N
);
12822 end Expand_N_Unchecked_Type_Conversion
;
12824 ----------------------------
12825 -- Expand_Record_Equality --
12826 ----------------------------
12828 -- For non-variant records, Equality is expanded when needed into:
12830 -- and then Lhs.Discr1 = Rhs.Discr1
12832 -- and then Lhs.Discrn = Rhs.Discrn
12833 -- and then Lhs.Cmp1 = Rhs.Cmp1
12835 -- and then Lhs.Cmpn = Rhs.Cmpn
12837 -- The expression is folded by the back end for adjacent fields. This
12838 -- function is called for tagged record in only one occasion: for imple-
12839 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12840 -- otherwise the primitive "=" is used directly.
12842 function Expand_Record_Equality
12847 Bodies
: List_Id
) return Node_Id
12849 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12854 First_Time
: Boolean := True;
12856 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
12857 -- Return the next discriminant or component to compare, starting with
12858 -- C, skipping inherited components.
12860 ------------------------
12861 -- Element_To_Compare --
12862 ------------------------
12864 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
12870 -- Exit loop when the next element to be compared is found, or
12871 -- there is no more such element.
12873 exit when No
(Comp
);
12875 exit when Ekind
(Comp
) in E_Discriminant | E_Component
12878 -- Skip inherited components
12880 -- Note: for a tagged type, we always generate the "=" primitive
12881 -- for the base type (not on the first subtype), so the test for
12882 -- Comp /= Original_Record_Component (Comp) is True for
12883 -- inherited components only.
12885 (Is_Tagged_Type
(Typ
)
12886 and then Comp
/= Original_Record_Component
(Comp
))
12890 or else Chars
(Comp
) = Name_uTag
12892 -- Skip interface elements (secondary tags???)
12894 or else Is_Interface
(Etype
(Comp
)));
12896 Next_Entity
(Comp
);
12900 end Element_To_Compare
;
12902 -- Start of processing for Expand_Record_Equality
12905 -- Generates the following code: (assuming that Typ has one Discr and
12906 -- component C2 is also a record)
12908 -- Lhs.Discr1 = Rhs.Discr1
12909 -- and then Lhs.C1 = Rhs.C1
12910 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12912 -- and then Lhs.Cmpn = Rhs.Cmpn
12914 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
12915 C
:= Element_To_Compare
(First_Entity
(Typ
));
12916 while Present
(C
) loop
12927 New_Lhs
:= New_Copy_Tree
(Lhs
);
12928 New_Rhs
:= New_Copy_Tree
(Rhs
);
12932 Expand_Composite_Equality
(Nod
, Etype
(C
),
12934 Make_Selected_Component
(Loc
,
12936 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12938 Make_Selected_Component
(Loc
,
12940 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12943 -- If some (sub)component is an unchecked_union, the whole
12944 -- operation will raise program error.
12946 if Nkind
(Check
) = N_Raise_Program_Error
then
12948 Set_Etype
(Result
, Standard_Boolean
);
12954 -- Generate logical "and" for CodePeer to simplify the
12955 -- generated code and analysis.
12957 elsif CodePeer_Mode
then
12960 Left_Opnd
=> Result
,
12961 Right_Opnd
=> Check
);
12965 Make_And_Then
(Loc
,
12966 Left_Opnd
=> Result
,
12967 Right_Opnd
=> Check
);
12972 First_Time
:= False;
12973 C
:= Element_To_Compare
(Next_Entity
(C
));
12977 end Expand_Record_Equality
;
12979 ---------------------------
12980 -- Expand_Set_Membership --
12981 ---------------------------
12983 procedure Expand_Set_Membership
(N
: Node_Id
) is
12984 Lop
: constant Node_Id
:= Left_Opnd
(N
);
12988 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
12989 -- If the alternative is a subtype mark, create a simple membership
12990 -- test. Otherwise create an equality test for it.
12996 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
12998 L
: constant Node_Id
:= New_Copy_Tree
(Lop
);
12999 R
: constant Node_Id
:= Relocate_Node
(Alt
);
13002 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
13003 or else Nkind
(Alt
) = N_Range
13006 Make_In
(Sloc
(Alt
),
13011 Make_Op_Eq
(Sloc
(Alt
),
13015 if Is_Record_Or_Limited_Type
(Etype
(Alt
)) then
13017 -- We reset the Entity in order to use the primitive equality
13018 -- of the type, as per RM 4.5.2 (28.1/4).
13020 Set_Entity
(Cond
, Empty
);
13027 -- Start of processing for Expand_Set_Membership
13030 Remove_Side_Effects
(Lop
);
13032 Alt
:= First
(Alternatives
(N
));
13033 Res
:= Make_Cond
(Alt
);
13036 -- We use left associativity as in the equivalent boolean case. This
13037 -- kind of canonicalization helps the optimizer of the code generator.
13039 while Present
(Alt
) loop
13041 Make_Or_Else
(Sloc
(Alt
),
13043 Right_Opnd
=> Make_Cond
(Alt
));
13048 Analyze_And_Resolve
(N
, Standard_Boolean
);
13049 end Expand_Set_Membership
;
13051 -----------------------------------
13052 -- Expand_Short_Circuit_Operator --
13053 -----------------------------------
13055 -- Deal with special expansion if actions are present for the right operand
13056 -- and deal with optimizing case of arguments being True or False. We also
13057 -- deal with the special case of non-standard boolean values.
13059 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
13060 Loc
: constant Source_Ptr
:= Sloc
(N
);
13061 Typ
: constant Entity_Id
:= Etype
(N
);
13062 Left
: constant Node_Id
:= Left_Opnd
(N
);
13063 Right
: constant Node_Id
:= Right_Opnd
(N
);
13064 LocR
: constant Source_Ptr
:= Sloc
(Right
);
13067 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
13068 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
13069 -- If Left = Shortcut_Value then Right need not be evaluated
13071 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
13072 -- For Opnd a boolean expression, return a Boolean expression equivalent
13073 -- to Opnd /= Shortcut_Value.
13075 function Useful
(Actions
: List_Id
) return Boolean;
13076 -- Return True if Actions is not empty and contains useful nodes to
13079 --------------------
13080 -- Make_Test_Expr --
13081 --------------------
13083 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
13085 if Shortcut_Value
then
13086 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
13090 end Make_Test_Expr
;
13096 function Useful
(Actions
: List_Id
) return Boolean is
13099 if Present
(Actions
) then
13100 L
:= First
(Actions
);
13102 -- For now "useful" means not N_Variable_Reference_Marker.
13103 -- Consider stripping other nodes in the future.
13105 while Present
(L
) loop
13106 if Nkind
(L
) /= N_Variable_Reference_Marker
then
13119 Op_Var
: Entity_Id
;
13120 -- Entity for a temporary variable holding the value of the operator,
13121 -- used for expansion in the case where actions are present.
13123 -- Start of processing for Expand_Short_Circuit_Operator
13126 -- Deal with non-standard booleans
13128 if Is_Boolean_Type
(Typ
) then
13129 Adjust_Condition
(Left
);
13130 Adjust_Condition
(Right
);
13131 Set_Etype
(N
, Standard_Boolean
);
13134 -- Check for cases where left argument is known to be True or False
13136 if Compile_Time_Known_Value
(Left
) then
13138 -- Mark SCO for left condition as compile time known
13140 if Generate_SCO
and then Comes_From_Source
(Left
) then
13141 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
13144 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
13145 -- Any actions associated with Right will be executed unconditionally
13146 -- and can thus be inserted into the tree unconditionally.
13148 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
13149 if Present
(Actions
(N
)) then
13150 Insert_Actions
(N
, Actions
(N
));
13153 Rewrite
(N
, Right
);
13155 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
13156 -- In this case we can forget the actions associated with Right,
13157 -- since they will never be executed.
13160 Kill_Dead_Code
(Right
);
13161 Kill_Dead_Code
(Actions
(N
));
13162 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
13165 Adjust_Result_Type
(N
, Typ
);
13169 -- If Actions are present for the right operand, we have to do some
13170 -- special processing. We can't just let these actions filter back into
13171 -- code preceding the short circuit (which is what would have happened
13172 -- if we had not trapped them in the short-circuit form), since they
13173 -- must only be executed if the right operand of the short circuit is
13174 -- executed and not otherwise.
13176 if Useful
(Actions
(N
)) then
13177 Actlist
:= Actions
(N
);
13179 -- The old approach is to expand:
13181 -- left AND THEN right
13185 -- C : Boolean := False;
13193 -- and finally rewrite the operator into a reference to C. Similarly
13194 -- for left OR ELSE right, with negated values. Note that this
13195 -- rewrite causes some difficulties for coverage analysis because
13196 -- of the introduction of the new variable C, which obscures the
13197 -- structure of the test.
13199 -- We use this "old approach" if Minimize_Expression_With_Actions
13202 if Minimize_Expression_With_Actions
then
13203 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
13206 Make_Object_Declaration
(Loc
,
13207 Defining_Identifier
=> Op_Var
,
13208 Object_Definition
=>
13209 New_Occurrence_Of
(Standard_Boolean
, Loc
),
13211 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
13213 Append_To
(Actlist
,
13214 Make_Implicit_If_Statement
(Right
,
13215 Condition
=> Make_Test_Expr
(Right
),
13216 Then_Statements
=> New_List
(
13217 Make_Assignment_Statement
(LocR
,
13218 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
13221 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
13224 Make_Implicit_If_Statement
(Left
,
13225 Condition
=> Make_Test_Expr
(Left
),
13226 Then_Statements
=> Actlist
));
13228 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
13229 Analyze_And_Resolve
(N
, Standard_Boolean
);
13231 -- The new approach (the default) is to use an
13232 -- Expression_With_Actions node for the right operand of the
13233 -- short-circuit form. Note that this solves the traceability
13234 -- problems for coverage analysis.
13238 Make_Expression_With_Actions
(LocR
,
13239 Expression
=> Relocate_Node
(Right
),
13240 Actions
=> Actlist
));
13242 Set_Actions
(N
, No_List
);
13243 Analyze_And_Resolve
(Right
, Standard_Boolean
);
13246 Adjust_Result_Type
(N
, Typ
);
13250 -- No actions present, check for cases of right argument True/False
13252 if Compile_Time_Known_Value
(Right
) then
13254 -- Mark SCO for left condition as compile time known
13256 if Generate_SCO
and then Comes_From_Source
(Right
) then
13257 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
13260 -- Change (Left and then True), (Left or else False) to Left. Note
13261 -- that we know there are no actions associated with the right
13262 -- operand, since we just checked for this case above.
13264 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
13267 -- Change (Left and then False), (Left or else True) to Right,
13268 -- making sure to preserve any side effects associated with the Left
13272 Remove_Side_Effects
(Left
);
13273 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
13277 Adjust_Result_Type
(N
, Typ
);
13278 end Expand_Short_Circuit_Operator
;
13280 ------------------------------------
13281 -- Fixup_Universal_Fixed_Operation --
13282 -------------------------------------
13284 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
13285 Conv
: constant Node_Id
:= Parent
(N
);
13288 -- We must have a type conversion immediately above us
13290 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
13292 -- Normally the type conversion gives our target type. The exception
13293 -- occurs in the case of the Round attribute, where the conversion
13294 -- will be to universal real, and our real type comes from the Round
13295 -- attribute (as well as an indication that we must round the result)
13297 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
13298 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
13300 Set_Etype
(N
, Base_Type
(Etype
(Parent
(Conv
))));
13301 Set_Rounded_Result
(N
);
13303 -- Normal case where type comes from conversion above us
13306 Set_Etype
(N
, Base_Type
(Etype
(Conv
)));
13308 end Fixup_Universal_Fixed_Operation
;
13310 ---------------------------------
13311 -- Has_Inferable_Discriminants --
13312 ---------------------------------
13314 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
13316 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
13317 -- Determines whether the left-most prefix of a selected component is a
13318 -- formal parameter in a subprogram. Assumes N is a selected component.
13320 --------------------------------
13321 -- Prefix_Is_Formal_Parameter --
13322 --------------------------------
13324 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
13325 Sel_Comp
: Node_Id
;
13328 -- Move to the left-most prefix by climbing up the tree
13331 while Present
(Parent
(Sel_Comp
))
13332 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
13334 Sel_Comp
:= Parent
(Sel_Comp
);
13337 return Is_Formal
(Entity
(Prefix
(Sel_Comp
)));
13338 end Prefix_Is_Formal_Parameter
;
13340 -- Start of processing for Has_Inferable_Discriminants
13343 -- For selected components, the subtype of the selector must be a
13344 -- constrained Unchecked_Union. If the component is subject to a
13345 -- per-object constraint, then the enclosing object must have inferable
13348 if Nkind
(N
) = N_Selected_Component
then
13349 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
13351 -- A small hack. If we have a per-object constrained selected
13352 -- component of a formal parameter, return True since we do not
13353 -- know the actual parameter association yet.
13355 if Prefix_Is_Formal_Parameter
(N
) then
13358 -- Otherwise, check the enclosing object and the selector
13361 return Has_Inferable_Discriminants
(Prefix
(N
))
13362 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
13365 -- The call to Has_Inferable_Discriminants will determine whether
13366 -- the selector has a constrained Unchecked_Union nominal type.
13369 return Has_Inferable_Discriminants
(Selector_Name
(N
));
13372 -- A qualified expression has inferable discriminants if its subtype
13373 -- mark is a constrained Unchecked_Union subtype.
13375 elsif Nkind
(N
) = N_Qualified_Expression
then
13376 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
13377 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
13379 -- For all other names, it is sufficient to have a constrained
13380 -- Unchecked_Union nominal subtype.
13383 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
13384 and then Is_Constrained
(Etype
(N
));
13386 end Has_Inferable_Discriminants
;
13388 -------------------------------
13389 -- Insert_Dereference_Action --
13390 -------------------------------
13392 procedure Insert_Dereference_Action
(N
: Node_Id
) is
13393 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
13394 -- Return true if type of P is derived from Checked_Pool;
13396 -----------------------------
13397 -- Is_Checked_Storage_Pool --
13398 -----------------------------
13400 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
13409 while T
/= Etype
(T
) loop
13410 if Is_RTE
(T
, RE_Checked_Pool
) then
13418 end Is_Checked_Storage_Pool
;
13422 Context
: constant Node_Id
:= Parent
(N
);
13423 Ptr_Typ
: constant Entity_Id
:= Etype
(N
);
13424 Desig_Typ
: constant Entity_Id
:=
13425 Available_View
(Designated_Type
(Ptr_Typ
));
13426 Loc
: constant Source_Ptr
:= Sloc
(N
);
13427 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
13433 Size_Bits
: Node_Id
;
13436 -- Start of processing for Insert_Dereference_Action
13439 pragma Assert
(Nkind
(Context
) = N_Explicit_Dereference
);
13441 -- Do not re-expand a dereference which has already been processed by
13444 if Has_Dereference_Action
(Context
) then
13447 -- Do not perform this type of expansion for internally-generated
13450 elsif not Comes_From_Source
(Original_Node
(Context
)) then
13453 -- A dereference action is only applicable to objects which have been
13454 -- allocated on a checked pool.
13456 elsif not Is_Checked_Storage_Pool
(Pool
) then
13460 -- Extract the address of the dereferenced object. Generate:
13462 -- Addr : System.Address := <N>'Pool_Address;
13464 Addr
:= Make_Temporary
(Loc
, 'P');
13467 Make_Object_Declaration
(Loc
,
13468 Defining_Identifier
=> Addr
,
13469 Object_Definition
=>
13470 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
13472 Make_Attribute_Reference
(Loc
,
13473 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
13474 Attribute_Name
=> Name_Pool_Address
)));
13476 -- Calculate the size of the dereferenced object. Generate:
13478 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13481 Make_Explicit_Dereference
(Loc
,
13482 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13483 Set_Has_Dereference_Action
(Deref
);
13486 Make_Attribute_Reference
(Loc
,
13488 Attribute_Name
=> Name_Size
);
13490 -- Special case of an unconstrained array: need to add descriptor size
13492 if Is_Array_Type
(Desig_Typ
)
13493 and then not Is_Constrained
(First_Subtype
(Desig_Typ
))
13498 Make_Attribute_Reference
(Loc
,
13500 New_Occurrence_Of
(First_Subtype
(Desig_Typ
), Loc
),
13501 Attribute_Name
=> Name_Descriptor_Size
),
13502 Right_Opnd
=> Size_Bits
);
13505 Size
:= Make_Temporary
(Loc
, 'S');
13507 Make_Object_Declaration
(Loc
,
13508 Defining_Identifier
=> Size
,
13509 Object_Definition
=>
13510 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13512 Make_Op_Divide
(Loc
,
13513 Left_Opnd
=> Size_Bits
,
13514 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
13516 -- Calculate the alignment of the dereferenced object. Generate:
13517 -- Alig : constant Storage_Count := <N>.all'Alignment;
13520 Make_Explicit_Dereference
(Loc
,
13521 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13522 Set_Has_Dereference_Action
(Deref
);
13524 Alig
:= Make_Temporary
(Loc
, 'A');
13526 Make_Object_Declaration
(Loc
,
13527 Defining_Identifier
=> Alig
,
13528 Object_Definition
=>
13529 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13531 Make_Attribute_Reference
(Loc
,
13533 Attribute_Name
=> Name_Alignment
)));
13535 -- A dereference of a controlled object requires special processing. The
13536 -- finalization machinery requests additional space from the underlying
13537 -- pool to allocate and hide two pointers. As a result, a checked pool
13538 -- may mark the wrong memory as valid. Since checked pools do not have
13539 -- knowledge of hidden pointers, we have to bring the two pointers back
13540 -- in view in order to restore the original state of the object.
13542 -- The address manipulation is not performed for access types that are
13543 -- subject to pragma No_Heap_Finalization because the two pointers do
13544 -- not exist in the first place.
13546 if No_Heap_Finalization
(Ptr_Typ
) then
13549 elsif Needs_Finalization
(Desig_Typ
) then
13551 -- Adjust the address and size of the dereferenced object. Generate:
13552 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13555 Make_Procedure_Call_Statement
(Loc
,
13557 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
13558 Parameter_Associations
=> New_List
(
13559 New_Occurrence_Of
(Addr
, Loc
),
13560 New_Occurrence_Of
(Size
, Loc
),
13561 New_Occurrence_Of
(Alig
, Loc
)));
13563 -- Class-wide types complicate things because we cannot determine
13564 -- statically whether the actual object is truly controlled. We must
13565 -- generate a runtime check to detect this property. Generate:
13567 -- if Needs_Finalization (<N>.all'Tag) then
13571 if Is_Class_Wide_Type
(Desig_Typ
) then
13573 Make_Explicit_Dereference
(Loc
,
13574 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13575 Set_Has_Dereference_Action
(Deref
);
13578 Make_Implicit_If_Statement
(N
,
13580 Make_Function_Call
(Loc
,
13582 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
13583 Parameter_Associations
=> New_List
(
13584 Make_Attribute_Reference
(Loc
,
13586 Attribute_Name
=> Name_Tag
))),
13587 Then_Statements
=> New_List
(Stmt
));
13590 Insert_Action
(N
, Stmt
);
13594 -- Dereference (Pool, Addr, Size, Alig);
13597 Make_Procedure_Call_Statement
(Loc
,
13600 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
13601 Parameter_Associations
=> New_List
(
13602 New_Occurrence_Of
(Pool
, Loc
),
13603 New_Occurrence_Of
(Addr
, Loc
),
13604 New_Occurrence_Of
(Size
, Loc
),
13605 New_Occurrence_Of
(Alig
, Loc
))));
13607 -- Mark the explicit dereference as processed to avoid potential
13608 -- infinite expansion.
13610 Set_Has_Dereference_Action
(Context
);
13613 when RE_Not_Available
=>
13615 end Insert_Dereference_Action
;
13617 --------------------------------
13618 -- Integer_Promotion_Possible --
13619 --------------------------------
13621 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
13622 Operand
: constant Node_Id
:= Expression
(N
);
13623 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
13624 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
13627 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
13631 -- We only do the transformation for source constructs. We assume
13632 -- that the expander knows what it is doing when it generates code.
13634 Comes_From_Source
(N
)
13636 -- If the operand type is Short_Integer or Short_Short_Integer,
13637 -- then we will promote to Integer, which is available on all
13638 -- targets, and is sufficient to ensure no intermediate overflow.
13639 -- Furthermore it is likely to be as efficient or more efficient
13640 -- than using the smaller type for the computation so we do this
13641 -- unconditionally.
13644 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
13646 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
13648 -- Test for interesting operation, which includes addition,
13649 -- division, exponentiation, multiplication, subtraction, absolute
13650 -- value and unary negation. Unary "+" is omitted since it is a
13651 -- no-op and thus can't overflow.
13653 and then Nkind
(Operand
) in
13654 N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
13655 N_Op_Minus | N_Op_Multiply | N_Op_Subtract
;
13656 end Integer_Promotion_Possible
;
13658 ------------------------------
13659 -- Make_Array_Comparison_Op --
13660 ------------------------------
13662 -- This is a hand-coded expansion of the following generic function:
13665 -- type elem is (<>);
13666 -- type index is (<>);
13667 -- type a is array (index range <>) of elem;
13669 -- function Gnnn (X : a; Y: a) return boolean is
13670 -- J : index := Y'first;
13673 -- if X'length = 0 then
13676 -- elsif Y'length = 0 then
13680 -- for I in X'range loop
13681 -- if X (I) = Y (J) then
13682 -- if J = Y'last then
13685 -- J := index'succ (J);
13689 -- return X (I) > Y (J);
13693 -- return X'length > Y'length;
13697 -- Note that since we are essentially doing this expansion by hand, we
13698 -- do not need to generate an actual or formal generic part, just the
13699 -- instantiated function itself.
13701 -- Perhaps we could have the actual generic available in the run-time,
13702 -- obtained by rtsfind, and actually expand a real instantiation ???
13704 function Make_Array_Comparison_Op
13706 Nod
: Node_Id
) return Node_Id
13708 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
13710 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
13711 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
13712 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
13713 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13715 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
13717 Loop_Statement
: Node_Id
;
13718 Loop_Body
: Node_Id
;
13720 Inner_If
: Node_Id
;
13721 Final_Expr
: Node_Id
;
13722 Func_Body
: Node_Id
;
13723 Func_Name
: Entity_Id
;
13729 -- if J = Y'last then
13732 -- J := index'succ (J);
13736 Make_Implicit_If_Statement
(Nod
,
13739 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
13741 Make_Attribute_Reference
(Loc
,
13742 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13743 Attribute_Name
=> Name_Last
)),
13745 Then_Statements
=> New_List
(
13746 Make_Exit_Statement
(Loc
)),
13750 Make_Assignment_Statement
(Loc
,
13751 Name
=> New_Occurrence_Of
(J
, Loc
),
13753 Make_Attribute_Reference
(Loc
,
13754 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
13755 Attribute_Name
=> Name_Succ
,
13756 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
13758 -- if X (I) = Y (J) then
13761 -- return X (I) > Y (J);
13765 Make_Implicit_If_Statement
(Nod
,
13769 Make_Indexed_Component
(Loc
,
13770 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13771 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13774 Make_Indexed_Component
(Loc
,
13775 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13776 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
13778 Then_Statements
=> New_List
(Inner_If
),
13780 Else_Statements
=> New_List
(
13781 Make_Simple_Return_Statement
(Loc
,
13785 Make_Indexed_Component
(Loc
,
13786 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13787 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13790 Make_Indexed_Component
(Loc
,
13791 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13792 Expressions
=> New_List
(
13793 New_Occurrence_Of
(J
, Loc
)))))));
13795 -- for I in X'range loop
13800 Make_Implicit_Loop_Statement
(Nod
,
13801 Identifier
=> Empty
,
13803 Iteration_Scheme
=>
13804 Make_Iteration_Scheme
(Loc
,
13805 Loop_Parameter_Specification
=>
13806 Make_Loop_Parameter_Specification
(Loc
,
13807 Defining_Identifier
=> I
,
13808 Discrete_Subtype_Definition
=>
13809 Make_Attribute_Reference
(Loc
,
13810 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13811 Attribute_Name
=> Name_Range
))),
13813 Statements
=> New_List
(Loop_Body
));
13815 -- if X'length = 0 then
13817 -- elsif Y'length = 0 then
13820 -- for ... loop ... end loop;
13821 -- return X'length > Y'length;
13825 Make_Attribute_Reference
(Loc
,
13826 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13827 Attribute_Name
=> Name_Length
);
13830 Make_Attribute_Reference
(Loc
,
13831 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13832 Attribute_Name
=> Name_Length
);
13836 Left_Opnd
=> Length1
,
13837 Right_Opnd
=> Length2
);
13840 Make_Implicit_If_Statement
(Nod
,
13844 Make_Attribute_Reference
(Loc
,
13845 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13846 Attribute_Name
=> Name_Length
),
13848 Make_Integer_Literal
(Loc
, 0)),
13852 Make_Simple_Return_Statement
(Loc
,
13853 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
13855 Elsif_Parts
=> New_List
(
13856 Make_Elsif_Part
(Loc
,
13860 Make_Attribute_Reference
(Loc
,
13861 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13862 Attribute_Name
=> Name_Length
),
13864 Make_Integer_Literal
(Loc
, 0)),
13868 Make_Simple_Return_Statement
(Loc
,
13869 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
13871 Else_Statements
=> New_List
(
13873 Make_Simple_Return_Statement
(Loc
,
13874 Expression
=> Final_Expr
)));
13878 Formals
:= New_List
(
13879 Make_Parameter_Specification
(Loc
,
13880 Defining_Identifier
=> X
,
13881 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13883 Make_Parameter_Specification
(Loc
,
13884 Defining_Identifier
=> Y
,
13885 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13887 -- function Gnnn (...) return boolean is
13888 -- J : index := Y'first;
13893 Func_Name
:= Make_Temporary
(Loc
, 'G');
13896 Make_Subprogram_Body
(Loc
,
13898 Make_Function_Specification
(Loc
,
13899 Defining_Unit_Name
=> Func_Name
,
13900 Parameter_Specifications
=> Formals
,
13901 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
13903 Declarations
=> New_List
(
13904 Make_Object_Declaration
(Loc
,
13905 Defining_Identifier
=> J
,
13906 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
13908 Make_Attribute_Reference
(Loc
,
13909 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13910 Attribute_Name
=> Name_First
))),
13912 Handled_Statement_Sequence
=>
13913 Make_Handled_Sequence_Of_Statements
(Loc
,
13914 Statements
=> New_List
(If_Stat
)));
13917 end Make_Array_Comparison_Op
;
13919 ---------------------------
13920 -- Make_Boolean_Array_Op --
13921 ---------------------------
13923 -- For logical operations on boolean arrays, expand in line the following,
13924 -- replacing 'and' with 'or' or 'xor' where needed:
13926 -- function Annn (A : typ; B: typ) return typ is
13929 -- for J in A'range loop
13930 -- C (J) := A (J) op B (J);
13935 -- Here typ is the boolean array type
13937 function Make_Boolean_Array_Op
13939 N
: Node_Id
) return Node_Id
13941 Loc
: constant Source_Ptr
:= Sloc
(N
);
13943 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
13944 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
13945 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
13946 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13954 Func_Name
: Entity_Id
;
13955 Func_Body
: Node_Id
;
13956 Loop_Statement
: Node_Id
;
13960 Make_Indexed_Component
(Loc
,
13961 Prefix
=> New_Occurrence_Of
(A
, Loc
),
13962 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13965 Make_Indexed_Component
(Loc
,
13966 Prefix
=> New_Occurrence_Of
(B
, Loc
),
13967 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13970 Make_Indexed_Component
(Loc
,
13971 Prefix
=> New_Occurrence_Of
(C
, Loc
),
13972 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13974 if Nkind
(N
) = N_Op_And
then
13978 Right_Opnd
=> B_J
);
13980 elsif Nkind
(N
) = N_Op_Or
then
13984 Right_Opnd
=> B_J
);
13990 Right_Opnd
=> B_J
);
13994 Make_Implicit_Loop_Statement
(N
,
13995 Identifier
=> Empty
,
13997 Iteration_Scheme
=>
13998 Make_Iteration_Scheme
(Loc
,
13999 Loop_Parameter_Specification
=>
14000 Make_Loop_Parameter_Specification
(Loc
,
14001 Defining_Identifier
=> J
,
14002 Discrete_Subtype_Definition
=>
14003 Make_Attribute_Reference
(Loc
,
14004 Prefix
=> New_Occurrence_Of
(A
, Loc
),
14005 Attribute_Name
=> Name_Range
))),
14007 Statements
=> New_List
(
14008 Make_Assignment_Statement
(Loc
,
14010 Expression
=> Op
)));
14012 Formals
:= New_List
(
14013 Make_Parameter_Specification
(Loc
,
14014 Defining_Identifier
=> A
,
14015 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
14017 Make_Parameter_Specification
(Loc
,
14018 Defining_Identifier
=> B
,
14019 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
14021 Func_Name
:= Make_Temporary
(Loc
, 'A');
14022 Set_Is_Inlined
(Func_Name
);
14025 Make_Subprogram_Body
(Loc
,
14027 Make_Function_Specification
(Loc
,
14028 Defining_Unit_Name
=> Func_Name
,
14029 Parameter_Specifications
=> Formals
,
14030 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
14032 Declarations
=> New_List
(
14033 Make_Object_Declaration
(Loc
,
14034 Defining_Identifier
=> C
,
14035 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
14037 Handled_Statement_Sequence
=>
14038 Make_Handled_Sequence_Of_Statements
(Loc
,
14039 Statements
=> New_List
(
14041 Make_Simple_Return_Statement
(Loc
,
14042 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
14045 end Make_Boolean_Array_Op
;
14047 -----------------------------------------
14048 -- Minimized_Eliminated_Overflow_Check --
14049 -----------------------------------------
14051 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
14054 Is_Signed_Integer_Type
(Etype
(N
))
14055 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
14056 end Minimized_Eliminated_Overflow_Check
;
14058 ----------------------------
14059 -- Narrow_Large_Operation --
14060 ----------------------------
14062 procedure Narrow_Large_Operation
(N
: Node_Id
) is
14063 Kind
: constant Node_Kind
:= Nkind
(N
);
14064 In_Rng
: constant Boolean := Kind
= N_In
;
14065 Binary
: constant Boolean := Kind
in N_Binary_Op
or else In_Rng
;
14066 Compar
: constant Boolean := Kind
in N_Op_Compare
or else In_Rng
;
14067 R
: constant Node_Id
:= Right_Opnd
(N
);
14068 Typ
: constant Entity_Id
:= Etype
(R
);
14069 Tsiz
: constant Uint
:= RM_Size
(Typ
);
14071 function Get_Size_For_Range
(Lo
, Hi
: Uint
) return Uint
;
14072 -- Return the size of a small signed integer type covering Lo .. Hi.
14073 -- The important thing is to return a size lower than that of Typ.
14075 ------------------------
14076 -- Get_Size_For_Range --
14077 ------------------------
14079 function Get_Size_For_Range
(Lo
, Hi
: Uint
) return Uint
is
14081 function Is_OK_For_Range
(Siz
: Uint
) return Boolean;
14082 -- Return True if a signed integer with given size can cover Lo .. Hi
14084 --------------------------
14085 -- Is_OK_For_Range --
14086 --------------------------
14088 function Is_OK_For_Range
(Siz
: Uint
) return Boolean is
14089 B
: constant Uint
:= Uint_2
** (Siz
- 1);
14092 -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
14094 return Lo
>= -B
and then Hi
>= -B
and then Lo
< B
and then Hi
< B
;
14095 end Is_OK_For_Range
;
14098 -- This is (almost always) the size of Integer
14100 if Is_OK_For_Range
(Uint_32
) then
14103 -- If the size of Typ is 64 then check 63
14105 elsif Tsiz
= Uint_64
and then Is_OK_For_Range
(Uint_63
) then
14108 -- This is (almost always) the size of Long_Long_Integer
14110 elsif Is_OK_For_Range
(Uint_64
) then
14113 -- If the size of Typ is 128 then check 127
14115 elsif Tsiz
= Uint_128
and then Is_OK_For_Range
(Uint_127
) then
14121 end Get_Size_For_Range
;
14135 -- Start of processing for Narrow_Large_Operation
14138 -- First, determine the range of the left operand, if any
14141 L
:= Left_Opnd
(N
);
14142 Determine_Range
(L
, OK
, Llo
, Lhi
, Assume_Valid
=> True);
14153 -- Second, determine the range of the right operand, which can itself
14154 -- be a range, in which case we take the lower bound of the low bound
14155 -- and the upper bound of the high bound.
14163 (Low_Bound
(R
), OK
, Rlo
, Zhi
, Assume_Valid
=> True);
14169 (High_Bound
(R
), OK
, Zlo
, Rhi
, Assume_Valid
=> True);
14176 Determine_Range
(R
, OK
, Rlo
, Rhi
, Assume_Valid
=> True);
14182 -- Then compute a size suitable for each range
14185 Lsiz
:= Get_Size_For_Range
(Llo
, Lhi
);
14190 Rsiz
:= Get_Size_For_Range
(Rlo
, Rhi
);
14192 -- Now compute the size of the narrower type
14195 -- The type must be able to accommodate the operands
14197 Nsiz
:= UI_Max
(Lsiz
, Rsiz
);
14200 -- The type must be able to accommodate the operand(s) and result.
14202 -- Note that Determine_Range typically does not report the bounds of
14203 -- the value as being larger than those of the base type, which means
14204 -- that it does not report overflow (see also Enable_Overflow_Check).
14206 Determine_Range
(N
, OK
, Nlo
, Nhi
, Assume_Valid
=> True);
14211 -- Therefore, if Nsiz is not lower than the size of the original type
14212 -- here, we cannot be sure that the operation does not overflow.
14214 Nsiz
:= Get_Size_For_Range
(Nlo
, Nhi
);
14215 Nsiz
:= UI_Max
(Nsiz
, Lsiz
);
14216 Nsiz
:= UI_Max
(Nsiz
, Rsiz
);
14219 -- If the size is not lower than the size of the original type, then
14220 -- there is no point in changing the type, except in the case where
14221 -- we can remove a conversion to the original type from an operand.
14224 and then not (Binary
14225 and then Nkind
(L
) = N_Type_Conversion
14226 and then Entity
(Subtype_Mark
(L
)) = Typ
)
14227 and then not (Nkind
(R
) = N_Type_Conversion
14228 and then Entity
(Subtype_Mark
(R
)) = Typ
)
14233 -- Now pick the narrower type according to the size. We use the base
14234 -- type instead of the first subtype because operations are done in
14235 -- the base type, so this avoids the need for useless conversions.
14237 if Nsiz
<= System_Max_Integer_Size
then
14238 Ntyp
:= Etype
(Integer_Type_For
(Nsiz
, Uns
=> False));
14243 -- Finally, rewrite the operation in the narrower type
14245 Nop
:= New_Op_Node
(Kind
, Sloc
(N
));
14248 Set_Left_Opnd
(Nop
, Convert_To
(Ntyp
, L
));
14252 Set_Right_Opnd
(Nop
,
14253 Make_Range
(Sloc
(N
),
14254 Convert_To
(Ntyp
, Low_Bound
(R
)),
14255 Convert_To
(Ntyp
, High_Bound
(R
))));
14257 Set_Right_Opnd
(Nop
, Convert_To
(Ntyp
, R
));
14263 -- Analyze it with the comparison type and checks suppressed since
14264 -- the conversions of the operands cannot overflow.
14266 Analyze_And_Resolve
14267 (N
, Etype
(Original_Node
(N
)), Suppress
=> Overflow_Check
);
14270 -- Analyze it with the narrower type and checks suppressed, but only
14271 -- when we are sure that the operation does not overflow, see above.
14273 if Nsiz
< Tsiz
then
14274 Analyze_And_Resolve
(N
, Ntyp
, Suppress
=> Overflow_Check
);
14276 Analyze_And_Resolve
(N
, Ntyp
);
14279 -- Put back a conversion to the original type
14281 Convert_To_And_Rewrite
(Typ
, N
);
14283 end Narrow_Large_Operation
;
14285 --------------------------------
14286 -- Optimize_Length_Comparison --
14287 --------------------------------
14289 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
14290 Loc
: constant Source_Ptr
:= Sloc
(N
);
14291 Typ
: constant Entity_Id
:= Etype
(N
);
14296 -- First and Last attribute reference nodes, which end up as left and
14297 -- right operands of the optimized result.
14300 -- True for comparison operand of zero
14302 Maybe_Superflat
: Boolean;
14303 -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set
14304 -- to false but the comparison operand can be zero at run time. In this
14305 -- case, we normally cannot do anything because the canonical formula of
14306 -- the length is not valid, but there is one exception: when the operand
14307 -- is itself the length of an array with the same bounds as the array on
14308 -- the LHS, we can entirely optimize away the comparison.
14311 -- Comparison operand, set only if Is_Zero is false
14313 Ent
: array (Pos
range 1 .. 2) of Entity_Id
:= (Empty
, Empty
);
14314 -- Entities whose length is being compared
14316 Index
: array (Pos
range 1 .. 2) of Node_Id
:= (Empty
, Empty
);
14317 -- Integer_Literal nodes for length attribute expressions, or Empty
14318 -- if there is no such expression present.
14320 Op
: Node_Kind
:= Nkind
(N
);
14321 -- Kind of comparison operator, gets flipped if operands backwards
14323 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
;
14324 -- Given a discrete expression, returns a Long_Long_Integer typed
14325 -- expression representing the underlying value of the expression.
14326 -- This is done with an unchecked conversion to Long_Long_Integer.
14327 -- We use unchecked conversion to handle the enumeration type case.
14329 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean;
14330 -- Tests if N is a length attribute applied to a simple entity. If so,
14331 -- returns True, and sets Ent to the entity, and Index to the integer
14332 -- literal provided as an attribute expression, or to Empty if none.
14333 -- Num is the index designating the relevant slot in Ent and Index.
14334 -- Also returns True if the expression is a generated type conversion
14335 -- whose expression is of the desired form. This latter case arises
14336 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
14337 -- to check for being in range, which is not needed in this context.
14338 -- Returns False if neither condition holds.
14340 function Is_Optimizable
(N
: Node_Id
) return Boolean;
14341 -- Tests N to see if it is an optimizable comparison value (defined as
14342 -- constant zero or one, or something else where the value is known to
14343 -- be nonnegative and in the 32-bit range and where the corresponding
14344 -- Length value is also known to be 32 bits). If result is true, sets
14345 -- Is_Zero, Maybe_Superflat and Comp accordingly.
14347 procedure Rewrite_For_Equal_Lengths
;
14348 -- Rewrite the comparison of two equal lengths into either True or False
14350 ----------------------------------
14351 -- Convert_To_Long_Long_Integer --
14352 ----------------------------------
14354 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
is
14356 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
14357 end Convert_To_Long_Long_Integer
;
14359 ----------------------
14360 -- Is_Entity_Length --
14361 ----------------------
14363 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean is
14365 if Nkind
(N
) = N_Attribute_Reference
14366 and then Attribute_Name
(N
) = Name_Length
14367 and then Is_Entity_Name
(Prefix
(N
))
14369 Ent
(Num
) := Entity
(Prefix
(N
));
14371 if Present
(Expressions
(N
)) then
14372 Index
(Num
) := First
(Expressions
(N
));
14374 Index
(Num
) := Empty
;
14379 elsif Nkind
(N
) = N_Type_Conversion
14380 and then not Comes_From_Source
(N
)
14382 return Is_Entity_Length
(Expression
(N
), Num
);
14387 end Is_Entity_Length
;
14389 --------------------
14390 -- Is_Optimizable --
14391 --------------------
14393 function Is_Optimizable
(N
: Node_Id
) return Boolean is
14403 if Compile_Time_Known_Value
(N
) then
14404 Val
:= Expr_Value
(N
);
14406 if Val
= Uint_0
then
14408 Maybe_Superflat
:= False;
14412 elsif Val
= Uint_1
then
14414 Maybe_Superflat
:= False;
14420 -- Here we have to make sure of being within a 32-bit range (take the
14421 -- full unsigned range so the length of 32-bit arrays is accepted).
14423 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
14426 or else Lo
< Uint_0
14427 or else Hi
> Uint_2
** 32
14432 Maybe_Superflat
:= (Lo
= Uint_0
);
14434 -- Tests if N is also a length attribute applied to a simple entity
14436 Dbl
:= Is_Entity_Length
(N
, 2);
14438 -- We can deal with the superflat case only if N is also a length
14440 if Maybe_Superflat
and then not Dbl
then
14444 -- Comparison value was within range, so now we must check the index
14445 -- value to make sure it is also within 32 bits.
14447 for K
in Pos
range 1 .. 2 loop
14448 Indx
:= First_Index
(Etype
(Ent
(K
)));
14450 if Present
(Index
(K
)) then
14451 for J
in 2 .. UI_To_Int
(Intval
(Index
(K
))) loop
14456 Ityp
:= Etype
(Indx
);
14458 if Esize
(Ityp
) > 32 then
14468 end Is_Optimizable
;
14470 -------------------------------
14471 -- Rewrite_For_Equal_Lengths --
14472 -------------------------------
14474 procedure Rewrite_For_Equal_Lengths
is
14483 New_Occurrence_Of
(Standard_True
, Sloc
(N
))));
14491 New_Occurrence_Of
(Standard_False
, Sloc
(N
))));
14494 raise Program_Error
;
14497 Analyze_And_Resolve
(N
, Typ
);
14498 end Rewrite_For_Equal_Lengths
;
14500 -- Start of processing for Optimize_Length_Comparison
14503 -- Nothing to do if not a comparison
14505 if Op
not in N_Op_Compare
then
14509 -- Nothing to do if special -gnatd.P debug flag set.
14511 if Debug_Flag_Dot_PP
then
14515 -- Ent'Length op 0/1
14517 if Is_Entity_Length
(Left_Opnd
(N
), 1)
14518 and then Is_Optimizable
(Right_Opnd
(N
))
14522 -- 0/1 op Ent'Length
14524 elsif Is_Entity_Length
(Right_Opnd
(N
), 1)
14525 and then Is_Optimizable
(Left_Opnd
(N
))
14527 -- Flip comparison to opposite sense
14530 when N_Op_Lt
=> Op
:= N_Op_Gt
;
14531 when N_Op_Le
=> Op
:= N_Op_Ge
;
14532 when N_Op_Gt
=> Op
:= N_Op_Lt
;
14533 when N_Op_Ge
=> Op
:= N_Op_Le
;
14534 when others => null;
14537 -- Else optimization not possible
14543 -- Fall through if we will do the optimization
14545 -- Cases to handle:
14547 -- X'Length = 0 => X'First > X'Last
14548 -- X'Length = 1 => X'First = X'Last
14549 -- X'Length = n => X'First + (n - 1) = X'Last
14551 -- X'Length /= 0 => X'First <= X'Last
14552 -- X'Length /= 1 => X'First /= X'Last
14553 -- X'Length /= n => X'First + (n - 1) /= X'Last
14555 -- X'Length >= 0 => always true, warn
14556 -- X'Length >= 1 => X'First <= X'Last
14557 -- X'Length >= n => X'First + (n - 1) <= X'Last
14559 -- X'Length > 0 => X'First <= X'Last
14560 -- X'Length > 1 => X'First < X'Last
14561 -- X'Length > n => X'First + (n - 1) < X'Last
14563 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
14564 -- X'Length <= 1 => X'First >= X'Last
14565 -- X'Length <= n => X'First + (n - 1) >= X'Last
14567 -- X'Length < 0 => always false (warn)
14568 -- X'Length < 1 => X'First > X'Last
14569 -- X'Length < n => X'First + (n - 1) > X'Last
14571 -- Note: for the cases of n (not constant 0,1), we require that the
14572 -- corresponding index type be integer or shorter (i.e. not 64-bit),
14573 -- and the same for the comparison value. Then we do the comparison
14574 -- using 64-bit arithmetic (actually long long integer), so that we
14575 -- cannot have overflow intefering with the result.
14577 -- First deal with warning cases
14586 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
14587 Analyze_And_Resolve
(N
, Typ
);
14588 Warn_On_Known_Condition
(N
);
14595 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
14596 Analyze_And_Resolve
(N
, Typ
);
14597 Warn_On_Known_Condition
(N
);
14601 if Constant_Condition_Warnings
14602 and then Comes_From_Source
(Original_Node
(N
))
14604 Error_Msg_N
("could replace by ""'=""?c?", N
);
14614 -- Build the First reference we will use
14617 Make_Attribute_Reference
(Loc
,
14618 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14619 Attribute_Name
=> Name_First
);
14621 if Present
(Index
(1)) then
14622 Set_Expressions
(Left
, New_List
(New_Copy
(Index
(1))));
14625 -- Build the Last reference we will use
14628 Make_Attribute_Reference
(Loc
,
14629 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14630 Attribute_Name
=> Name_Last
);
14632 if Present
(Index
(1)) then
14633 Set_Expressions
(Right
, New_List
(New_Copy
(Index
(1))));
14636 -- If general value case, then do the addition of (n - 1), and
14637 -- also add the needed conversions to type Long_Long_Integer.
14639 -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into:
14641 -- Y'Last + (X'First - Y'First) op X'Last
14643 -- in the hope that X'First - Y'First can be computed statically.
14645 if Present
(Comp
) then
14646 if Present
(Ent
(2)) then
14648 Y_First
: constant Node_Id
:=
14649 Make_Attribute_Reference
(Loc
,
14650 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14651 Attribute_Name
=> Name_First
);
14652 Y_Last
: constant Node_Id
:=
14653 Make_Attribute_Reference
(Loc
,
14654 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14655 Attribute_Name
=> Name_Last
);
14656 R
: Compare_Result
;
14659 if Present
(Index
(2)) then
14660 Set_Expressions
(Y_First
, New_List
(New_Copy
(Index
(2))));
14661 Set_Expressions
(Y_Last
, New_List
(New_Copy
(Index
(2))));
14667 -- If X'First = Y'First, simplify the above formula into a
14668 -- direct comparison of Y'Last and X'Last.
14670 R
:= Compile_Time_Compare
(Left
, Y_First
, Assume_Valid
=> True);
14676 R
:= Compile_Time_Compare
14677 (Right
, Y_Last
, Assume_Valid
=> True);
14679 -- If the pairs of attributes are equal, we are done
14682 Rewrite_For_Equal_Lengths
;
14686 -- If the base types are different, convert both operands to
14687 -- Long_Long_Integer, else compare them directly.
14689 if Base_Type
(Etype
(Right
)) /= Base_Type
(Etype
(Y_Last
))
14691 Left
:= Convert_To_Long_Long_Integer
(Y_Last
);
14697 -- Otherwise, use the above formula as-is
14703 Convert_To_Long_Long_Integer
(Y_Last
),
14705 Make_Op_Subtract
(Loc
,
14707 Convert_To_Long_Long_Integer
(Left
),
14709 Convert_To_Long_Long_Integer
(Y_First
)));
14713 -- General value case
14718 Left_Opnd
=> Convert_To_Long_Long_Integer
(Left
),
14720 Make_Op_Subtract
(Loc
,
14721 Left_Opnd
=> Convert_To_Long_Long_Integer
(Comp
),
14722 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
14726 -- We cannot do anything in the superflat case past this point
14728 if Maybe_Superflat
then
14732 -- If general operand, convert Last reference to Long_Long_Integer
14734 if Present
(Comp
) then
14735 Right
:= Convert_To_Long_Long_Integer
(Right
);
14738 -- Check for cases to optimize
14740 -- X'Length = 0 => X'First > X'Last
14741 -- X'Length < 1 => X'First > X'Last
14742 -- X'Length < n => X'First + (n - 1) > X'Last
14744 if (Is_Zero
and then Op
= N_Op_Eq
)
14745 or else (not Is_Zero
and then Op
= N_Op_Lt
)
14750 Right_Opnd
=> Right
);
14752 -- X'Length = 1 => X'First = X'Last
14753 -- X'Length = n => X'First + (n - 1) = X'Last
14755 elsif not Is_Zero
and then Op
= N_Op_Eq
then
14759 Right_Opnd
=> Right
);
14761 -- X'Length /= 0 => X'First <= X'Last
14762 -- X'Length > 0 => X'First <= X'Last
14764 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
14768 Right_Opnd
=> Right
);
14770 -- X'Length /= 1 => X'First /= X'Last
14771 -- X'Length /= n => X'First + (n - 1) /= X'Last
14773 elsif not Is_Zero
and then Op
= N_Op_Ne
then
14777 Right_Opnd
=> Right
);
14779 -- X'Length >= 1 => X'First <= X'Last
14780 -- X'Length >= n => X'First + (n - 1) <= X'Last
14782 elsif not Is_Zero
and then Op
= N_Op_Ge
then
14786 Right_Opnd
=> Right
);
14788 -- X'Length > 1 => X'First < X'Last
14789 -- X'Length > n => X'First + (n = 1) < X'Last
14791 elsif not Is_Zero
and then Op
= N_Op_Gt
then
14795 Right_Opnd
=> Right
);
14797 -- X'Length <= 1 => X'First >= X'Last
14798 -- X'Length <= n => X'First + (n - 1) >= X'Last
14800 elsif not Is_Zero
and then Op
= N_Op_Le
then
14804 Right_Opnd
=> Right
);
14806 -- Should not happen at this stage
14809 raise Program_Error
;
14812 -- Rewrite and finish up (we can suppress overflow checks, see above)
14814 Rewrite
(N
, Result
);
14815 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Overflow_Check
);
14816 end Optimize_Length_Comparison
;
14818 --------------------------------
14819 -- Process_If_Case_Statements --
14820 --------------------------------
14822 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
) is
14826 Decl
:= First
(Stmts
);
14827 while Present
(Decl
) loop
14828 if Nkind
(Decl
) = N_Object_Declaration
14829 and then Is_Finalizable_Transient
(Decl
, N
)
14831 Process_Transient_In_Expression
(Decl
, N
, Stmts
);
14836 end Process_If_Case_Statements
;
14838 -------------------------------------
14839 -- Process_Transient_In_Expression --
14840 -------------------------------------
14842 procedure Process_Transient_In_Expression
14843 (Obj_Decl
: Node_Id
;
14847 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
14848 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Obj_Decl
);
14850 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Expr
);
14851 -- The node on which to insert the hook as an action. This is usually
14852 -- the innermost enclosing non-transient construct.
14854 Fin_Call
: Node_Id
;
14855 Hook_Assign
: Node_Id
;
14856 Hook_Clear
: Node_Id
;
14857 Hook_Decl
: Node_Id
;
14858 Hook_Insert
: Node_Id
;
14859 Ptr_Decl
: Node_Id
;
14861 Fin_Context
: Node_Id
;
14862 -- The node after which to insert the finalization actions of the
14863 -- transient object.
14866 pragma Assert
(Nkind
(Expr
) in N_Case_Expression
14867 | N_Expression_With_Actions
14868 | N_If_Expression
);
14870 -- When the context is a Boolean evaluation, all three nodes capture the
14871 -- result of their computation in a local temporary:
14874 -- Trans_Id : Ctrl_Typ := ...;
14875 -- Result : constant Boolean := ... Trans_Id ...;
14876 -- <finalize Trans_Id>
14879 -- As a result, the finalization of any transient objects can safely
14880 -- take place after the result capture.
14882 -- ??? could this be extended to elementary types?
14884 if Is_Boolean_Type
(Etype
(Expr
)) then
14885 Fin_Context
:= Last
(Stmts
);
14887 -- Otherwise the immediate context may not be safe enough to carry
14888 -- out transient object finalization due to aliasing and nesting of
14889 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14890 -- enclosing non-transient construct.
14893 Fin_Context
:= Hook_Context
;
14896 -- Mark the transient object as successfully processed to avoid double
14899 Set_Is_Finalized_Transient
(Obj_Id
);
14901 -- Construct all the pieces necessary to hook and finalize a transient
14904 Build_Transient_Object_Statements
14905 (Obj_Decl
=> Obj_Decl
,
14906 Fin_Call
=> Fin_Call
,
14907 Hook_Assign
=> Hook_Assign
,
14908 Hook_Clear
=> Hook_Clear
,
14909 Hook_Decl
=> Hook_Decl
,
14910 Ptr_Decl
=> Ptr_Decl
,
14911 Finalize_Obj
=> False);
14913 -- Add the access type which provides a reference to the transient
14914 -- object. Generate:
14916 -- type Ptr_Typ is access all Desig_Typ;
14918 Insert_Action
(Hook_Context
, Ptr_Decl
);
14920 -- Add the temporary which acts as a hook to the transient object.
14923 -- Hook : Ptr_Id := null;
14925 Insert_Action
(Hook_Context
, Hook_Decl
);
14927 -- When the transient object is initialized by an aggregate, the hook
14928 -- must capture the object after the last aggregate assignment takes
14929 -- place. Only then is the object considered initialized. Generate:
14931 -- Hook := Ptr_Typ (Obj_Id);
14933 -- Hook := Obj_Id'Unrestricted_Access;
14935 if Ekind
(Obj_Id
) in E_Constant | E_Variable
14936 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
14938 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
14940 -- Otherwise the hook seizes the related object immediately
14943 Hook_Insert
:= Obj_Decl
;
14946 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
14948 -- When the node is part of a return statement, there is no need to
14949 -- insert a finalization call, as the general finalization mechanism
14950 -- (see Build_Finalizer) would take care of the transient object on
14951 -- subprogram exit. Note that it would also be impossible to insert the
14952 -- finalization code after the return statement as this will render it
14955 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
14958 -- Finalize the hook after the context has been evaluated. Generate:
14960 -- if Hook /= null then
14961 -- [Deep_]Finalize (Hook.all);
14966 Insert_Action_After
(Fin_Context
,
14967 Make_Implicit_If_Statement
(Obj_Decl
,
14971 New_Occurrence_Of
(Defining_Entity
(Hook_Decl
), Loc
),
14972 Right_Opnd
=> Make_Null
(Loc
)),
14974 Then_Statements
=> New_List
(
14978 end Process_Transient_In_Expression
;
14980 ------------------------
14981 -- Rewrite_Comparison --
14982 ------------------------
14984 procedure Rewrite_Comparison
(N
: Node_Id
) is
14985 Typ
: constant Entity_Id
:= Etype
(N
);
14987 False_Result
: Boolean;
14988 True_Result
: Boolean;
14991 if Nkind
(N
) = N_Type_Conversion
then
14992 Rewrite_Comparison
(Expression
(N
));
14995 elsif Nkind
(N
) not in N_Op_Compare
then
14999 -- Determine the potential outcome of the comparison assuming that the
15000 -- operands are valid and emit a warning when the comparison evaluates
15001 -- to True or False only in the presence of invalid values.
15003 Warn_On_Constant_Valid_Condition
(N
);
15005 -- Determine the potential outcome of the comparison assuming that the
15006 -- operands are not valid.
15010 Assume_Valid
=> False,
15011 True_Result
=> True_Result
,
15012 False_Result
=> False_Result
);
15014 -- The outcome is a decisive False or True, rewrite the operator
15016 if False_Result
or True_Result
then
15019 New_Occurrence_Of
(Boolean_Literals
(True_Result
), Sloc
(N
))));
15021 Analyze_And_Resolve
(N
, Typ
);
15022 Warn_On_Known_Condition
(N
);
15024 end Rewrite_Comparison
;
15026 ----------------------------
15027 -- Safe_In_Place_Array_Op --
15028 ----------------------------
15030 function Safe_In_Place_Array_Op
15033 Op2
: Node_Id
) return Boolean
15035 Target
: Entity_Id
;
15037 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
15038 -- Operand is safe if it cannot overlap part of the target of the
15039 -- operation. If the operand and the target are identical, the operand
15040 -- is safe. The operand can be empty in the case of negation.
15042 function Is_Unaliased
(N
: Node_Id
) return Boolean;
15043 -- Check that N is a stand-alone entity
15049 function Is_Unaliased
(N
: Node_Id
) return Boolean is
15053 and then No
(Address_Clause
(Entity
(N
)))
15054 and then No
(Renamed_Object
(Entity
(N
)));
15057 ---------------------
15058 -- Is_Safe_Operand --
15059 ---------------------
15061 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
15066 elsif Is_Entity_Name
(Op
) then
15067 return Is_Unaliased
(Op
);
15069 elsif Nkind
(Op
) in N_Indexed_Component | N_Selected_Component
then
15070 return Is_Unaliased
(Prefix
(Op
));
15072 elsif Nkind
(Op
) = N_Slice
then
15074 Is_Unaliased
(Prefix
(Op
))
15075 and then Entity
(Prefix
(Op
)) /= Target
;
15077 elsif Nkind
(Op
) = N_Op_Not
then
15078 return Is_Safe_Operand
(Right_Opnd
(Op
));
15083 end Is_Safe_Operand
;
15085 -- Start of processing for Safe_In_Place_Array_Op
15088 -- Skip this processing if the component size is different from system
15089 -- storage unit (since at least for NOT this would cause problems).
15091 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
15094 -- Cannot do in place stuff if non-standard Boolean representation
15096 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
15099 elsif not Is_Unaliased
(Lhs
) then
15103 Target
:= Entity
(Lhs
);
15104 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
15106 end Safe_In_Place_Array_Op
;
15108 -----------------------
15109 -- Tagged_Membership --
15110 -----------------------
15112 -- There are two different cases to consider depending on whether the right
15113 -- operand is a class-wide type or not. If not we just compare the actual
15114 -- tag of the left expr to the target type tag:
15116 -- Left_Expr.Tag = Right_Type'Tag;
15118 -- If it is a class-wide type we use the RT function CW_Membership which is
15119 -- usually implemented by looking in the ancestor tables contained in the
15120 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
15122 -- In both cases if Left_Expr is an access type, we first check whether it
15125 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
15126 -- function IW_Membership which is usually implemented by looking in the
15127 -- table of abstract interface types plus the ancestor table contained in
15128 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
15130 procedure Tagged_Membership
15132 SCIL_Node
: out Node_Id
;
15133 Result
: out Node_Id
)
15135 Left
: constant Node_Id
:= Left_Opnd
(N
);
15136 Right
: constant Node_Id
:= Right_Opnd
(N
);
15137 Loc
: constant Source_Ptr
:= Sloc
(N
);
15139 -- Handle entities from the limited view
15141 Orig_Right_Type
: constant Entity_Id
:= Available_View
(Etype
(Right
));
15143 Full_R_Typ
: Entity_Id
;
15144 Left_Type
: Entity_Id
:= Available_View
(Etype
(Left
));
15145 Right_Type
: Entity_Id
:= Orig_Right_Type
;
15149 SCIL_Node
:= Empty
;
15151 -- In the case where the type is an access type, the test is applied
15152 -- using the designated types (needed in Ada 2012 for implicit anonymous
15153 -- access conversions, for AI05-0149).
15155 if Is_Access_Type
(Right_Type
) then
15156 Left_Type
:= Designated_Type
(Left_Type
);
15157 Right_Type
:= Designated_Type
(Right_Type
);
15160 if Is_Class_Wide_Type
(Left_Type
) then
15161 Left_Type
:= Root_Type
(Left_Type
);
15164 if Is_Class_Wide_Type
(Right_Type
) then
15165 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
15167 Full_R_Typ
:= Underlying_Type
(Right_Type
);
15171 Make_Selected_Component
(Loc
,
15172 Prefix
=> Relocate_Node
(Left
),
15174 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
15176 if Is_Class_Wide_Type
(Right_Type
) or else Is_Interface
(Left_Type
) then
15178 -- No need to issue a run-time check if we statically know that the
15179 -- result of this membership test is always true. For example,
15180 -- considering the following declarations:
15182 -- type Iface is interface;
15183 -- type T is tagged null record;
15184 -- type DT is new T and Iface with null record;
15189 -- These membership tests are always true:
15192 -- Obj2 in T'Class;
15193 -- Obj2 in Iface'Class;
15195 -- We do not need to handle cases where the membership is illegal.
15198 -- Obj1 in DT'Class; -- Compile time error
15199 -- Obj1 in Iface'Class; -- Compile time error
15201 if not Is_Interface
(Left_Type
)
15202 and then not Is_Class_Wide_Type
(Left_Type
)
15203 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
15204 Use_Full_View
=> True)
15205 or else (Is_Interface
(Etype
(Right_Type
))
15206 and then Interface_Present_In_Ancestor
15208 Iface
=> Etype
(Right_Type
))))
15210 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
15214 -- Ada 2005 (AI-251): Class-wide applied to interfaces
15216 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
15218 -- Support to: "Iface_CW_Typ in Typ'Class"
15220 or else Is_Interface
(Left_Type
)
15222 -- Issue error if IW_Membership operation not available in a
15223 -- configurable run-time setting.
15225 if not RTE_Available
(RE_IW_Membership
) then
15227 ("dynamic membership test on interface types", N
);
15233 Make_Function_Call
(Loc
,
15234 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
15235 Parameter_Associations
=> New_List
(
15236 Make_Attribute_Reference
(Loc
,
15238 Attribute_Name
=> Name_Address
),
15239 New_Occurrence_Of
(
15240 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15243 -- Ada 95: Normal case
15246 -- Issue error if CW_Membership operation not available in a
15247 -- configurable run-time setting.
15249 if not RTE_Available
(RE_CW_Membership
) then
15251 ("dynamic membership test on tagged types", N
);
15257 Make_Function_Call
(Loc
,
15258 Name
=> New_Occurrence_Of
(RTE
(RE_CW_Membership
), Loc
),
15259 Parameter_Associations
=> New_List
(
15261 New_Occurrence_Of
(
15262 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15265 -- Generate the SCIL node for this class-wide membership test.
15267 if Generate_SCIL
then
15268 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
15269 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
15270 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
15274 -- Right_Type is not a class-wide type
15277 -- No need to check the tag of the object if Right_Typ is abstract
15279 if Is_Abstract_Type
(Right_Type
) then
15280 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
15285 Left_Opnd
=> Obj_Tag
,
15288 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
15292 -- if Left is an access object then generate test of the form:
15293 -- * if Right_Type excludes null: Left /= null and then ...
15294 -- * if Right_Type includes null: Left = null or else ...
15296 if Is_Access_Type
(Orig_Right_Type
) then
15297 if Can_Never_Be_Null
(Orig_Right_Type
) then
15298 Result
:= Make_And_Then
(Loc
,
15302 Right_Opnd
=> Make_Null
(Loc
)),
15303 Right_Opnd
=> Result
);
15306 Result
:= Make_Or_Else
(Loc
,
15310 Right_Opnd
=> Make_Null
(Loc
)),
15311 Right_Opnd
=> Result
);
15314 end Tagged_Membership
;
15316 ------------------------------
15317 -- Unary_Op_Validity_Checks --
15318 ------------------------------
15320 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
15322 if Validity_Checks_On
and Validity_Check_Operands
then
15323 Ensure_Valid
(Right_Opnd
(N
));
15325 end Unary_Op_Validity_Checks
;