1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, 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_Ch2
; use Exp_Ch2
;
35 with Exp_Ch3
; use Exp_Ch3
;
36 with Exp_Ch6
; use Exp_Ch6
;
37 with Exp_Ch7
; use Exp_Ch7
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Disp
; use Exp_Disp
;
40 with Exp_Fixd
; use Exp_Fixd
;
41 with Exp_Intr
; use Exp_Intr
;
42 with Exp_Pakd
; use Exp_Pakd
;
43 with Exp_Tss
; use Exp_Tss
;
44 with Exp_Util
; use Exp_Util
;
45 with Freeze
; use Freeze
;
46 with Inline
; use Inline
;
47 with Namet
; use Namet
;
48 with Nlists
; use Nlists
;
49 with Nmake
; use Nmake
;
51 with Par_SCO
; use Par_SCO
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Cat
; use Sem_Cat
;
58 with Sem_Ch3
; use Sem_Ch3
;
59 with Sem_Ch13
; use Sem_Ch13
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Res
; use Sem_Res
;
62 with Sem_Type
; use Sem_Type
;
63 with Sem_Util
; use Sem_Util
;
64 with Sem_Warn
; use Sem_Warn
;
65 with Sinfo
; use Sinfo
;
66 with Snames
; use Snames
;
67 with Stand
; use Stand
;
68 with SCIL_LL
; use SCIL_LL
;
69 with Targparm
; use Targparm
;
70 with Tbuild
; use Tbuild
;
71 with Ttypes
; use Ttypes
;
72 with Uintp
; use Uintp
;
73 with Urealp
; use Urealp
;
74 with Validsw
; use Validsw
;
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 or an aggregate.
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 Optimize_Length_Comparison
(N
: Node_Id
);
227 -- Given an expression, if it is of the form X'Length op N (or the other
228 -- way round), where N is known at compile time to be 0 or 1, and X is a
229 -- simple entity, and op is a comparison operator, optimizes it into a
230 -- comparison of First and Last.
232 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
);
233 -- Inspect and process statement list Stmt of if or case expression N for
234 -- transient objects. If such objects are found, the routine generates code
235 -- to clean them up when the context of the expression is evaluated.
237 procedure Process_Transient_In_Expression
241 -- Subsidiary routine to the expansion of expression_with_actions, if and
242 -- case expressions. Generate all necessary code to finalize a transient
243 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
244 -- denotes the declaration of the transient object, which is usually the
245 -- result of a controlled function call. Expr denotes the expression with
246 -- actions, if expression, or case expression node. Stmts denotes the
247 -- statement list which contains Decl, either at the top level or within a
250 procedure Rewrite_Comparison
(N
: Node_Id
);
251 -- If N is the node for a comparison whose outcome can be determined at
252 -- compile time, then the node N can be rewritten with True or False. If
253 -- the outcome cannot be determined at compile time, the call has no
254 -- effect. If N is a type conversion, then this processing is applied to
255 -- its expression. If N is neither comparison nor a type conversion, the
256 -- call has no effect.
258 procedure Tagged_Membership
260 SCIL_Node
: out Node_Id
;
261 Result
: out Node_Id
);
262 -- Construct the expression corresponding to the tagged membership test.
263 -- Deals with a second operand being (or not) a class-wide type.
265 function Safe_In_Place_Array_Op
268 Op2
: Node_Id
) return Boolean;
269 -- In the context of an assignment, where the right-hand side is a boolean
270 -- operation on arrays, check whether operation can be performed in place.
272 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
273 pragma Inline
(Unary_Op_Validity_Checks
);
274 -- Performs validity checks for a unary operator
276 -------------------------------
277 -- Binary_Op_Validity_Checks --
278 -------------------------------
280 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
282 if Validity_Checks_On
and Validity_Check_Operands
then
283 Ensure_Valid
(Left_Opnd
(N
));
284 Ensure_Valid
(Right_Opnd
(N
));
286 end Binary_Op_Validity_Checks
;
288 ------------------------------------
289 -- Build_Boolean_Array_Proc_Call --
290 ------------------------------------
292 procedure Build_Boolean_Array_Proc_Call
297 Loc
: constant Source_Ptr
:= Sloc
(N
);
298 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
299 Target
: constant Node_Id
:=
300 Make_Attribute_Reference
(Loc
,
302 Attribute_Name
=> Name_Address
);
304 Arg1
: Node_Id
:= Op1
;
305 Arg2
: Node_Id
:= Op2
;
307 Proc_Name
: Entity_Id
;
310 if Kind
= N_Op_Not
then
311 if Nkind
(Op1
) in N_Binary_Op
then
313 -- Use negated version of the binary operators
315 if Nkind
(Op1
) = N_Op_And
then
316 Proc_Name
:= RTE
(RE_Vector_Nand
);
318 elsif Nkind
(Op1
) = N_Op_Or
then
319 Proc_Name
:= RTE
(RE_Vector_Nor
);
321 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
322 Proc_Name
:= RTE
(RE_Vector_Xor
);
326 Make_Procedure_Call_Statement
(Loc
,
327 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
329 Parameter_Associations
=> New_List
(
331 Make_Attribute_Reference
(Loc
,
332 Prefix
=> Left_Opnd
(Op1
),
333 Attribute_Name
=> Name_Address
),
335 Make_Attribute_Reference
(Loc
,
336 Prefix
=> Right_Opnd
(Op1
),
337 Attribute_Name
=> Name_Address
),
339 Make_Attribute_Reference
(Loc
,
340 Prefix
=> Left_Opnd
(Op1
),
341 Attribute_Name
=> Name_Length
)));
344 Proc_Name
:= RTE
(RE_Vector_Not
);
347 Make_Procedure_Call_Statement
(Loc
,
348 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
349 Parameter_Associations
=> New_List
(
352 Make_Attribute_Reference
(Loc
,
354 Attribute_Name
=> Name_Address
),
356 Make_Attribute_Reference
(Loc
,
358 Attribute_Name
=> Name_Length
)));
362 -- We use the following equivalences:
364 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
365 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
366 -- (not X) xor (not Y) = X xor Y
367 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
369 if Nkind
(Op1
) = N_Op_Not
then
370 Arg1
:= Right_Opnd
(Op1
);
371 Arg2
:= Right_Opnd
(Op2
);
373 if Kind
= N_Op_And
then
374 Proc_Name
:= RTE
(RE_Vector_Nor
);
375 elsif Kind
= N_Op_Or
then
376 Proc_Name
:= RTE
(RE_Vector_Nand
);
378 Proc_Name
:= RTE
(RE_Vector_Xor
);
382 if Kind
= N_Op_And
then
383 Proc_Name
:= RTE
(RE_Vector_And
);
384 elsif Kind
= N_Op_Or
then
385 Proc_Name
:= RTE
(RE_Vector_Or
);
386 elsif Nkind
(Op2
) = N_Op_Not
then
387 Proc_Name
:= RTE
(RE_Vector_Nxor
);
388 Arg2
:= Right_Opnd
(Op2
);
390 Proc_Name
:= RTE
(RE_Vector_Xor
);
395 Make_Procedure_Call_Statement
(Loc
,
396 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
397 Parameter_Associations
=> New_List
(
399 Make_Attribute_Reference
(Loc
,
401 Attribute_Name
=> Name_Address
),
402 Make_Attribute_Reference
(Loc
,
404 Attribute_Name
=> Name_Address
),
405 Make_Attribute_Reference
(Loc
,
407 Attribute_Name
=> Name_Length
)));
410 Rewrite
(N
, Call_Node
);
414 when RE_Not_Available
=>
416 end Build_Boolean_Array_Proc_Call
;
418 --------------------------------
419 -- Displace_Allocator_Pointer --
420 --------------------------------
422 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
423 Loc
: constant Source_Ptr
:= Sloc
(N
);
424 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
430 -- Do nothing in case of VM targets: the virtual machine will handle
431 -- interfaces directly.
433 if not Tagged_Type_Expansion
then
437 pragma Assert
(Nkind
(N
) = N_Identifier
438 and then Nkind
(Orig_Node
) = N_Allocator
);
440 PtrT
:= Etype
(Orig_Node
);
441 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
442 Etyp
:= Etype
(Expression
(Orig_Node
));
444 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
446 -- If the type of the allocator expression is not an interface type
447 -- we can generate code to reference the record component containing
448 -- the pointer to the secondary dispatch table.
450 if not Is_Interface
(Etyp
) then
452 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
455 -- 1) Get access to the allocated object
458 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
462 -- 2) Add the conversion to displace the pointer to reference
463 -- the secondary dispatch table.
465 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
466 Analyze_And_Resolve
(N
, Dtyp
);
468 -- 3) The 'access to the secondary dispatch table will be used
469 -- as the value returned by the allocator.
472 Make_Attribute_Reference
(Loc
,
473 Prefix
=> Relocate_Node
(N
),
474 Attribute_Name
=> Name_Access
));
475 Set_Etype
(N
, Saved_Typ
);
479 -- If the type of the allocator expression is an interface type we
480 -- generate a run-time call to displace "this" to reference the
481 -- component containing the pointer to the secondary dispatch table
482 -- or else raise Constraint_Error if the actual object does not
483 -- implement the target interface. This case corresponds to the
484 -- following example:
486 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
488 -- return new Iface_2'Class'(Obj);
493 Unchecked_Convert_To
(PtrT
,
494 Make_Function_Call
(Loc
,
495 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
496 Parameter_Associations
=> New_List
(
497 Unchecked_Convert_To
(RTE
(RE_Address
),
503 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
505 Analyze_And_Resolve
(N
, PtrT
);
508 end Displace_Allocator_Pointer
;
510 ---------------------------------
511 -- Expand_Allocator_Expression --
512 ---------------------------------
514 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
515 Loc
: constant Source_Ptr
:= Sloc
(N
);
516 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
517 PtrT
: constant Entity_Id
:= Etype
(N
);
518 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
520 procedure Apply_Accessibility_Check
522 Built_In_Place
: Boolean := False);
523 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
524 -- type, generate an accessibility check to verify that the level of the
525 -- type of the created object is not deeper than the level of the access
526 -- type. If the type of the qualified expression is class-wide, then
527 -- always generate the check (except in the case where it is known to be
528 -- unnecessary, see comment below). Otherwise, only generate the check
529 -- if the level of the qualified expression type is statically deeper
530 -- than the access type.
532 -- Although the static accessibility will generally have been performed
533 -- as a legality check, it won't have been done in cases where the
534 -- allocator appears in generic body, so a run-time check is needed in
535 -- general. One special case is when the access type is declared in the
536 -- same scope as the class-wide allocator, in which case the check can
537 -- never fail, so it need not be generated.
539 -- As an open issue, there seem to be cases where the static level
540 -- associated with the class-wide object's underlying type is not
541 -- sufficient to perform the proper accessibility check, such as for
542 -- allocators in nested subprograms or accept statements initialized by
543 -- class-wide formals when the actual originates outside at a deeper
544 -- static level. The nested subprogram case might require passing
545 -- accessibility levels along with class-wide parameters, and the task
546 -- case seems to be an actual gap in the language rules that needs to
547 -- be fixed by the ARG. ???
549 -------------------------------
550 -- Apply_Accessibility_Check --
551 -------------------------------
553 procedure Apply_Accessibility_Check
555 Built_In_Place
: Boolean := False)
557 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
565 if Ada_Version
>= Ada_2005
566 and then Is_Class_Wide_Type
(DesigT
)
567 and then Tagged_Type_Expansion
568 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
570 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
572 (Is_Class_Wide_Type
(Etype
(Exp
))
573 and then Scope
(PtrT
) /= Current_Scope
))
575 -- If the allocator was built in place, Ref is already a reference
576 -- to the access object initialized to the result of the allocator
577 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
578 -- Remove_Side_Effects for cases where the build-in-place call may
579 -- still be the prefix of the reference (to avoid generating
580 -- duplicate calls). Otherwise, it is the entity associated with
581 -- the object containing the address of the allocated object.
583 if Built_In_Place
then
584 Remove_Side_Effects
(Ref
);
585 Obj_Ref
:= New_Copy_Tree
(Ref
);
587 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
590 -- For access to interface types we must generate code to displace
591 -- the pointer to the base of the object since the subsequent code
592 -- references components located in the TSD of the object (which
593 -- is associated with the primary dispatch table --see a-tags.ads)
594 -- and also generates code invoking Free, which requires also a
595 -- reference to the base of the unallocated object.
597 if Is_Interface
(DesigT
) and then Tagged_Type_Expansion
then
599 Unchecked_Convert_To
(Etype
(Obj_Ref
),
600 Make_Function_Call
(Loc
,
602 New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
603 Parameter_Associations
=> New_List
(
604 Unchecked_Convert_To
(RTE
(RE_Address
),
605 New_Copy_Tree
(Obj_Ref
)))));
608 -- Step 1: Create the object clean up code
612 -- Deallocate the object if the accessibility check fails. This
613 -- is done only on targets or profiles that support deallocation.
617 if RTE_Available
(RE_Free
) then
618 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
619 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
621 Append_To
(Stmts
, Free_Stmt
);
623 -- The target or profile cannot deallocate objects
629 -- Finalize the object if applicable. Generate:
631 -- [Deep_]Finalize (Obj_Ref.all);
633 if Needs_Finalization
(DesigT
)
634 and then not No_Heap_Finalization
(PtrT
)
639 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
642 -- Guard against a missing [Deep_]Finalize when the designated
643 -- type was not properly frozen.
645 if No
(Fin_Call
) then
646 Fin_Call
:= Make_Null_Statement
(Loc
);
649 -- When the target or profile supports deallocation, wrap the
650 -- finalization call in a block to ensure proper deallocation
651 -- even if finalization fails. Generate:
661 if Present
(Free_Stmt
) then
663 Make_Block_Statement
(Loc
,
664 Handled_Statement_Sequence
=>
665 Make_Handled_Sequence_Of_Statements
(Loc
,
666 Statements
=> New_List
(Fin_Call
),
668 Exception_Handlers
=> New_List
(
669 Make_Exception_Handler
(Loc
,
670 Exception_Choices
=> New_List
(
671 Make_Others_Choice
(Loc
)),
672 Statements
=> New_List
(
673 New_Copy_Tree
(Free_Stmt
),
674 Make_Raise_Statement
(Loc
))))));
677 Prepend_To
(Stmts
, Fin_Call
);
680 -- Signal the accessibility failure through a Program_Error
683 Make_Raise_Program_Error
(Loc
,
684 Condition
=> New_Occurrence_Of
(Standard_True
, Loc
),
685 Reason
=> PE_Accessibility_Check_Failed
));
687 -- Step 2: Create the accessibility comparison
693 Make_Attribute_Reference
(Loc
,
695 Attribute_Name
=> Name_Tag
);
697 -- For tagged types, determine the accessibility level by looking
698 -- at the type specific data of the dispatch table. Generate:
700 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
702 if Tagged_Type_Expansion
then
703 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
705 -- Use a runtime call to determine the accessibility level when
706 -- compiling on virtual machine targets. Generate:
708 -- Get_Access_Level (Ref'Tag)
712 Make_Function_Call
(Loc
,
714 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
715 Parameter_Associations
=> New_List
(Obj_Ref
));
722 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
724 -- Due to the complexity and side effects of the check, utilize an
725 -- if statement instead of the regular Program_Error circuitry.
728 Make_Implicit_If_Statement
(N
,
730 Then_Statements
=> Stmts
));
732 end Apply_Accessibility_Check
;
736 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
737 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
738 T
: constant Entity_Id
:= Entity
(Indic
);
741 Tag_Assign
: Node_Id
;
745 TagT
: Entity_Id
:= Empty
;
746 -- Type used as source for tag assignment
748 TagR
: Node_Id
:= Empty
;
749 -- Target reference for tag assignment
751 -- Start of processing for Expand_Allocator_Expression
754 -- Handle call to C++ constructor
756 if Is_CPP_Constructor_Call
(Exp
) then
757 Make_CPP_Constructor_Call_In_Allocator
759 Function_Call
=> Exp
);
763 -- In the case of an Ada 2012 allocator whose initial value comes from a
764 -- function call, pass "the accessibility level determined by the point
765 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
766 -- Expand_Call but it couldn't be done there (because the Etype of the
767 -- allocator wasn't set then) so we generate the parameter here. See
768 -- the Boolean variable Defer in (a block within) Expand_Call.
770 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
775 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
776 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
778 Subp
:= Entity
(Name
(Exp
));
781 Subp
:= Ultimate_Alias
(Subp
);
783 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
784 Add_Extra_Actual_To_Call
785 (Subprogram_Call
=> Exp
,
786 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
787 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
792 -- Case of tagged type or type requiring finalization
794 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
796 -- Ada 2005 (AI-318-02): If the initialization expression is a call
797 -- to a build-in-place function, then access to the allocated object
798 -- must be passed to the function.
800 if Is_Build_In_Place_Function_Call
(Exp
) then
801 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
802 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
805 -- Ada 2005 (AI-318-02): Specialization of the previous case for
806 -- expressions containing a build-in-place function call whose
807 -- returned object covers interface types, and Expr has calls to
808 -- Ada.Tags.Displace to displace the pointer to the returned build-
809 -- in-place object to reference the secondary dispatch table of a
810 -- covered interface type.
812 elsif Present
(Unqual_BIP_Iface_Function_Call
(Exp
)) then
813 Make_Build_In_Place_Iface_Call_In_Allocator
(N
, Exp
);
814 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
818 -- Actions inserted before:
819 -- Temp : constant ptr_T := new T'(Expression);
820 -- Temp._tag = T'tag; -- when not class-wide
821 -- [Deep_]Adjust (Temp.all);
823 -- We analyze by hand the new internal allocator to avoid any
824 -- recursion and inappropriate call to Initialize.
826 -- We don't want to remove side effects when the expression must be
827 -- built in place. In the case of a build-in-place function call,
828 -- that could lead to a duplication of the call, which was already
829 -- substituted for the allocator.
831 if not Aggr_In_Place
then
832 Remove_Side_Effects
(Exp
);
835 Temp
:= Make_Temporary
(Loc
, 'P', N
);
837 -- For a class wide allocation generate the following code:
839 -- type Equiv_Record is record ... end record;
840 -- implicit subtype CW is <Class_Wide_Subytpe>;
841 -- temp : PtrT := new CW'(CW!(expr));
843 if Is_Class_Wide_Type
(T
) then
844 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
846 -- Ada 2005 (AI-251): If the expression is a class-wide interface
847 -- object we generate code to move up "this" to reference the
848 -- base of the object before allocating the new object.
850 -- Note that Exp'Address is recursively expanded into a call
851 -- to Base_Address (Exp.Tag)
853 if Is_Class_Wide_Type
(Etype
(Exp
))
854 and then Is_Interface
(Etype
(Exp
))
855 and then Tagged_Type_Expansion
859 Unchecked_Convert_To
(Entity
(Indic
),
860 Make_Explicit_Dereference
(Loc
,
861 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
862 Make_Attribute_Reference
(Loc
,
864 Attribute_Name
=> Name_Address
)))));
868 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
871 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
874 -- Processing for allocators returning non-interface types
876 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
877 if Aggr_In_Place
then
879 Make_Object_Declaration
(Loc
,
880 Defining_Identifier
=> Temp
,
881 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
885 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
887 -- Copy the Comes_From_Source flag for the allocator we just
888 -- built, since logically this allocator is a replacement of
889 -- the original allocator node. This is for proper handling of
890 -- restriction No_Implicit_Heap_Allocations.
892 Set_Comes_From_Source
893 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
895 Set_No_Initialization
(Expression
(Temp_Decl
));
896 Insert_Action
(N
, Temp_Decl
);
898 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
899 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
902 Node
:= Relocate_Node
(N
);
906 Make_Object_Declaration
(Loc
,
907 Defining_Identifier
=> Temp
,
908 Constant_Present
=> True,
909 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
912 Insert_Action
(N
, Temp_Decl
);
913 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
916 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
917 -- interface type. In this case we use the type of the qualified
918 -- expression to allocate the object.
922 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
927 Make_Full_Type_Declaration
(Loc
,
928 Defining_Identifier
=> Def_Id
,
930 Make_Access_To_Object_Definition
(Loc
,
932 Null_Exclusion_Present
=> False,
934 Is_Access_Constant
(Etype
(N
)),
935 Subtype_Indication
=>
936 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
938 Insert_Action
(N
, New_Decl
);
940 -- Inherit the allocation-related attributes from the original
943 Set_Finalization_Master
944 (Def_Id
, Finalization_Master
(PtrT
));
946 Set_Associated_Storage_Pool
947 (Def_Id
, Associated_Storage_Pool
(PtrT
));
949 -- Declare the object using the previous type declaration
951 if Aggr_In_Place
then
953 Make_Object_Declaration
(Loc
,
954 Defining_Identifier
=> Temp
,
955 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
958 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
960 -- Copy the Comes_From_Source flag for the allocator we just
961 -- built, since logically this allocator is a replacement of
962 -- the original allocator node. This is for proper handling
963 -- of restriction No_Implicit_Heap_Allocations.
965 Set_Comes_From_Source
966 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
968 Set_No_Initialization
(Expression
(Temp_Decl
));
969 Insert_Action
(N
, Temp_Decl
);
971 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
972 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
975 Node
:= Relocate_Node
(N
);
979 Make_Object_Declaration
(Loc
,
980 Defining_Identifier
=> Temp
,
981 Constant_Present
=> True,
982 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
985 Insert_Action
(N
, Temp_Decl
);
986 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
989 -- Generate an additional object containing the address of the
990 -- returned object. The type of this second object declaration
991 -- is the correct type required for the common processing that
992 -- is still performed by this subprogram. The displacement of
993 -- this pointer to reference the component associated with the
994 -- interface type will be done at the end of common processing.
997 Make_Object_Declaration
(Loc
,
998 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
999 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1001 Unchecked_Convert_To
(PtrT
,
1002 New_Occurrence_Of
(Temp
, Loc
)));
1004 Insert_Action
(N
, New_Decl
);
1006 Temp_Decl
:= New_Decl
;
1007 Temp
:= Defining_Identifier
(New_Decl
);
1011 -- Generate the tag assignment
1013 -- Suppress the tag assignment for VM targets because VM tags are
1014 -- represented implicitly in objects.
1016 if not Tagged_Type_Expansion
then
1019 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1020 -- interface objects because in this case the tag does not change.
1022 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1023 pragma Assert
(Is_Class_Wide_Type
1024 (Directly_Designated_Type
(Etype
(N
))));
1027 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1029 TagR
:= New_Occurrence_Of
(Temp
, Loc
);
1031 elsif Is_Private_Type
(T
)
1032 and then Is_Tagged_Type
(Underlying_Type
(T
))
1034 TagT
:= Underlying_Type
(T
);
1036 Unchecked_Convert_To
(Underlying_Type
(T
),
1037 Make_Explicit_Dereference
(Loc
,
1038 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
1041 if Present
(TagT
) then
1043 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1047 Make_Assignment_Statement
(Loc
,
1049 Make_Selected_Component
(Loc
,
1053 (First_Tag_Component
(Full_T
), Loc
)),
1056 Unchecked_Convert_To
(RTE
(RE_Tag
),
1059 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1062 -- The previous assignment has to be done in any case
1064 Set_Assignment_OK
(Name
(Tag_Assign
));
1065 Insert_Action
(N
, Tag_Assign
);
1068 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1069 -- the object may be inherently limited, in which case there is no
1070 -- Adjust procedure, and the object is built in place. In Ada 95, the
1071 -- object can be limited but not inherently limited if this allocator
1072 -- came from a return statement (we're allocating the result on the
1073 -- secondary stack). In that case, the object will be moved, so we do
1074 -- want to Adjust. However, if it's a nonlimited build-in-place
1075 -- function call, Adjust is not wanted.
1077 if Needs_Finalization
(DesigT
)
1078 and then Needs_Finalization
(T
)
1079 and then not Aggr_In_Place
1080 and then not Is_Limited_View
(T
)
1081 and then not Alloc_For_BIP_Return
(N
)
1082 and then not Is_Build_In_Place_Function_Call
(Expression
(N
))
1084 -- An unchecked conversion is needed in the classwide case because
1085 -- the designated type can be an ancestor of the subtype mark of
1091 Unchecked_Convert_To
(T
,
1092 Make_Explicit_Dereference
(Loc
,
1093 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
1096 if Present
(Adj_Call
) then
1097 Insert_Action
(N
, Adj_Call
);
1101 -- Note: the accessibility check must be inserted after the call to
1102 -- [Deep_]Adjust to ensure proper completion of the assignment.
1104 Apply_Accessibility_Check
(Temp
);
1106 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1107 Analyze_And_Resolve
(N
, PtrT
);
1109 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1110 -- component containing the secondary dispatch table of the interface
1113 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1114 Displace_Allocator_Pointer
(N
);
1117 -- Always force the generation of a temporary for aggregates when
1118 -- generating C code, to simplify the work in the code generator.
1121 or else (Modify_Tree_For_C
and then Nkind
(Exp
) = N_Aggregate
)
1123 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1125 Make_Object_Declaration
(Loc
,
1126 Defining_Identifier
=> Temp
,
1127 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1129 Make_Allocator
(Loc
,
1130 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1132 -- Copy the Comes_From_Source flag for the allocator we just built,
1133 -- since logically this allocator is a replacement of the original
1134 -- allocator node. This is for proper handling of restriction
1135 -- No_Implicit_Heap_Allocations.
1137 Set_Comes_From_Source
1138 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1140 Set_No_Initialization
(Expression
(Temp_Decl
));
1141 Insert_Action
(N
, Temp_Decl
);
1143 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1144 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1146 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1147 Analyze_And_Resolve
(N
, PtrT
);
1149 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1150 Install_Null_Excluding_Check
(Exp
);
1152 elsif Is_Access_Type
(DesigT
)
1153 and then Nkind
(Exp
) = N_Allocator
1154 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1156 -- Apply constraint to designated subtype indication
1158 Apply_Constraint_Check
1159 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1161 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1163 -- Propagate constraint_error to enclosing allocator
1165 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1169 Build_Allocate_Deallocate_Proc
(N
, True);
1172 -- type A is access T1;
1173 -- X : A := new T2'(...);
1174 -- T1 and T2 can be different subtypes, and we might need to check
1175 -- both constraints. First check against the type of the qualified
1178 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1180 if Do_Range_Check
(Exp
) then
1181 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1184 -- A check is also needed in cases where the designated subtype is
1185 -- constrained and differs from the subtype given in the qualified
1186 -- expression. Note that the check on the qualified expression does
1187 -- not allow sliding, but this check does (a relaxation from Ada 83).
1189 if Is_Constrained
(DesigT
)
1190 and then not Subtypes_Statically_Match
(T
, DesigT
)
1192 Apply_Constraint_Check
1193 (Exp
, DesigT
, No_Sliding
=> False);
1195 if Do_Range_Check
(Exp
) then
1196 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1200 -- For an access to unconstrained packed array, GIGI needs to see an
1201 -- expression with a constrained subtype in order to compute the
1202 -- proper size for the allocator.
1204 if Is_Array_Type
(T
)
1205 and then not Is_Constrained
(T
)
1206 and then Is_Packed
(T
)
1209 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1210 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1213 Make_Subtype_Declaration
(Loc
,
1214 Defining_Identifier
=> ConstrT
,
1215 Subtype_Indication
=>
1216 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1217 Freeze_Itype
(ConstrT
, Exp
);
1218 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1222 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1223 -- to a build-in-place function, then access to the allocated object
1224 -- must be passed to the function.
1226 if Is_Build_In_Place_Function_Call
(Exp
) then
1227 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1232 when RE_Not_Available
=>
1234 end Expand_Allocator_Expression
;
1236 -----------------------------
1237 -- Expand_Array_Comparison --
1238 -----------------------------
1240 -- Expansion is only required in the case of array types. For the unpacked
1241 -- case, an appropriate runtime routine is called. For packed cases, and
1242 -- also in some other cases where a runtime routine cannot be called, the
1243 -- form of the expansion is:
1245 -- [body for greater_nn; boolean_expression]
1247 -- The body is built by Make_Array_Comparison_Op, and the form of the
1248 -- Boolean expression depends on the operator involved.
1250 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1251 Loc
: constant Source_Ptr
:= Sloc
(N
);
1252 Op1
: Node_Id
:= Left_Opnd
(N
);
1253 Op2
: Node_Id
:= Right_Opnd
(N
);
1254 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1255 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1258 Func_Body
: Node_Id
;
1259 Func_Name
: Entity_Id
;
1263 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1264 -- True for byte addressable target
1266 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1267 -- Returns True if the length of the given operand is known to be less
1268 -- than 4. Returns False if this length is known to be four or greater
1269 -- or is not known at compile time.
1271 ------------------------
1272 -- Length_Less_Than_4 --
1273 ------------------------
1275 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1276 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1279 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1280 return String_Literal_Length
(Otyp
) < 4;
1284 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1285 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1286 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1291 if Compile_Time_Known_Value
(Lo
) then
1292 Lov
:= Expr_Value
(Lo
);
1297 if Compile_Time_Known_Value
(Hi
) then
1298 Hiv
:= Expr_Value
(Hi
);
1303 return Hiv
< Lov
+ 3;
1306 end Length_Less_Than_4
;
1308 -- Start of processing for Expand_Array_Comparison
1311 -- Deal first with unpacked case, where we can call a runtime routine
1312 -- except that we avoid this for targets for which are not addressable
1315 if not Is_Bit_Packed_Array
(Typ1
)
1316 and then Byte_Addressable
1318 -- The call we generate is:
1320 -- Compare_Array_xn[_Unaligned]
1321 -- (left'address, right'address, left'length, right'length) <op> 0
1323 -- x = U for unsigned, S for signed
1324 -- n = 8,16,32,64 for component size
1325 -- Add _Unaligned if length < 4 and component size is 8.
1326 -- <op> is the standard comparison operator
1328 if Component_Size
(Typ1
) = 8 then
1329 if Length_Less_Than_4
(Op1
)
1331 Length_Less_Than_4
(Op2
)
1333 if Is_Unsigned_Type
(Ctyp
) then
1334 Comp
:= RE_Compare_Array_U8_Unaligned
;
1336 Comp
:= RE_Compare_Array_S8_Unaligned
;
1340 if Is_Unsigned_Type
(Ctyp
) then
1341 Comp
:= RE_Compare_Array_U8
;
1343 Comp
:= RE_Compare_Array_S8
;
1347 elsif Component_Size
(Typ1
) = 16 then
1348 if Is_Unsigned_Type
(Ctyp
) then
1349 Comp
:= RE_Compare_Array_U16
;
1351 Comp
:= RE_Compare_Array_S16
;
1354 elsif Component_Size
(Typ1
) = 32 then
1355 if Is_Unsigned_Type
(Ctyp
) then
1356 Comp
:= RE_Compare_Array_U32
;
1358 Comp
:= RE_Compare_Array_S32
;
1361 else pragma Assert
(Component_Size
(Typ1
) = 64);
1362 if Is_Unsigned_Type
(Ctyp
) then
1363 Comp
:= RE_Compare_Array_U64
;
1365 Comp
:= RE_Compare_Array_S64
;
1369 if RTE_Available
(Comp
) then
1371 -- Expand to a call only if the runtime function is available,
1372 -- otherwise fall back to inline code.
1374 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1375 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1378 Make_Function_Call
(Sloc
(Op1
),
1379 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1381 Parameter_Associations
=> New_List
(
1382 Make_Attribute_Reference
(Loc
,
1383 Prefix
=> Relocate_Node
(Op1
),
1384 Attribute_Name
=> Name_Address
),
1386 Make_Attribute_Reference
(Loc
,
1387 Prefix
=> Relocate_Node
(Op2
),
1388 Attribute_Name
=> Name_Address
),
1390 Make_Attribute_Reference
(Loc
,
1391 Prefix
=> Relocate_Node
(Op1
),
1392 Attribute_Name
=> Name_Length
),
1394 Make_Attribute_Reference
(Loc
,
1395 Prefix
=> Relocate_Node
(Op2
),
1396 Attribute_Name
=> Name_Length
))));
1399 Make_Integer_Literal
(Sloc
(Op2
),
1402 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1403 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1408 -- Cases where we cannot make runtime call
1410 -- For (a <= b) we convert to not (a > b)
1412 if Chars
(N
) = Name_Op_Le
then
1418 Right_Opnd
=> Op2
)));
1419 Analyze_And_Resolve
(N
, Standard_Boolean
);
1422 -- For < the Boolean expression is
1423 -- greater__nn (op2, op1)
1425 elsif Chars
(N
) = Name_Op_Lt
then
1426 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1430 Op1
:= Right_Opnd
(N
);
1431 Op2
:= Left_Opnd
(N
);
1433 -- For (a >= b) we convert to not (a < b)
1435 elsif Chars
(N
) = Name_Op_Ge
then
1441 Right_Opnd
=> Op2
)));
1442 Analyze_And_Resolve
(N
, Standard_Boolean
);
1445 -- For > the Boolean expression is
1446 -- greater__nn (op1, op2)
1449 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1450 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1453 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1455 Make_Function_Call
(Loc
,
1456 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1457 Parameter_Associations
=> New_List
(Op1
, Op2
));
1459 Insert_Action
(N
, Func_Body
);
1461 Analyze_And_Resolve
(N
, Standard_Boolean
);
1462 end Expand_Array_Comparison
;
1464 ---------------------------
1465 -- Expand_Array_Equality --
1466 ---------------------------
1468 -- Expand an equality function for multi-dimensional arrays. Here is an
1469 -- example of such a function for Nb_Dimension = 2
1471 -- function Enn (A : atyp; B : btyp) return boolean is
1473 -- if (A'length (1) = 0 or else A'length (2) = 0)
1475 -- (B'length (1) = 0 or else B'length (2) = 0)
1477 -- return True; -- RM 4.5.2(22)
1480 -- if A'length (1) /= B'length (1)
1482 -- A'length (2) /= B'length (2)
1484 -- return False; -- RM 4.5.2(23)
1488 -- A1 : Index_T1 := A'first (1);
1489 -- B1 : Index_T1 := B'first (1);
1493 -- A2 : Index_T2 := A'first (2);
1494 -- B2 : Index_T2 := B'first (2);
1497 -- if A (A1, A2) /= B (B1, B2) then
1501 -- exit when A2 = A'last (2);
1502 -- A2 := Index_T2'succ (A2);
1503 -- B2 := Index_T2'succ (B2);
1507 -- exit when A1 = A'last (1);
1508 -- A1 := Index_T1'succ (A1);
1509 -- B1 := Index_T1'succ (B1);
1516 -- Note on the formal types used (atyp and btyp). If either of the arrays
1517 -- is of a private type, we use the underlying type, and do an unchecked
1518 -- conversion of the actual. If either of the arrays has a bound depending
1519 -- on a discriminant, then we use the base type since otherwise we have an
1520 -- escaped discriminant in the function.
1522 -- If both arrays are constrained and have the same bounds, we can generate
1523 -- a loop with an explicit iteration scheme using a 'Range attribute over
1526 function Expand_Array_Equality
1531 Typ
: Entity_Id
) return Node_Id
1533 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1534 Decls
: constant List_Id
:= New_List
;
1535 Index_List1
: constant List_Id
:= New_List
;
1536 Index_List2
: constant List_Id
:= New_List
;
1540 Func_Name
: Entity_Id
;
1541 Func_Body
: Node_Id
;
1543 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1544 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1548 -- The parameter types to be used for the formals
1553 Num
: Int
) return Node_Id
;
1554 -- This builds the attribute reference Arr'Nam (Expr)
1556 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1557 -- Create one statement to compare corresponding components, designated
1558 -- by a full set of indexes.
1560 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1561 -- Given one of the arguments, computes the appropriate type to be used
1562 -- for that argument in the corresponding function formal
1564 function Handle_One_Dimension
1566 Index
: Node_Id
) return Node_Id
;
1567 -- This procedure returns the following code
1570 -- Bn : Index_T := B'First (N);
1574 -- exit when An = A'Last (N);
1575 -- An := Index_T'Succ (An)
1576 -- Bn := Index_T'Succ (Bn)
1580 -- If both indexes are constrained and identical, the procedure
1581 -- returns a simpler loop:
1583 -- for An in A'Range (N) loop
1587 -- N is the dimension for which we are generating a loop. Index is the
1588 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1589 -- xxx statement is either the loop or declare for the next dimension
1590 -- or if this is the last dimension the comparison of corresponding
1591 -- components of the arrays.
1593 -- The actual way the code works is to return the comparison of
1594 -- corresponding components for the N+1 call. That's neater.
1596 function Test_Empty_Arrays
return Node_Id
;
1597 -- This function constructs the test for both arrays being empty
1598 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1600 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1602 function Test_Lengths_Correspond
return Node_Id
;
1603 -- This function constructs the test for arrays having different lengths
1604 -- in at least one index position, in which case the resulting code is:
1606 -- A'length (1) /= B'length (1)
1608 -- A'length (2) /= B'length (2)
1619 Num
: Int
) return Node_Id
1623 Make_Attribute_Reference
(Loc
,
1624 Attribute_Name
=> Nam
,
1625 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1626 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1629 ------------------------
1630 -- Component_Equality --
1631 ------------------------
1633 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1638 -- if a(i1...) /= b(j1...) then return false; end if;
1641 Make_Indexed_Component
(Loc
,
1642 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1643 Expressions
=> Index_List1
);
1646 Make_Indexed_Component
(Loc
,
1647 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1648 Expressions
=> Index_List2
);
1650 Test
:= Expand_Composite_Equality
1651 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1653 -- If some (sub)component is an unchecked_union, the whole operation
1654 -- will raise program error.
1656 if Nkind
(Test
) = N_Raise_Program_Error
then
1658 -- This node is going to be inserted at a location where a
1659 -- statement is expected: clear its Etype so analysis will set
1660 -- it to the expected Standard_Void_Type.
1662 Set_Etype
(Test
, Empty
);
1667 Make_Implicit_If_Statement
(Nod
,
1668 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1669 Then_Statements
=> New_List
(
1670 Make_Simple_Return_Statement
(Loc
,
1671 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1673 end Component_Equality
;
1679 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1690 T
:= Underlying_Type
(T
);
1692 X
:= First_Index
(T
);
1693 while Present
(X
) loop
1694 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1696 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1709 --------------------------
1710 -- Handle_One_Dimension --
1711 ---------------------------
1713 function Handle_One_Dimension
1715 Index
: Node_Id
) return Node_Id
1717 Need_Separate_Indexes
: constant Boolean :=
1718 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1719 -- If the index types are identical, and we are working with
1720 -- constrained types, then we can use the same index for both
1723 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1726 Index_T
: Entity_Id
;
1731 if N
> Number_Dimensions
(Ltyp
) then
1732 return Component_Equality
(Ltyp
);
1735 -- Case where we generate a loop
1737 Index_T
:= Base_Type
(Etype
(Index
));
1739 if Need_Separate_Indexes
then
1740 Bn
:= Make_Temporary
(Loc
, 'B');
1745 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1746 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1748 Stm_List
:= New_List
(
1749 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1751 if Need_Separate_Indexes
then
1753 -- Generate guard for loop, followed by increments of indexes
1755 Append_To
(Stm_List
,
1756 Make_Exit_Statement
(Loc
,
1759 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1760 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1762 Append_To
(Stm_List
,
1763 Make_Assignment_Statement
(Loc
,
1764 Name
=> New_Occurrence_Of
(An
, Loc
),
1766 Make_Attribute_Reference
(Loc
,
1767 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1768 Attribute_Name
=> Name_Succ
,
1769 Expressions
=> New_List
(
1770 New_Occurrence_Of
(An
, Loc
)))));
1772 Append_To
(Stm_List
,
1773 Make_Assignment_Statement
(Loc
,
1774 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1776 Make_Attribute_Reference
(Loc
,
1777 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1778 Attribute_Name
=> Name_Succ
,
1779 Expressions
=> New_List
(
1780 New_Occurrence_Of
(Bn
, Loc
)))));
1783 -- If separate indexes, we need a declare block for An and Bn, and a
1784 -- loop without an iteration scheme.
1786 if Need_Separate_Indexes
then
1788 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1791 Make_Block_Statement
(Loc
,
1792 Declarations
=> New_List
(
1793 Make_Object_Declaration
(Loc
,
1794 Defining_Identifier
=> An
,
1795 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1796 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1798 Make_Object_Declaration
(Loc
,
1799 Defining_Identifier
=> Bn
,
1800 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1801 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1803 Handled_Statement_Sequence
=>
1804 Make_Handled_Sequence_Of_Statements
(Loc
,
1805 Statements
=> New_List
(Loop_Stm
)));
1807 -- If no separate indexes, return loop statement with explicit
1808 -- iteration scheme on its own
1812 Make_Implicit_Loop_Statement
(Nod
,
1813 Statements
=> Stm_List
,
1815 Make_Iteration_Scheme
(Loc
,
1816 Loop_Parameter_Specification
=>
1817 Make_Loop_Parameter_Specification
(Loc
,
1818 Defining_Identifier
=> An
,
1819 Discrete_Subtype_Definition
=>
1820 Arr_Attr
(A
, Name_Range
, N
))));
1823 end Handle_One_Dimension
;
1825 -----------------------
1826 -- Test_Empty_Arrays --
1827 -----------------------
1829 function Test_Empty_Arrays
return Node_Id
is
1839 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1842 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1843 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1847 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1848 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1857 Left_Opnd
=> Relocate_Node
(Alist
),
1858 Right_Opnd
=> Atest
);
1862 Left_Opnd
=> Relocate_Node
(Blist
),
1863 Right_Opnd
=> Btest
);
1870 Right_Opnd
=> Blist
);
1871 end Test_Empty_Arrays
;
1873 -----------------------------
1874 -- Test_Lengths_Correspond --
1875 -----------------------------
1877 function Test_Lengths_Correspond
return Node_Id
is
1883 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1886 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1887 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
1894 Left_Opnd
=> Relocate_Node
(Result
),
1895 Right_Opnd
=> Rtest
);
1900 end Test_Lengths_Correspond
;
1902 -- Start of processing for Expand_Array_Equality
1905 Ltyp
:= Get_Arg_Type
(Lhs
);
1906 Rtyp
:= Get_Arg_Type
(Rhs
);
1908 -- For now, if the argument types are not the same, go to the base type,
1909 -- since the code assumes that the formals have the same type. This is
1910 -- fixable in future ???
1912 if Ltyp
/= Rtyp
then
1913 Ltyp
:= Base_Type
(Ltyp
);
1914 Rtyp
:= Base_Type
(Rtyp
);
1915 pragma Assert
(Ltyp
= Rtyp
);
1918 -- Build list of formals for function
1920 Formals
:= New_List
(
1921 Make_Parameter_Specification
(Loc
,
1922 Defining_Identifier
=> A
,
1923 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
1925 Make_Parameter_Specification
(Loc
,
1926 Defining_Identifier
=> B
,
1927 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
1929 Func_Name
:= Make_Temporary
(Loc
, 'E');
1931 -- Build statement sequence for function
1934 Make_Subprogram_Body
(Loc
,
1936 Make_Function_Specification
(Loc
,
1937 Defining_Unit_Name
=> Func_Name
,
1938 Parameter_Specifications
=> Formals
,
1939 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1941 Declarations
=> Decls
,
1943 Handled_Statement_Sequence
=>
1944 Make_Handled_Sequence_Of_Statements
(Loc
,
1945 Statements
=> New_List
(
1947 Make_Implicit_If_Statement
(Nod
,
1948 Condition
=> Test_Empty_Arrays
,
1949 Then_Statements
=> New_List
(
1950 Make_Simple_Return_Statement
(Loc
,
1952 New_Occurrence_Of
(Standard_True
, Loc
)))),
1954 Make_Implicit_If_Statement
(Nod
,
1955 Condition
=> Test_Lengths_Correspond
,
1956 Then_Statements
=> New_List
(
1957 Make_Simple_Return_Statement
(Loc
,
1958 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
1960 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
1962 Make_Simple_Return_Statement
(Loc
,
1963 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1965 Set_Has_Completion
(Func_Name
, True);
1966 Set_Is_Inlined
(Func_Name
);
1968 -- If the array type is distinct from the type of the arguments, it
1969 -- is the full view of a private type. Apply an unchecked conversion
1970 -- to insure that analysis of the call succeeds.
1980 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1982 L
:= OK_Convert_To
(Ltyp
, Lhs
);
1986 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1988 R
:= OK_Convert_To
(Rtyp
, Rhs
);
1991 Actuals
:= New_List
(L
, R
);
1994 Append_To
(Bodies
, Func_Body
);
1997 Make_Function_Call
(Loc
,
1998 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1999 Parameter_Associations
=> Actuals
);
2000 end Expand_Array_Equality
;
2002 -----------------------------
2003 -- Expand_Boolean_Operator --
2004 -----------------------------
2006 -- Note that we first get the actual subtypes of the operands, since we
2007 -- always want to deal with types that have bounds.
2009 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2010 Typ
: constant Entity_Id
:= Etype
(N
);
2013 -- Special case of bit packed array where both operands are known to be
2014 -- properly aligned. In this case we use an efficient run time routine
2015 -- to carry out the operation (see System.Bit_Ops).
2017 if Is_Bit_Packed_Array
(Typ
)
2018 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2019 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2021 Expand_Packed_Boolean_Operator
(N
);
2025 -- For the normal non-packed case, the general expansion is to build
2026 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2027 -- and then inserting it into the tree. The original operator node is
2028 -- then rewritten as a call to this function. We also use this in the
2029 -- packed case if either operand is a possibly unaligned object.
2032 Loc
: constant Source_Ptr
:= Sloc
(N
);
2033 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2034 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2035 Func_Body
: Node_Id
;
2036 Func_Name
: Entity_Id
;
2039 Convert_To_Actual_Subtype
(L
);
2040 Convert_To_Actual_Subtype
(R
);
2041 Ensure_Defined
(Etype
(L
), N
);
2042 Ensure_Defined
(Etype
(R
), N
);
2043 Apply_Length_Check
(R
, Etype
(L
));
2045 if Nkind
(N
) = N_Op_Xor
then
2046 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2049 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2050 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2052 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2054 elsif Nkind
(Parent
(N
)) = N_Op_Not
2055 and then Nkind
(N
) = N_Op_And
2056 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2057 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2062 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2063 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2064 Insert_Action
(N
, Func_Body
);
2066 -- Now rewrite the expression with a call
2069 Make_Function_Call
(Loc
,
2070 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2071 Parameter_Associations
=>
2074 Make_Type_Conversion
2075 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2077 Analyze_And_Resolve
(N
, Typ
);
2080 end Expand_Boolean_Operator
;
2082 ------------------------------------------------
2083 -- Expand_Compare_Minimize_Eliminate_Overflow --
2084 ------------------------------------------------
2086 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2087 Loc
: constant Source_Ptr
:= Sloc
(N
);
2089 Result_Type
: constant Entity_Id
:= Etype
(N
);
2090 -- Capture result type (could be a derived boolean type)
2095 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2096 -- Entity for Long_Long_Integer'Base
2098 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2099 -- Current overflow checking mode
2102 procedure Set_False
;
2103 -- These procedures rewrite N with an occurrence of Standard_True or
2104 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2110 procedure Set_False
is
2112 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2113 Warn_On_Known_Condition
(N
);
2120 procedure Set_True
is
2122 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2123 Warn_On_Known_Condition
(N
);
2126 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2129 -- Nothing to do unless we have a comparison operator with operands
2130 -- that are signed integer types, and we are operating in either
2131 -- MINIMIZED or ELIMINATED overflow checking mode.
2133 if Nkind
(N
) not in N_Op_Compare
2134 or else Check
not in Minimized_Or_Eliminated
2135 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2140 -- OK, this is the case we are interested in. First step is to process
2141 -- our operands using the Minimize_Eliminate circuitry which applies
2142 -- this processing to the two operand subtrees.
2144 Minimize_Eliminate_Overflows
2145 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2146 Minimize_Eliminate_Overflows
2147 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2149 -- See if the range information decides the result of the comparison.
2150 -- We can only do this if we in fact have full range information (which
2151 -- won't be the case if either operand is bignum at this stage).
2153 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2154 case N_Op_Compare
(Nkind
(N
)) is
2156 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2158 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2165 elsif Lhi
< Rlo
then
2172 elsif Lhi
<= Rlo
then
2179 elsif Lhi
<= Rlo
then
2186 elsif Lhi
< Rlo
then
2191 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2193 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2198 -- All done if we did the rewrite
2200 if Nkind
(N
) not in N_Op_Compare
then
2205 -- Otherwise, time to do the comparison
2208 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2209 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2212 -- If the two operands have the same signed integer type we are
2213 -- all set, nothing more to do. This is the case where either
2214 -- both operands were unchanged, or we rewrote both of them to
2215 -- be Long_Long_Integer.
2217 -- Note: Entity for the comparison may be wrong, but it's not worth
2218 -- the effort to change it, since the back end does not use it.
2220 if Is_Signed_Integer_Type
(Ltype
)
2221 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2225 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2227 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2229 Left
: Node_Id
:= Left_Opnd
(N
);
2230 Right
: Node_Id
:= Right_Opnd
(N
);
2231 -- Bignum references for left and right operands
2234 if not Is_RTE
(Ltype
, RE_Bignum
) then
2235 Left
:= Convert_To_Bignum
(Left
);
2236 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2237 Right
:= Convert_To_Bignum
(Right
);
2240 -- We rewrite our node with:
2243 -- Bnn : Result_Type;
2245 -- M : Mark_Id := SS_Mark;
2247 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2255 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2256 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2260 case N_Op_Compare
(Nkind
(N
)) is
2261 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2262 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2263 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2264 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2265 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2266 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2269 -- Insert assignment to Bnn into the bignum block
2272 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2273 Make_Assignment_Statement
(Loc
,
2274 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2276 Make_Function_Call
(Loc
,
2278 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2279 Parameter_Associations
=> New_List
(Left
, Right
))));
2281 -- Now do the rewrite with expression actions
2284 Make_Expression_With_Actions
(Loc
,
2285 Actions
=> New_List
(
2286 Make_Object_Declaration
(Loc
,
2287 Defining_Identifier
=> Bnn
,
2288 Object_Definition
=>
2289 New_Occurrence_Of
(Result_Type
, Loc
)),
2291 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2292 Analyze_And_Resolve
(N
, Result_Type
);
2296 -- No bignums involved, but types are different, so we must have
2297 -- rewritten one of the operands as a Long_Long_Integer but not
2300 -- If left operand is Long_Long_Integer, convert right operand
2301 -- and we are done (with a comparison of two Long_Long_Integers).
2303 elsif Ltype
= LLIB
then
2304 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2305 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2308 -- If right operand is Long_Long_Integer, convert left operand
2309 -- and we are done (with a comparison of two Long_Long_Integers).
2311 -- This is the only remaining possibility
2313 else pragma Assert
(Rtype
= LLIB
);
2314 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2315 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2319 end Expand_Compare_Minimize_Eliminate_Overflow
;
2321 -------------------------------
2322 -- Expand_Composite_Equality --
2323 -------------------------------
2325 -- This function is only called for comparing internal fields of composite
2326 -- types when these fields are themselves composites. This is a special
2327 -- case because it is not possible to respect normal Ada visibility rules.
2329 function Expand_Composite_Equality
2334 Bodies
: List_Id
) return Node_Id
2336 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2337 Full_Type
: Entity_Id
;
2340 function Find_Primitive_Eq
return Node_Id
;
2341 -- AI05-0123: Locate primitive equality for type if it exists, and
2342 -- build the corresponding call. If operation is abstract, replace
2343 -- call with an explicit raise. Return Empty if there is no primitive.
2345 -----------------------
2346 -- Find_Primitive_Eq --
2347 -----------------------
2349 function Find_Primitive_Eq
return Node_Id
is
2354 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2355 while Present
(Prim_E
) loop
2356 Prim
:= Node
(Prim_E
);
2358 -- Locate primitive equality with the right signature
2360 if Chars
(Prim
) = Name_Op_Eq
2361 and then Etype
(First_Formal
(Prim
)) =
2362 Etype
(Next_Formal
(First_Formal
(Prim
)))
2363 and then Etype
(Prim
) = Standard_Boolean
2365 if Is_Abstract_Subprogram
(Prim
) then
2367 Make_Raise_Program_Error
(Loc
,
2368 Reason
=> PE_Explicit_Raise
);
2372 Make_Function_Call
(Loc
,
2373 Name
=> New_Occurrence_Of
(Prim
, Loc
),
2374 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2381 -- If not found, predefined operation will be used
2384 end Find_Primitive_Eq
;
2386 -- Start of processing for Expand_Composite_Equality
2389 if Is_Private_Type
(Typ
) then
2390 Full_Type
:= Underlying_Type
(Typ
);
2395 -- If the private type has no completion the context may be the
2396 -- expansion of a composite equality for a composite type with some
2397 -- still incomplete components. The expression will not be analyzed
2398 -- until the enclosing type is completed, at which point this will be
2399 -- properly expanded, unless there is a bona fide completion error.
2401 if No
(Full_Type
) then
2402 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2405 Full_Type
:= Base_Type
(Full_Type
);
2407 -- When the base type itself is private, use the full view to expand
2408 -- the composite equality.
2410 if Is_Private_Type
(Full_Type
) then
2411 Full_Type
:= Underlying_Type
(Full_Type
);
2414 -- Case of array types
2416 if Is_Array_Type
(Full_Type
) then
2418 -- If the operand is an elementary type other than a floating-point
2419 -- type, then we can simply use the built-in block bitwise equality,
2420 -- since the predefined equality operators always apply and bitwise
2421 -- equality is fine for all these cases.
2423 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2424 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2426 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2428 -- For composite component types, and floating-point types, use the
2429 -- expansion. This deals with tagged component types (where we use
2430 -- the applicable equality routine) and floating-point (where we
2431 -- need to worry about negative zeroes), and also the case of any
2432 -- composite type recursively containing such fields.
2436 Comp_Typ
: Entity_Id
;
2443 -- Do the comparison in the type (or its full view) and not in
2444 -- its unconstrained base type, because the latter operation is
2445 -- more complex and would also require an unchecked conversion.
2447 if Is_Private_Type
(Typ
) then
2448 Comp_Typ
:= Underlying_Type
(Typ
);
2453 -- Except for the case where the bounds of the type depend on a
2454 -- discriminant, or else we would run into scoping issues.
2456 Indx
:= First_Index
(Comp_Typ
);
2457 while Present
(Indx
) loop
2458 Ityp
:= Etype
(Indx
);
2460 Lo
:= Type_Low_Bound
(Ityp
);
2461 Hi
:= Type_High_Bound
(Ityp
);
2463 if (Nkind
(Lo
) = N_Identifier
2464 and then Ekind
(Entity
(Lo
)) = E_Discriminant
)
2466 (Nkind
(Hi
) = N_Identifier
2467 and then Ekind
(Entity
(Hi
)) = E_Discriminant
)
2469 Comp_Typ
:= Full_Type
;
2476 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Comp_Typ
);
2480 -- Case of tagged record types
2482 elsif Is_Tagged_Type
(Full_Type
) then
2483 Eq_Op
:= Find_Primitive_Eq
(Typ
);
2484 pragma Assert
(Present
(Eq_Op
));
2487 Make_Function_Call
(Loc
,
2488 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2489 Parameter_Associations
=>
2491 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2492 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2494 -- Case of untagged record types
2496 elsif Is_Record_Type
(Full_Type
) then
2497 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2499 if Present
(Eq_Op
) then
2500 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2502 -- Inherited equality from parent type. Convert the actuals to
2503 -- match signature of operation.
2506 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2510 Make_Function_Call
(Loc
,
2511 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2512 Parameter_Associations
=> New_List
(
2513 OK_Convert_To
(T
, Lhs
),
2514 OK_Convert_To
(T
, Rhs
)));
2518 -- Comparison between Unchecked_Union components
2520 if Is_Unchecked_Union
(Full_Type
) then
2522 Lhs_Type
: Node_Id
:= Full_Type
;
2523 Rhs_Type
: Node_Id
:= Full_Type
;
2524 Lhs_Discr_Val
: Node_Id
;
2525 Rhs_Discr_Val
: Node_Id
;
2530 if Nkind
(Lhs
) = N_Selected_Component
then
2531 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2536 if Nkind
(Rhs
) = N_Selected_Component
then
2537 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2540 -- Lhs of the composite equality
2542 if Is_Constrained
(Lhs_Type
) then
2544 -- Since the enclosing record type can never be an
2545 -- Unchecked_Union (this code is executed for records
2546 -- that do not have variants), we may reference its
2549 if Nkind
(Lhs
) = N_Selected_Component
2550 and then Has_Per_Object_Constraint
2551 (Entity
(Selector_Name
(Lhs
)))
2554 Make_Selected_Component
(Loc
,
2555 Prefix
=> Prefix
(Lhs
),
2558 (Get_Discriminant_Value
2559 (First_Discriminant
(Lhs_Type
),
2561 Stored_Constraint
(Lhs_Type
))));
2566 (Get_Discriminant_Value
2567 (First_Discriminant
(Lhs_Type
),
2569 Stored_Constraint
(Lhs_Type
)));
2573 -- It is not possible to infer the discriminant since
2574 -- the subtype is not constrained.
2577 Make_Raise_Program_Error
(Loc
,
2578 Reason
=> PE_Unchecked_Union_Restriction
);
2581 -- Rhs of the composite equality
2583 if Is_Constrained
(Rhs_Type
) then
2584 if Nkind
(Rhs
) = N_Selected_Component
2585 and then Has_Per_Object_Constraint
2586 (Entity
(Selector_Name
(Rhs
)))
2589 Make_Selected_Component
(Loc
,
2590 Prefix
=> Prefix
(Rhs
),
2593 (Get_Discriminant_Value
2594 (First_Discriminant
(Rhs_Type
),
2596 Stored_Constraint
(Rhs_Type
))));
2601 (Get_Discriminant_Value
2602 (First_Discriminant
(Rhs_Type
),
2604 Stored_Constraint
(Rhs_Type
)));
2609 Make_Raise_Program_Error
(Loc
,
2610 Reason
=> PE_Unchecked_Union_Restriction
);
2613 -- Call the TSS equality function with the inferred
2614 -- discriminant values.
2617 Make_Function_Call
(Loc
,
2618 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2619 Parameter_Associations
=> New_List
(
2626 -- All cases other than comparing Unchecked_Union types
2630 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2633 Make_Function_Call
(Loc
,
2635 New_Occurrence_Of
(Eq_Op
, Loc
),
2636 Parameter_Associations
=> New_List
(
2637 OK_Convert_To
(T
, Lhs
),
2638 OK_Convert_To
(T
, Rhs
)));
2643 -- Equality composes in Ada 2012 for untagged record types. It also
2644 -- composes for bounded strings, because they are part of the
2645 -- predefined environment. We could make it compose for bounded
2646 -- strings by making them tagged, or by making sure all subcomponents
2647 -- are set to the same value, even when not used. Instead, we have
2648 -- this special case in the compiler, because it's more efficient.
2650 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2652 -- If no TSS has been created for the type, check whether there is
2653 -- a primitive equality declared for it.
2656 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2659 -- Use user-defined primitive if it exists, otherwise use
2660 -- predefined equality.
2662 if Present
(Op
) then
2665 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2670 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2673 -- Non-composite types (always use predefined equality)
2676 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2678 end Expand_Composite_Equality
;
2680 ------------------------
2681 -- Expand_Concatenate --
2682 ------------------------
2684 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2685 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2687 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2688 -- Result type of concatenation
2690 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2691 -- Component type. Elements of this component type can appear as one
2692 -- of the operands of concatenation as well as arrays.
2694 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2697 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2698 -- Index type. This is the base type of the index subtype, and is used
2699 -- for all computed bounds (which may be out of range of Istyp in the
2700 -- case of null ranges).
2703 -- This is the type we use to do arithmetic to compute the bounds and
2704 -- lengths of operands. The choice of this type is a little subtle and
2705 -- is discussed in a separate section at the start of the body code.
2707 Concatenation_Error
: exception;
2708 -- Raised if concatenation is sure to raise a CE
2710 Result_May_Be_Null
: Boolean := True;
2711 -- Reset to False if at least one operand is encountered which is known
2712 -- at compile time to be non-null. Used for handling the special case
2713 -- of setting the high bound to the last operand high bound for a null
2714 -- result, thus ensuring a proper high bound in the super-flat case.
2716 N
: constant Nat
:= List_Length
(Opnds
);
2717 -- Number of concatenation operands including possibly null operands
2720 -- Number of operands excluding any known to be null, except that the
2721 -- last operand is always retained, in case it provides the bounds for
2724 Opnd
: Node_Id
:= Empty
;
2725 -- Current operand being processed in the loop through operands. After
2726 -- this loop is complete, always contains the last operand (which is not
2727 -- the same as Operands (NN), since null operands are skipped).
2729 -- Arrays describing the operands, only the first NN entries of each
2730 -- array are set (NN < N when we exclude known null operands).
2732 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2733 -- True if length of corresponding operand known at compile time
2735 Operands
: array (1 .. N
) of Node_Id
;
2736 -- Set to the corresponding entry in the Opnds list (but note that null
2737 -- operands are excluded, so not all entries in the list are stored).
2739 Fixed_Length
: array (1 .. N
) of Uint
;
2740 -- Set to length of operand. Entries in this array are set only if the
2741 -- corresponding entry in Is_Fixed_Length is True.
2743 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2744 -- Set to lower bound of operand. Either an integer literal in the case
2745 -- where the bound is known at compile time, else actual lower bound.
2746 -- The operand low bound is of type Ityp.
2748 Var_Length
: array (1 .. N
) of Entity_Id
;
2749 -- Set to an entity of type Natural that contains the length of an
2750 -- operand whose length is not known at compile time. Entries in this
2751 -- array are set only if the corresponding entry in Is_Fixed_Length
2752 -- is False. The entity is of type Artyp.
2754 Aggr_Length
: array (0 .. N
) of Node_Id
;
2755 -- The J'th entry in an expression node that represents the total length
2756 -- of operands 1 through J. It is either an integer literal node, or a
2757 -- reference to a constant entity with the right value, so it is fine
2758 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2759 -- entry always is set to zero. The length is of type Artyp.
2761 Low_Bound
: Node_Id
;
2762 -- A tree node representing the low bound of the result (of type Ityp).
2763 -- This is either an integer literal node, or an identifier reference to
2764 -- a constant entity initialized to the appropriate value.
2766 Last_Opnd_Low_Bound
: Node_Id
:= Empty
;
2767 -- A tree node representing the low bound of the last operand. This
2768 -- need only be set if the result could be null. It is used for the
2769 -- special case of setting the right low bound for a null result.
2770 -- This is of type Ityp.
2772 Last_Opnd_High_Bound
: Node_Id
:= Empty
;
2773 -- A tree node representing the high bound of the last operand. This
2774 -- need only be set if the result could be null. It is used for the
2775 -- special case of setting the right high bound for a null result.
2776 -- This is of type Ityp.
2778 High_Bound
: Node_Id
:= Empty
;
2779 -- A tree node representing the high bound of the result (of type Ityp)
2782 -- Result of the concatenation (of type Ityp)
2784 Actions
: constant List_Id
:= New_List
;
2785 -- Collect actions to be inserted
2787 Known_Non_Null_Operand_Seen
: Boolean;
2788 -- Set True during generation of the assignments of operands into
2789 -- result once an operand known to be non-null has been seen.
2791 function Library_Level_Target
return Boolean;
2792 -- Return True if the concatenation is within the expression of the
2793 -- declaration of a library-level object.
2795 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2796 -- This function makes an N_Integer_Literal node that is returned in
2797 -- analyzed form with the type set to Artyp. Importantly this literal
2798 -- is not flagged as static, so that if we do computations with it that
2799 -- result in statically detected out of range conditions, we will not
2800 -- generate error messages but instead warning messages.
2802 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2803 -- Given a node of type Ityp, returns the corresponding value of type
2804 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2805 -- For enum types, the Pos of the value is returned.
2807 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2808 -- The inverse function (uses Val in the case of enumeration types)
2810 --------------------------
2811 -- Library_Level_Target --
2812 --------------------------
2814 function Library_Level_Target
return Boolean is
2815 P
: Node_Id
:= Parent
(Cnode
);
2818 while Present
(P
) loop
2819 if Nkind
(P
) = N_Object_Declaration
then
2820 return Is_Library_Level_Entity
(Defining_Identifier
(P
));
2822 -- Prevent the search from going too far
2824 elsif Is_Body_Or_Package_Declaration
(P
) then
2832 end Library_Level_Target
;
2834 ------------------------
2835 -- Make_Artyp_Literal --
2836 ------------------------
2838 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2839 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2841 Set_Etype
(Result
, Artyp
);
2842 Set_Analyzed
(Result
, True);
2843 Set_Is_Static_Expression
(Result
, False);
2845 end Make_Artyp_Literal
;
2851 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2853 if Ityp
= Base_Type
(Artyp
) then
2856 elsif Is_Enumeration_Type
(Ityp
) then
2858 Make_Attribute_Reference
(Loc
,
2859 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2860 Attribute_Name
=> Name_Pos
,
2861 Expressions
=> New_List
(X
));
2864 return Convert_To
(Artyp
, X
);
2872 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2874 if Is_Enumeration_Type
(Ityp
) then
2876 Make_Attribute_Reference
(Loc
,
2877 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2878 Attribute_Name
=> Name_Val
,
2879 Expressions
=> New_List
(X
));
2881 -- Case where we will do a type conversion
2884 if Ityp
= Base_Type
(Artyp
) then
2887 return Convert_To
(Ityp
, X
);
2892 -- Local Declarations
2894 Opnd_Typ
: Entity_Id
;
2901 -- Start of processing for Expand_Concatenate
2904 -- Choose an appropriate computational type
2906 -- We will be doing calculations of lengths and bounds in this routine
2907 -- and computing one from the other in some cases, e.g. getting the high
2908 -- bound by adding the length-1 to the low bound.
2910 -- We can't just use the index type, or even its base type for this
2911 -- purpose for two reasons. First it might be an enumeration type which
2912 -- is not suitable for computations of any kind, and second it may
2913 -- simply not have enough range. For example if the index type is
2914 -- -128..+127 then lengths can be up to 256, which is out of range of
2917 -- For enumeration types, we can simply use Standard_Integer, this is
2918 -- sufficient since the actual number of enumeration literals cannot
2919 -- possibly exceed the range of integer (remember we will be doing the
2920 -- arithmetic with POS values, not representation values).
2922 if Is_Enumeration_Type
(Ityp
) then
2923 Artyp
:= Standard_Integer
;
2925 -- If index type is Positive, we use the standard unsigned type, to give
2926 -- more room on the top of the range, obviating the need for an overflow
2927 -- check when creating the upper bound. This is needed to avoid junk
2928 -- overflow checks in the common case of String types.
2930 -- ??? Disabled for now
2932 -- elsif Istyp = Standard_Positive then
2933 -- Artyp := Standard_Unsigned;
2935 -- For modular types, we use a 32-bit modular type for types whose size
2936 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2937 -- identity type, and for larger unsigned types we use 64-bits.
2939 elsif Is_Modular_Integer_Type
(Ityp
) then
2940 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
2941 Artyp
:= Standard_Unsigned
;
2942 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
2945 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
2948 -- Similar treatment for signed types
2951 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
2952 Artyp
:= Standard_Integer
;
2953 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
2956 Artyp
:= Standard_Long_Long_Integer
;
2960 -- Supply dummy entry at start of length array
2962 Aggr_Length
(0) := Make_Artyp_Literal
(0);
2964 -- Go through operands setting up the above arrays
2968 Opnd
:= Remove_Head
(Opnds
);
2969 Opnd_Typ
:= Etype
(Opnd
);
2971 -- The parent got messed up when we put the operands in a list,
2972 -- so now put back the proper parent for the saved operand, that
2973 -- is to say the concatenation node, to make sure that each operand
2974 -- is seen as a subexpression, e.g. if actions must be inserted.
2976 Set_Parent
(Opnd
, Cnode
);
2978 -- Set will be True when we have setup one entry in the array
2982 -- Singleton element (or character literal) case
2984 if Base_Type
(Opnd_Typ
) = Ctyp
then
2986 Operands
(NN
) := Opnd
;
2987 Is_Fixed_Length
(NN
) := True;
2988 Fixed_Length
(NN
) := Uint_1
;
2989 Result_May_Be_Null
:= False;
2991 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2992 -- since we know that the result cannot be null).
2994 Opnd_Low_Bound
(NN
) :=
2995 Make_Attribute_Reference
(Loc
,
2996 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
2997 Attribute_Name
=> Name_First
);
3001 -- String literal case (can only occur for strings of course)
3003 elsif Nkind
(Opnd
) = N_String_Literal
then
3004 Len
:= String_Literal_Length
(Opnd_Typ
);
3007 Result_May_Be_Null
:= False;
3010 -- Capture last operand low and high bound if result could be null
3012 if J
= N
and then Result_May_Be_Null
then
3013 Last_Opnd_Low_Bound
:=
3014 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3016 Last_Opnd_High_Bound
:=
3017 Make_Op_Subtract
(Loc
,
3019 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3020 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3023 -- Skip null string literal
3025 if J
< N
and then Len
= 0 then
3030 Operands
(NN
) := Opnd
;
3031 Is_Fixed_Length
(NN
) := True;
3033 -- Set length and bounds
3035 Fixed_Length
(NN
) := Len
;
3037 Opnd_Low_Bound
(NN
) :=
3038 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3045 -- Check constrained case with known bounds
3047 if Is_Constrained
(Opnd_Typ
) then
3049 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3050 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3051 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3052 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3055 -- Fixed length constrained array type with known at compile
3056 -- time bounds is last case of fixed length operand.
3058 if Compile_Time_Known_Value
(Lo
)
3060 Compile_Time_Known_Value
(Hi
)
3063 Loval
: constant Uint
:= Expr_Value
(Lo
);
3064 Hival
: constant Uint
:= Expr_Value
(Hi
);
3065 Len
: constant Uint
:=
3066 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3070 Result_May_Be_Null
:= False;
3073 -- Capture last operand bounds if result could be null
3075 if J
= N
and then Result_May_Be_Null
then
3076 Last_Opnd_Low_Bound
:=
3078 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3080 Last_Opnd_High_Bound
:=
3082 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3085 -- Exclude null length case unless last operand
3087 if J
< N
and then Len
= 0 then
3092 Operands
(NN
) := Opnd
;
3093 Is_Fixed_Length
(NN
) := True;
3094 Fixed_Length
(NN
) := Len
;
3096 Opnd_Low_Bound
(NN
) :=
3098 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3105 -- All cases where the length is not known at compile time, or the
3106 -- special case of an operand which is known to be null but has a
3107 -- lower bound other than 1 or is other than a string type.
3112 -- Capture operand bounds
3114 Opnd_Low_Bound
(NN
) :=
3115 Make_Attribute_Reference
(Loc
,
3117 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3118 Attribute_Name
=> Name_First
);
3120 -- Capture last operand bounds if result could be null
3122 if J
= N
and Result_May_Be_Null
then
3123 Last_Opnd_Low_Bound
:=
3125 Make_Attribute_Reference
(Loc
,
3127 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3128 Attribute_Name
=> Name_First
));
3130 Last_Opnd_High_Bound
:=
3132 Make_Attribute_Reference
(Loc
,
3134 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3135 Attribute_Name
=> Name_Last
));
3138 -- Capture length of operand in entity
3140 Operands
(NN
) := Opnd
;
3141 Is_Fixed_Length
(NN
) := False;
3143 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3146 Make_Object_Declaration
(Loc
,
3147 Defining_Identifier
=> Var_Length
(NN
),
3148 Constant_Present
=> True,
3149 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3151 Make_Attribute_Reference
(Loc
,
3153 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3154 Attribute_Name
=> Name_Length
)));
3158 -- Set next entry in aggregate length array
3160 -- For first entry, make either integer literal for fixed length
3161 -- or a reference to the saved length for variable length.
3164 if Is_Fixed_Length
(1) then
3165 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3167 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
3170 -- If entry is fixed length and only fixed lengths so far, make
3171 -- appropriate new integer literal adding new length.
3173 elsif Is_Fixed_Length
(NN
)
3174 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3177 Make_Integer_Literal
(Loc
,
3178 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3180 -- All other cases, construct an addition node for the length and
3181 -- create an entity initialized to this length.
3184 Ent
:= Make_Temporary
(Loc
, 'L');
3186 if Is_Fixed_Length
(NN
) then
3187 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3189 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3193 Make_Object_Declaration
(Loc
,
3194 Defining_Identifier
=> Ent
,
3195 Constant_Present
=> True,
3196 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3199 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
- 1)),
3200 Right_Opnd
=> Clen
)));
3202 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3209 -- If we have only skipped null operands, return the last operand
3216 -- If we have only one non-null operand, return it and we are done.
3217 -- There is one case in which this cannot be done, and that is when
3218 -- the sole operand is of the element type, in which case it must be
3219 -- converted to an array, and the easiest way of doing that is to go
3220 -- through the normal general circuit.
3222 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3223 Result
:= Operands
(1);
3227 -- Cases where we have a real concatenation
3229 -- Next step is to find the low bound for the result array that we
3230 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3232 -- If the ultimate ancestor of the index subtype is a constrained array
3233 -- definition, then the lower bound is that of the index subtype as
3234 -- specified by (RM 4.5.3(6)).
3236 -- The right test here is to go to the root type, and then the ultimate
3237 -- ancestor is the first subtype of this root type.
3239 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3241 Make_Attribute_Reference
(Loc
,
3243 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3244 Attribute_Name
=> Name_First
);
3246 -- If the first operand in the list has known length we know that
3247 -- the lower bound of the result is the lower bound of this operand.
3249 elsif Is_Fixed_Length
(1) then
3250 Low_Bound
:= Opnd_Low_Bound
(1);
3252 -- OK, we don't know the lower bound, we have to build a horrible
3253 -- if expression node of the form
3255 -- if Cond1'Length /= 0 then
3258 -- if Opnd2'Length /= 0 then
3263 -- The nesting ends either when we hit an operand whose length is known
3264 -- at compile time, or on reaching the last operand, whose low bound we
3265 -- take unconditionally whether or not it is null. It's easiest to do
3266 -- this with a recursive procedure:
3270 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3271 -- Returns the lower bound determined by operands J .. NN
3273 ---------------------
3274 -- Get_Known_Bound --
3275 ---------------------
3277 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3279 if Is_Fixed_Length
(J
) or else J
= NN
then
3280 return New_Copy_Tree
(Opnd_Low_Bound
(J
));
3284 Make_If_Expression
(Loc
,
3285 Expressions
=> New_List
(
3289 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3291 Make_Integer_Literal
(Loc
, 0)),
3293 New_Copy_Tree
(Opnd_Low_Bound
(J
)),
3294 Get_Known_Bound
(J
+ 1)));
3296 end Get_Known_Bound
;
3299 Ent
:= Make_Temporary
(Loc
, 'L');
3302 Make_Object_Declaration
(Loc
,
3303 Defining_Identifier
=> Ent
,
3304 Constant_Present
=> True,
3305 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3306 Expression
=> Get_Known_Bound
(1)));
3308 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3312 -- Now we can safely compute the upper bound, normally
3313 -- Low_Bound + Length - 1.
3318 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3320 Make_Op_Subtract
(Loc
,
3321 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3322 Right_Opnd
=> Make_Artyp_Literal
(1))));
3324 -- Note that calculation of the high bound may cause overflow in some
3325 -- very weird cases, so in the general case we need an overflow check on
3326 -- the high bound. We can avoid this for the common case of string types
3327 -- and other types whose index is Positive, since we chose a wider range
3328 -- for the arithmetic type. If checks are suppressed we do not set the
3329 -- flag, and possibly superfluous warnings will be omitted.
3331 if Istyp
/= Standard_Positive
3332 and then not Overflow_Checks_Suppressed
(Istyp
)
3334 Activate_Overflow_Check
(High_Bound
);
3337 -- Handle the exceptional case where the result is null, in which case
3338 -- case the bounds come from the last operand (so that we get the proper
3339 -- bounds if the last operand is super-flat).
3341 if Result_May_Be_Null
then
3343 Make_If_Expression
(Loc
,
3344 Expressions
=> New_List
(
3346 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3347 Right_Opnd
=> Make_Artyp_Literal
(0)),
3348 Last_Opnd_Low_Bound
,
3352 Make_If_Expression
(Loc
,
3353 Expressions
=> New_List
(
3355 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3356 Right_Opnd
=> Make_Artyp_Literal
(0)),
3357 Last_Opnd_High_Bound
,
3361 -- Here is where we insert the saved up actions
3363 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3365 -- Now we construct an array object with appropriate bounds. We mark
3366 -- the target as internal to prevent useless initialization when
3367 -- Initialize_Scalars is enabled. Also since this is the actual result
3368 -- entity, we make sure we have debug information for the result.
3370 Ent
:= Make_Temporary
(Loc
, 'S');
3371 Set_Is_Internal
(Ent
);
3372 Set_Needs_Debug_Info
(Ent
);
3374 -- If the bound is statically known to be out of range, we do not want
3375 -- to abort, we want a warning and a runtime constraint error. Note that
3376 -- we have arranged that the result will not be treated as a static
3377 -- constant, so we won't get an illegality during this insertion.
3379 Insert_Action
(Cnode
,
3380 Make_Object_Declaration
(Loc
,
3381 Defining_Identifier
=> Ent
,
3382 Object_Definition
=>
3383 Make_Subtype_Indication
(Loc
,
3384 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3386 Make_Index_Or_Discriminant_Constraint
(Loc
,
3387 Constraints
=> New_List
(
3389 Low_Bound
=> Low_Bound
,
3390 High_Bound
=> High_Bound
))))),
3391 Suppress
=> All_Checks
);
3393 -- If the result of the concatenation appears as the initializing
3394 -- expression of an object declaration, we can just rename the
3395 -- result, rather than copying it.
3397 Set_OK_To_Rename
(Ent
);
3399 -- Catch the static out of range case now
3401 if Raises_Constraint_Error
(High_Bound
) then
3402 raise Concatenation_Error
;
3405 -- Now we will generate the assignments to do the actual concatenation
3407 -- There is one case in which we will not do this, namely when all the
3408 -- following conditions are met:
3410 -- The result type is Standard.String
3412 -- There are nine or fewer retained (non-null) operands
3414 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3415 -- and the debug flag gnatd.c is not set.
3417 -- The corresponding System.Concat_n.Str_Concat_n routine is
3418 -- available in the run time.
3420 -- If all these conditions are met then we generate a call to the
3421 -- relevant concatenation routine. The purpose of this is to avoid
3422 -- undesirable code bloat at -O0.
3424 -- If the concatenation is within the declaration of a library-level
3425 -- object, we call the built-in concatenation routines to prevent code
3426 -- bloat, regardless of the optimization level. This is space efficient
3427 -- and prevents linking problems when units are compiled with different
3428 -- optimization levels.
3430 if Atyp
= Standard_String
3431 and then NN
in 2 .. 9
3432 and then (((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3433 and then not Debug_Flag_Dot_C
)
3434 or else Library_Level_Target
)
3437 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3448 if RTE_Available
(RR
(NN
)) then
3450 Opnds
: constant List_Id
:=
3451 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3454 for J
in 1 .. NN
loop
3455 if Is_List_Member
(Operands
(J
)) then
3456 Remove
(Operands
(J
));
3459 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3461 Make_Aggregate
(Loc
,
3462 Component_Associations
=> New_List
(
3463 Make_Component_Association
(Loc
,
3464 Choices
=> New_List
(
3465 Make_Integer_Literal
(Loc
, 1)),
3466 Expression
=> Operands
(J
)))));
3469 Append_To
(Opnds
, Operands
(J
));
3473 Insert_Action
(Cnode
,
3474 Make_Procedure_Call_Statement
(Loc
,
3475 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3476 Parameter_Associations
=> Opnds
));
3478 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3485 -- Not special case so generate the assignments
3487 Known_Non_Null_Operand_Seen
:= False;
3489 for J
in 1 .. NN
loop
3491 Lo
: constant Node_Id
:=
3493 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3494 Right_Opnd
=> Aggr_Length
(J
- 1));
3496 Hi
: constant Node_Id
:=
3498 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3500 Make_Op_Subtract
(Loc
,
3501 Left_Opnd
=> Aggr_Length
(J
),
3502 Right_Opnd
=> Make_Artyp_Literal
(1)));
3505 -- Singleton case, simple assignment
3507 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3508 Known_Non_Null_Operand_Seen
:= True;
3509 Insert_Action
(Cnode
,
3510 Make_Assignment_Statement
(Loc
,
3512 Make_Indexed_Component
(Loc
,
3513 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3514 Expressions
=> New_List
(To_Ityp
(Lo
))),
3515 Expression
=> Operands
(J
)),
3516 Suppress
=> All_Checks
);
3518 -- Array case, slice assignment, skipped when argument is fixed
3519 -- length and known to be null.
3521 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3524 Make_Assignment_Statement
(Loc
,
3528 New_Occurrence_Of
(Ent
, Loc
),
3531 Low_Bound
=> To_Ityp
(Lo
),
3532 High_Bound
=> To_Ityp
(Hi
))),
3533 Expression
=> Operands
(J
));
3535 if Is_Fixed_Length
(J
) then
3536 Known_Non_Null_Operand_Seen
:= True;
3538 elsif not Known_Non_Null_Operand_Seen
then
3540 -- Here if operand length is not statically known and no
3541 -- operand known to be non-null has been processed yet.
3542 -- If operand length is 0, we do not need to perform the
3543 -- assignment, and we must avoid the evaluation of the
3544 -- high bound of the slice, since it may underflow if the
3545 -- low bound is Ityp'First.
3548 Make_Implicit_If_Statement
(Cnode
,
3552 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3553 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3554 Then_Statements
=> New_List
(Assign
));
3557 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3563 -- Finally we build the result, which is a reference to the array object
3565 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3568 Rewrite
(Cnode
, Result
);
3569 Analyze_And_Resolve
(Cnode
, Atyp
);
3572 when Concatenation_Error
=>
3574 -- Kill warning generated for the declaration of the static out of
3575 -- range high bound, and instead generate a Constraint_Error with
3576 -- an appropriate specific message.
3578 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3579 Apply_Compile_Time_Constraint_Error
3581 Msg
=> "concatenation result upper bound out of range??",
3582 Reason
=> CE_Range_Check_Failed
);
3583 end Expand_Concatenate
;
3585 ---------------------------------------------------
3586 -- Expand_Membership_Minimize_Eliminate_Overflow --
3587 ---------------------------------------------------
3589 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3590 pragma Assert
(Nkind
(N
) = N_In
);
3591 -- Despite the name, this routine applies only to N_In, not to
3592 -- N_Not_In. The latter is always rewritten as not (X in Y).
3594 Result_Type
: constant Entity_Id
:= Etype
(N
);
3595 -- Capture result type, may be a derived boolean type
3597 Loc
: constant Source_Ptr
:= Sloc
(N
);
3598 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3599 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3601 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3602 -- is thus tempting to capture these values, but due to the rewrites
3603 -- that occur as a result of overflow checking, these values change
3604 -- as we go along, and it is safe just to always use Etype explicitly.
3606 Restype
: constant Entity_Id
:= Etype
(N
);
3610 -- Bounds in Minimize calls, not used currently
3612 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3613 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3616 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3618 -- If right operand is a subtype name, and the subtype name has no
3619 -- predicate, then we can just replace the right operand with an
3620 -- explicit range T'First .. T'Last, and use the explicit range code.
3622 if Nkind
(Rop
) /= N_Range
3623 and then No
(Predicate_Function
(Etype
(Rop
)))
3626 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3631 Make_Attribute_Reference
(Loc
,
3632 Attribute_Name
=> Name_First
,
3633 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3635 Make_Attribute_Reference
(Loc
,
3636 Attribute_Name
=> Name_Last
,
3637 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3638 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3642 -- Here for the explicit range case. Note that the bounds of the range
3643 -- have not been processed for minimized or eliminated checks.
3645 if Nkind
(Rop
) = N_Range
then
3646 Minimize_Eliminate_Overflows
3647 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3648 Minimize_Eliminate_Overflows
3649 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3651 -- We have A in B .. C, treated as A >= B and then A <= C
3655 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3656 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3657 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3660 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3661 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3662 L
: constant Entity_Id
:=
3663 Make_Defining_Identifier
(Loc
, Name_uL
);
3664 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3665 Lbound
: constant Node_Id
:=
3666 Convert_To_Bignum
(Low_Bound
(Rop
));
3667 Hbound
: constant Node_Id
:=
3668 Convert_To_Bignum
(High_Bound
(Rop
));
3670 -- Now we rewrite the membership test node to look like
3673 -- Bnn : Result_Type;
3675 -- M : Mark_Id := SS_Mark;
3676 -- L : Bignum := Lopnd;
3678 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3686 -- Insert declaration of L into declarations of bignum block
3689 (Last
(Declarations
(Blk
)),
3690 Make_Object_Declaration
(Loc
,
3691 Defining_Identifier
=> L
,
3692 Object_Definition
=>
3693 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3694 Expression
=> Lopnd
));
3696 -- Insert assignment to Bnn into expressions of bignum block
3699 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3700 Make_Assignment_Statement
(Loc
,
3701 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3705 Make_Function_Call
(Loc
,
3707 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3708 Parameter_Associations
=> New_List
(
3709 New_Occurrence_Of
(L
, Loc
),
3713 Make_Function_Call
(Loc
,
3715 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3716 Parameter_Associations
=> New_List
(
3717 New_Occurrence_Of
(L
, Loc
),
3720 -- Now rewrite the node
3723 Make_Expression_With_Actions
(Loc
,
3724 Actions
=> New_List
(
3725 Make_Object_Declaration
(Loc
,
3726 Defining_Identifier
=> Bnn
,
3727 Object_Definition
=>
3728 New_Occurrence_Of
(Result_Type
, Loc
)),
3730 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3731 Analyze_And_Resolve
(N
, Result_Type
);
3735 -- Here if no bignums around
3738 -- Case where types are all the same
3740 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3742 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3746 -- If types are not all the same, it means that we have rewritten
3747 -- at least one of them to be of type Long_Long_Integer, and we
3748 -- will convert the other operands to Long_Long_Integer.
3751 Convert_To_And_Rewrite
(LLIB
, Lop
);
3752 Set_Analyzed
(Lop
, False);
3753 Analyze_And_Resolve
(Lop
, LLIB
);
3755 -- For the right operand, avoid unnecessary recursion into
3756 -- this routine, we know that overflow is not possible.
3758 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3759 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3760 Set_Analyzed
(Rop
, False);
3761 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3764 -- Now the three operands are of the same signed integer type,
3765 -- so we can use the normal expansion routine for membership,
3766 -- setting the flag to prevent recursion into this procedure.
3768 Set_No_Minimize_Eliminate
(N
);
3772 -- Right operand is a subtype name and the subtype has a predicate. We
3773 -- have to make sure the predicate is checked, and for that we need to
3774 -- use the standard N_In circuitry with appropriate types.
3777 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3779 -- If types are "right", just call Expand_N_In preventing recursion
3781 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3782 Set_No_Minimize_Eliminate
(N
);
3787 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3789 -- For X in T, we want to rewrite our node as
3792 -- Bnn : Result_Type;
3795 -- M : Mark_Id := SS_Mark;
3796 -- Lnn : Long_Long_Integer'Base
3802 -- if not Bignum_In_LLI_Range (Nnn) then
3805 -- Lnn := From_Bignum (Nnn);
3807 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3808 -- and then T'Base (Lnn) in T;
3817 -- A bit gruesome, but there doesn't seem to be a simpler way
3820 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3821 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3822 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3823 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3824 T
: constant Entity_Id
:= Etype
(Rop
);
3825 TB
: constant Entity_Id
:= Base_Type
(T
);
3829 -- Mark the last membership operation to prevent recursion
3833 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3834 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3835 Set_No_Minimize_Eliminate
(Nin
);
3837 -- Now decorate the block
3840 (Last
(Declarations
(Blk
)),
3841 Make_Object_Declaration
(Loc
,
3842 Defining_Identifier
=> Lnn
,
3843 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3846 (Last
(Declarations
(Blk
)),
3847 Make_Object_Declaration
(Loc
,
3848 Defining_Identifier
=> Nnn
,
3849 Object_Definition
=>
3850 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3853 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3855 Make_Assignment_Statement
(Loc
,
3856 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3857 Expression
=> Relocate_Node
(Lop
)),
3859 Make_Implicit_If_Statement
(N
,
3863 Make_Function_Call
(Loc
,
3866 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3867 Parameter_Associations
=> New_List
(
3868 New_Occurrence_Of
(Nnn
, Loc
)))),
3870 Then_Statements
=> New_List
(
3871 Make_Assignment_Statement
(Loc
,
3872 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3874 New_Occurrence_Of
(Standard_False
, Loc
))),
3876 Else_Statements
=> New_List
(
3877 Make_Assignment_Statement
(Loc
,
3878 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3880 Make_Function_Call
(Loc
,
3882 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3883 Parameter_Associations
=> New_List
(
3884 New_Occurrence_Of
(Nnn
, Loc
)))),
3886 Make_Assignment_Statement
(Loc
,
3887 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3892 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3897 Make_Attribute_Reference
(Loc
,
3898 Attribute_Name
=> Name_First
,
3900 New_Occurrence_Of
(TB
, Loc
))),
3904 Make_Attribute_Reference
(Loc
,
3905 Attribute_Name
=> Name_Last
,
3907 New_Occurrence_Of
(TB
, Loc
))))),
3909 Right_Opnd
=> Nin
))))));
3911 -- Now we can do the rewrite
3914 Make_Expression_With_Actions
(Loc
,
3915 Actions
=> New_List
(
3916 Make_Object_Declaration
(Loc
,
3917 Defining_Identifier
=> Bnn
,
3918 Object_Definition
=>
3919 New_Occurrence_Of
(Result_Type
, Loc
)),
3921 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3922 Analyze_And_Resolve
(N
, Result_Type
);
3926 -- Not bignum case, but types don't match (this means we rewrote the
3927 -- left operand to be Long_Long_Integer).
3930 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
3932 -- We rewrite the membership test as (where T is the type with
3933 -- the predicate, i.e. the type of the right operand)
3935 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3936 -- and then T'Base (Lop) in T
3939 T
: constant Entity_Id
:= Etype
(Rop
);
3940 TB
: constant Entity_Id
:= Base_Type
(T
);
3944 -- The last membership test is marked to prevent recursion
3948 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
3949 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3950 Set_No_Minimize_Eliminate
(Nin
);
3952 -- Now do the rewrite
3963 Make_Attribute_Reference
(Loc
,
3964 Attribute_Name
=> Name_First
,
3966 New_Occurrence_Of
(TB
, Loc
))),
3969 Make_Attribute_Reference
(Loc
,
3970 Attribute_Name
=> Name_Last
,
3972 New_Occurrence_Of
(TB
, Loc
))))),
3973 Right_Opnd
=> Nin
));
3974 Set_Analyzed
(N
, False);
3975 Analyze_And_Resolve
(N
, Restype
);
3979 end Expand_Membership_Minimize_Eliminate_Overflow
;
3981 ---------------------------------
3982 -- Expand_Nonbinary_Modular_Op --
3983 ---------------------------------
3985 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
) is
3986 Loc
: constant Source_Ptr
:= Sloc
(N
);
3987 Typ
: constant Entity_Id
:= Etype
(N
);
3989 procedure Expand_Modular_Addition
;
3990 -- Expand the modular addition, handling the special case of adding a
3993 procedure Expand_Modular_Op
;
3994 -- Compute the general rule: (lhs OP rhs) mod Modulus
3996 procedure Expand_Modular_Subtraction
;
3997 -- Expand the modular addition, handling the special case of subtracting
4000 -----------------------------
4001 -- Expand_Modular_Addition --
4002 -----------------------------
4004 procedure Expand_Modular_Addition
is
4006 -- If this is not the addition of a constant then compute it using
4007 -- the general rule: (lhs + rhs) mod Modulus
4009 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4012 -- If this is an addition of a constant, convert it to a subtraction
4013 -- plus a conditional expression since we can compute it faster than
4014 -- computing the modulus.
4016 -- modMinusRhs = Modulus - rhs
4017 -- if lhs < modMinusRhs then lhs + rhs
4018 -- else lhs - modMinusRhs
4022 Mod_Minus_Right
: constant Uint
:=
4023 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4025 Exprs
: constant List_Id
:= New_List
;
4026 Cond_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Lt
, Loc
);
4027 Then_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Add
, Loc
);
4028 Else_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Subtract
,
4031 -- To prevent spurious visibility issues, convert all
4032 -- operands to Standard.Unsigned.
4034 Set_Left_Opnd
(Cond_Expr
,
4035 Unchecked_Convert_To
(Standard_Unsigned
,
4036 New_Copy_Tree
(Left_Opnd
(N
))));
4037 Set_Right_Opnd
(Cond_Expr
,
4038 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4039 Append_To
(Exprs
, Cond_Expr
);
4041 Set_Left_Opnd
(Then_Expr
,
4042 Unchecked_Convert_To
(Standard_Unsigned
,
4043 New_Copy_Tree
(Left_Opnd
(N
))));
4044 Set_Right_Opnd
(Then_Expr
,
4045 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4046 Append_To
(Exprs
, Then_Expr
);
4048 Set_Left_Opnd
(Else_Expr
,
4049 Unchecked_Convert_To
(Standard_Unsigned
,
4050 New_Copy_Tree
(Left_Opnd
(N
))));
4051 Set_Right_Opnd
(Else_Expr
,
4052 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4053 Append_To
(Exprs
, Else_Expr
);
4056 Unchecked_Convert_To
(Typ
,
4057 Make_If_Expression
(Loc
, Expressions
=> Exprs
)));
4060 end Expand_Modular_Addition
;
4062 -----------------------
4063 -- Expand_Modular_Op --
4064 -----------------------
4066 procedure Expand_Modular_Op
is
4067 Op_Expr
: constant Node_Id
:= New_Op_Node
(Nkind
(N
), Loc
);
4068 Mod_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Mod
, Loc
);
4070 Target_Type
: Entity_Id
;
4073 -- Convert nonbinary modular type operands into integer values. Thus
4074 -- we avoid never-ending loops expanding them, and we also ensure
4075 -- the back end never receives nonbinary modular type expressions.
4077 if Nkind_In
(Nkind
(N
), N_Op_And
, N_Op_Or
, N_Op_Xor
) then
4078 Set_Left_Opnd
(Op_Expr
,
4079 Unchecked_Convert_To
(Standard_Unsigned
,
4080 New_Copy_Tree
(Left_Opnd
(N
))));
4081 Set_Right_Opnd
(Op_Expr
,
4082 Unchecked_Convert_To
(Standard_Unsigned
,
4083 New_Copy_Tree
(Right_Opnd
(N
))));
4084 Set_Left_Opnd
(Mod_Expr
,
4085 Unchecked_Convert_To
(Standard_Integer
, Op_Expr
));
4088 -- If the modulus of the type is larger than Integer'Last
4089 -- use a larger type for the operands, to prevent spurious
4090 -- constraint errors on large legal literals of the type.
4092 if Modulus
(Etype
(N
)) > UI_From_Int
(Int
(Integer'Last)) then
4093 Target_Type
:= Standard_Long_Integer
;
4095 Target_Type
:= Standard_Integer
;
4098 Set_Left_Opnd
(Op_Expr
,
4099 Unchecked_Convert_To
(Target_Type
,
4100 New_Copy_Tree
(Left_Opnd
(N
))));
4101 Set_Right_Opnd
(Op_Expr
,
4102 Unchecked_Convert_To
(Target_Type
,
4103 New_Copy_Tree
(Right_Opnd
(N
))));
4105 -- Link this node to the tree to analyze it
4107 -- If the parent node is an expression with actions we link it to
4108 -- N since otherwise Force_Evaluation cannot identify if this node
4109 -- comes from the Expression and rejects generating the temporary.
4111 if Nkind
(Parent
(N
)) = N_Expression_With_Actions
then
4112 Set_Parent
(Op_Expr
, N
);
4117 Set_Parent
(Op_Expr
, Parent
(N
));
4122 -- Force generating a temporary because in the expansion of this
4123 -- expression we may generate code that performs this computation
4126 Force_Evaluation
(Op_Expr
, Mode
=> Strict
);
4128 Set_Left_Opnd
(Mod_Expr
, Op_Expr
);
4131 Set_Right_Opnd
(Mod_Expr
,
4132 Make_Integer_Literal
(Loc
, Modulus
(Typ
)));
4135 Unchecked_Convert_To
(Typ
, Mod_Expr
));
4136 end Expand_Modular_Op
;
4138 --------------------------------
4139 -- Expand_Modular_Subtraction --
4140 --------------------------------
4142 procedure Expand_Modular_Subtraction
is
4144 -- If this is not the addition of a constant then compute it using
4145 -- the general rule: (lhs + rhs) mod Modulus
4147 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4150 -- If this is an addition of a constant, convert it to a subtraction
4151 -- plus a conditional expression since we can compute it faster than
4152 -- computing the modulus.
4154 -- modMinusRhs = Modulus - rhs
4155 -- if lhs < rhs then lhs + modMinusRhs
4160 Mod_Minus_Right
: constant Uint
:=
4161 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4163 Exprs
: constant List_Id
:= New_List
;
4164 Cond_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Lt
, Loc
);
4165 Then_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Add
, Loc
);
4166 Else_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Subtract
,
4169 Set_Left_Opnd
(Cond_Expr
,
4170 Unchecked_Convert_To
(Standard_Unsigned
,
4171 New_Copy_Tree
(Left_Opnd
(N
))));
4172 Set_Right_Opnd
(Cond_Expr
,
4173 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4174 Append_To
(Exprs
, Cond_Expr
);
4176 Set_Left_Opnd
(Then_Expr
,
4177 Unchecked_Convert_To
(Standard_Unsigned
,
4178 New_Copy_Tree
(Left_Opnd
(N
))));
4179 Set_Right_Opnd
(Then_Expr
,
4180 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4181 Append_To
(Exprs
, Then_Expr
);
4183 Set_Left_Opnd
(Else_Expr
,
4184 Unchecked_Convert_To
(Standard_Unsigned
,
4185 New_Copy_Tree
(Left_Opnd
(N
))));
4186 Set_Right_Opnd
(Else_Expr
,
4187 Unchecked_Convert_To
(Standard_Unsigned
,
4188 New_Copy_Tree
(Right_Opnd
(N
))));
4189 Append_To
(Exprs
, Else_Expr
);
4192 Unchecked_Convert_To
(Typ
,
4193 Make_If_Expression
(Loc
, Expressions
=> Exprs
)));
4196 end Expand_Modular_Subtraction
;
4198 -- Start of processing for Expand_Nonbinary_Modular_Op
4201 -- No action needed if front-end expansion is not required or if we
4202 -- have a binary modular operand.
4204 if not Expand_Nonbinary_Modular_Ops
4205 or else not Non_Binary_Modulus
(Typ
)
4212 Expand_Modular_Addition
;
4214 when N_Op_Subtract
=>
4215 Expand_Modular_Subtraction
;
4219 -- Expand -expr into (0 - expr)
4222 Make_Op_Subtract
(Loc
,
4223 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
4224 Right_Opnd
=> Right_Opnd
(N
)));
4225 Analyze_And_Resolve
(N
, Typ
);
4231 Analyze_And_Resolve
(N
, Typ
);
4232 end Expand_Nonbinary_Modular_Op
;
4234 ------------------------
4235 -- Expand_N_Allocator --
4236 ------------------------
4238 procedure Expand_N_Allocator
(N
: Node_Id
) is
4239 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4240 Loc
: constant Source_Ptr
:= Sloc
(N
);
4241 PtrT
: constant Entity_Id
:= Etype
(N
);
4243 procedure Rewrite_Coextension
(N
: Node_Id
);
4244 -- Static coextensions have the same lifetime as the entity they
4245 -- constrain. Such occurrences can be rewritten as aliased objects
4246 -- and their unrestricted access used instead of the coextension.
4248 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4249 -- Given a constrained array type E, returns a node representing the
4250 -- code to compute the size in storage elements for the given type.
4251 -- This is done without using the attribute (which malfunctions for
4254 -------------------------
4255 -- Rewrite_Coextension --
4256 -------------------------
4258 procedure Rewrite_Coextension
(N
: Node_Id
) is
4259 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4260 Temp_Decl
: Node_Id
;
4264 -- Cnn : aliased Etyp;
4267 Make_Object_Declaration
(Loc
,
4268 Defining_Identifier
=> Temp_Id
,
4269 Aliased_Present
=> True,
4270 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4272 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4273 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4276 Insert_Action
(N
, Temp_Decl
);
4278 Make_Attribute_Reference
(Loc
,
4279 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4280 Attribute_Name
=> Name_Unrestricted_Access
));
4282 Analyze_And_Resolve
(N
, PtrT
);
4283 end Rewrite_Coextension
;
4285 ------------------------------
4286 -- Size_In_Storage_Elements --
4287 ------------------------------
4289 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4291 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4292 -- However, the reason for the existence of this function is
4293 -- to construct a test for sizes too large, which means near the
4294 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4295 -- is that we get overflows when sizes are greater than 2**31.
4297 -- So what we end up doing for array types is to use the expression:
4299 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4301 -- which avoids this problem. All this is a bit bogus, but it does
4302 -- mean we catch common cases of trying to allocate arrays that
4303 -- are too large, and which in the absence of a check results in
4304 -- undetected chaos ???
4306 -- Note in particular that this is a pessimistic estimate in the
4307 -- case of packed array types, where an array element might occupy
4308 -- just a fraction of a storage element???
4313 pragma Warnings
(Off
, Res
);
4316 for J
in 1 .. Number_Dimensions
(E
) loop
4318 Make_Attribute_Reference
(Loc
,
4319 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4320 Attribute_Name
=> Name_Length
,
4321 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4328 Make_Op_Multiply
(Loc
,
4335 Make_Op_Multiply
(Loc
,
4338 Make_Attribute_Reference
(Loc
,
4339 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4340 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4342 end Size_In_Storage_Elements
;
4346 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4350 Rel_Typ
: Entity_Id
;
4353 -- Start of processing for Expand_N_Allocator
4356 -- RM E.2.3(22). We enforce that the expected type of an allocator
4357 -- shall not be a remote access-to-class-wide-limited-private type
4359 -- Why is this being done at expansion time, seems clearly wrong ???
4361 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4363 -- Processing for anonymous access-to-controlled types. These access
4364 -- types receive a special finalization master which appears in the
4365 -- declarations of the enclosing semantic unit. This expansion is done
4366 -- now to ensure that any additional types generated by this routine or
4367 -- Expand_Allocator_Expression inherit the proper type attributes.
4369 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4370 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4371 and then Needs_Finalization
(Dtyp
)
4373 -- Detect the allocation of an anonymous controlled object where the
4374 -- type of the context is named. For example:
4376 -- procedure Proc (Ptr : Named_Access_Typ);
4377 -- Proc (new Designated_Typ);
4379 -- Regardless of the anonymous-to-named access type conversion, the
4380 -- lifetime of the object must be associated with the named access
4381 -- type. Use the finalization-related attributes of this type.
4383 if Nkind_In
(Parent
(N
), N_Type_Conversion
,
4384 N_Unchecked_Type_Conversion
)
4385 and then Ekind_In
(Etype
(Parent
(N
)), E_Access_Subtype
,
4387 E_General_Access_Type
)
4389 Rel_Typ
:= Etype
(Parent
(N
));
4394 -- Anonymous access-to-controlled types allocate on the global pool.
4395 -- Note that this is a "root type only" attribute.
4397 if No
(Associated_Storage_Pool
(PtrT
)) then
4398 if Present
(Rel_Typ
) then
4399 Set_Associated_Storage_Pool
4400 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4402 Set_Associated_Storage_Pool
4403 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4407 -- The finalization master must be inserted and analyzed as part of
4408 -- the current semantic unit. Note that the master is updated when
4409 -- analysis changes current units. Note that this is a "root type
4412 if Present
(Rel_Typ
) then
4413 Set_Finalization_Master
4414 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4416 Build_Anonymous_Master
(Root_Type
(PtrT
));
4420 -- Set the storage pool and find the appropriate version of Allocate to
4421 -- call. Do not overwrite the storage pool if it is already set, which
4422 -- can happen for build-in-place function returns (see
4423 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4425 if No
(Storage_Pool
(N
)) then
4426 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4428 if Present
(Pool
) then
4429 Set_Storage_Pool
(N
, Pool
);
4431 if Is_RTE
(Pool
, RE_SS_Pool
) then
4432 Check_Restriction
(No_Secondary_Stack
, N
);
4433 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4435 -- In the case of an allocator for a simple storage pool, locate
4436 -- and save a reference to the pool type's Allocate routine.
4438 elsif Present
(Get_Rep_Pragma
4439 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4442 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4443 Alloc_Op
: Entity_Id
;
4445 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4446 while Present
(Alloc_Op
) loop
4447 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4448 and then Present
(First_Formal
(Alloc_Op
))
4449 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4451 Set_Procedure_To_Call
(N
, Alloc_Op
);
4454 Alloc_Op
:= Homonym
(Alloc_Op
);
4459 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4460 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4463 Set_Procedure_To_Call
(N
,
4464 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4469 -- Under certain circumstances we can replace an allocator by an access
4470 -- to statically allocated storage. The conditions, as noted in AARM
4471 -- 3.10 (10c) are as follows:
4473 -- Size and initial value is known at compile time
4474 -- Access type is access-to-constant
4476 -- The allocator is not part of a constraint on a record component,
4477 -- because in that case the inserted actions are delayed until the
4478 -- record declaration is fully analyzed, which is too late for the
4479 -- analysis of the rewritten allocator.
4481 if Is_Access_Constant
(PtrT
)
4482 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4483 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4484 and then Size_Known_At_Compile_Time
4485 (Etype
(Expression
(Expression
(N
))))
4486 and then not Is_Record_Type
(Current_Scope
)
4488 -- Here we can do the optimization. For the allocator
4492 -- We insert an object declaration
4494 -- Tnn : aliased x := y;
4496 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4497 -- marked as requiring static allocation.
4499 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4500 Desig
:= Subtype_Mark
(Expression
(N
));
4502 -- If context is constrained, use constrained subtype directly,
4503 -- so that the constant is not labelled as having a nominally
4504 -- unconstrained subtype.
4506 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4507 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4511 Make_Object_Declaration
(Loc
,
4512 Defining_Identifier
=> Temp
,
4513 Aliased_Present
=> True,
4514 Constant_Present
=> Is_Access_Constant
(PtrT
),
4515 Object_Definition
=> Desig
,
4516 Expression
=> Expression
(Expression
(N
))));
4519 Make_Attribute_Reference
(Loc
,
4520 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4521 Attribute_Name
=> Name_Unrestricted_Access
));
4523 Analyze_And_Resolve
(N
, PtrT
);
4525 -- We set the variable as statically allocated, since we don't want
4526 -- it going on the stack of the current procedure.
4528 Set_Is_Statically_Allocated
(Temp
);
4532 -- Same if the allocator is an access discriminant for a local object:
4533 -- instead of an allocator we create a local value and constrain the
4534 -- enclosing object with the corresponding access attribute.
4536 if Is_Static_Coextension
(N
) then
4537 Rewrite_Coextension
(N
);
4541 -- Check for size too large, we do this because the back end misses
4542 -- proper checks here and can generate rubbish allocation calls when
4543 -- we are near the limit. We only do this for the 32-bit address case
4544 -- since that is from a practical point of view where we see a problem.
4546 if System_Address_Size
= 32
4547 and then not Storage_Checks_Suppressed
(PtrT
)
4548 and then not Storage_Checks_Suppressed
(Dtyp
)
4549 and then not Storage_Checks_Suppressed
(Etyp
)
4551 -- The check we want to generate should look like
4553 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4554 -- raise Storage_Error;
4557 -- where 3.5 gigabytes is a constant large enough to accommodate any
4558 -- reasonable request for. But we can't do it this way because at
4559 -- least at the moment we don't compute this attribute right, and
4560 -- can silently give wrong results when the result gets large. Since
4561 -- this is all about large results, that's bad, so instead we only
4562 -- apply the check for constrained arrays, and manually compute the
4563 -- value of the attribute ???
4565 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4567 Make_Raise_Storage_Error
(Loc
,
4570 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4572 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4573 Reason
=> SE_Object_Too_Large
));
4577 -- If no storage pool has been specified, or the storage pool
4578 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4579 -- No_Standard_Allocators_After_Elaboration is present, then generate
4580 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4582 if Nkind
(N
) = N_Allocator
4583 and then (No
(Storage_Pool
(N
))
4584 or else Is_RTE
(Storage_Pool
(N
), RE_Global_Pool_Object
))
4585 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4588 Make_Procedure_Call_Statement
(Loc
,
4590 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4593 -- Handle case of qualified expression (other than optimization above)
4594 -- First apply constraint checks, because the bounds or discriminants
4595 -- in the aggregate might not match the subtype mark in the allocator.
4597 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4599 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
4600 Typ
: constant Entity_Id
:= Etype
(Expression
(N
));
4603 Apply_Constraint_Check
(Exp
, Typ
);
4604 Apply_Predicate_Check
(Exp
, Typ
);
4607 Expand_Allocator_Expression
(N
);
4611 -- If the allocator is for a type which requires initialization, and
4612 -- there is no initial value (i.e. operand is a subtype indication
4613 -- rather than a qualified expression), then we must generate a call to
4614 -- the initialization routine using an expressions action node:
4616 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4618 -- Here ptr_T is the pointer type for the allocator, and T is the
4619 -- subtype of the allocator. A special case arises if the designated
4620 -- type of the access type is a task or contains tasks. In this case
4621 -- the call to Init (Temp.all ...) is replaced by code that ensures
4622 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4623 -- for details). In addition, if the type T is a task type, then the
4624 -- first argument to Init must be converted to the task record type.
4627 T
: constant Entity_Id
:= Etype
(Expression
(N
));
4633 Init_Arg1
: Node_Id
;
4634 Init_Call
: Node_Id
;
4635 Temp_Decl
: Node_Id
;
4636 Temp_Type
: Entity_Id
;
4639 if No_Initialization
(N
) then
4641 -- Even though this might be a simple allocation, create a custom
4642 -- Allocate if the context requires it.
4644 if Present
(Finalization_Master
(PtrT
)) then
4645 Build_Allocate_Deallocate_Proc
4647 Is_Allocate
=> True);
4650 -- Optimize the default allocation of an array object when pragma
4651 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4652 -- in-place initialization aggregate which may be convert into a fast
4653 -- memset by the backend.
4655 elsif Init_Or_Norm_Scalars
4656 and then Is_Array_Type
(T
)
4658 -- The array must lack atomic components because they are treated
4659 -- as non-static, and as a result the backend will not initialize
4660 -- the memory in one go.
4662 and then not Has_Atomic_Components
(T
)
4664 -- The array must not be packed because the invalid values in
4665 -- System.Scalar_Values are multiples of Storage_Unit.
4667 and then not Is_Packed
(T
)
4669 -- The array must have static non-empty ranges, otherwise the
4670 -- backend cannot initialize the memory in one go.
4672 and then Has_Static_Non_Empty_Array_Bounds
(T
)
4674 -- The optimization is only relevant for arrays of scalar types
4676 and then Is_Scalar_Type
(Component_Type
(T
))
4678 -- Similar to regular array initialization using a type init proc,
4679 -- predicate checks are not performed because the initialization
4680 -- values are intentionally invalid, and may violate the predicate.
4682 and then not Has_Predicates
(Component_Type
(T
))
4684 -- The component type must have a single initialization value
4686 and then Needs_Simple_Initialization
4687 (Typ
=> Component_Type
(T
),
4688 Consider_IS
=> True)
4691 Temp
:= Make_Temporary
(Loc
, 'P');
4694 -- Temp : Ptr_Typ := new ...;
4699 Make_Object_Declaration
(Loc
,
4700 Defining_Identifier
=> Temp
,
4701 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
4702 Expression
=> Relocate_Node
(N
)),
4703 Suppress
=> All_Checks
);
4706 -- Temp.all := (others => ...);
4711 Make_Assignment_Statement
(Loc
,
4713 Make_Explicit_Dereference
(Loc
,
4714 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
4719 Size
=> Esize
(Component_Type
(T
)))),
4720 Suppress
=> All_Checks
);
4722 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4723 Analyze_And_Resolve
(N
, PtrT
);
4725 -- Case of no initialization procedure present
4727 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4729 -- Case of simple initialization required
4731 if Needs_Simple_Initialization
(T
) then
4732 Check_Restriction
(No_Default_Initialization
, N
);
4733 Rewrite
(Expression
(N
),
4734 Make_Qualified_Expression
(Loc
,
4735 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4736 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4738 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4739 Analyze_And_Resolve
(Expression
(N
), T
);
4740 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4741 Expand_N_Allocator
(N
);
4743 -- No initialization required
4746 Build_Allocate_Deallocate_Proc
4748 Is_Allocate
=> True);
4751 -- Case of initialization procedure present, must be called
4754 Check_Restriction
(No_Default_Initialization
, N
);
4756 if not Restriction_Active
(No_Default_Initialization
) then
4757 Init
:= Base_Init_Proc
(T
);
4759 Temp
:= Make_Temporary
(Loc
, 'P');
4761 -- Construct argument list for the initialization routine call
4764 Make_Explicit_Dereference
(Loc
,
4766 New_Occurrence_Of
(Temp
, Loc
));
4768 Set_Assignment_OK
(Init_Arg1
);
4771 -- The initialization procedure expects a specific type. if the
4772 -- context is access to class wide, indicate that the object
4773 -- being allocated has the right specific type.
4775 if Is_Class_Wide_Type
(Dtyp
) then
4776 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4779 -- If designated type is a concurrent type or if it is private
4780 -- type whose definition is a concurrent type, the first
4781 -- argument in the Init routine has to be unchecked conversion
4782 -- to the corresponding record type. If the designated type is
4783 -- a derived type, also convert the argument to its root type.
4785 if Is_Concurrent_Type
(T
) then
4787 Unchecked_Convert_To
(
4788 Corresponding_Record_Type
(T
), Init_Arg1
);
4790 elsif Is_Private_Type
(T
)
4791 and then Present
(Full_View
(T
))
4792 and then Is_Concurrent_Type
(Full_View
(T
))
4795 Unchecked_Convert_To
4796 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4798 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4800 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4803 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4804 Set_Etype
(Init_Arg1
, Ftyp
);
4808 Args
:= New_List
(Init_Arg1
);
4810 -- For the task case, pass the Master_Id of the access type as
4811 -- the value of the _Master parameter, and _Chain as the value
4812 -- of the _Chain parameter (_Chain will be defined as part of
4813 -- the generated code for the allocator).
4815 -- In Ada 2005, the context may be a function that returns an
4816 -- anonymous access type. In that case the Master_Id has been
4817 -- created when expanding the function declaration.
4819 if Has_Task
(T
) then
4820 if No
(Master_Id
(Base_Type
(PtrT
))) then
4822 -- The designated type was an incomplete type, and the
4823 -- access type did not get expanded. Salvage it now.
4825 if not Restriction_Active
(No_Task_Hierarchy
) then
4826 if Present
(Parent
(Base_Type
(PtrT
))) then
4827 Expand_N_Full_Type_Declaration
4828 (Parent
(Base_Type
(PtrT
)));
4830 -- The only other possibility is an itype. For this
4831 -- case, the master must exist in the context. This is
4832 -- the case when the allocator initializes an access
4833 -- component in an init-proc.
4836 pragma Assert
(Is_Itype
(PtrT
));
4837 Build_Master_Renaming
(PtrT
, N
);
4842 -- If the context of the allocator is a declaration or an
4843 -- assignment, we can generate a meaningful image for it,
4844 -- even though subsequent assignments might remove the
4845 -- connection between task and entity. We build this image
4846 -- when the left-hand side is a simple variable, a simple
4847 -- indexed assignment or a simple selected component.
4849 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4851 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4854 if Is_Entity_Name
(Nam
) then
4856 Build_Task_Image_Decls
4859 (Entity
(Nam
), Sloc
(Nam
)), T
);
4861 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4862 N_Selected_Component
)
4863 and then Is_Entity_Name
(Prefix
(Nam
))
4866 Build_Task_Image_Decls
4867 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4869 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4873 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4875 Build_Task_Image_Decls
4876 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4879 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4882 if Restriction_Active
(No_Task_Hierarchy
) then
4884 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4888 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4891 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4893 Decl
:= Last
(Decls
);
4895 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4897 -- Has_Task is false, Decls not used
4903 -- Add discriminants if discriminated type
4906 Dis
: Boolean := False;
4907 Typ
: Entity_Id
:= Empty
;
4910 if Has_Discriminants
(T
) then
4914 -- Type may be a private type with no visible discriminants
4915 -- in which case check full view if in scope, or the
4916 -- underlying_full_view if dealing with a type whose full
4917 -- view may be derived from a private type whose own full
4918 -- view has discriminants.
4920 elsif Is_Private_Type
(T
) then
4921 if Present
(Full_View
(T
))
4922 and then Has_Discriminants
(Full_View
(T
))
4925 Typ
:= Full_View
(T
);
4927 elsif Present
(Underlying_Full_View
(T
))
4928 and then Has_Discriminants
(Underlying_Full_View
(T
))
4931 Typ
:= Underlying_Full_View
(T
);
4937 -- If the allocated object will be constrained by the
4938 -- default values for discriminants, then build a subtype
4939 -- with those defaults, and change the allocated subtype
4940 -- to that. Note that this happens in fewer cases in Ada
4943 if not Is_Constrained
(Typ
)
4944 and then Present
(Discriminant_Default_Value
4945 (First_Discriminant
(Typ
)))
4946 and then (Ada_Version
< Ada_2005
4948 Object_Type_Has_Constrained_Partial_View
4949 (Typ
, Current_Scope
))
4951 Typ
:= Build_Default_Subtype
(Typ
, N
);
4952 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
4955 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4956 while Present
(Discr
) loop
4957 Nod
:= Node
(Discr
);
4958 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4960 -- AI-416: when the discriminant constraint is an
4961 -- anonymous access type make sure an accessibility
4962 -- check is inserted if necessary (3.10.2(22.q/2))
4964 if Ada_Version
>= Ada_2005
4966 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4968 Apply_Accessibility_Check
4969 (Nod
, Typ
, Insert_Node
=> Nod
);
4977 -- We set the allocator as analyzed so that when we analyze
4978 -- the if expression node, we do not get an unwanted recursive
4979 -- expansion of the allocator expression.
4981 Set_Analyzed
(N
, True);
4982 Nod
:= Relocate_Node
(N
);
4984 -- Here is the transformation:
4985 -- input: new Ctrl_Typ
4986 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4987 -- Ctrl_TypIP (Temp.all, ...);
4988 -- [Deep_]Initialize (Temp.all);
4990 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4991 -- is the subtype of the allocator.
4994 Make_Object_Declaration
(Loc
,
4995 Defining_Identifier
=> Temp
,
4996 Constant_Present
=> True,
4997 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
5000 Set_Assignment_OK
(Temp_Decl
);
5001 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
5003 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
5005 -- If the designated type is a task type or contains tasks,
5006 -- create block to activate created tasks, and insert
5007 -- declaration for Task_Image variable ahead of call.
5009 if Has_Task
(T
) then
5011 L
: constant List_Id
:= New_List
;
5014 Build_Task_Allocate_Block
(L
, Nod
, Args
);
5016 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
5017 Insert_Actions
(N
, L
);
5022 Make_Procedure_Call_Statement
(Loc
,
5023 Name
=> New_Occurrence_Of
(Init
, Loc
),
5024 Parameter_Associations
=> Args
));
5027 if Needs_Finalization
(T
) then
5030 -- [Deep_]Initialize (Init_Arg1);
5034 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
5037 -- Guard against a missing [Deep_]Initialize when the
5038 -- designated type was not properly frozen.
5040 if Present
(Init_Call
) then
5041 Insert_Action
(N
, Init_Call
);
5045 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5046 Analyze_And_Resolve
(N
, PtrT
);
5051 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5052 -- object that has been rewritten as a reference, we displace "this"
5053 -- to reference properly its secondary dispatch table.
5055 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
5056 Displace_Allocator_Pointer
(N
);
5060 when RE_Not_Available
=>
5062 end Expand_N_Allocator
;
5064 -----------------------
5065 -- Expand_N_And_Then --
5066 -----------------------
5068 procedure Expand_N_And_Then
(N
: Node_Id
)
5069 renames Expand_Short_Circuit_Operator
;
5071 ------------------------------
5072 -- Expand_N_Case_Expression --
5073 ------------------------------
5075 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
5077 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean;
5078 -- Return True if we can copy objects of this type when expanding a case
5085 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean is
5087 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5088 -- large objects, as long as they are constrained and not limited.
5091 Is_Elementary_Type
(Underlying_Type
(Typ
))
5093 (Minimize_Expression_With_Actions
5094 and then Is_Constrained
(Underlying_Type
(Typ
))
5095 and then not Is_Limited_View
(Underlying_Type
(Typ
)));
5100 Loc
: constant Source_Ptr
:= Sloc
(N
);
5101 Par
: constant Node_Id
:= Parent
(N
);
5102 Typ
: constant Entity_Id
:= Etype
(N
);
5106 Case_Stmt
: Node_Id
;
5110 Target_Typ
: Entity_Id
;
5112 In_Predicate
: Boolean := False;
5113 -- Flag set when the case expression appears within a predicate
5115 Optimize_Return_Stmt
: Boolean := False;
5116 -- Flag set when the case expression can be optimized in the context of
5117 -- a simple return statement.
5119 -- Start of processing for Expand_N_Case_Expression
5122 -- Check for MINIMIZED/ELIMINATED overflow mode
5124 if Minimized_Eliminated_Overflow_Check
(N
) then
5125 Apply_Arithmetic_Overflow_Check
(N
);
5129 -- If the case expression is a predicate specification, and the type
5130 -- to which it applies has a static predicate aspect, do not expand,
5131 -- because it will be converted to the proper predicate form later.
5133 if Ekind_In
(Current_Scope
, E_Function
, E_Procedure
)
5134 and then Is_Predicate_Function
(Current_Scope
)
5136 In_Predicate
:= True;
5138 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
5144 -- When the type of the case expression is elementary, expand
5146 -- (case X is when A => AX, when B => BX ...)
5161 -- In all other cases expand into
5164 -- type Ptr_Typ is access all Typ;
5165 -- Target : Ptr_Typ;
5168 -- Target := AX'Unrestricted_Access;
5170 -- Target := BX'Unrestricted_Access;
5173 -- in Target.all end;
5175 -- This approach avoids extra copies of potentially large objects. It
5176 -- also allows handling of values of limited or unconstrained types.
5177 -- Note that we do the copy also for constrained, nonlimited types
5178 -- when minimizing expressions with actions (e.g. when generating C
5179 -- code) since it allows us to do the optimization below in more cases.
5181 -- Small optimization: when the case expression appears in the context
5182 -- of a simple return statement, expand into
5193 Make_Case_Statement
(Loc
,
5194 Expression
=> Expression
(N
),
5195 Alternatives
=> New_List
);
5197 -- Preserve the original context for which the case statement is being
5198 -- generated. This is needed by the finalization machinery to prevent
5199 -- the premature finalization of controlled objects found within the
5202 Set_From_Conditional_Expression
(Case_Stmt
);
5207 if Is_Copy_Type
(Typ
) then
5210 -- ??? Do not perform the optimization when the return statement is
5211 -- within a predicate function, as this causes spurious errors. Could
5212 -- this be a possible mismatch in handling this case somewhere else
5213 -- in semantic analysis?
5215 Optimize_Return_Stmt
:=
5216 Nkind
(Par
) = N_Simple_Return_Statement
and then not In_Predicate
;
5218 -- Otherwise create an access type to handle the general case using
5219 -- 'Unrestricted_Access.
5222 -- type Ptr_Typ is access all Typ;
5225 if Generate_C_Code
then
5227 -- We cannot ensure that correct C code will be generated if any
5228 -- temporary is created down the line (to e.g. handle checks or
5229 -- capture values) since we might end up with dangling references
5230 -- to local variables, so better be safe and reject the construct.
5233 ("case expression too complex, use case statement instead", N
);
5236 Target_Typ
:= Make_Temporary
(Loc
, 'P');
5239 Make_Full_Type_Declaration
(Loc
,
5240 Defining_Identifier
=> Target_Typ
,
5242 Make_Access_To_Object_Definition
(Loc
,
5243 All_Present
=> True,
5244 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5247 -- Create the declaration of the target which captures the value of the
5251 -- Target : [Ptr_]Typ;
5253 if not Optimize_Return_Stmt
then
5254 Target
:= Make_Temporary
(Loc
, 'T');
5257 Make_Object_Declaration
(Loc
,
5258 Defining_Identifier
=> Target
,
5259 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
5260 Set_No_Initialization
(Decl
);
5262 Append_To
(Acts
, Decl
);
5265 -- Process the alternatives
5267 Alt
:= First
(Alternatives
(N
));
5268 while Present
(Alt
) loop
5270 Alt_Expr
: Node_Id
:= Expression
(Alt
);
5271 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
5275 -- Take the unrestricted access of the expression value for non-
5276 -- scalar types. This approach avoids big copies and covers the
5277 -- limited and unconstrained cases.
5280 -- AX'Unrestricted_Access
5282 if not Is_Copy_Type
(Typ
) then
5284 Make_Attribute_Reference
(Alt_Loc
,
5285 Prefix
=> Relocate_Node
(Alt_Expr
),
5286 Attribute_Name
=> Name_Unrestricted_Access
);
5290 -- return AX['Unrestricted_Access];
5292 if Optimize_Return_Stmt
then
5294 Make_Simple_Return_Statement
(Alt_Loc
,
5295 Expression
=> Alt_Expr
));
5298 -- Target := AX['Unrestricted_Access];
5302 Make_Assignment_Statement
(Alt_Loc
,
5303 Name
=> New_Occurrence_Of
(Target
, Loc
),
5304 Expression
=> Alt_Expr
));
5307 -- Propagate declarations inserted in the node by Insert_Actions
5308 -- (for example, temporaries generated to remove side effects).
5309 -- These actions must remain attached to the alternative, given
5310 -- that they are generated by the corresponding expression.
5312 if Present
(Actions
(Alt
)) then
5313 Prepend_List
(Actions
(Alt
), Stmts
);
5316 -- Finalize any transient objects on exit from the alternative.
5317 -- This is done only in the return optimization case because
5318 -- otherwise the case expression is converted into an expression
5319 -- with actions which already contains this form of processing.
5321 if Optimize_Return_Stmt
then
5322 Process_If_Case_Statements
(N
, Stmts
);
5326 (Alternatives
(Case_Stmt
),
5327 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5328 Discrete_Choices
=> Discrete_Choices
(Alt
),
5329 Statements
=> Stmts
));
5335 -- Rewrite the parent return statement as a case statement
5337 if Optimize_Return_Stmt
then
5338 Rewrite
(Par
, Case_Stmt
);
5341 -- Otherwise convert the case expression into an expression with actions
5344 Append_To
(Acts
, Case_Stmt
);
5346 if Is_Copy_Type
(Typ
) then
5347 Expr
:= New_Occurrence_Of
(Target
, Loc
);
5351 Make_Explicit_Dereference
(Loc
,
5352 Prefix
=> New_Occurrence_Of
(Target
, Loc
));
5358 -- in Target[.all] end;
5361 Make_Expression_With_Actions
(Loc
,
5365 Analyze_And_Resolve
(N
, Typ
);
5367 end Expand_N_Case_Expression
;
5369 -----------------------------------
5370 -- Expand_N_Explicit_Dereference --
5371 -----------------------------------
5373 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5375 -- Insert explicit dereference call for the checked storage pool case
5377 Insert_Dereference_Action
(Prefix
(N
));
5379 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5380 -- we set the atomic sync flag.
5382 if Is_Atomic
(Etype
(N
))
5383 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5385 Activate_Atomic_Synchronization
(N
);
5387 end Expand_N_Explicit_Dereference
;
5389 --------------------------------------
5390 -- Expand_N_Expression_With_Actions --
5391 --------------------------------------
5393 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5394 Acts
: constant List_Id
:= Actions
(N
);
5396 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
5397 -- Force the evaluation of Boolean expression Expr
5399 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5400 -- Inspect and process a single action of an expression_with_actions for
5401 -- transient objects. If such objects are found, the routine generates
5402 -- code to clean them up when the context of the expression is evaluated
5405 ------------------------------
5406 -- Force_Boolean_Evaluation --
5407 ------------------------------
5409 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
5410 Loc
: constant Source_Ptr
:= Sloc
(N
);
5411 Flag_Decl
: Node_Id
;
5412 Flag_Id
: Entity_Id
;
5415 -- Relocate the expression to the actions list by capturing its value
5416 -- in a Boolean flag. Generate:
5417 -- Flag : constant Boolean := Expr;
5419 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5422 Make_Object_Declaration
(Loc
,
5423 Defining_Identifier
=> Flag_Id
,
5424 Constant_Present
=> True,
5425 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5426 Expression
=> Relocate_Node
(Expr
));
5428 Append
(Flag_Decl
, Acts
);
5429 Analyze
(Flag_Decl
);
5431 -- Replace the expression with a reference to the flag
5433 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
5434 Analyze
(Expression
(N
));
5435 end Force_Boolean_Evaluation
;
5437 --------------------
5438 -- Process_Action --
5439 --------------------
5441 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5443 if Nkind
(Act
) = N_Object_Declaration
5444 and then Is_Finalizable_Transient
(Act
, N
)
5446 Process_Transient_In_Expression
(Act
, N
, Acts
);
5449 -- Avoid processing temporary function results multiple times when
5450 -- dealing with nested expression_with_actions.
5452 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5455 -- Do not process temporary function results in loops. This is done
5456 -- by Expand_N_Loop_Statement and Build_Finalizer.
5458 elsif Nkind
(Act
) = N_Loop_Statement
then
5465 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5471 -- Start of processing for Expand_N_Expression_With_Actions
5474 -- Do not evaluate the expression when it denotes an entity because the
5475 -- expression_with_actions node will be replaced by the reference.
5477 if Is_Entity_Name
(Expression
(N
)) then
5480 -- Do not evaluate the expression when there are no actions because the
5481 -- expression_with_actions node will be replaced by the expression.
5483 elsif No
(Acts
) or else Is_Empty_List
(Acts
) then
5486 -- Force the evaluation of the expression by capturing its value in a
5487 -- temporary. This ensures that aliases of transient objects do not leak
5488 -- to the expression of the expression_with_actions node:
5491 -- Trans_Id : Ctrl_Typ := ...;
5492 -- Alias : ... := Trans_Id;
5493 -- in ... Alias ... end;
5495 -- In the example above, Trans_Id cannot be finalized at the end of the
5496 -- actions list because this may affect the alias and the final value of
5497 -- the expression_with_actions. Forcing the evaluation encapsulates the
5498 -- reference to the Alias within the actions list:
5501 -- Trans_Id : Ctrl_Typ := ...;
5502 -- Alias : ... := Trans_Id;
5503 -- Val : constant Boolean := ... Alias ...;
5504 -- <finalize Trans_Id>
5507 -- Once this transformation is performed, it is safe to finalize the
5508 -- transient object at the end of the actions list.
5510 -- Note that Force_Evaluation does not remove side effects in operators
5511 -- because it assumes that all operands are evaluated and side effect
5512 -- free. This is not the case when an operand depends implicitly on the
5513 -- transient object through the use of access types.
5515 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5516 Force_Boolean_Evaluation
(Expression
(N
));
5518 -- The expression of an expression_with_actions node may not necessarily
5519 -- be Boolean when the node appears in an if expression. In this case do
5520 -- the usual forced evaluation to encapsulate potential aliasing.
5523 Force_Evaluation
(Expression
(N
));
5526 -- Process all transient objects found within the actions of the EWA
5529 Act
:= First
(Acts
);
5530 while Present
(Act
) loop
5531 Process_Single_Action
(Act
);
5535 -- Deal with case where there are no actions. In this case we simply
5536 -- rewrite the node with its expression since we don't need the actions
5537 -- and the specification of this node does not allow a null action list.
5539 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5540 -- the expanded tree and relying on being able to retrieve the original
5541 -- tree in cases like this. This raises a whole lot of issues of whether
5542 -- we have problems elsewhere, which will be addressed in the future???
5544 if Is_Empty_List
(Acts
) then
5545 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5547 end Expand_N_Expression_With_Actions
;
5549 ----------------------------
5550 -- Expand_N_If_Expression --
5551 ----------------------------
5553 -- Deal with limited types and condition actions
5555 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5556 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5557 Loc
: constant Source_Ptr
:= Sloc
(N
);
5558 Thenx
: constant Node_Id
:= Next
(Cond
);
5559 Elsex
: constant Node_Id
:= Next
(Thenx
);
5560 Typ
: constant Entity_Id
:= Etype
(N
);
5569 -- Check for MINIMIZED/ELIMINATED overflow mode
5571 if Minimized_Eliminated_Overflow_Check
(N
) then
5572 Apply_Arithmetic_Overflow_Check
(N
);
5576 -- Fold at compile time if condition known. We have already folded
5577 -- static if expressions, but it is possible to fold any case in which
5578 -- the condition is known at compile time, even though the result is
5581 -- Note that we don't do the fold of such cases in Sem_Elab because
5582 -- it can cause infinite loops with the expander adding a conditional
5583 -- expression, and Sem_Elab circuitry removing it repeatedly.
5585 if Compile_Time_Known_Value
(Cond
) then
5587 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5588 -- Fold at compile time. Assumes condition known. Return True if
5589 -- folding occurred, meaning we're done.
5591 ----------------------
5592 -- Fold_Known_Value --
5593 ----------------------
5595 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5597 if Is_True
(Expr_Value
(Cond
)) then
5599 Actions
:= Then_Actions
(N
);
5602 Actions
:= Else_Actions
(N
);
5607 if Present
(Actions
) then
5609 -- To minimize the use of Expression_With_Actions, just skip
5610 -- the optimization as it is not critical for correctness.
5612 if Minimize_Expression_With_Actions
then
5617 Make_Expression_With_Actions
(Loc
,
5618 Expression
=> Relocate_Node
(Expr
),
5619 Actions
=> Actions
));
5620 Analyze_And_Resolve
(N
, Typ
);
5623 Rewrite
(N
, Relocate_Node
(Expr
));
5626 -- Note that the result is never static (legitimate cases of
5627 -- static if expressions were folded in Sem_Eval).
5629 Set_Is_Static_Expression
(N
, False);
5631 end Fold_Known_Value
;
5634 if Fold_Known_Value
(Cond
) then
5640 -- If the type is limited, and the back end does not handle limited
5641 -- types, then we expand as follows to avoid the possibility of
5642 -- improper copying.
5644 -- type Ptr is access all Typ;
5648 -- Cnn := then-expr'Unrestricted_Access;
5651 -- Cnn := else-expr'Unrestricted_Access;
5654 -- and replace the if expression by a reference to Cnn.all.
5656 -- This special case can be skipped if the back end handles limited
5657 -- types properly and ensures that no incorrect copies are made.
5659 if Is_By_Reference_Type
(Typ
)
5660 and then not Back_End_Handles_Limited_Types
5662 -- When the "then" or "else" expressions involve controlled function
5663 -- calls, generated temporaries are chained on the corresponding list
5664 -- of actions. These temporaries need to be finalized after the if
5665 -- expression is evaluated.
5667 Process_If_Case_Statements
(N
, Then_Actions
(N
));
5668 Process_If_Case_Statements
(N
, Else_Actions
(N
));
5671 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C', N
);
5672 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5676 -- type Ann is access all Typ;
5679 Make_Full_Type_Declaration
(Loc
,
5680 Defining_Identifier
=> Ptr_Typ
,
5682 Make_Access_To_Object_Definition
(Loc
,
5683 All_Present
=> True,
5684 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5690 Make_Object_Declaration
(Loc
,
5691 Defining_Identifier
=> Cnn
,
5692 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5696 -- Cnn := <Thenx>'Unrestricted_Access;
5698 -- Cnn := <Elsex>'Unrestricted_Access;
5702 Make_Implicit_If_Statement
(N
,
5703 Condition
=> Relocate_Node
(Cond
),
5704 Then_Statements
=> New_List
(
5705 Make_Assignment_Statement
(Sloc
(Thenx
),
5706 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5708 Make_Attribute_Reference
(Loc
,
5709 Prefix
=> Relocate_Node
(Thenx
),
5710 Attribute_Name
=> Name_Unrestricted_Access
))),
5712 Else_Statements
=> New_List
(
5713 Make_Assignment_Statement
(Sloc
(Elsex
),
5714 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5716 Make_Attribute_Reference
(Loc
,
5717 Prefix
=> Relocate_Node
(Elsex
),
5718 Attribute_Name
=> Name_Unrestricted_Access
))));
5720 -- Preserve the original context for which the if statement is
5721 -- being generated. This is needed by the finalization machinery
5722 -- to prevent the premature finalization of controlled objects
5723 -- found within the if statement.
5725 Set_From_Conditional_Expression
(New_If
);
5728 Make_Explicit_Dereference
(Loc
,
5729 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5732 -- If the result is an unconstrained array and the if expression is in a
5733 -- context other than the initializing expression of the declaration of
5734 -- an object, then we pull out the if expression as follows:
5736 -- Cnn : constant typ := if-expression
5738 -- and then replace the if expression with an occurrence of Cnn. This
5739 -- avoids the need in the back end to create on-the-fly variable length
5740 -- temporaries (which it cannot do!)
5742 -- Note that the test for being in an object declaration avoids doing an
5743 -- unnecessary expansion, and also avoids infinite recursion.
5745 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
)
5746 and then (Nkind
(Parent
(N
)) /= N_Object_Declaration
5747 or else Expression
(Parent
(N
)) /= N
)
5750 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5754 Make_Object_Declaration
(Loc
,
5755 Defining_Identifier
=> Cnn
,
5756 Constant_Present
=> True,
5757 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5758 Expression
=> Relocate_Node
(N
),
5759 Has_Init_Expression
=> True));
5761 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
5765 -- For other types, we only need to expand if there are other actions
5766 -- associated with either branch.
5768 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5770 -- We now wrap the actions into the appropriate expression
5772 if Minimize_Expression_With_Actions
5773 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
5774 or else Is_Constrained
(Underlying_Type
(Typ
)))
5776 -- If we can't use N_Expression_With_Actions nodes, then we insert
5777 -- the following sequence of actions (using Insert_Actions):
5782 -- Cnn := then-expr;
5788 -- and replace the if expression by a reference to Cnn
5791 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5795 Make_Object_Declaration
(Loc
,
5796 Defining_Identifier
=> Cnn
,
5797 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
5800 Make_Implicit_If_Statement
(N
,
5801 Condition
=> Relocate_Node
(Cond
),
5803 Then_Statements
=> New_List
(
5804 Make_Assignment_Statement
(Sloc
(Thenx
),
5805 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5806 Expression
=> Relocate_Node
(Thenx
))),
5808 Else_Statements
=> New_List
(
5809 Make_Assignment_Statement
(Sloc
(Elsex
),
5810 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5811 Expression
=> Relocate_Node
(Elsex
))));
5813 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
5814 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
5816 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
5819 -- Regular path using Expression_With_Actions
5822 if Present
(Then_Actions
(N
)) then
5824 Make_Expression_With_Actions
(Sloc
(Thenx
),
5825 Actions
=> Then_Actions
(N
),
5826 Expression
=> Relocate_Node
(Thenx
)));
5828 Set_Then_Actions
(N
, No_List
);
5829 Analyze_And_Resolve
(Thenx
, Typ
);
5832 if Present
(Else_Actions
(N
)) then
5834 Make_Expression_With_Actions
(Sloc
(Elsex
),
5835 Actions
=> Else_Actions
(N
),
5836 Expression
=> Relocate_Node
(Elsex
)));
5838 Set_Else_Actions
(N
, No_List
);
5839 Analyze_And_Resolve
(Elsex
, Typ
);
5845 -- If no actions then no expansion needed, gigi will handle it using the
5846 -- same approach as a C conditional expression.
5852 -- Fall through here for either the limited expansion, or the case of
5853 -- inserting actions for nonlimited types. In both these cases, we must
5854 -- move the SLOC of the parent If statement to the newly created one and
5855 -- change it to the SLOC of the expression which, after expansion, will
5856 -- correspond to what is being evaluated.
5858 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
5859 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5860 Set_Sloc
(Parent
(N
), Loc
);
5863 -- Make sure Then_Actions and Else_Actions are appropriately moved
5864 -- to the new if statement.
5866 if Present
(Then_Actions
(N
)) then
5868 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5871 if Present
(Else_Actions
(N
)) then
5873 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5876 Insert_Action
(N
, Decl
);
5877 Insert_Action
(N
, New_If
);
5879 Analyze_And_Resolve
(N
, Typ
);
5880 end Expand_N_If_Expression
;
5886 procedure Expand_N_In
(N
: Node_Id
) is
5887 Loc
: constant Source_Ptr
:= Sloc
(N
);
5888 Restyp
: constant Entity_Id
:= Etype
(N
);
5889 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5890 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5891 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5893 procedure Substitute_Valid_Check
;
5894 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5895 -- test for the left operand being in range of its subtype.
5897 ----------------------------
5898 -- Substitute_Valid_Check --
5899 ----------------------------
5901 procedure Substitute_Valid_Check
is
5902 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
5903 -- Determine whether arbitrary node Nod denotes a source object that
5904 -- may safely act as prefix of attribute 'Valid.
5906 ----------------------------
5907 -- Is_OK_Object_Reference --
5908 ----------------------------
5910 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
5914 -- Inspect the original operand
5916 Obj_Ref
:= Original_Node
(Nod
);
5918 -- The object reference must be a source construct, otherwise the
5919 -- codefix suggestion may refer to nonexistent code from a user
5922 if Comes_From_Source
(Obj_Ref
) then
5924 -- Recover the actual object reference. There may be more cases
5928 if Nkind_In
(Obj_Ref
, N_Type_Conversion
,
5929 N_Unchecked_Type_Conversion
)
5931 Obj_Ref
:= Expression
(Obj_Ref
);
5937 return Is_Object_Reference
(Obj_Ref
);
5941 end Is_OK_Object_Reference
;
5943 -- Start of processing for Substitute_Valid_Check
5947 Make_Attribute_Reference
(Loc
,
5948 Prefix
=> Relocate_Node
(Lop
),
5949 Attribute_Name
=> Name_Valid
));
5951 Analyze_And_Resolve
(N
, Restyp
);
5953 -- Emit a warning when the left-hand operand of the membership test
5954 -- is a source object, otherwise the use of attribute 'Valid would be
5955 -- illegal. The warning is not given when overflow checking is either
5956 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
5957 -- eliminated above.
5959 if Is_OK_Object_Reference
(Lop
)
5960 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
5963 ("??explicit membership test may be optimized away", N
);
5964 Error_Msg_N
-- CODEFIX
5965 ("\??use ''Valid attribute instead", N
);
5967 end Substitute_Valid_Check
;
5974 -- Start of processing for Expand_N_In
5977 -- If set membership case, expand with separate procedure
5979 if Present
(Alternatives
(N
)) then
5980 Expand_Set_Membership
(N
);
5984 -- Not set membership, proceed with expansion
5986 Ltyp
:= Etype
(Left_Opnd
(N
));
5987 Rtyp
:= Etype
(Right_Opnd
(N
));
5989 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5990 -- type, then expand with a separate procedure. Note the use of the
5991 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5993 if Overflow_Check_Mode
in Minimized_Or_Eliminated
5994 and then Is_Signed_Integer_Type
(Ltyp
)
5995 and then not No_Minimize_Eliminate
(N
)
5997 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
6001 -- Check case of explicit test for an expression in range of its
6002 -- subtype. This is suspicious usage and we replace it with a 'Valid
6003 -- test and give a warning for scalar types.
6005 if Is_Scalar_Type
(Ltyp
)
6007 -- Only relevant for source comparisons
6009 and then Comes_From_Source
(N
)
6011 -- In floating-point this is a standard way to check for finite values
6012 -- and using 'Valid would typically be a pessimization.
6014 and then not Is_Floating_Point_Type
(Ltyp
)
6016 -- Don't give the message unless right operand is a type entity and
6017 -- the type of the left operand matches this type. Note that this
6018 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6019 -- checks have changed the type of the left operand.
6021 and then Nkind
(Rop
) in N_Has_Entity
6022 and then Ltyp
= Entity
(Rop
)
6024 -- Skip this for predicated types, where such expressions are a
6025 -- reasonable way of testing if something meets the predicate.
6027 and then not Present
(Predicate_Function
(Ltyp
))
6029 Substitute_Valid_Check
;
6033 -- Do validity check on operands
6035 if Validity_Checks_On
and Validity_Check_Operands
then
6036 Ensure_Valid
(Left_Opnd
(N
));
6037 Validity_Check_Range
(Right_Opnd
(N
));
6040 -- Case of explicit range
6042 if Nkind
(Rop
) = N_Range
then
6044 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
6045 Hi
: constant Node_Id
:= High_Bound
(Rop
);
6047 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
6048 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
6050 Lcheck
: Compare_Result
;
6051 Ucheck
: Compare_Result
;
6053 Warn1
: constant Boolean :=
6054 Constant_Condition_Warnings
6055 and then Comes_From_Source
(N
)
6056 and then not In_Instance
;
6057 -- This must be true for any of the optimization warnings, we
6058 -- clearly want to give them only for source with the flag on. We
6059 -- also skip these warnings in an instance since it may be the
6060 -- case that different instantiations have different ranges.
6062 Warn2
: constant Boolean :=
6064 and then Nkind
(Original_Node
(Rop
)) = N_Range
6065 and then Is_Integer_Type
(Etype
(Lo
));
6066 -- For the case where only one bound warning is elided, we also
6067 -- insist on an explicit range and an integer type. The reason is
6068 -- that the use of enumeration ranges including an end point is
6069 -- common, as is the use of a subtype name, one of whose bounds is
6070 -- the same as the type of the expression.
6073 -- If test is explicit x'First .. x'Last, replace by valid check
6075 -- Could use some individual comments for this complex test ???
6077 if Is_Scalar_Type
(Ltyp
)
6079 -- And left operand is X'First where X matches left operand
6080 -- type (this eliminates cases of type mismatch, including
6081 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6082 -- type of the left operand.
6084 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
6085 and then Attribute_Name
(Lo_Orig
) = Name_First
6086 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
6087 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
6089 -- Same tests for right operand
6091 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
6092 and then Attribute_Name
(Hi_Orig
) = Name_Last
6093 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
6094 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
6096 -- Relevant only for source cases
6098 and then Comes_From_Source
(N
)
6100 Substitute_Valid_Check
;
6104 -- If bounds of type are known at compile time, and the end points
6105 -- are known at compile time and identical, this is another case
6106 -- for substituting a valid test. We only do this for discrete
6107 -- types, since it won't arise in practice for float types.
6109 if Comes_From_Source
(N
)
6110 and then Is_Discrete_Type
(Ltyp
)
6111 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
6112 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
6113 and then Compile_Time_Known_Value
(Lo
)
6114 and then Compile_Time_Known_Value
(Hi
)
6115 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
6116 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
6118 -- Kill warnings in instances, since they may be cases where we
6119 -- have a test in the generic that makes sense with some types
6120 -- and not with other types.
6122 -- Similarly, do not rewrite membership as a validity check if
6123 -- within the predicate function for the type.
6127 or else (Ekind
(Current_Scope
) = E_Function
6128 and then Is_Predicate_Function
(Current_Scope
))
6133 Substitute_Valid_Check
;
6138 -- If we have an explicit range, do a bit of optimization based on
6139 -- range analysis (we may be able to kill one or both checks).
6141 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
6142 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
6144 -- If either check is known to fail, replace result by False since
6145 -- the other check does not matter. Preserve the static flag for
6146 -- legality checks, because we are constant-folding beyond RM 4.9.
6148 if Lcheck
= LT
or else Ucheck
= GT
then
6150 Error_Msg_N
("?c?range test optimized away", N
);
6151 Error_Msg_N
("\?c?value is known to be out of range", N
);
6154 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6155 Analyze_And_Resolve
(N
, Restyp
);
6156 Set_Is_Static_Expression
(N
, Static
);
6159 -- If both checks are known to succeed, replace result by True,
6160 -- since we know we are in range.
6162 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6164 Error_Msg_N
("?c?range test optimized away", N
);
6165 Error_Msg_N
("\?c?value is known to be in range", N
);
6168 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6169 Analyze_And_Resolve
(N
, Restyp
);
6170 Set_Is_Static_Expression
(N
, Static
);
6173 -- If lower bound check succeeds and upper bound check is not
6174 -- known to succeed or fail, then replace the range check with
6175 -- a comparison against the upper bound.
6177 elsif Lcheck
in Compare_GE
then
6178 if Warn2
and then not In_Instance
then
6179 Error_Msg_N
("??lower bound test optimized away", Lo
);
6180 Error_Msg_N
("\??value is known to be in range", Lo
);
6186 Right_Opnd
=> High_Bound
(Rop
)));
6187 Analyze_And_Resolve
(N
, Restyp
);
6190 -- If upper bound check succeeds and lower bound check is not
6191 -- known to succeed or fail, then replace the range check with
6192 -- a comparison against the lower bound.
6194 elsif Ucheck
in Compare_LE
then
6195 if Warn2
and then not In_Instance
then
6196 Error_Msg_N
("??upper bound test optimized away", Hi
);
6197 Error_Msg_N
("\??value is known to be in range", Hi
);
6203 Right_Opnd
=> Low_Bound
(Rop
)));
6204 Analyze_And_Resolve
(N
, Restyp
);
6208 -- We couldn't optimize away the range check, but there is one
6209 -- more issue. If we are checking constant conditionals, then we
6210 -- see if we can determine the outcome assuming everything is
6211 -- valid, and if so give an appropriate warning.
6213 if Warn1
and then not Assume_No_Invalid_Values
then
6214 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
6215 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
6217 -- Result is out of range for valid value
6219 if Lcheck
= LT
or else Ucheck
= GT
then
6221 ("?c?value can only be in range if it is invalid", N
);
6223 -- Result is in range for valid value
6225 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6227 ("?c?value can only be out of range if it is invalid", N
);
6229 -- Lower bound check succeeds if value is valid
6231 elsif Warn2
and then Lcheck
in Compare_GE
then
6233 ("?c?lower bound check only fails if it is invalid", Lo
);
6235 -- Upper bound check succeeds if value is valid
6237 elsif Warn2
and then Ucheck
in Compare_LE
then
6239 ("?c?upper bound check only fails for invalid values", Hi
);
6244 -- For all other cases of an explicit range, nothing to be done
6248 -- Here right operand is a subtype mark
6252 Typ
: Entity_Id
:= Etype
(Rop
);
6253 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
6254 Cond
: Node_Id
:= Empty
;
6256 Obj
: Node_Id
:= Lop
;
6257 SCIL_Node
: Node_Id
;
6260 Remove_Side_Effects
(Obj
);
6262 -- For tagged type, do tagged membership operation
6264 if Is_Tagged_Type
(Typ
) then
6266 -- No expansion will be performed for VM targets, as the VM
6267 -- back ends will handle the membership tests directly.
6269 if Tagged_Type_Expansion
then
6270 Tagged_Membership
(N
, SCIL_Node
, New_N
);
6272 Analyze_And_Resolve
(N
, Restyp
, Suppress
=> All_Checks
);
6274 -- Update decoration of relocated node referenced by the
6277 if Generate_SCIL
and then Present
(SCIL_Node
) then
6278 Set_SCIL_Node
(N
, SCIL_Node
);
6284 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6285 -- This reason we do this is that the bounds may have the wrong
6286 -- type if they come from the original type definition. Also this
6287 -- way we get all the processing above for an explicit range.
6289 -- Don't do this for predicated types, since in this case we
6290 -- want to check the predicate.
6292 elsif Is_Scalar_Type
(Typ
) then
6293 if No
(Predicate_Function
(Typ
)) then
6297 Make_Attribute_Reference
(Loc
,
6298 Attribute_Name
=> Name_First
,
6299 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
6302 Make_Attribute_Reference
(Loc
,
6303 Attribute_Name
=> Name_Last
,
6304 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
6305 Analyze_And_Resolve
(N
, Restyp
);
6310 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
6311 -- a membership test if the subtype mark denotes a constrained
6312 -- Unchecked_Union subtype and the expression lacks inferable
6315 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
6316 and then Is_Constrained
(Typ
)
6317 and then not Has_Inferable_Discriminants
(Lop
)
6320 Make_Raise_Program_Error
(Loc
,
6321 Reason
=> PE_Unchecked_Union_Restriction
));
6323 -- Prevent Gigi from generating incorrect code by rewriting the
6324 -- test as False. What is this undocumented thing about ???
6326 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6330 -- Here we have a non-scalar type
6333 Typ
:= Designated_Type
(Typ
);
6336 if not Is_Constrained
(Typ
) then
6337 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6338 Analyze_And_Resolve
(N
, Restyp
);
6340 -- For the constrained array case, we have to check the subscripts
6341 -- for an exact match if the lengths are non-zero (the lengths
6342 -- must match in any case).
6344 elsif Is_Array_Type
(Typ
) then
6345 Check_Subscripts
: declare
6346 function Build_Attribute_Reference
6349 Dim
: Nat
) return Node_Id
;
6350 -- Build attribute reference E'Nam (Dim)
6352 -------------------------------
6353 -- Build_Attribute_Reference --
6354 -------------------------------
6356 function Build_Attribute_Reference
6359 Dim
: Nat
) return Node_Id
6363 Make_Attribute_Reference
(Loc
,
6365 Attribute_Name
=> Nam
,
6366 Expressions
=> New_List
(
6367 Make_Integer_Literal
(Loc
, Dim
)));
6368 end Build_Attribute_Reference
;
6370 -- Start of processing for Check_Subscripts
6373 for J
in 1 .. Number_Dimensions
(Typ
) loop
6374 Evolve_And_Then
(Cond
,
6377 Build_Attribute_Reference
6378 (Duplicate_Subexpr_No_Checks
(Obj
),
6381 Build_Attribute_Reference
6382 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
6384 Evolve_And_Then
(Cond
,
6387 Build_Attribute_Reference
6388 (Duplicate_Subexpr_No_Checks
(Obj
),
6391 Build_Attribute_Reference
6392 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
6401 Right_Opnd
=> Make_Null
(Loc
)),
6402 Right_Opnd
=> Cond
);
6406 Analyze_And_Resolve
(N
, Restyp
);
6407 end Check_Subscripts
;
6409 -- These are the cases where constraint checks may be required,
6410 -- e.g. records with possible discriminants
6413 -- Expand the test into a series of discriminant comparisons.
6414 -- The expression that is built is the negation of the one that
6415 -- is used for checking discriminant constraints.
6417 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6419 if Has_Discriminants
(Typ
) then
6420 Cond
:= Make_Op_Not
(Loc
,
6421 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6424 Cond
:= Make_Or_Else
(Loc
,
6428 Right_Opnd
=> Make_Null
(Loc
)),
6429 Right_Opnd
=> Cond
);
6433 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6437 Analyze_And_Resolve
(N
, Restyp
);
6440 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6441 -- expression of an anonymous access type. This can involve an
6442 -- accessibility test and a tagged type membership test in the
6443 -- case of tagged designated types.
6445 if Ada_Version
>= Ada_2012
6447 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6450 Expr_Entity
: Entity_Id
:= Empty
;
6452 Param_Level
: Node_Id
;
6453 Type_Level
: Node_Id
;
6456 if Is_Entity_Name
(Lop
) then
6457 Expr_Entity
:= Param_Entity
(Lop
);
6459 if not Present
(Expr_Entity
) then
6460 Expr_Entity
:= Entity
(Lop
);
6464 -- If a conversion of the anonymous access value to the
6465 -- tested type would be illegal, then the result is False.
6467 if not Valid_Conversion
6468 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6470 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6471 Analyze_And_Resolve
(N
, Restyp
);
6473 -- Apply an accessibility check if the access object has an
6474 -- associated access level and when the level of the type is
6475 -- less deep than the level of the access parameter. This
6476 -- only occur for access parameters and stand-alone objects
6477 -- of an anonymous access type.
6480 if Present
(Expr_Entity
)
6483 (Effective_Extra_Accessibility
(Expr_Entity
))
6484 and then UI_Gt
(Object_Access_Level
(Lop
),
6485 Type_Access_Level
(Rtyp
))
6489 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
6492 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6494 -- Return True only if the accessibility level of the
6495 -- expression entity is not deeper than the level of
6496 -- the tested access type.
6500 Left_Opnd
=> Relocate_Node
(N
),
6501 Right_Opnd
=> Make_Op_Le
(Loc
,
6502 Left_Opnd
=> Param_Level
,
6503 Right_Opnd
=> Type_Level
)));
6505 Analyze_And_Resolve
(N
);
6508 -- If the designated type is tagged, do tagged membership
6511 -- *** NOTE: we have to check not null before doing the
6512 -- tagged membership test (but maybe that can be done
6513 -- inside Tagged_Membership?).
6515 if Is_Tagged_Type
(Typ
) then
6518 Left_Opnd
=> Relocate_Node
(N
),
6522 Right_Opnd
=> Make_Null
(Loc
))));
6524 -- No expansion will be performed for VM targets, as
6525 -- the VM back ends will handle the membership tests
6528 if Tagged_Type_Expansion
then
6530 -- Note that we have to pass Original_Node, because
6531 -- the membership test might already have been
6532 -- rewritten by earlier parts of membership test.
6535 (Original_Node
(N
), SCIL_Node
, New_N
);
6537 -- Update decoration of relocated node referenced
6538 -- by the SCIL node.
6540 if Generate_SCIL
and then Present
(SCIL_Node
) then
6541 Set_SCIL_Node
(New_N
, SCIL_Node
);
6546 Left_Opnd
=> Relocate_Node
(N
),
6547 Right_Opnd
=> New_N
));
6549 Analyze_And_Resolve
(N
, Restyp
);
6558 -- At this point, we have done the processing required for the basic
6559 -- membership test, but not yet dealt with the predicate.
6563 -- If a predicate is present, then we do the predicate test, but we
6564 -- most certainly want to omit this if we are within the predicate
6565 -- function itself, since otherwise we have an infinite recursion.
6566 -- The check should also not be emitted when testing against a range
6567 -- (the check is only done when the right operand is a subtype; see
6568 -- RM12-4.5.2 (28.1/3-30/3)).
6570 Predicate_Check
: declare
6571 function In_Range_Check
return Boolean;
6572 -- Within an expanded range check that may raise Constraint_Error do
6573 -- not generate a predicate check as well. It is redundant because
6574 -- the context will add an explicit predicate check, and it will
6575 -- raise the wrong exception if it fails.
6577 --------------------
6578 -- In_Range_Check --
6579 --------------------
6581 function In_Range_Check
return Boolean is
6585 while Present
(P
) loop
6586 if Nkind
(P
) = N_Raise_Constraint_Error
then
6589 elsif Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6590 or else Nkind
(P
) = N_Procedure_Call_Statement
6591 or else Nkind
(P
) in N_Declaration
6604 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6607 -- Start of processing for Predicate_Check
6611 and then Current_Scope
/= PFunc
6612 and then Nkind
(Rop
) /= N_Range
6614 if not In_Range_Check
then
6615 R_Op
:= Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True);
6617 R_Op
:= New_Occurrence_Of
(Standard_True
, Loc
);
6622 Left_Opnd
=> Relocate_Node
(N
),
6623 Right_Opnd
=> R_Op
));
6625 -- Analyze new expression, mark left operand as analyzed to
6626 -- avoid infinite recursion adding predicate calls. Similarly,
6627 -- suppress further range checks on the call.
6629 Set_Analyzed
(Left_Opnd
(N
));
6630 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6632 -- All done, skip attempt at compile time determination of result
6636 end Predicate_Check
;
6639 --------------------------------
6640 -- Expand_N_Indexed_Component --
6641 --------------------------------
6643 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6644 Loc
: constant Source_Ptr
:= Sloc
(N
);
6645 Typ
: constant Entity_Id
:= Etype
(N
);
6646 P
: constant Node_Id
:= Prefix
(N
);
6647 T
: constant Entity_Id
:= Etype
(P
);
6651 -- A special optimization, if we have an indexed component that is
6652 -- selecting from a slice, then we can eliminate the slice, since, for
6653 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6654 -- the range check required by the slice. The range check for the slice
6655 -- itself has already been generated. The range check for the
6656 -- subscripting operation is ensured by converting the subject to
6657 -- the subtype of the slice.
6659 -- This optimization not only generates better code, avoiding slice
6660 -- messing especially in the packed case, but more importantly bypasses
6661 -- some problems in handling this peculiar case, for example, the issue
6662 -- of dealing specially with object renamings.
6664 if Nkind
(P
) = N_Slice
6666 -- This optimization is disabled for CodePeer because it can transform
6667 -- an index-check constraint_error into a range-check constraint_error
6668 -- and CodePeer cares about that distinction.
6670 and then not CodePeer_Mode
6673 Make_Indexed_Component
(Loc
,
6674 Prefix
=> Prefix
(P
),
6675 Expressions
=> New_List
(
6677 (Etype
(First_Index
(Etype
(P
))),
6678 First
(Expressions
(N
))))));
6679 Analyze_And_Resolve
(N
, Typ
);
6683 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6684 -- function, then additional actuals must be passed.
6686 if Is_Build_In_Place_Function_Call
(P
) then
6687 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6689 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
6690 -- containing build-in-place function calls whose returned object covers
6693 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
6694 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
6697 -- If the prefix is an access type, then we unconditionally rewrite if
6698 -- as an explicit dereference. This simplifies processing for several
6699 -- cases, including packed array cases and certain cases in which checks
6700 -- must be generated. We used to try to do this only when it was
6701 -- necessary, but it cleans up the code to do it all the time.
6703 if Is_Access_Type
(T
) then
6704 Insert_Explicit_Dereference
(P
);
6705 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6706 Atp
:= Designated_Type
(T
);
6711 -- Generate index and validity checks
6713 Generate_Index_Checks
(N
);
6715 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6716 Apply_Subscript_Validity_Checks
(N
);
6719 -- If selecting from an array with atomic components, and atomic sync
6720 -- is not suppressed for this array type, set atomic sync flag.
6722 if (Has_Atomic_Components
(Atp
)
6723 and then not Atomic_Synchronization_Disabled
(Atp
))
6724 or else (Is_Atomic
(Typ
)
6725 and then not Atomic_Synchronization_Disabled
(Typ
))
6726 or else (Is_Entity_Name
(P
)
6727 and then Has_Atomic_Components
(Entity
(P
))
6728 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
6730 Activate_Atomic_Synchronization
(N
);
6733 -- All done if the prefix is not a packed array implemented specially
6735 if not (Is_Packed
(Etype
(Prefix
(N
)))
6736 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(N
)))))
6741 -- For packed arrays that are not bit-packed (i.e. the case of an array
6742 -- with one or more index types with a non-contiguous enumeration type),
6743 -- we can always use the normal packed element get circuit.
6745 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6746 Expand_Packed_Element_Reference
(N
);
6750 -- For a reference to a component of a bit packed array, we convert it
6751 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6752 -- want to do this for simple references, and not for:
6754 -- Left side of assignment, or prefix of left side of assignment, or
6755 -- prefix of the prefix, to handle packed arrays of packed arrays,
6756 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6758 -- Renaming objects in renaming associations
6759 -- This case is handled when a use of the renamed variable occurs
6761 -- Actual parameters for a procedure call
6762 -- This case is handled in Exp_Ch6.Expand_Actuals
6764 -- The second expression in a 'Read attribute reference
6766 -- The prefix of an address or bit or size attribute reference
6768 -- The following circuit detects these exceptions. Note that we need to
6769 -- deal with implicit dereferences when climbing up the parent chain,
6770 -- with the additional difficulty that the type of parents may have yet
6771 -- to be resolved since prefixes are usually resolved first.
6774 Child
: Node_Id
:= N
;
6775 Parnt
: Node_Id
:= Parent
(N
);
6779 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6782 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6783 N_Procedure_Call_Statement
)
6784 or else (Nkind
(Parnt
) = N_Parameter_Association
6786 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6790 elsif Nkind
(Parnt
) = N_Attribute_Reference
6791 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
6794 and then Prefix
(Parnt
) = Child
6798 elsif Nkind
(Parnt
) = N_Assignment_Statement
6799 and then Name
(Parnt
) = Child
6803 -- If the expression is an index of an indexed component, it must
6804 -- be expanded regardless of context.
6806 elsif Nkind
(Parnt
) = N_Indexed_Component
6807 and then Child
/= Prefix
(Parnt
)
6809 Expand_Packed_Element_Reference
(N
);
6812 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6813 and then Name
(Parent
(Parnt
)) = Parnt
6817 elsif Nkind
(Parnt
) = N_Attribute_Reference
6818 and then Attribute_Name
(Parnt
) = Name_Read
6819 and then Next
(First
(Expressions
(Parnt
))) = Child
6823 elsif Nkind
(Parnt
) = N_Indexed_Component
6824 and then Prefix
(Parnt
) = Child
6828 elsif Nkind
(Parnt
) = N_Selected_Component
6829 and then Prefix
(Parnt
) = Child
6830 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
6832 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
6836 -- If the parent is a dereference, either implicit or explicit,
6837 -- then the packed reference needs to be expanded.
6840 Expand_Packed_Element_Reference
(N
);
6844 -- Keep looking up tree for unchecked expression, or if we are the
6845 -- prefix of a possible assignment left side.
6848 Parnt
:= Parent
(Child
);
6851 end Expand_N_Indexed_Component
;
6853 ---------------------
6854 -- Expand_N_Not_In --
6855 ---------------------
6857 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6858 -- can be done. This avoids needing to duplicate this expansion code.
6860 procedure Expand_N_Not_In
(N
: Node_Id
) is
6861 Loc
: constant Source_Ptr
:= Sloc
(N
);
6862 Typ
: constant Entity_Id
:= Etype
(N
);
6863 Cfs
: constant Boolean := Comes_From_Source
(N
);
6870 Left_Opnd
=> Left_Opnd
(N
),
6871 Right_Opnd
=> Right_Opnd
(N
))));
6873 -- If this is a set membership, preserve list of alternatives
6875 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6877 -- We want this to appear as coming from source if original does (see
6878 -- transformations in Expand_N_In).
6880 Set_Comes_From_Source
(N
, Cfs
);
6881 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6883 -- Now analyze transformed node
6885 Analyze_And_Resolve
(N
, Typ
);
6886 end Expand_N_Not_In
;
6892 -- The only replacement required is for the case of a null of a type that
6893 -- is an access to protected subprogram, or a subtype thereof. We represent
6894 -- such access values as a record, and so we must replace the occurrence of
6895 -- null by the equivalent record (with a null address and a null pointer in
6896 -- it), so that the back end creates the proper value.
6898 procedure Expand_N_Null
(N
: Node_Id
) is
6899 Loc
: constant Source_Ptr
:= Sloc
(N
);
6900 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6904 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6906 Make_Aggregate
(Loc
,
6907 Expressions
=> New_List
(
6908 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6912 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6914 -- For subsequent semantic analysis, the node must retain its type.
6915 -- Gigi in any case replaces this type by the corresponding record
6916 -- type before processing the node.
6922 when RE_Not_Available
=>
6926 ---------------------
6927 -- Expand_N_Op_Abs --
6928 ---------------------
6930 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6931 Loc
: constant Source_Ptr
:= Sloc
(N
);
6932 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6935 Unary_Op_Validity_Checks
(N
);
6937 -- Check for MINIMIZED/ELIMINATED overflow mode
6939 if Minimized_Eliminated_Overflow_Check
(N
) then
6940 Apply_Arithmetic_Overflow_Check
(N
);
6944 -- Deal with software overflow checking
6946 if Is_Signed_Integer_Type
(Etype
(N
))
6947 and then Do_Overflow_Check
(N
)
6949 -- The only case to worry about is when the argument is equal to the
6950 -- largest negative number, so what we do is to insert the check:
6952 -- [constraint_error when Expr = typ'Base'First]
6954 -- with the usual Duplicate_Subexpr use coding for expr
6957 Make_Raise_Constraint_Error
(Loc
,
6960 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6962 Make_Attribute_Reference
(Loc
,
6964 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6965 Attribute_Name
=> Name_First
)),
6966 Reason
=> CE_Overflow_Check_Failed
));
6968 Set_Do_Overflow_Check
(N
, False);
6970 end Expand_N_Op_Abs
;
6972 ---------------------
6973 -- Expand_N_Op_Add --
6974 ---------------------
6976 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6977 Typ
: constant Entity_Id
:= Etype
(N
);
6980 Binary_Op_Validity_Checks
(N
);
6982 -- Check for MINIMIZED/ELIMINATED overflow mode
6984 if Minimized_Eliminated_Overflow_Check
(N
) then
6985 Apply_Arithmetic_Overflow_Check
(N
);
6989 -- N + 0 = 0 + N = N for integer types
6991 if Is_Integer_Type
(Typ
) then
6992 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6993 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6995 Rewrite
(N
, Left_Opnd
(N
));
6998 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6999 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
7001 Rewrite
(N
, Right_Opnd
(N
));
7006 -- Arithmetic overflow checks for signed integer/fixed point types
7008 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
7009 Apply_Arithmetic_Overflow_Check
(N
);
7013 -- Overflow checks for floating-point if -gnateF mode active
7015 Check_Float_Op_Overflow
(N
);
7017 Expand_Nonbinary_Modular_Op
(N
);
7018 end Expand_N_Op_Add
;
7020 ---------------------
7021 -- Expand_N_Op_And --
7022 ---------------------
7024 procedure Expand_N_Op_And
(N
: Node_Id
) is
7025 Typ
: constant Entity_Id
:= Etype
(N
);
7028 Binary_Op_Validity_Checks
(N
);
7030 if Is_Array_Type
(Etype
(N
)) then
7031 Expand_Boolean_Operator
(N
);
7033 elsif Is_Boolean_Type
(Etype
(N
)) then
7034 Adjust_Condition
(Left_Opnd
(N
));
7035 Adjust_Condition
(Right_Opnd
(N
));
7036 Set_Etype
(N
, Standard_Boolean
);
7037 Adjust_Result_Type
(N
, Typ
);
7039 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
7040 Expand_Intrinsic_Call
(N
, Entity
(N
));
7043 Expand_Nonbinary_Modular_Op
(N
);
7044 end Expand_N_Op_And
;
7046 ------------------------
7047 -- Expand_N_Op_Concat --
7048 ------------------------
7050 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
7052 -- List of operands to be concatenated
7055 -- Node which is to be replaced by the result of concatenating the nodes
7056 -- in the list Opnds.
7059 -- Ensure validity of both operands
7061 Binary_Op_Validity_Checks
(N
);
7063 -- If we are the left operand of a concatenation higher up the tree,
7064 -- then do nothing for now, since we want to deal with a series of
7065 -- concatenations as a unit.
7067 if Nkind
(Parent
(N
)) = N_Op_Concat
7068 and then N
= Left_Opnd
(Parent
(N
))
7073 -- We get here with a concatenation whose left operand may be a
7074 -- concatenation itself with a consistent type. We need to process
7075 -- these concatenation operands from left to right, which means
7076 -- from the deepest node in the tree to the highest node.
7079 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
7080 Cnode
:= Left_Opnd
(Cnode
);
7083 -- Now Cnode is the deepest concatenation, and its parents are the
7084 -- concatenation nodes above, so now we process bottom up, doing the
7087 -- The outer loop runs more than once if more than one concatenation
7088 -- type is involved.
7091 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
7092 Set_Parent
(Opnds
, N
);
7094 -- The inner loop gathers concatenation operands
7096 Inner
: while Cnode
/= N
7097 and then Base_Type
(Etype
(Cnode
)) =
7098 Base_Type
(Etype
(Parent
(Cnode
)))
7100 Cnode
:= Parent
(Cnode
);
7101 Append
(Right_Opnd
(Cnode
), Opnds
);
7104 -- Note: The following code is a temporary workaround for N731-034
7105 -- and N829-028 and will be kept until the general issue of internal
7106 -- symbol serialization is addressed. The workaround is kept under a
7107 -- debug switch to avoid permiating into the general case.
7109 -- Wrap the node to concatenate into an expression actions node to
7110 -- keep it nicely packaged. This is useful in the case of an assert
7111 -- pragma with a concatenation where we want to be able to delete
7112 -- the concatenation and all its expansion stuff.
7114 if Debug_Flag_Dot_H
then
7116 Cnod
: constant Node_Id
:= New_Copy_Tree
(Cnode
);
7117 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
7120 -- Note: use Rewrite rather than Replace here, so that for
7121 -- example Why_Not_Static can find the original concatenation
7125 Make_Expression_With_Actions
(Sloc
(Cnode
),
7126 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
7127 Expression
=> Cnod
));
7129 Expand_Concatenate
(Cnod
, Opnds
);
7130 Analyze_And_Resolve
(Cnode
, Typ
);
7136 Expand_Concatenate
(Cnode
, Opnds
);
7139 exit Outer
when Cnode
= N
;
7140 Cnode
:= Parent
(Cnode
);
7142 end Expand_N_Op_Concat
;
7144 ------------------------
7145 -- Expand_N_Op_Divide --
7146 ------------------------
7148 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
7149 Loc
: constant Source_Ptr
:= Sloc
(N
);
7150 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
7151 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
7152 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
7153 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
7154 Typ
: Entity_Id
:= Etype
(N
);
7155 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
7157 Compile_Time_Known_Value
(Ropnd
);
7161 Binary_Op_Validity_Checks
(N
);
7163 -- Check for MINIMIZED/ELIMINATED overflow mode
7165 if Minimized_Eliminated_Overflow_Check
(N
) then
7166 Apply_Arithmetic_Overflow_Check
(N
);
7170 -- Otherwise proceed with expansion of division
7173 Rval
:= Expr_Value
(Ropnd
);
7176 -- N / 1 = N for integer types
7178 if Rknow
and then Rval
= Uint_1
then
7183 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7184 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7185 -- operand is an unsigned integer, as required for this to work.
7187 if Nkind
(Ropnd
) = N_Op_Expon
7188 and then Is_Power_Of_2_For_Shift
(Ropnd
)
7190 -- We cannot do this transformation in configurable run time mode if we
7191 -- have 64-bit integers and long shifts are not available.
7193 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
7196 Make_Op_Shift_Right
(Loc
,
7199 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
7200 Analyze_And_Resolve
(N
, Typ
);
7204 -- Do required fixup of universal fixed operation
7206 if Typ
= Universal_Fixed
then
7207 Fixup_Universal_Fixed_Operation
(N
);
7211 -- Divisions with fixed-point results
7213 if Is_Fixed_Point_Type
(Typ
) then
7215 -- No special processing if Treat_Fixed_As_Integer is set, since
7216 -- from a semantic point of view such operations are simply integer
7217 -- operations and will be treated that way.
7219 if not Treat_Fixed_As_Integer
(N
) then
7220 if Is_Integer_Type
(Rtyp
) then
7221 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
7223 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
7227 -- Deal with divide-by-zero check if back end cannot handle them
7228 -- and the flag is set indicating that we need such a check. Note
7229 -- that we don't need to bother here with the case of mixed-mode
7230 -- (Right operand an integer type), since these will be rewritten
7231 -- with conversions to a divide with a fixed-point right operand.
7233 if Nkind
(N
) = N_Op_Divide
7234 and then Do_Division_Check
(N
)
7235 and then not Backend_Divide_Checks_On_Target
7236 and then not Is_Integer_Type
(Rtyp
)
7238 Set_Do_Division_Check
(N
, False);
7240 Make_Raise_Constraint_Error
(Loc
,
7243 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
7244 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
7245 Reason
=> CE_Divide_By_Zero
));
7248 -- Other cases of division of fixed-point operands. Again we exclude the
7249 -- case where Treat_Fixed_As_Integer is set.
7251 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
7252 and then not Treat_Fixed_As_Integer
(N
)
7254 if Is_Integer_Type
(Typ
) then
7255 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
7257 pragma Assert
(Is_Floating_Point_Type
(Typ
));
7258 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
7261 -- Mixed-mode operations can appear in a non-static universal context,
7262 -- in which case the integer argument must be converted explicitly.
7264 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
7266 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
7268 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
7270 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
7272 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
7274 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
7276 -- Non-fixed point cases, do integer zero divide and overflow checks
7278 elsif Is_Integer_Type
(Typ
) then
7279 Apply_Divide_Checks
(N
);
7282 -- Overflow checks for floating-point if -gnateF mode active
7284 Check_Float_Op_Overflow
(N
);
7286 Expand_Nonbinary_Modular_Op
(N
);
7287 end Expand_N_Op_Divide
;
7289 --------------------
7290 -- Expand_N_Op_Eq --
7291 --------------------
7293 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
7294 Loc
: constant Source_Ptr
:= Sloc
(N
);
7295 Typ
: constant Entity_Id
:= Etype
(N
);
7296 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
7297 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
7298 Bodies
: constant List_Id
:= New_List
;
7299 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
7301 Typl
: Entity_Id
:= A_Typ
;
7302 Op_Name
: Entity_Id
;
7305 procedure Build_Equality_Call
(Eq
: Entity_Id
);
7306 -- If a constructed equality exists for the type or for its parent,
7307 -- build and analyze call, adding conversions if the operation is
7310 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
7311 -- Determines whether a type has a subcomponent of an unconstrained
7312 -- Unchecked_Union subtype. Typ is a record type.
7314 -------------------------
7315 -- Build_Equality_Call --
7316 -------------------------
7318 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
7319 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
7320 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
7321 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
7324 -- Adjust operands if necessary to comparison type
7326 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
7327 and then not Is_Class_Wide_Type
(A_Typ
)
7329 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
7330 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
7333 -- If we have an Unchecked_Union, we need to add the inferred
7334 -- discriminant values as actuals in the function call. At this
7335 -- point, the expansion has determined that both operands have
7336 -- inferable discriminants.
7338 if Is_Unchecked_Union
(Op_Type
) then
7340 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
7341 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
7343 Lhs_Discr_Vals
: Elist_Id
;
7344 -- List of inferred discriminant values for left operand.
7346 Rhs_Discr_Vals
: Elist_Id
;
7347 -- List of inferred discriminant values for right operand.
7352 Lhs_Discr_Vals
:= New_Elmt_List
;
7353 Rhs_Discr_Vals
:= New_Elmt_List
;
7355 -- Per-object constrained selected components require special
7356 -- attention. If the enclosing scope of the component is an
7357 -- Unchecked_Union, we cannot reference its discriminants
7358 -- directly. This is why we use the extra parameters of the
7359 -- equality function of the enclosing Unchecked_Union.
7361 -- type UU_Type (Discr : Integer := 0) is
7364 -- pragma Unchecked_Union (UU_Type);
7366 -- 1. Unchecked_Union enclosing record:
7368 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
7370 -- Comp : UU_Type (Discr);
7372 -- end Enclosing_UU_Type;
7373 -- pragma Unchecked_Union (Enclosing_UU_Type);
7375 -- Obj1 : Enclosing_UU_Type;
7376 -- Obj2 : Enclosing_UU_Type (1);
7378 -- [. . .] Obj1 = Obj2 [. . .]
7382 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
7384 -- A and B are the formal parameters of the equality function
7385 -- of Enclosing_UU_Type. The function always has two extra
7386 -- formals to capture the inferred discriminant values for
7387 -- each discriminant of the type.
7389 -- 2. Non-Unchecked_Union enclosing record:
7392 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
7395 -- Comp : UU_Type (Discr);
7397 -- end Enclosing_Non_UU_Type;
7399 -- Obj1 : Enclosing_Non_UU_Type;
7400 -- Obj2 : Enclosing_Non_UU_Type (1);
7402 -- ... Obj1 = Obj2 ...
7406 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
7407 -- obj1.discr, obj2.discr)) then
7409 -- In this case we can directly reference the discriminants of
7410 -- the enclosing record.
7412 -- Process left operand of equality
7414 if Nkind
(Lhs
) = N_Selected_Component
7416 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
7418 -- If enclosing record is an Unchecked_Union, use formals
7419 -- corresponding to each discriminant. The name of the
7420 -- formal is that of the discriminant, with added suffix,
7421 -- see Exp_Ch3.Build_Record_Equality for details.
7423 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Lhs
))))
7427 (Scope
(Entity
(Selector_Name
(Lhs
))));
7428 while Present
(Discr
) loop
7430 (Make_Identifier
(Loc
,
7431 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
7432 To
=> Lhs_Discr_Vals
);
7433 Next_Discriminant
(Discr
);
7436 -- If enclosing record is of a non-Unchecked_Union type, it
7437 -- is possible to reference its discriminants directly.
7440 Discr
:= First_Discriminant
(Lhs_Type
);
7441 while Present
(Discr
) loop
7443 (Make_Selected_Component
(Loc
,
7444 Prefix
=> Prefix
(Lhs
),
7447 (Get_Discriminant_Value
(Discr
,
7449 Stored_Constraint
(Lhs_Type
)))),
7450 To
=> Lhs_Discr_Vals
);
7451 Next_Discriminant
(Discr
);
7455 -- Otherwise operand is on object with a constrained type.
7456 -- Infer the discriminant values from the constraint.
7460 Discr
:= First_Discriminant
(Lhs_Type
);
7461 while Present
(Discr
) loop
7464 (Get_Discriminant_Value
(Discr
,
7466 Stored_Constraint
(Lhs_Type
))),
7467 To
=> Lhs_Discr_Vals
);
7468 Next_Discriminant
(Discr
);
7472 -- Similar processing for right operand of equality
7474 if Nkind
(Rhs
) = N_Selected_Component
7476 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
7478 if Is_Unchecked_Union
7479 (Scope
(Entity
(Selector_Name
(Rhs
))))
7483 (Scope
(Entity
(Selector_Name
(Rhs
))));
7484 while Present
(Discr
) loop
7486 (Make_Identifier
(Loc
,
7487 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
7488 To
=> Rhs_Discr_Vals
);
7489 Next_Discriminant
(Discr
);
7493 Discr
:= First_Discriminant
(Rhs_Type
);
7494 while Present
(Discr
) loop
7496 (Make_Selected_Component
(Loc
,
7497 Prefix
=> Prefix
(Rhs
),
7499 New_Copy
(Get_Discriminant_Value
7502 Stored_Constraint
(Rhs_Type
)))),
7503 To
=> Rhs_Discr_Vals
);
7504 Next_Discriminant
(Discr
);
7509 Discr
:= First_Discriminant
(Rhs_Type
);
7510 while Present
(Discr
) loop
7512 (New_Copy
(Get_Discriminant_Value
7515 Stored_Constraint
(Rhs_Type
))),
7516 To
=> Rhs_Discr_Vals
);
7517 Next_Discriminant
(Discr
);
7521 -- Now merge the list of discriminant values so that values
7522 -- of corresponding discriminants are adjacent.
7530 Params
:= New_List
(L_Exp
, R_Exp
);
7531 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
7532 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
7533 while Present
(L_Elmt
) loop
7534 Append_To
(Params
, Node
(L_Elmt
));
7535 Append_To
(Params
, Node
(R_Elmt
));
7541 Make_Function_Call
(Loc
,
7542 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7543 Parameter_Associations
=> Params
));
7547 -- Normal case, not an unchecked union
7551 Make_Function_Call
(Loc
,
7552 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7553 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7556 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7557 end Build_Equality_Call
;
7559 ------------------------------------
7560 -- Has_Unconstrained_UU_Component --
7561 ------------------------------------
7563 function Has_Unconstrained_UU_Component
7564 (Typ
: Node_Id
) return Boolean
7566 Tdef
: constant Node_Id
:=
7567 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
7571 function Component_Is_Unconstrained_UU
7572 (Comp
: Node_Id
) return Boolean;
7573 -- Determines whether the subtype of the component is an
7574 -- unconstrained Unchecked_Union.
7576 function Variant_Is_Unconstrained_UU
7577 (Variant
: Node_Id
) return Boolean;
7578 -- Determines whether a component of the variant has an unconstrained
7579 -- Unchecked_Union subtype.
7581 -----------------------------------
7582 -- Component_Is_Unconstrained_UU --
7583 -----------------------------------
7585 function Component_Is_Unconstrained_UU
7586 (Comp
: Node_Id
) return Boolean
7589 if Nkind
(Comp
) /= N_Component_Declaration
then
7594 Sindic
: constant Node_Id
:=
7595 Subtype_Indication
(Component_Definition
(Comp
));
7598 -- Unconstrained nominal type. In the case of a constraint
7599 -- present, the node kind would have been N_Subtype_Indication.
7601 if Nkind
(Sindic
) = N_Identifier
then
7602 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
7607 end Component_Is_Unconstrained_UU
;
7609 ---------------------------------
7610 -- Variant_Is_Unconstrained_UU --
7611 ---------------------------------
7613 function Variant_Is_Unconstrained_UU
7614 (Variant
: Node_Id
) return Boolean
7616 Clist
: constant Node_Id
:= Component_List
(Variant
);
7619 if Is_Empty_List
(Component_Items
(Clist
)) then
7623 -- We only need to test one component
7626 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7629 while Present
(Comp
) loop
7630 if Component_Is_Unconstrained_UU
(Comp
) then
7638 -- None of the components withing the variant were of
7639 -- unconstrained Unchecked_Union type.
7642 end Variant_Is_Unconstrained_UU
;
7644 -- Start of processing for Has_Unconstrained_UU_Component
7647 if Null_Present
(Tdef
) then
7651 Clist
:= Component_List
(Tdef
);
7652 Vpart
:= Variant_Part
(Clist
);
7654 -- Inspect available components
7656 if Present
(Component_Items
(Clist
)) then
7658 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7661 while Present
(Comp
) loop
7663 -- One component is sufficient
7665 if Component_Is_Unconstrained_UU
(Comp
) then
7674 -- Inspect available components withing variants
7676 if Present
(Vpart
) then
7678 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7681 while Present
(Variant
) loop
7683 -- One component within a variant is sufficient
7685 if Variant_Is_Unconstrained_UU
(Variant
) then
7694 -- Neither the available components, nor the components inside the
7695 -- variant parts were of an unconstrained Unchecked_Union subtype.
7698 end Has_Unconstrained_UU_Component
;
7700 -- Start of processing for Expand_N_Op_Eq
7703 Binary_Op_Validity_Checks
(N
);
7705 -- Deal with private types
7707 if Ekind
(Typl
) = E_Private_Type
then
7708 Typl
:= Underlying_Type
(Typl
);
7709 elsif Ekind
(Typl
) = E_Private_Subtype
then
7710 Typl
:= Underlying_Type
(Base_Type
(Typl
));
7715 -- It may happen in error situations that the underlying type is not
7716 -- set. The error will be detected later, here we just defend the
7723 -- Now get the implementation base type (note that plain Base_Type here
7724 -- might lead us back to the private type, which is not what we want!)
7726 Typl
:= Implementation_Base_Type
(Typl
);
7728 -- Equality between variant records results in a call to a routine
7729 -- that has conditional tests of the discriminant value(s), and hence
7730 -- violates the No_Implicit_Conditionals restriction.
7732 if Has_Variant_Part
(Typl
) then
7737 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
7741 ("\comparison of variant records tests discriminants", N
);
7747 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7748 -- means we no longer have a comparison operation, we are all done.
7750 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7752 if Nkind
(N
) /= N_Op_Eq
then
7756 -- Boolean types (requiring handling of non-standard case)
7758 if Is_Boolean_Type
(Typl
) then
7759 Adjust_Condition
(Left_Opnd
(N
));
7760 Adjust_Condition
(Right_Opnd
(N
));
7761 Set_Etype
(N
, Standard_Boolean
);
7762 Adjust_Result_Type
(N
, Typ
);
7766 elsif Is_Array_Type
(Typl
) then
7768 -- If we are doing full validity checking, and it is possible for the
7769 -- array elements to be invalid then expand out array comparisons to
7770 -- make sure that we check the array elements.
7772 if Validity_Check_Operands
7773 and then not Is_Known_Valid
(Component_Type
(Typl
))
7776 Save_Force_Validity_Checks
: constant Boolean :=
7777 Force_Validity_Checks
;
7779 Force_Validity_Checks
:= True;
7781 Expand_Array_Equality
7783 Relocate_Node
(Lhs
),
7784 Relocate_Node
(Rhs
),
7787 Insert_Actions
(N
, Bodies
);
7788 Analyze_And_Resolve
(N
, Standard_Boolean
);
7789 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7792 -- Packed case where both operands are known aligned
7794 elsif Is_Bit_Packed_Array
(Typl
)
7795 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7796 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7798 Expand_Packed_Eq
(N
);
7800 -- Where the component type is elementary we can use a block bit
7801 -- comparison (if supported on the target) exception in the case
7802 -- of floating-point (negative zero issues require element by
7803 -- element comparison), and atomic/VFA types (where we must be sure
7804 -- to load elements independently) and possibly unaligned arrays.
7806 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7807 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7808 and then not Is_Atomic_Or_VFA
(Component_Type
(Typl
))
7809 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7810 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7811 and then Support_Composite_Compare_On_Target
7815 -- For composite and floating-point cases, expand equality loop to
7816 -- make sure of using proper comparisons for tagged types, and
7817 -- correctly handling the floating-point case.
7821 Expand_Array_Equality
7823 Relocate_Node
(Lhs
),
7824 Relocate_Node
(Rhs
),
7827 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7828 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7833 elsif Is_Record_Type
(Typl
) then
7835 -- For tagged types, use the primitive "="
7837 if Is_Tagged_Type
(Typl
) then
7839 -- No need to do anything else compiling under restriction
7840 -- No_Dispatching_Calls. During the semantic analysis we
7841 -- already notified such violation.
7843 if Restriction_Active
(No_Dispatching_Calls
) then
7847 -- If this is an untagged private type completed with a derivation
7848 -- of an untagged private type whose full view is a tagged type,
7849 -- we use the primitive operations of the private type (since it
7850 -- does not have a full view, and also because its equality
7851 -- primitive may have been overridden in its untagged full view).
7853 if Inherits_From_Tagged_Full_View
(A_Typ
) then
7855 -- Search for equality operation, checking that the operands
7856 -- have the same type. Note that we must find a matching entry,
7857 -- or something is very wrong.
7859 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7861 while Present
(Prim
) loop
7862 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7863 and then Etype
(First_Formal
(Node
(Prim
))) =
7864 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7866 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7871 pragma Assert
(Present
(Prim
));
7872 Op_Name
:= Node
(Prim
);
7874 -- Find the type's predefined equality or an overriding
7875 -- user-defined equality. The reason for not simply calling
7876 -- Find_Prim_Op here is that there may be a user-defined
7877 -- overloaded equality op that precedes the equality that we
7878 -- want, so we have to explicitly search (e.g., there could be
7879 -- an equality with two different parameter types).
7882 if Is_Class_Wide_Type
(Typl
) then
7883 Typl
:= Find_Specific_Type
(Typl
);
7886 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7887 while Present
(Prim
) loop
7888 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7889 and then Etype
(First_Formal
(Node
(Prim
))) =
7890 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7892 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7897 pragma Assert
(Present
(Prim
));
7898 Op_Name
:= Node
(Prim
);
7901 Build_Equality_Call
(Op_Name
);
7903 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7904 -- predefined equality operator for a type which has a subcomponent
7905 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7907 elsif Has_Unconstrained_UU_Component
(Typl
) then
7909 Make_Raise_Program_Error
(Loc
,
7910 Reason
=> PE_Unchecked_Union_Restriction
));
7912 -- Prevent Gigi from generating incorrect code by rewriting the
7913 -- equality as a standard False. (is this documented somewhere???)
7916 New_Occurrence_Of
(Standard_False
, Loc
));
7918 elsif Is_Unchecked_Union
(Typl
) then
7920 -- If we can infer the discriminants of the operands, we make a
7921 -- call to the TSS equality function.
7923 if Has_Inferable_Discriminants
(Lhs
)
7925 Has_Inferable_Discriminants
(Rhs
)
7928 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7931 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7932 -- the predefined equality operator for an Unchecked_Union type
7933 -- if either of the operands lack inferable discriminants.
7936 Make_Raise_Program_Error
(Loc
,
7937 Reason
=> PE_Unchecked_Union_Restriction
));
7939 -- Emit a warning on source equalities only, otherwise the
7940 -- message may appear out of place due to internal use. The
7941 -- warning is unconditional because it is required by the
7944 if Comes_From_Source
(N
) then
7946 ("Unchecked_Union discriminants cannot be determined??",
7949 ("\Program_Error will be raised for equality operation??",
7953 -- Prevent Gigi from generating incorrect code by rewriting
7954 -- the equality as a standard False (documented where???).
7957 New_Occurrence_Of
(Standard_False
, Loc
));
7960 -- If a type support function is present (for complex cases), use it
7962 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7964 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7966 -- When comparing two Bounded_Strings, use the primitive equality of
7967 -- the root Super_String type.
7969 elsif Is_Bounded_String
(Typl
) then
7971 First_Elmt
(Collect_Primitive_Operations
(Root_Type
(Typl
)));
7973 while Present
(Prim
) loop
7974 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7975 and then Etype
(First_Formal
(Node
(Prim
))) =
7976 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7977 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7982 -- A Super_String type should always have a primitive equality
7984 pragma Assert
(Present
(Prim
));
7985 Build_Equality_Call
(Node
(Prim
));
7987 -- Otherwise expand the component by component equality. Note that
7988 -- we never use block-bit comparisons for records, because of the
7989 -- problems with gaps. The back end will often be able to recombine
7990 -- the separate comparisons that we generate here.
7993 Remove_Side_Effects
(Lhs
);
7994 Remove_Side_Effects
(Rhs
);
7996 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7998 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7999 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8003 -- Test if result is known at compile time
8005 Rewrite_Comparison
(N
);
8007 -- Special optimization of length comparison
8009 Optimize_Length_Comparison
(N
);
8011 -- One more special case: if we have a comparison of X'Result = expr
8012 -- in floating-point, then if not already there, change expr to be
8013 -- f'Machine (expr) to eliminate surprise from extra precision.
8015 if Is_Floating_Point_Type
(Typl
)
8016 and then Nkind
(Original_Node
(Lhs
)) = N_Attribute_Reference
8017 and then Attribute_Name
(Original_Node
(Lhs
)) = Name_Result
8019 -- Stick in the Typ'Machine call if not already there
8021 if Nkind
(Rhs
) /= N_Attribute_Reference
8022 or else Attribute_Name
(Rhs
) /= Name_Machine
8025 Make_Attribute_Reference
(Loc
,
8026 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
8027 Attribute_Name
=> Name_Machine
,
8028 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
8029 Analyze_And_Resolve
(Rhs
, Typl
);
8034 -----------------------
8035 -- Expand_N_Op_Expon --
8036 -----------------------
8038 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
8039 Loc
: constant Source_Ptr
:= Sloc
(N
);
8040 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
8041 Typ
: constant Entity_Id
:= Etype
(N
);
8042 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
8046 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
8047 -- Given an expression Exp, if the root type is Float or Long_Float,
8048 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8049 -- extra precision. This is done to ensure that X**A = X**B when A is
8050 -- a static constant and B is a variable with the same value. For any
8051 -- other type, the node Exp is returned unchanged.
8057 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
8058 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
8061 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
8063 Make_Attribute_Reference
(Loc
,
8064 Attribute_Name
=> Name_Machine
,
8065 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
8066 Expressions
=> New_List
(Relocate_Node
(Exp
)));
8084 -- Start of processing for Expand_N_Op_Expon
8087 Binary_Op_Validity_Checks
(N
);
8089 -- CodePeer wants to see the unexpanded N_Op_Expon node
8091 if CodePeer_Mode
then
8095 -- Relocation of left and right operands must be done after performing
8096 -- the validity checks since the generation of validation checks may
8097 -- remove side effects.
8099 Base
:= Relocate_Node
(Left_Opnd
(N
));
8100 Bastyp
:= Etype
(Base
);
8101 Exp
:= Relocate_Node
(Right_Opnd
(N
));
8102 Exptyp
:= Etype
(Exp
);
8104 -- If either operand is of a private type, then we have the use of an
8105 -- intrinsic operator, and we get rid of the privateness, by using root
8106 -- types of underlying types for the actual operation. Otherwise the
8107 -- private types will cause trouble if we expand multiplications or
8108 -- shifts etc. We also do this transformation if the result type is
8109 -- different from the base type.
8111 if Is_Private_Type
(Etype
(Base
))
8112 or else Is_Private_Type
(Typ
)
8113 or else Is_Private_Type
(Exptyp
)
8114 or else Rtyp
/= Root_Type
(Bastyp
)
8117 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
8118 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
8121 Unchecked_Convert_To
(Typ
,
8123 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
8124 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
8125 Analyze_And_Resolve
(N
, Typ
);
8130 -- Check for MINIMIZED/ELIMINATED overflow mode
8132 if Minimized_Eliminated_Overflow_Check
(N
) then
8133 Apply_Arithmetic_Overflow_Check
(N
);
8137 -- Test for case of known right argument where we can replace the
8138 -- exponentiation by an equivalent expression using multiplication.
8140 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8141 -- configurable run-time mode, we may not have the exponentiation
8142 -- routine available, and we don't want the legality of the program
8143 -- to depend on how clever the compiler is in knowing values.
8145 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
8146 Expv
:= Expr_Value
(Exp
);
8148 -- We only fold small non-negative exponents. You might think we
8149 -- could fold small negative exponents for the real case, but we
8150 -- can't because we are required to raise Constraint_Error for
8151 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8152 -- See ACVC test C4A012B, and it is not worth generating the test.
8154 -- For small negative exponents, we return the reciprocal of
8155 -- the folding of the exponentiation for the opposite (positive)
8156 -- exponent, as required by Ada RM 4.5.6(11/3).
8158 if abs Expv
<= 4 then
8160 -- X ** 0 = 1 (or 1.0)
8164 -- Call Remove_Side_Effects to ensure that any side effects
8165 -- in the ignored left operand (in particular function calls
8166 -- to user defined functions) are properly executed.
8168 Remove_Side_Effects
(Base
);
8170 if Ekind
(Typ
) in Integer_Kind
then
8171 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
8173 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
8186 Make_Op_Multiply
(Loc
,
8187 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8188 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8190 -- X ** 3 = X * X * X
8195 Make_Op_Multiply
(Loc
,
8197 Make_Op_Multiply
(Loc
,
8198 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8199 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
8200 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8205 -- En : constant base'type := base * base;
8210 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
8213 Make_Expression_With_Actions
(Loc
,
8214 Actions
=> New_List
(
8215 Make_Object_Declaration
(Loc
,
8216 Defining_Identifier
=> Temp
,
8217 Constant_Present
=> True,
8218 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8221 Make_Op_Multiply
(Loc
,
8223 Duplicate_Subexpr
(Base
),
8225 Duplicate_Subexpr_No_Checks
(Base
))))),
8229 Make_Op_Multiply
(Loc
,
8230 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
8231 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
8233 -- X ** N = 1.0 / X ** (-N)
8238 (Expv
= -1 or Expv
= -2 or Expv
= -3 or Expv
= -4);
8241 Make_Op_Divide
(Loc
,
8243 Make_Float_Literal
(Loc
,
8245 Significand
=> Uint_1
,
8246 Exponent
=> Uint_0
),
8249 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8251 Make_Integer_Literal
(Loc
,
8256 Analyze_And_Resolve
(N
, Typ
);
8261 -- Deal with optimizing 2 ** expression to shift where possible
8263 -- Note: we used to check that Exptyp was an unsigned type. But that is
8264 -- an unnecessary check, since if Exp is negative, we have a run-time
8265 -- error that is either caught (so we get the right result) or we have
8266 -- suppressed the check, in which case the code is erroneous anyway.
8268 if Is_Integer_Type
(Rtyp
)
8270 -- The base value must be "safe compile-time known", and exactly 2
8272 and then Nkind
(Base
) = N_Integer_Literal
8273 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
8274 and then Expr_Value
(Base
) = Uint_2
8276 -- We only handle cases where the right type is a integer
8278 and then Is_Integer_Type
(Root_Type
(Exptyp
))
8279 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
8281 -- This transformation is not applicable for a modular type with a
8282 -- nonbinary modulus because we do not handle modular reduction in
8283 -- a correct manner if we attempt this transformation in this case.
8285 and then not Non_Binary_Modulus
(Typ
)
8287 -- Handle the cases where our parent is a division or multiplication
8288 -- specially. In these cases we can convert to using a shift at the
8289 -- parent level if we are not doing overflow checking, since it is
8290 -- too tricky to combine the overflow check at the parent level.
8293 and then Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
)
8296 P
: constant Node_Id
:= Parent
(N
);
8297 L
: constant Node_Id
:= Left_Opnd
(P
);
8298 R
: constant Node_Id
:= Right_Opnd
(P
);
8301 if (Nkind
(P
) = N_Op_Multiply
8303 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
8305 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
8306 and then not Do_Overflow_Check
(P
))
8309 (Nkind
(P
) = N_Op_Divide
8310 and then Is_Integer_Type
(Etype
(L
))
8311 and then Is_Unsigned_Type
(Etype
(L
))
8313 and then not Do_Overflow_Check
(P
))
8315 Set_Is_Power_Of_2_For_Shift
(N
);
8320 -- Here we just have 2 ** N on its own, so we can convert this to a
8321 -- shift node. We are prepared to deal with overflow here, and we
8322 -- also have to handle proper modular reduction for binary modular.
8331 -- Maximum shift count with no overflow
8334 -- Set True if we must test the shift count
8337 -- Node for test against TestS
8340 -- Compute maximum shift based on the underlying size. For a
8341 -- modular type this is one less than the size.
8343 if Is_Modular_Integer_Type
(Typ
) then
8345 -- For modular integer types, this is the size of the value
8346 -- being shifted minus one. Any larger values will cause
8347 -- modular reduction to a result of zero. Note that we do
8348 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
8349 -- of 6, since 2**7 should be reduced to zero).
8351 MaxS
:= RM_Size
(Rtyp
) - 1;
8353 -- For signed integer types, we use the size of the value
8354 -- being shifted minus 2. Larger values cause overflow.
8357 MaxS
:= Esize
(Rtyp
) - 2;
8360 -- Determine range to see if it can be larger than MaxS
8363 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
8364 TestS
:= (not OK
) or else Hi
> MaxS
;
8366 -- Signed integer case
8368 if Is_Signed_Integer_Type
(Typ
) then
8370 -- Generate overflow check if overflow is active. Note that
8371 -- we can simply ignore the possibility of overflow if the
8372 -- flag is not set (means that overflow cannot happen or
8373 -- that overflow checks are suppressed).
8375 if Ovflo
and TestS
then
8377 Make_Raise_Constraint_Error
(Loc
,
8380 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
8381 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
8382 Reason
=> CE_Overflow_Check_Failed
));
8385 -- Now rewrite node as Shift_Left (1, right-operand)
8388 Make_Op_Shift_Left
(Loc
,
8389 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8390 Right_Opnd
=> Right_Opnd
(N
)));
8392 -- Modular integer case
8394 else pragma Assert
(Is_Modular_Integer_Type
(Typ
));
8396 -- If shift count can be greater than MaxS, we need to wrap
8397 -- the shift in a test that will reduce the result value to
8398 -- zero if this shift count is exceeded.
8402 -- Note: build node for the comparison first, before we
8403 -- reuse the Right_Opnd, so that we have proper parents
8404 -- in place for the Duplicate_Subexpr call.
8408 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
8409 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
));
8412 Make_If_Expression
(Loc
,
8413 Expressions
=> New_List
(
8415 Make_Integer_Literal
(Loc
, Uint_0
),
8416 Make_Op_Shift_Left
(Loc
,
8417 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8418 Right_Opnd
=> Right_Opnd
(N
)))));
8420 -- If we know shift count cannot be greater than MaxS, then
8421 -- it is safe to just rewrite as a shift with no test.
8425 Make_Op_Shift_Left
(Loc
,
8426 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8427 Right_Opnd
=> Right_Opnd
(N
)));
8431 Analyze_And_Resolve
(N
, Typ
);
8437 -- Fall through if exponentiation must be done using a runtime routine
8439 -- First deal with modular case
8441 if Is_Modular_Integer_Type
(Rtyp
) then
8443 -- Nonbinary modular case, we call the special exponentiation
8444 -- routine for the nonbinary case, converting the argument to
8445 -- Long_Long_Integer and passing the modulus value. Then the
8446 -- result is converted back to the base type.
8448 if Non_Binary_Modulus
(Rtyp
) then
8451 Make_Function_Call
(Loc
,
8453 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
8454 Parameter_Associations
=> New_List
(
8455 Convert_To
(RTE
(RE_Unsigned
), Base
),
8456 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
8459 -- Binary modular case, in this case, we call one of two routines,
8460 -- either the unsigned integer case, or the unsigned long long
8461 -- integer case, with a final "and" operation to do the required mod.
8464 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
8465 Ent
:= RTE
(RE_Exp_Unsigned
);
8467 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
8474 Make_Function_Call
(Loc
,
8475 Name
=> New_Occurrence_Of
(Ent
, Loc
),
8476 Parameter_Associations
=> New_List
(
8477 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
8480 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
8484 -- Common exit point for modular type case
8486 Analyze_And_Resolve
(N
, Typ
);
8489 -- Signed integer cases, done using either Integer or Long_Long_Integer.
8490 -- It is not worth having routines for Short_[Short_]Integer, since for
8491 -- most machines it would not help, and it would generate more code that
8492 -- might need certification when a certified run time is required.
8494 -- In the integer cases, we have two routines, one for when overflow
8495 -- checks are required, and one when they are not required, since there
8496 -- is a real gain in omitting checks on many machines.
8498 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
8499 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
8501 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
8502 or else Rtyp
= Universal_Integer
8504 Etyp
:= Standard_Long_Long_Integer
;
8507 Rent
:= RE_Exp_Long_Long_Integer
;
8509 Rent
:= RE_Exn_Long_Long_Integer
;
8512 elsif Is_Signed_Integer_Type
(Rtyp
) then
8513 Etyp
:= Standard_Integer
;
8516 Rent
:= RE_Exp_Integer
;
8518 Rent
:= RE_Exn_Integer
;
8521 -- Floating-point cases. We do not need separate routines for the
8522 -- overflow case here, since in the case of floating-point, we generate
8523 -- infinities anyway as a rule (either that or we automatically trap
8524 -- overflow), and if there is an infinity generated and a range check
8525 -- is required, the check will fail anyway.
8527 -- Historical note: we used to convert everything to Long_Long_Float
8528 -- and call a single common routine, but this had the undesirable effect
8529 -- of giving different results for small static exponent values and the
8530 -- same dynamic values.
8533 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
8535 if Rtyp
= Standard_Float
then
8536 Etyp
:= Standard_Float
;
8537 Rent
:= RE_Exn_Float
;
8539 elsif Rtyp
= Standard_Long_Float
then
8540 Etyp
:= Standard_Long_Float
;
8541 Rent
:= RE_Exn_Long_Float
;
8544 Etyp
:= Standard_Long_Long_Float
;
8545 Rent
:= RE_Exn_Long_Long_Float
;
8549 -- Common processing for integer cases and floating-point cases.
8550 -- If we are in the right type, we can call runtime routine directly
8553 and then Rtyp
/= Universal_Integer
8554 and then Rtyp
/= Universal_Real
8558 Make_Function_Call
(Loc
,
8559 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8560 Parameter_Associations
=> New_List
(Base
, Exp
))));
8562 -- Otherwise we have to introduce conversions (conversions are also
8563 -- required in the universal cases, since the runtime routine is
8564 -- typed using one of the standard types).
8569 Make_Function_Call
(Loc
,
8570 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8571 Parameter_Associations
=> New_List
(
8572 Convert_To
(Etyp
, Base
),
8576 Analyze_And_Resolve
(N
, Typ
);
8580 when RE_Not_Available
=>
8582 end Expand_N_Op_Expon
;
8584 --------------------
8585 -- Expand_N_Op_Ge --
8586 --------------------
8588 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
8589 Typ
: constant Entity_Id
:= Etype
(N
);
8590 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8591 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8592 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8595 Binary_Op_Validity_Checks
(N
);
8597 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8598 -- means we no longer have a comparison operation, we are all done.
8600 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8602 if Nkind
(N
) /= N_Op_Ge
then
8608 if Is_Array_Type
(Typ1
) then
8609 Expand_Array_Comparison
(N
);
8613 -- Deal with boolean operands
8615 if Is_Boolean_Type
(Typ1
) then
8616 Adjust_Condition
(Op1
);
8617 Adjust_Condition
(Op2
);
8618 Set_Etype
(N
, Standard_Boolean
);
8619 Adjust_Result_Type
(N
, Typ
);
8622 Rewrite_Comparison
(N
);
8624 Optimize_Length_Comparison
(N
);
8627 --------------------
8628 -- Expand_N_Op_Gt --
8629 --------------------
8631 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
8632 Typ
: constant Entity_Id
:= Etype
(N
);
8633 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8634 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8635 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8638 Binary_Op_Validity_Checks
(N
);
8640 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8641 -- means we no longer have a comparison operation, we are all done.
8643 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8645 if Nkind
(N
) /= N_Op_Gt
then
8649 -- Deal with array type operands
8651 if Is_Array_Type
(Typ1
) then
8652 Expand_Array_Comparison
(N
);
8656 -- Deal with boolean type operands
8658 if Is_Boolean_Type
(Typ1
) then
8659 Adjust_Condition
(Op1
);
8660 Adjust_Condition
(Op2
);
8661 Set_Etype
(N
, Standard_Boolean
);
8662 Adjust_Result_Type
(N
, Typ
);
8665 Rewrite_Comparison
(N
);
8667 Optimize_Length_Comparison
(N
);
8670 --------------------
8671 -- Expand_N_Op_Le --
8672 --------------------
8674 procedure Expand_N_Op_Le
(N
: Node_Id
) is
8675 Typ
: constant Entity_Id
:= Etype
(N
);
8676 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8677 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8678 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8681 Binary_Op_Validity_Checks
(N
);
8683 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8684 -- means we no longer have a comparison operation, we are all done.
8686 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8688 if Nkind
(N
) /= N_Op_Le
then
8692 -- Deal with array type operands
8694 if Is_Array_Type
(Typ1
) then
8695 Expand_Array_Comparison
(N
);
8699 -- Deal with Boolean type operands
8701 if Is_Boolean_Type
(Typ1
) then
8702 Adjust_Condition
(Op1
);
8703 Adjust_Condition
(Op2
);
8704 Set_Etype
(N
, Standard_Boolean
);
8705 Adjust_Result_Type
(N
, Typ
);
8708 Rewrite_Comparison
(N
);
8710 Optimize_Length_Comparison
(N
);
8713 --------------------
8714 -- Expand_N_Op_Lt --
8715 --------------------
8717 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
8718 Typ
: constant Entity_Id
:= Etype
(N
);
8719 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8720 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8721 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8724 Binary_Op_Validity_Checks
(N
);
8726 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8727 -- means we no longer have a comparison operation, we are all done.
8729 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8731 if Nkind
(N
) /= N_Op_Lt
then
8735 -- Deal with array type operands
8737 if Is_Array_Type
(Typ1
) then
8738 Expand_Array_Comparison
(N
);
8742 -- Deal with Boolean type operands
8744 if Is_Boolean_Type
(Typ1
) then
8745 Adjust_Condition
(Op1
);
8746 Adjust_Condition
(Op2
);
8747 Set_Etype
(N
, Standard_Boolean
);
8748 Adjust_Result_Type
(N
, Typ
);
8751 Rewrite_Comparison
(N
);
8753 Optimize_Length_Comparison
(N
);
8756 -----------------------
8757 -- Expand_N_Op_Minus --
8758 -----------------------
8760 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
8761 Loc
: constant Source_Ptr
:= Sloc
(N
);
8762 Typ
: constant Entity_Id
:= Etype
(N
);
8765 Unary_Op_Validity_Checks
(N
);
8767 -- Check for MINIMIZED/ELIMINATED overflow mode
8769 if Minimized_Eliminated_Overflow_Check
(N
) then
8770 Apply_Arithmetic_Overflow_Check
(N
);
8774 if not Backend_Overflow_Checks_On_Target
8775 and then Is_Signed_Integer_Type
(Etype
(N
))
8776 and then Do_Overflow_Check
(N
)
8778 -- Software overflow checking expands -expr into (0 - expr)
8781 Make_Op_Subtract
(Loc
,
8782 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
8783 Right_Opnd
=> Right_Opnd
(N
)));
8785 Analyze_And_Resolve
(N
, Typ
);
8788 Expand_Nonbinary_Modular_Op
(N
);
8789 end Expand_N_Op_Minus
;
8791 ---------------------
8792 -- Expand_N_Op_Mod --
8793 ---------------------
8795 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
8796 Loc
: constant Source_Ptr
:= Sloc
(N
);
8797 Typ
: constant Entity_Id
:= Etype
(N
);
8798 DDC
: constant Boolean := Do_Division_Check
(N
);
8811 pragma Warnings
(Off
, Lhi
);
8814 Binary_Op_Validity_Checks
(N
);
8816 -- Check for MINIMIZED/ELIMINATED overflow mode
8818 if Minimized_Eliminated_Overflow_Check
(N
) then
8819 Apply_Arithmetic_Overflow_Check
(N
);
8823 if Is_Integer_Type
(Etype
(N
)) then
8824 Apply_Divide_Checks
(N
);
8826 -- All done if we don't have a MOD any more, which can happen as a
8827 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8829 if Nkind
(N
) /= N_Op_Mod
then
8834 -- Proceed with expansion of mod operator
8836 Left
:= Left_Opnd
(N
);
8837 Right
:= Right_Opnd
(N
);
8839 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
8840 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
8842 -- Convert mod to rem if operands are both known to be non-negative, or
8843 -- both known to be non-positive (these are the cases in which rem and
8844 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8845 -- likely that this will improve the quality of code, (the operation now
8846 -- corresponds to the hardware remainder), and it does not seem likely
8847 -- that it could be harmful. It also avoids some cases of the elaborate
8848 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8851 and then ((Llo
>= 0 and then Rlo
>= 0)
8853 (Lhi
<= 0 and then Rhi
<= 0))
8856 Make_Op_Rem
(Sloc
(N
),
8857 Left_Opnd
=> Left_Opnd
(N
),
8858 Right_Opnd
=> Right_Opnd
(N
)));
8860 -- Instead of reanalyzing the node we do the analysis manually. This
8861 -- avoids anomalies when the replacement is done in an instance and
8862 -- is epsilon more efficient.
8864 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
8866 Set_Do_Division_Check
(N
, DDC
);
8867 Expand_N_Op_Rem
(N
);
8871 -- Otherwise, normal mod processing
8874 -- Apply optimization x mod 1 = 0. We don't really need that with
8875 -- gcc, but it is useful with other back ends and is certainly
8878 if Is_Integer_Type
(Etype
(N
))
8879 and then Compile_Time_Known_Value
(Right
)
8880 and then Expr_Value
(Right
) = Uint_1
8882 -- Call Remove_Side_Effects to ensure that any side effects in
8883 -- the ignored left operand (in particular function calls to
8884 -- user defined functions) are properly executed.
8886 Remove_Side_Effects
(Left
);
8888 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8889 Analyze_And_Resolve
(N
, Typ
);
8893 -- If we still have a mod operator and we are in Modify_Tree_For_C
8894 -- mode, and we have a signed integer type, then here is where we do
8895 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8896 -- for the special handling of the annoying case of largest negative
8897 -- number mod minus one.
8899 if Nkind
(N
) = N_Op_Mod
8900 and then Is_Signed_Integer_Type
(Typ
)
8901 and then Modify_Tree_For_C
8903 -- In the general case, we expand A mod B as
8905 -- Tnn : constant typ := A rem B;
8907 -- (if (A >= 0) = (B >= 0) then Tnn
8908 -- elsif Tnn = 0 then 0
8911 -- The comparison can be written simply as A >= 0 if we know that
8912 -- B >= 0 which is a very common case.
8914 -- An important optimization is when B is known at compile time
8915 -- to be 2**K for some constant. In this case we can simply AND
8916 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8917 -- and that works for both the positive and negative cases.
8920 P2
: constant Nat
:= Power_Of_Two
(Right
);
8925 Unchecked_Convert_To
(Typ
,
8928 Unchecked_Convert_To
8929 (Corresponding_Unsigned_Type
(Typ
), Left
),
8931 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
8932 Analyze_And_Resolve
(N
, Typ
);
8937 -- Here for the full rewrite
8940 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
8946 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
8947 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
8949 if not LOK
or else Rlo
< 0 then
8955 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
8956 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
8960 Make_Object_Declaration
(Loc
,
8961 Defining_Identifier
=> Tnn
,
8962 Constant_Present
=> True,
8963 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8967 Right_Opnd
=> Right
)));
8970 Make_If_Expression
(Loc
,
8971 Expressions
=> New_List
(
8973 New_Occurrence_Of
(Tnn
, Loc
),
8974 Make_If_Expression
(Loc
,
8976 Expressions
=> New_List
(
8978 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8979 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
8980 Make_Integer_Literal
(Loc
, 0),
8982 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8984 Duplicate_Subexpr_No_Checks
(Right
)))))));
8986 Analyze_And_Resolve
(N
, Typ
);
8991 -- Deal with annoying case of largest negative number mod minus one.
8992 -- Gigi may not handle this case correctly, because on some targets,
8993 -- the mod value is computed using a divide instruction which gives
8994 -- an overflow trap for this case.
8996 -- It would be a bit more efficient to figure out which targets
8997 -- this is really needed for, but in practice it is reasonable
8998 -- to do the following special check in all cases, since it means
8999 -- we get a clearer message, and also the overhead is minimal given
9000 -- that division is expensive in any case.
9002 -- In fact the check is quite easy, if the right operand is -1, then
9003 -- the mod value is always 0, and we can just ignore the left operand
9004 -- completely in this case.
9006 -- This only applies if we still have a mod operator. Skip if we
9007 -- have already rewritten this (e.g. in the case of eliminated
9008 -- overflow checks which have driven us into bignum mode).
9010 if Nkind
(N
) = N_Op_Mod
then
9012 -- The operand type may be private (e.g. in the expansion of an
9013 -- intrinsic operation) so we must use the underlying type to get
9014 -- the bounds, and convert the literals explicitly.
9018 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
9020 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
9021 and then ((not LOK
) or else (Llo
= LLB
))
9024 Make_If_Expression
(Loc
,
9025 Expressions
=> New_List
(
9027 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9029 Unchecked_Convert_To
(Typ
,
9030 Make_Integer_Literal
(Loc
, -1))),
9031 Unchecked_Convert_To
(Typ
,
9032 Make_Integer_Literal
(Loc
, Uint_0
)),
9033 Relocate_Node
(N
))));
9035 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9036 Analyze_And_Resolve
(N
, Typ
);
9040 end Expand_N_Op_Mod
;
9042 --------------------------
9043 -- Expand_N_Op_Multiply --
9044 --------------------------
9046 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
9047 Loc
: constant Source_Ptr
:= Sloc
(N
);
9048 Lop
: constant Node_Id
:= Left_Opnd
(N
);
9049 Rop
: constant Node_Id
:= Right_Opnd
(N
);
9051 Lp2
: constant Boolean :=
9052 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
9053 Rp2
: constant Boolean :=
9054 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
9056 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
9057 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
9058 Typ
: Entity_Id
:= Etype
(N
);
9061 Binary_Op_Validity_Checks
(N
);
9063 -- Check for MINIMIZED/ELIMINATED overflow mode
9065 if Minimized_Eliminated_Overflow_Check
(N
) then
9066 Apply_Arithmetic_Overflow_Check
(N
);
9070 -- Special optimizations for integer types
9072 if Is_Integer_Type
(Typ
) then
9074 -- N * 0 = 0 for integer types
9076 if Compile_Time_Known_Value
(Rop
)
9077 and then Expr_Value
(Rop
) = Uint_0
9079 -- Call Remove_Side_Effects to ensure that any side effects in
9080 -- the ignored left operand (in particular function calls to
9081 -- user defined functions) are properly executed.
9083 Remove_Side_Effects
(Lop
);
9085 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9086 Analyze_And_Resolve
(N
, Typ
);
9090 -- Similar handling for 0 * N = 0
9092 if Compile_Time_Known_Value
(Lop
)
9093 and then Expr_Value
(Lop
) = Uint_0
9095 Remove_Side_Effects
(Rop
);
9096 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9097 Analyze_And_Resolve
(N
, Typ
);
9101 -- N * 1 = 1 * N = N for integer types
9103 -- This optimisation is not done if we are going to
9104 -- rewrite the product 1 * 2 ** N to a shift.
9106 if Compile_Time_Known_Value
(Rop
)
9107 and then Expr_Value
(Rop
) = Uint_1
9113 elsif Compile_Time_Known_Value
(Lop
)
9114 and then Expr_Value
(Lop
) = Uint_1
9122 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9123 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9124 -- operand is an integer, as required for this to work.
9129 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9133 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
9136 Left_Opnd
=> Right_Opnd
(Lop
),
9137 Right_Opnd
=> Right_Opnd
(Rop
))));
9138 Analyze_And_Resolve
(N
, Typ
);
9142 -- If the result is modular, perform the reduction of the result
9145 if Is_Modular_Integer_Type
(Typ
)
9146 and then not Non_Binary_Modulus
(Typ
)
9151 Make_Op_Shift_Left
(Loc
,
9154 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
9156 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9160 Make_Op_Shift_Left
(Loc
,
9163 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
9166 Analyze_And_Resolve
(N
, Typ
);
9170 -- Same processing for the operands the other way round
9173 if Is_Modular_Integer_Type
(Typ
)
9174 and then not Non_Binary_Modulus
(Typ
)
9179 Make_Op_Shift_Left
(Loc
,
9182 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
9184 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9188 Make_Op_Shift_Left
(Loc
,
9191 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
9194 Analyze_And_Resolve
(N
, Typ
);
9198 -- Do required fixup of universal fixed operation
9200 if Typ
= Universal_Fixed
then
9201 Fixup_Universal_Fixed_Operation
(N
);
9205 -- Multiplications with fixed-point results
9207 if Is_Fixed_Point_Type
(Typ
) then
9209 -- No special processing if Treat_Fixed_As_Integer is set, since from
9210 -- a semantic point of view such operations are simply integer
9211 -- operations and will be treated that way.
9213 if not Treat_Fixed_As_Integer
(N
) then
9215 -- Case of fixed * integer => fixed
9217 if Is_Integer_Type
(Rtyp
) then
9218 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
9220 -- Case of integer * fixed => fixed
9222 elsif Is_Integer_Type
(Ltyp
) then
9223 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
9225 -- Case of fixed * fixed => fixed
9228 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
9232 -- Other cases of multiplication of fixed-point operands. Again we
9233 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
9235 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
9236 and then not Treat_Fixed_As_Integer
(N
)
9238 if Is_Integer_Type
(Typ
) then
9239 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
9241 pragma Assert
(Is_Floating_Point_Type
(Typ
));
9242 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
9245 -- Mixed-mode operations can appear in a non-static universal context,
9246 -- in which case the integer argument must be converted explicitly.
9248 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
9249 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
9250 Analyze_And_Resolve
(Rop
, Universal_Real
);
9252 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
9253 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
9254 Analyze_And_Resolve
(Lop
, Universal_Real
);
9256 -- Non-fixed point cases, check software overflow checking required
9258 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
9259 Apply_Arithmetic_Overflow_Check
(N
);
9262 -- Overflow checks for floating-point if -gnateF mode active
9264 Check_Float_Op_Overflow
(N
);
9266 Expand_Nonbinary_Modular_Op
(N
);
9267 end Expand_N_Op_Multiply
;
9269 --------------------
9270 -- Expand_N_Op_Ne --
9271 --------------------
9273 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
9274 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
9277 -- Case of elementary type with standard operator
9279 if Is_Elementary_Type
(Typ
)
9280 and then Sloc
(Entity
(N
)) = Standard_Location
9282 Binary_Op_Validity_Checks
(N
);
9284 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9285 -- means we no longer have a /= operation, we are all done.
9287 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9289 if Nkind
(N
) /= N_Op_Ne
then
9293 -- Boolean types (requiring handling of non-standard case)
9295 if Is_Boolean_Type
(Typ
) then
9296 Adjust_Condition
(Left_Opnd
(N
));
9297 Adjust_Condition
(Right_Opnd
(N
));
9298 Set_Etype
(N
, Standard_Boolean
);
9299 Adjust_Result_Type
(N
, Typ
);
9302 Rewrite_Comparison
(N
);
9304 -- For all cases other than elementary types, we rewrite node as the
9305 -- negation of an equality operation, and reanalyze. The equality to be
9306 -- used is defined in the same scope and has the same signature. This
9307 -- signature must be set explicitly since in an instance it may not have
9308 -- the same visibility as in the generic unit. This avoids duplicating
9309 -- or factoring the complex code for record/array equality tests etc.
9311 -- This case is also used for the minimal expansion performed in
9316 Loc
: constant Source_Ptr
:= Sloc
(N
);
9318 Ne
: constant Entity_Id
:= Entity
(N
);
9321 Binary_Op_Validity_Checks
(N
);
9327 Left_Opnd
=> Left_Opnd
(N
),
9328 Right_Opnd
=> Right_Opnd
(N
)));
9330 -- The level of parentheses is useless in GNATprove mode, and
9331 -- bumping its level here leads to wrong columns being used in
9332 -- check messages, hence skip it in this mode.
9334 if not GNATprove_Mode
then
9335 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
9338 if Scope
(Ne
) /= Standard_Standard
then
9339 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
9342 -- For navigation purposes, we want to treat the inequality as an
9343 -- implicit reference to the corresponding equality. Preserve the
9344 -- Comes_From_ source flag to generate proper Xref entries.
9346 Preserve_Comes_From_Source
(Neg
, N
);
9347 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
9349 Analyze_And_Resolve
(N
, Standard_Boolean
);
9353 -- No need for optimization in GNATprove mode, where we would rather see
9354 -- the original source expression.
9356 if not GNATprove_Mode
then
9357 Optimize_Length_Comparison
(N
);
9361 ---------------------
9362 -- Expand_N_Op_Not --
9363 ---------------------
9365 -- If the argument is other than a Boolean array type, there is no special
9366 -- expansion required, except for dealing with validity checks, and non-
9367 -- standard boolean representations.
9369 -- For the packed array case, we call the special routine in Exp_Pakd,
9370 -- except that if the component size is greater than one, we use the
9371 -- standard routine generating a gruesome loop (it is so peculiar to have
9372 -- packed arrays with non-standard Boolean representations anyway, so it
9373 -- does not matter that we do not handle this case efficiently).
9375 -- For the unpacked array case (and for the special packed case where we
9376 -- have non standard Booleans, as discussed above), we generate and insert
9377 -- into the tree the following function definition:
9379 -- function Nnnn (A : arr) is
9382 -- for J in a'range loop
9383 -- B (J) := not A (J);
9388 -- Here arr is the actual subtype of the parameter (and hence always
9389 -- constrained). Then we replace the not with a call to this function.
9391 procedure Expand_N_Op_Not
(N
: Node_Id
) is
9392 Loc
: constant Source_Ptr
:= Sloc
(N
);
9393 Typ
: constant Entity_Id
:= Etype
(N
);
9402 Func_Name
: Entity_Id
;
9403 Loop_Statement
: Node_Id
;
9406 Unary_Op_Validity_Checks
(N
);
9408 -- For boolean operand, deal with non-standard booleans
9410 if Is_Boolean_Type
(Typ
) then
9411 Adjust_Condition
(Right_Opnd
(N
));
9412 Set_Etype
(N
, Standard_Boolean
);
9413 Adjust_Result_Type
(N
, Typ
);
9417 -- Only array types need any other processing
9419 if not Is_Array_Type
(Typ
) then
9423 -- Case of array operand. If bit packed with a component size of 1,
9424 -- handle it in Exp_Pakd if the operand is known to be aligned.
9426 if Is_Bit_Packed_Array
(Typ
)
9427 and then Component_Size
(Typ
) = 1
9428 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
9430 Expand_Packed_Not
(N
);
9434 -- Case of array operand which is not bit-packed. If the context is
9435 -- a safe assignment, call in-place operation, If context is a larger
9436 -- boolean expression in the context of a safe assignment, expansion is
9437 -- done by enclosing operation.
9439 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
9440 Convert_To_Actual_Subtype
(Opnd
);
9441 Arr
:= Etype
(Opnd
);
9442 Ensure_Defined
(Arr
, N
);
9443 Silly_Boolean_Array_Not_Test
(N
, Arr
);
9445 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9446 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
9447 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9450 -- Special case the negation of a binary operation
9452 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
9453 and then Safe_In_Place_Array_Op
9454 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
9456 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9460 elsif Nkind
(Parent
(N
)) in N_Binary_Op
9461 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9464 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
9465 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
9466 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
9469 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
9471 -- (not A) op (not B) can be reduced to a single call
9473 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
9476 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
9479 -- A xor (not B) can also be special-cased
9481 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
9488 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
9489 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
9490 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
9493 Make_Indexed_Component
(Loc
,
9494 Prefix
=> New_Occurrence_Of
(A
, Loc
),
9495 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9498 Make_Indexed_Component
(Loc
,
9499 Prefix
=> New_Occurrence_Of
(B
, Loc
),
9500 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9503 Make_Implicit_Loop_Statement
(N
,
9504 Identifier
=> Empty
,
9507 Make_Iteration_Scheme
(Loc
,
9508 Loop_Parameter_Specification
=>
9509 Make_Loop_Parameter_Specification
(Loc
,
9510 Defining_Identifier
=> J
,
9511 Discrete_Subtype_Definition
=>
9512 Make_Attribute_Reference
(Loc
,
9513 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
9514 Attribute_Name
=> Name_Range
))),
9516 Statements
=> New_List
(
9517 Make_Assignment_Statement
(Loc
,
9519 Expression
=> Make_Op_Not
(Loc
, A_J
))));
9521 Func_Name
:= Make_Temporary
(Loc
, 'N');
9522 Set_Is_Inlined
(Func_Name
);
9525 Make_Subprogram_Body
(Loc
,
9527 Make_Function_Specification
(Loc
,
9528 Defining_Unit_Name
=> Func_Name
,
9529 Parameter_Specifications
=> New_List
(
9530 Make_Parameter_Specification
(Loc
,
9531 Defining_Identifier
=> A
,
9532 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9533 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9535 Declarations
=> New_List
(
9536 Make_Object_Declaration
(Loc
,
9537 Defining_Identifier
=> B
,
9538 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
9540 Handled_Statement_Sequence
=>
9541 Make_Handled_Sequence_Of_Statements
(Loc
,
9542 Statements
=> New_List
(
9544 Make_Simple_Return_Statement
(Loc
,
9545 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
9548 Make_Function_Call
(Loc
,
9549 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
9550 Parameter_Associations
=> New_List
(Opnd
)));
9552 Analyze_And_Resolve
(N
, Typ
);
9553 end Expand_N_Op_Not
;
9555 --------------------
9556 -- Expand_N_Op_Or --
9557 --------------------
9559 procedure Expand_N_Op_Or
(N
: Node_Id
) is
9560 Typ
: constant Entity_Id
:= Etype
(N
);
9563 Binary_Op_Validity_Checks
(N
);
9565 if Is_Array_Type
(Etype
(N
)) then
9566 Expand_Boolean_Operator
(N
);
9568 elsif Is_Boolean_Type
(Etype
(N
)) then
9569 Adjust_Condition
(Left_Opnd
(N
));
9570 Adjust_Condition
(Right_Opnd
(N
));
9571 Set_Etype
(N
, Standard_Boolean
);
9572 Adjust_Result_Type
(N
, Typ
);
9574 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9575 Expand_Intrinsic_Call
(N
, Entity
(N
));
9578 Expand_Nonbinary_Modular_Op
(N
);
9581 ----------------------
9582 -- Expand_N_Op_Plus --
9583 ----------------------
9585 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
9587 Unary_Op_Validity_Checks
(N
);
9589 -- Check for MINIMIZED/ELIMINATED overflow mode
9591 if Minimized_Eliminated_Overflow_Check
(N
) then
9592 Apply_Arithmetic_Overflow_Check
(N
);
9595 end Expand_N_Op_Plus
;
9597 ---------------------
9598 -- Expand_N_Op_Rem --
9599 ---------------------
9601 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
9602 Loc
: constant Source_Ptr
:= Sloc
(N
);
9603 Typ
: constant Entity_Id
:= Etype
(N
);
9614 -- Set if corresponding operand can be negative
9616 pragma Unreferenced
(Hi
);
9619 Binary_Op_Validity_Checks
(N
);
9621 -- Check for MINIMIZED/ELIMINATED overflow mode
9623 if Minimized_Eliminated_Overflow_Check
(N
) then
9624 Apply_Arithmetic_Overflow_Check
(N
);
9628 if Is_Integer_Type
(Etype
(N
)) then
9629 Apply_Divide_Checks
(N
);
9631 -- All done if we don't have a REM any more, which can happen as a
9632 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9634 if Nkind
(N
) /= N_Op_Rem
then
9639 -- Proceed with expansion of REM
9641 Left
:= Left_Opnd
(N
);
9642 Right
:= Right_Opnd
(N
);
9644 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9645 -- but it is useful with other back ends, and is certainly harmless.
9647 if Is_Integer_Type
(Etype
(N
))
9648 and then Compile_Time_Known_Value
(Right
)
9649 and then Expr_Value
(Right
) = Uint_1
9651 -- Call Remove_Side_Effects to ensure that any side effects in the
9652 -- ignored left operand (in particular function calls to user defined
9653 -- functions) are properly executed.
9655 Remove_Side_Effects
(Left
);
9657 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9658 Analyze_And_Resolve
(N
, Typ
);
9662 -- Deal with annoying case of largest negative number remainder minus
9663 -- one. Gigi may not handle this case correctly, because on some
9664 -- targets, the mod value is computed using a divide instruction
9665 -- which gives an overflow trap for this case.
9667 -- It would be a bit more efficient to figure out which targets this
9668 -- is really needed for, but in practice it is reasonable to do the
9669 -- following special check in all cases, since it means we get a clearer
9670 -- message, and also the overhead is minimal given that division is
9671 -- expensive in any case.
9673 -- In fact the check is quite easy, if the right operand is -1, then
9674 -- the remainder is always 0, and we can just ignore the left operand
9675 -- completely in this case.
9677 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9678 Lneg
:= (not OK
) or else Lo
< 0;
9680 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9681 Rneg
:= (not OK
) or else Lo
< 0;
9683 -- We won't mess with trying to find out if the left operand can really
9684 -- be the largest negative number (that's a pain in the case of private
9685 -- types and this is really marginal). We will just assume that we need
9686 -- the test if the left operand can be negative at all.
9688 if Lneg
and Rneg
then
9690 Make_If_Expression
(Loc
,
9691 Expressions
=> New_List
(
9693 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9695 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
9697 Unchecked_Convert_To
(Typ
,
9698 Make_Integer_Literal
(Loc
, Uint_0
)),
9700 Relocate_Node
(N
))));
9702 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9703 Analyze_And_Resolve
(N
, Typ
);
9705 end Expand_N_Op_Rem
;
9707 -----------------------------
9708 -- Expand_N_Op_Rotate_Left --
9709 -----------------------------
9711 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
9713 Binary_Op_Validity_Checks
(N
);
9715 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9716 -- so we rewrite in terms of logical shifts
9718 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9720 -- where Bits is the shift count mod Esize (the mod operation here
9721 -- deals with ludicrous large shift counts, which are apparently OK).
9723 -- What about nonbinary modulus ???
9726 Loc
: constant Source_Ptr
:= Sloc
(N
);
9727 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9728 Typ
: constant Entity_Id
:= Etype
(N
);
9731 if Modify_Tree_For_C
then
9732 Rewrite
(Right_Opnd
(N
),
9734 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9735 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9737 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9742 Make_Op_Shift_Left
(Loc
,
9743 Left_Opnd
=> Left_Opnd
(N
),
9744 Right_Opnd
=> Right_Opnd
(N
)),
9747 Make_Op_Shift_Right
(Loc
,
9748 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9750 Make_Op_Subtract
(Loc
,
9751 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9753 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9755 Analyze_And_Resolve
(N
, Typ
);
9758 end Expand_N_Op_Rotate_Left
;
9760 ------------------------------
9761 -- Expand_N_Op_Rotate_Right --
9762 ------------------------------
9764 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
9766 Binary_Op_Validity_Checks
(N
);
9768 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9769 -- so we rewrite in terms of logical shifts
9771 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9773 -- where Bits is the shift count mod Esize (the mod operation here
9774 -- deals with ludicrous large shift counts, which are apparently OK).
9776 -- What about nonbinary modulus ???
9779 Loc
: constant Source_Ptr
:= Sloc
(N
);
9780 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9781 Typ
: constant Entity_Id
:= Etype
(N
);
9784 Rewrite
(Right_Opnd
(N
),
9786 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9787 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9789 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9791 if Modify_Tree_For_C
then
9795 Make_Op_Shift_Right
(Loc
,
9796 Left_Opnd
=> Left_Opnd
(N
),
9797 Right_Opnd
=> Right_Opnd
(N
)),
9800 Make_Op_Shift_Left
(Loc
,
9801 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9803 Make_Op_Subtract
(Loc
,
9804 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9806 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9808 Analyze_And_Resolve
(N
, Typ
);
9811 end Expand_N_Op_Rotate_Right
;
9813 ----------------------------
9814 -- Expand_N_Op_Shift_Left --
9815 ----------------------------
9817 -- Note: nothing in this routine depends on left as opposed to right shifts
9818 -- so we share the routine for expanding shift right operations.
9820 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
9822 Binary_Op_Validity_Checks
(N
);
9824 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9825 -- operand is not greater than the word size (since that would not
9826 -- be defined properly by the corresponding C shift operator).
9828 if Modify_Tree_For_C
then
9830 Right
: constant Node_Id
:= Right_Opnd
(N
);
9831 Loc
: constant Source_Ptr
:= Sloc
(Right
);
9832 Typ
: constant Entity_Id
:= Etype
(N
);
9833 Siz
: constant Uint
:= Esize
(Typ
);
9840 if Compile_Time_Known_Value
(Right
) then
9841 if Expr_Value
(Right
) >= Siz
then
9842 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9843 Analyze_And_Resolve
(N
, Typ
);
9846 -- Not compile time known, find range
9849 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9851 -- Nothing to do if known to be OK range, otherwise expand
9853 if not OK
or else Hi
>= Siz
then
9855 -- Prevent recursion on copy of shift node
9857 Orig
:= Relocate_Node
(N
);
9858 Set_Analyzed
(Orig
);
9860 -- Now do the rewrite
9863 Make_If_Expression
(Loc
,
9864 Expressions
=> New_List
(
9866 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
9867 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
9868 Make_Integer_Literal
(Loc
, 0),
9870 Analyze_And_Resolve
(N
, Typ
);
9875 end Expand_N_Op_Shift_Left
;
9877 -----------------------------
9878 -- Expand_N_Op_Shift_Right --
9879 -----------------------------
9881 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
9883 -- Share shift left circuit
9885 Expand_N_Op_Shift_Left
(N
);
9886 end Expand_N_Op_Shift_Right
;
9888 ----------------------------------------
9889 -- Expand_N_Op_Shift_Right_Arithmetic --
9890 ----------------------------------------
9892 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
9894 Binary_Op_Validity_Checks
(N
);
9896 -- If we are in Modify_Tree_For_C mode, there is no shift right
9897 -- arithmetic in C, so we rewrite in terms of logical shifts.
9899 -- Shift_Right (Num, Bits) or
9901 -- then not (Shift_Right (Mask, bits))
9904 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9906 -- Note: in almost all C compilers it would work to just shift a
9907 -- signed integer right, but it's undefined and we cannot rely on it.
9909 -- Note: the above works fine for shift counts greater than or equal
9910 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9911 -- generates all 1'bits.
9913 -- What about nonbinary modulus ???
9916 Loc
: constant Source_Ptr
:= Sloc
(N
);
9917 Typ
: constant Entity_Id
:= Etype
(N
);
9918 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
9919 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
9920 Left
: constant Node_Id
:= Left_Opnd
(N
);
9921 Right
: constant Node_Id
:= Right_Opnd
(N
);
9925 if Modify_Tree_For_C
then
9927 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9928 -- compile time as a single constant.
9930 if Compile_Time_Known_Value
(Right
) then
9932 Val
: constant Uint
:= Expr_Value
(Right
);
9935 if Val
>= Esize
(Typ
) then
9936 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
9940 Make_Integer_Literal
(Loc
,
9941 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
9949 Make_Op_Shift_Right
(Loc
,
9950 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
9951 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
9954 -- Now do the rewrite
9959 Make_Op_Shift_Right
(Loc
,
9961 Right_Opnd
=> Right
),
9963 Make_If_Expression
(Loc
,
9964 Expressions
=> New_List
(
9966 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9967 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
9969 Make_Integer_Literal
(Loc
, 0)))));
9970 Analyze_And_Resolve
(N
, Typ
);
9973 end Expand_N_Op_Shift_Right_Arithmetic
;
9975 --------------------------
9976 -- Expand_N_Op_Subtract --
9977 --------------------------
9979 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
9980 Typ
: constant Entity_Id
:= Etype
(N
);
9983 Binary_Op_Validity_Checks
(N
);
9985 -- Check for MINIMIZED/ELIMINATED overflow mode
9987 if Minimized_Eliminated_Overflow_Check
(N
) then
9988 Apply_Arithmetic_Overflow_Check
(N
);
9992 -- N - 0 = N for integer types
9994 if Is_Integer_Type
(Typ
)
9995 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
9996 and then Expr_Value
(Right_Opnd
(N
)) = 0
9998 Rewrite
(N
, Left_Opnd
(N
));
10002 -- Arithmetic overflow checks for signed integer/fixed point types
10004 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
10005 Apply_Arithmetic_Overflow_Check
(N
);
10008 -- Overflow checks for floating-point if -gnateF mode active
10010 Check_Float_Op_Overflow
(N
);
10012 Expand_Nonbinary_Modular_Op
(N
);
10013 end Expand_N_Op_Subtract
;
10015 ---------------------
10016 -- Expand_N_Op_Xor --
10017 ---------------------
10019 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
10020 Typ
: constant Entity_Id
:= Etype
(N
);
10023 Binary_Op_Validity_Checks
(N
);
10025 if Is_Array_Type
(Etype
(N
)) then
10026 Expand_Boolean_Operator
(N
);
10028 elsif Is_Boolean_Type
(Etype
(N
)) then
10029 Adjust_Condition
(Left_Opnd
(N
));
10030 Adjust_Condition
(Right_Opnd
(N
));
10031 Set_Etype
(N
, Standard_Boolean
);
10032 Adjust_Result_Type
(N
, Typ
);
10034 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10035 Expand_Intrinsic_Call
(N
, Entity
(N
));
10038 Expand_Nonbinary_Modular_Op
(N
);
10039 end Expand_N_Op_Xor
;
10041 ----------------------
10042 -- Expand_N_Or_Else --
10043 ----------------------
10045 procedure Expand_N_Or_Else
(N
: Node_Id
)
10046 renames Expand_Short_Circuit_Operator
;
10048 -----------------------------------
10049 -- Expand_N_Qualified_Expression --
10050 -----------------------------------
10052 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
10053 Operand
: constant Node_Id
:= Expression
(N
);
10054 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
10057 -- Do validity check if validity checking operands
10059 if Validity_Checks_On
and Validity_Check_Operands
then
10060 Ensure_Valid
(Operand
);
10063 -- Apply possible constraint check
10065 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
10067 if Do_Range_Check
(Operand
) then
10068 Set_Do_Range_Check
(Operand
, False);
10069 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
10071 end Expand_N_Qualified_Expression
;
10073 ------------------------------------
10074 -- Expand_N_Quantified_Expression --
10075 ------------------------------------
10079 -- for all X in range => Cond
10084 -- for X in range loop
10085 -- if not Cond then
10091 -- Similarly, an existentially quantified expression:
10093 -- for some X in range => Cond
10098 -- for X in range loop
10105 -- In both cases, the iteration may be over a container in which case it is
10106 -- given by an iterator specification, not a loop parameter specification.
10108 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
10109 Actions
: constant List_Id
:= New_List
;
10110 For_All
: constant Boolean := All_Present
(N
);
10111 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
10112 Loc
: constant Source_Ptr
:= Sloc
(N
);
10113 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
10120 -- Create the declaration of the flag which tracks the status of the
10121 -- quantified expression. Generate:
10123 -- Flag : Boolean := (True | False);
10125 Flag
:= Make_Temporary
(Loc
, 'T', N
);
10127 Append_To
(Actions
,
10128 Make_Object_Declaration
(Loc
,
10129 Defining_Identifier
=> Flag
,
10130 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
10132 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
10134 -- Construct the circuitry which tracks the status of the quantified
10135 -- expression. Generate:
10137 -- if [not] Cond then
10138 -- Flag := (False | True);
10142 Cond
:= Relocate_Node
(Condition
(N
));
10145 Cond
:= Make_Op_Not
(Loc
, Cond
);
10148 Stmts
:= New_List
(
10149 Make_Implicit_If_Statement
(N
,
10151 Then_Statements
=> New_List
(
10152 Make_Assignment_Statement
(Loc
,
10153 Name
=> New_Occurrence_Of
(Flag
, Loc
),
10155 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
10156 Make_Exit_Statement
(Loc
))));
10158 -- Build the loop equivalent of the quantified expression
10160 if Present
(Iter_Spec
) then
10162 Make_Iteration_Scheme
(Loc
,
10163 Iterator_Specification
=> Iter_Spec
);
10166 Make_Iteration_Scheme
(Loc
,
10167 Loop_Parameter_Specification
=> Loop_Spec
);
10170 Append_To
(Actions
,
10171 Make_Loop_Statement
(Loc
,
10172 Iteration_Scheme
=> Scheme
,
10173 Statements
=> Stmts
,
10174 End_Label
=> Empty
));
10176 -- Transform the quantified expression
10179 Make_Expression_With_Actions
(Loc
,
10180 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
10181 Actions
=> Actions
));
10182 Analyze_And_Resolve
(N
, Standard_Boolean
);
10183 end Expand_N_Quantified_Expression
;
10185 ---------------------------------
10186 -- Expand_N_Selected_Component --
10187 ---------------------------------
10189 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
10190 Loc
: constant Source_Ptr
:= Sloc
(N
);
10191 Par
: constant Node_Id
:= Parent
(N
);
10192 P
: constant Node_Id
:= Prefix
(N
);
10193 S
: constant Node_Id
:= Selector_Name
(N
);
10194 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
10200 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
10201 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10202 -- unless the context of an assignment can provide size information.
10203 -- Don't we have a general routine that does this???
10205 function Is_Subtype_Declaration
return Boolean;
10206 -- The replacement of a discriminant reference by its value is required
10207 -- if this is part of the initialization of an temporary generated by a
10208 -- change of representation. This shows up as the construction of a
10209 -- discriminant constraint for a subtype declared at the same point as
10210 -- the entity in the prefix of the selected component. We recognize this
10211 -- case when the context of the reference is:
10212 -- subtype ST is T(Obj.D);
10213 -- where the entity for Obj comes from source, and ST has the same sloc.
10215 -----------------------
10216 -- In_Left_Hand_Side --
10217 -----------------------
10219 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
10221 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
10222 and then Comp
= Name
(Parent
(Comp
)))
10223 or else (Present
(Parent
(Comp
))
10224 and then Nkind
(Parent
(Comp
)) in N_Subexpr
10225 and then In_Left_Hand_Side
(Parent
(Comp
)));
10226 end In_Left_Hand_Side
;
10228 -----------------------------
10229 -- Is_Subtype_Declaration --
10230 -----------------------------
10232 function Is_Subtype_Declaration
return Boolean is
10233 Par
: constant Node_Id
:= Parent
(N
);
10236 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
10237 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
10238 and then Comes_From_Source
(Entity
(Prefix
(N
)))
10239 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
10240 end Is_Subtype_Declaration
;
10242 -- Start of processing for Expand_N_Selected_Component
10245 -- Insert explicit dereference if required
10247 if Is_Access_Type
(Ptyp
) then
10249 -- First set prefix type to proper access type, in case it currently
10250 -- has a private (non-access) view of this type.
10252 Set_Etype
(P
, Ptyp
);
10254 Insert_Explicit_Dereference
(P
);
10255 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
10257 if Ekind
(Etype
(P
)) = E_Private_Subtype
10258 and then Is_For_Access_Subtype
(Etype
(P
))
10260 Set_Etype
(P
, Base_Type
(Etype
(P
)));
10266 -- Deal with discriminant check required
10268 if Do_Discriminant_Check
(N
) then
10269 if Present
(Discriminant_Checking_Func
10270 (Original_Record_Component
(Entity
(S
))))
10272 -- Present the discriminant checking function to the backend, so
10273 -- that it can inline the call to the function.
10276 (Discriminant_Checking_Func
10277 (Original_Record_Component
(Entity
(S
))),
10280 -- Now reset the flag and generate the call
10282 Set_Do_Discriminant_Check
(N
, False);
10283 Generate_Discriminant_Check
(N
);
10285 -- In the case of Unchecked_Union, no discriminant checking is
10286 -- actually performed.
10289 Set_Do_Discriminant_Check
(N
, False);
10293 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10294 -- function, then additional actuals must be passed.
10296 if Is_Build_In_Place_Function_Call
(P
) then
10297 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
10299 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10300 -- containing build-in-place function calls whose returned object covers
10301 -- interface types.
10303 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
10304 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
10307 -- Gigi cannot handle unchecked conversions that are the prefix of a
10308 -- selected component with discriminants. This must be checked during
10309 -- expansion, because during analysis the type of the selector is not
10310 -- known at the point the prefix is analyzed. If the conversion is the
10311 -- target of an assignment, then we cannot force the evaluation.
10313 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
10314 and then Has_Discriminants
(Etype
(N
))
10315 and then not In_Left_Hand_Side
(N
)
10317 Force_Evaluation
(Prefix
(N
));
10320 -- Remaining processing applies only if selector is a discriminant
10322 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
10324 -- If the selector is a discriminant of a constrained record type,
10325 -- we may be able to rewrite the expression with the actual value
10326 -- of the discriminant, a useful optimization in some cases.
10328 if Is_Record_Type
(Ptyp
)
10329 and then Has_Discriminants
(Ptyp
)
10330 and then Is_Constrained
(Ptyp
)
10332 -- Do this optimization for discrete types only, and not for
10333 -- access types (access discriminants get us into trouble).
10335 if not Is_Discrete_Type
(Etype
(N
)) then
10338 -- Don't do this on the left-hand side of an assignment statement.
10339 -- Normally one would think that references like this would not
10340 -- occur, but they do in generated code, and mean that we really
10341 -- do want to assign the discriminant.
10343 elsif Nkind
(Par
) = N_Assignment_Statement
10344 and then Name
(Par
) = N
10348 -- Don't do this optimization for the prefix of an attribute or
10349 -- the name of an object renaming declaration since these are
10350 -- contexts where we do not want the value anyway.
10352 elsif (Nkind
(Par
) = N_Attribute_Reference
10353 and then Prefix
(Par
) = N
)
10354 or else Is_Renamed_Object
(N
)
10358 -- Don't do this optimization if we are within the code for a
10359 -- discriminant check, since the whole point of such a check may
10360 -- be to verify the condition on which the code below depends.
10362 elsif Is_In_Discriminant_Check
(N
) then
10365 -- Green light to see if we can do the optimization. There is
10366 -- still one condition that inhibits the optimization below but
10367 -- now is the time to check the particular discriminant.
10370 -- Loop through discriminants to find the matching discriminant
10371 -- constraint to see if we can copy it.
10373 Disc
:= First_Discriminant
(Ptyp
);
10374 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
10375 Discr_Loop
: while Present
(Dcon
) loop
10376 Dval
:= Node
(Dcon
);
10378 -- Check if this is the matching discriminant and if the
10379 -- discriminant value is simple enough to make sense to
10380 -- copy. We don't want to copy complex expressions, and
10381 -- indeed to do so can cause trouble (before we put in
10382 -- this guard, a discriminant expression containing an
10383 -- AND THEN was copied, causing problems for coverage
10384 -- analysis tools).
10386 -- However, if the reference is part of the initialization
10387 -- code generated for an object declaration, we must use
10388 -- the discriminant value from the subtype constraint,
10389 -- because the selected component may be a reference to the
10390 -- object being initialized, whose discriminant is not yet
10391 -- set. This only happens in complex cases involving changes
10392 -- or representation.
10394 if Disc
= Entity
(Selector_Name
(N
))
10395 and then (Is_Entity_Name
(Dval
)
10396 or else Compile_Time_Known_Value
(Dval
)
10397 or else Is_Subtype_Declaration
)
10399 -- Here we have the matching discriminant. Check for
10400 -- the case of a discriminant of a component that is
10401 -- constrained by an outer discriminant, which cannot
10402 -- be optimized away.
10404 if Denotes_Discriminant
10405 (Dval
, Check_Concurrent
=> True)
10409 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
10411 Denotes_Discriminant
10412 (Selector_Name
(Original_Node
(Dval
)), True)
10416 -- Do not retrieve value if constraint is not static. It
10417 -- is generally not useful, and the constraint may be a
10418 -- rewritten outer discriminant in which case it is in
10421 elsif Is_Entity_Name
(Dval
)
10423 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
10424 and then Present
(Expression
(Parent
(Entity
(Dval
))))
10426 Is_OK_Static_Expression
10427 (Expression
(Parent
(Entity
(Dval
))))
10431 -- In the context of a case statement, the expression may
10432 -- have the base type of the discriminant, and we need to
10433 -- preserve the constraint to avoid spurious errors on
10436 elsif Nkind
(Parent
(N
)) = N_Case_Statement
10437 and then Etype
(Dval
) /= Etype
(Disc
)
10440 Make_Qualified_Expression
(Loc
,
10442 New_Occurrence_Of
(Etype
(Disc
), Loc
),
10444 New_Copy_Tree
(Dval
)));
10445 Analyze_And_Resolve
(N
, Etype
(Disc
));
10447 -- In case that comes out as a static expression,
10448 -- reset it (a selected component is never static).
10450 Set_Is_Static_Expression
(N
, False);
10453 -- Otherwise we can just copy the constraint, but the
10454 -- result is certainly not static. In some cases the
10455 -- discriminant constraint has been analyzed in the
10456 -- context of the original subtype indication, but for
10457 -- itypes the constraint might not have been analyzed
10458 -- yet, and this must be done now.
10461 Rewrite
(N
, New_Copy_Tree
(Dval
));
10462 Analyze_And_Resolve
(N
);
10463 Set_Is_Static_Expression
(N
, False);
10469 Next_Discriminant
(Disc
);
10470 end loop Discr_Loop
;
10472 -- Note: the above loop should always find a matching
10473 -- discriminant, but if it does not, we just missed an
10474 -- optimization due to some glitch (perhaps a previous
10475 -- error), so ignore.
10480 -- The only remaining processing is in the case of a discriminant of
10481 -- a concurrent object, where we rewrite the prefix to denote the
10482 -- corresponding record type. If the type is derived and has renamed
10483 -- discriminants, use corresponding discriminant, which is the one
10484 -- that appears in the corresponding record.
10486 if not Is_Concurrent_Type
(Ptyp
) then
10490 Disc
:= Entity
(Selector_Name
(N
));
10492 if Is_Derived_Type
(Ptyp
)
10493 and then Present
(Corresponding_Discriminant
(Disc
))
10495 Disc
:= Corresponding_Discriminant
(Disc
);
10499 Make_Selected_Component
(Loc
,
10501 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
10502 New_Copy_Tree
(P
)),
10503 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
10505 Rewrite
(N
, New_N
);
10509 -- Set Atomic_Sync_Required if necessary for atomic component
10511 if Nkind
(N
) = N_Selected_Component
then
10513 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
10517 -- If component is atomic, but type is not, setting depends on
10518 -- disable/enable state for the component.
10520 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
10521 Set
:= not Atomic_Synchronization_Disabled
(E
);
10523 -- If component is not atomic, but its type is atomic, setting
10524 -- depends on disable/enable state for the type.
10526 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
10527 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
10529 -- If both component and type are atomic, we disable if either
10530 -- component or its type have sync disabled.
10532 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
10533 Set
:= (not Atomic_Synchronization_Disabled
(E
))
10535 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
10541 -- Set flag if required
10544 Activate_Atomic_Synchronization
(N
);
10548 end Expand_N_Selected_Component
;
10550 --------------------
10551 -- Expand_N_Slice --
10552 --------------------
10554 procedure Expand_N_Slice
(N
: Node_Id
) is
10555 Loc
: constant Source_Ptr
:= Sloc
(N
);
10556 Typ
: constant Entity_Id
:= Etype
(N
);
10558 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
10559 -- Check whether the argument is an actual for a procedure call, in
10560 -- which case the expansion of a bit-packed slice is deferred until the
10561 -- call itself is expanded. The reason this is required is that we might
10562 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10563 -- that copy out would be missed if we created a temporary here in
10564 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10565 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10566 -- is harmless to defer expansion in the IN case, since the call
10567 -- processing will still generate the appropriate copy in operation,
10568 -- which will take care of the slice.
10570 procedure Make_Temporary_For_Slice
;
10571 -- Create a named variable for the value of the slice, in cases where
10572 -- the back end cannot handle it properly, e.g. when packed types or
10573 -- unaligned slices are involved.
10575 -------------------------
10576 -- Is_Procedure_Actual --
10577 -------------------------
10579 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
10580 Par
: Node_Id
:= Parent
(N
);
10584 -- If our parent is a procedure call we can return
10586 if Nkind
(Par
) = N_Procedure_Call_Statement
then
10589 -- If our parent is a type conversion, keep climbing the tree,
10590 -- since a type conversion can be a procedure actual. Also keep
10591 -- climbing if parameter association or a qualified expression,
10592 -- since these are additional cases that do can appear on
10593 -- procedure actuals.
10595 elsif Nkind_In
(Par
, N_Type_Conversion
,
10596 N_Parameter_Association
,
10597 N_Qualified_Expression
)
10599 Par
:= Parent
(Par
);
10601 -- Any other case is not what we are looking for
10607 end Is_Procedure_Actual
;
10609 ------------------------------
10610 -- Make_Temporary_For_Slice --
10611 ------------------------------
10613 procedure Make_Temporary_For_Slice
is
10614 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
10619 Make_Object_Declaration
(Loc
,
10620 Defining_Identifier
=> Ent
,
10621 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10623 Set_No_Initialization
(Decl
);
10625 Insert_Actions
(N
, New_List
(
10627 Make_Assignment_Statement
(Loc
,
10628 Name
=> New_Occurrence_Of
(Ent
, Loc
),
10629 Expression
=> Relocate_Node
(N
))));
10631 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
10632 Analyze_And_Resolve
(N
, Typ
);
10633 end Make_Temporary_For_Slice
;
10637 Pref
: constant Node_Id
:= Prefix
(N
);
10638 Pref_Typ
: Entity_Id
:= Etype
(Pref
);
10640 -- Start of processing for Expand_N_Slice
10643 -- Special handling for access types
10645 if Is_Access_Type
(Pref_Typ
) then
10646 Pref_Typ
:= Designated_Type
(Pref_Typ
);
10649 Make_Explicit_Dereference
(Sloc
(N
),
10650 Prefix
=> Relocate_Node
(Pref
)));
10652 Analyze_And_Resolve
(Pref
, Pref_Typ
);
10655 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10656 -- function, then additional actuals must be passed.
10658 if Is_Build_In_Place_Function_Call
(Pref
) then
10659 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
10661 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10662 -- containing build-in-place function calls whose returned object covers
10663 -- interface types.
10665 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
10666 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
10669 -- The remaining case to be handled is packed slices. We can leave
10670 -- packed slices as they are in the following situations:
10672 -- 1. Right or left side of an assignment (we can handle this
10673 -- situation correctly in the assignment statement expansion).
10675 -- 2. Prefix of indexed component (the slide is optimized away in this
10676 -- case, see the start of Expand_N_Slice.)
10678 -- 3. Object renaming declaration, since we want the name of the
10679 -- slice, not the value.
10681 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10682 -- be required, and this is handled in the expansion of call
10685 -- 5. Prefix of an address attribute (this is an error which is caught
10686 -- elsewhere, and the expansion would interfere with generating the
10689 if not Is_Packed
(Typ
) then
10691 -- Apply transformation for actuals of a function call, where
10692 -- Expand_Actuals is not used.
10694 if Nkind
(Parent
(N
)) = N_Function_Call
10695 and then Is_Possibly_Unaligned_Slice
(N
)
10697 Make_Temporary_For_Slice
;
10700 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
10701 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
10702 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
10706 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
10707 or else Is_Renamed_Object
(N
)
10708 or else Is_Procedure_Actual
(N
)
10712 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
10713 and then Attribute_Name
(Parent
(N
)) = Name_Address
10718 Make_Temporary_For_Slice
;
10720 end Expand_N_Slice
;
10722 ------------------------------
10723 -- Expand_N_Type_Conversion --
10724 ------------------------------
10726 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
10727 Loc
: constant Source_Ptr
:= Sloc
(N
);
10728 Operand
: constant Node_Id
:= Expression
(N
);
10729 Target_Type
: constant Entity_Id
:= Etype
(N
);
10730 Operand_Type
: Entity_Id
:= Etype
(Operand
);
10732 procedure Handle_Changed_Representation
;
10733 -- This is called in the case of record and array type conversions to
10734 -- see if there is a change of representation to be handled. Change of
10735 -- representation is actually handled at the assignment statement level,
10736 -- and what this procedure does is rewrite node N conversion as an
10737 -- assignment to temporary. If there is no change of representation,
10738 -- then the conversion node is unchanged.
10740 procedure Raise_Accessibility_Error
;
10741 -- Called when we know that an accessibility check will fail. Rewrites
10742 -- node N to an appropriate raise statement and outputs warning msgs.
10743 -- The Etype of the raise node is set to Target_Type. Note that in this
10744 -- case the rest of the processing should be skipped (i.e. the call to
10745 -- this procedure will be followed by "goto Done").
10747 procedure Real_Range_Check
;
10748 -- Handles generation of range check for real target value
10750 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
10751 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
10752 -- evaluates to True.
10754 -----------------------------------
10755 -- Handle_Changed_Representation --
10756 -----------------------------------
10758 procedure Handle_Changed_Representation
is
10766 -- Nothing else to do if no change of representation
10768 if Same_Representation
(Operand_Type
, Target_Type
) then
10771 -- The real change of representation work is done by the assignment
10772 -- statement processing. So if this type conversion is appearing as
10773 -- the expression of an assignment statement, nothing needs to be
10774 -- done to the conversion.
10776 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
10779 -- Otherwise we need to generate a temporary variable, and do the
10780 -- change of representation assignment into that temporary variable.
10781 -- The conversion is then replaced by a reference to this variable.
10786 -- If type is unconstrained we have to add a constraint, copied
10787 -- from the actual value of the left-hand side.
10789 if not Is_Constrained
(Target_Type
) then
10790 if Has_Discriminants
(Operand_Type
) then
10792 -- A change of representation can only apply to untagged
10793 -- types. We need to build the constraint that applies to
10794 -- the target type, using the constraints of the operand.
10795 -- The analysis is complicated if there are both inherited
10796 -- discriminants and constrained discriminants.
10797 -- We iterate over the discriminants of the target, and
10798 -- find the discriminant of the same name:
10800 -- a) If there is a corresponding discriminant in the object
10801 -- then the value is a selected component of the operand.
10803 -- b) Otherwise the value of a constrained discriminant is
10804 -- found in the stored constraint of the operand.
10807 Stored
: constant Elist_Id
:=
10808 Stored_Constraint
(Operand_Type
);
10812 Disc_O
: Entity_Id
;
10813 -- Discriminant of the operand type. Its value in the
10814 -- object is captured in a selected component.
10816 Disc_S
: Entity_Id
;
10817 -- Stored discriminant of the operand. If present, it
10818 -- corresponds to a constrained discriminant of the
10821 Disc_T
: Entity_Id
;
10822 -- Discriminant of the target type
10825 Disc_T
:= First_Discriminant
(Target_Type
);
10826 Disc_O
:= First_Discriminant
(Operand_Type
);
10827 Disc_S
:= First_Stored_Discriminant
(Operand_Type
);
10829 if Present
(Stored
) then
10830 Elmt
:= First_Elmt
(Stored
);
10832 Elmt
:= No_Elmt
; -- init to avoid warning
10836 while Present
(Disc_T
) loop
10837 if Present
(Disc_O
)
10838 and then Chars
(Disc_T
) = Chars
(Disc_O
)
10841 Make_Selected_Component
(Loc
,
10843 Duplicate_Subexpr_Move_Checks
(Operand
),
10845 Make_Identifier
(Loc
, Chars
(Disc_O
))));
10846 Next_Discriminant
(Disc_O
);
10848 elsif Present
(Disc_S
) then
10849 Append_To
(Cons
, New_Copy_Tree
(Node
(Elmt
)));
10853 Next_Discriminant
(Disc_T
);
10857 elsif Is_Array_Type
(Operand_Type
) then
10858 N_Ix
:= First_Index
(Target_Type
);
10861 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
10863 -- We convert the bounds explicitly. We use an unchecked
10864 -- conversion because bounds checks are done elsewhere.
10869 Unchecked_Convert_To
(Etype
(N_Ix
),
10870 Make_Attribute_Reference
(Loc
,
10872 Duplicate_Subexpr_No_Checks
10873 (Operand
, Name_Req
=> True),
10874 Attribute_Name
=> Name_First
,
10875 Expressions
=> New_List
(
10876 Make_Integer_Literal
(Loc
, J
)))),
10879 Unchecked_Convert_To
(Etype
(N_Ix
),
10880 Make_Attribute_Reference
(Loc
,
10882 Duplicate_Subexpr_No_Checks
10883 (Operand
, Name_Req
=> True),
10884 Attribute_Name
=> Name_Last
,
10885 Expressions
=> New_List
(
10886 Make_Integer_Literal
(Loc
, J
))))));
10893 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
10895 if Present
(Cons
) then
10897 Make_Subtype_Indication
(Loc
,
10898 Subtype_Mark
=> Odef
,
10900 Make_Index_Or_Discriminant_Constraint
(Loc
,
10901 Constraints
=> Cons
));
10904 Temp
:= Make_Temporary
(Loc
, 'C');
10906 Make_Object_Declaration
(Loc
,
10907 Defining_Identifier
=> Temp
,
10908 Object_Definition
=> Odef
);
10910 Set_No_Initialization
(Decl
, True);
10912 -- Insert required actions. It is essential to suppress checks
10913 -- since we have suppressed default initialization, which means
10914 -- that the variable we create may have no discriminants.
10919 Make_Assignment_Statement
(Loc
,
10920 Name
=> New_Occurrence_Of
(Temp
, Loc
),
10921 Expression
=> Relocate_Node
(N
))),
10922 Suppress
=> All_Checks
);
10924 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
10927 end Handle_Changed_Representation
;
10929 -------------------------------
10930 -- Raise_Accessibility_Error --
10931 -------------------------------
10933 procedure Raise_Accessibility_Error
is
10935 Error_Msg_Warn
:= SPARK_Mode
/= On
;
10937 Make_Raise_Program_Error
(Sloc
(N
),
10938 Reason
=> PE_Accessibility_Check_Failed
));
10939 Set_Etype
(N
, Target_Type
);
10941 Error_Msg_N
("<<accessibility check failure", N
);
10942 Error_Msg_NE
("\<<& [", N
, Standard_Program_Error
);
10943 end Raise_Accessibility_Error
;
10945 ----------------------
10946 -- Real_Range_Check --
10947 ----------------------
10949 -- Case of conversions to floating-point or fixed-point. If range checks
10950 -- are enabled and the target type has a range constraint, we convert:
10956 -- Tnn : typ'Base := typ'Base (x);
10957 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10960 -- This is necessary when there is a conversion of integer to float or
10961 -- to fixed-point to ensure that the correct checks are made. It is not
10962 -- necessary for float to float where it is enough to simply set the
10963 -- Do_Range_Check flag.
10965 procedure Real_Range_Check
is
10966 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
10967 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
10968 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
10969 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
10979 -- Nothing to do if conversion was rewritten
10981 if Nkind
(N
) /= N_Type_Conversion
then
10985 -- Nothing to do if range checks suppressed, or target has the same
10986 -- range as the base type (or is the base type).
10988 if Range_Checks_Suppressed
(Target_Type
)
10989 or else (Lo
= Type_Low_Bound
(Btyp
)
10991 Hi
= Type_High_Bound
(Btyp
))
10996 -- Nothing to do if expression is an entity on which checks have been
10999 if Is_Entity_Name
(Operand
)
11000 and then Range_Checks_Suppressed
(Entity
(Operand
))
11005 -- Nothing to do if bounds are all static and we can tell that the
11006 -- expression is within the bounds of the target. Note that if the
11007 -- operand is of an unconstrained floating-point type, then we do
11008 -- not trust it to be in range (might be infinite)
11011 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
11012 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
11015 if (not Is_Floating_Point_Type
(Xtyp
)
11016 or else Is_Constrained
(Xtyp
))
11017 and then Compile_Time_Known_Value
(S_Lo
)
11018 and then Compile_Time_Known_Value
(S_Hi
)
11019 and then Compile_Time_Known_Value
(Hi
)
11020 and then Compile_Time_Known_Value
(Lo
)
11023 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
11024 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
11029 if Is_Real_Type
(Xtyp
) then
11030 S_Lov
:= Expr_Value_R
(S_Lo
);
11031 S_Hiv
:= Expr_Value_R
(S_Hi
);
11033 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
11034 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
11038 and then S_Lov
>= D_Lov
11039 and then S_Hiv
<= D_Hiv
11041 -- Unset the range check flag on the current value of
11042 -- Expression (N), since the captured Operand may have
11043 -- been rewritten (such as for the case of a conversion
11044 -- to a fixed-point type).
11046 Set_Do_Range_Check
(Expression
(N
), False);
11054 -- For float to float conversions, we are done
11056 if Is_Floating_Point_Type
(Xtyp
)
11058 Is_Floating_Point_Type
(Btyp
)
11063 -- Otherwise rewrite the conversion as described above
11065 Conv
:= Relocate_Node
(N
);
11066 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
11067 Set_Etype
(Conv
, Btyp
);
11069 -- Enable overflow except for case of integer to float conversions,
11070 -- where it is never required, since we can never have overflow in
11073 if not Is_Integer_Type
(Etype
(Operand
)) then
11074 Enable_Overflow_Check
(Conv
);
11077 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
11079 -- For a conversion from Float to Fixed where the bounds of the
11080 -- fixed-point type are static, we can obtain a more accurate
11081 -- fixed-point value by converting the result of the floating-
11082 -- point expression to an appropriate integer type, and then
11083 -- performing an unchecked conversion to the target fixed-point
11084 -- type. The range check can then use the corresponding integer
11085 -- value of the bounds instead of requiring further conversions.
11086 -- This preserves the identity:
11088 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11090 -- which used to fail when Fix_Val was a bound of the type and
11091 -- the 'Small was not a representable number.
11092 -- This transformation requires an integer type large enough to
11093 -- accommodate a fixed-point value. This will not be the case
11094 -- in systems where Duration is larger than Long_Integer.
11096 if Is_Ordinary_Fixed_Point_Type
(Target_Type
)
11097 and then Is_Floating_Point_Type
(Operand_Type
)
11098 and then RM_Size
(Base_Type
(Target_Type
)) <=
11099 RM_Size
(Standard_Long_Integer
)
11100 and then Nkind
(Lo
) = N_Real_Literal
11101 and then Nkind
(Hi
) = N_Real_Literal
11103 -- Find the integer type of the right size to perform an unchecked
11104 -- conversion to the target fixed-point type.
11107 Bfx_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
11108 Expr_Id
: constant Entity_Id
:=
11109 Make_Temporary
(Loc
, 'T', Conv
);
11110 Int_Type
: Entity_Id
;
11113 if RM_Size
(Bfx_Type
) > RM_Size
(Standard_Integer
) then
11114 Int_Type
:= Standard_Long_Integer
;
11116 elsif RM_Size
(Bfx_Type
) > RM_Size
(Standard_Short_Integer
) then
11117 Int_Type
:= Standard_Integer
;
11120 Int_Type
:= Standard_Short_Integer
;
11123 -- Generate a temporary with the integer value. Required in the
11124 -- CCG compiler to ensure that runtime checks reference this
11125 -- integer expression (instead of the resulting fixed-point
11126 -- value) because fixed-point values are handled by means of
11127 -- unsigned integer types).
11130 Make_Object_Declaration
(Loc
,
11131 Defining_Identifier
=> Expr_Id
,
11132 Object_Definition
=> New_Occurrence_Of
(Int_Type
, Loc
),
11133 Constant_Present
=> True,
11135 Convert_To
(Int_Type
, Expression
(Conv
))));
11137 -- Create integer objects for range checking of result.
11140 Unchecked_Convert_To
11141 (Int_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11144 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Lo
));
11147 Unchecked_Convert_To
11148 (Int_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11151 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Hi
));
11153 -- Rewrite conversion as an integer conversion of the
11154 -- original floating-point expression, followed by an
11155 -- unchecked conversion to the target fixed-point type.
11158 Make_Unchecked_Type_Conversion
(Loc
,
11159 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
11160 Expression
=> New_Occurrence_Of
(Expr_Id
, Loc
));
11163 -- All other conversions
11166 Lo_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11168 Make_Attribute_Reference
(Loc
,
11169 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11170 Attribute_Name
=> Name_First
);
11172 Hi_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11174 Make_Attribute_Reference
(Loc
,
11175 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11176 Attribute_Name
=> Name_Last
);
11179 -- Build code for range checking
11181 Insert_Actions
(N
, New_List
(
11182 Make_Object_Declaration
(Loc
,
11183 Defining_Identifier
=> Tnn
,
11184 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
11185 Constant_Present
=> True,
11186 Expression
=> Conv
),
11188 Make_Raise_Constraint_Error
(Loc
,
11193 Left_Opnd
=> Lo_Arg
,
11194 Right_Opnd
=> Lo_Val
),
11198 Left_Opnd
=> Hi_Arg
,
11199 Right_Opnd
=> Hi_Val
)),
11200 Reason
=> CE_Range_Check_Failed
)));
11202 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
11203 Analyze_And_Resolve
(N
, Btyp
);
11204 end Real_Range_Check
;
11206 -----------------------------
11207 -- Has_Extra_Accessibility --
11208 -----------------------------
11210 -- Returns true for a formal of an anonymous access type or for an Ada
11211 -- 2012-style stand-alone object of an anonymous access type.
11213 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
11215 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
11216 return Present
(Effective_Extra_Accessibility
(Id
));
11220 end Has_Extra_Accessibility
;
11222 -- Start of processing for Expand_N_Type_Conversion
11225 -- First remove check marks put by the semantic analysis on the type
11226 -- conversion between array types. We need these checks, and they will
11227 -- be generated by this expansion routine, but we do not depend on these
11228 -- flags being set, and since we do intend to expand the checks in the
11229 -- front end, we don't want them on the tree passed to the back end.
11231 if Is_Array_Type
(Target_Type
) then
11232 if Is_Constrained
(Target_Type
) then
11233 Set_Do_Length_Check
(N
, False);
11235 Set_Do_Range_Check
(Operand
, False);
11239 -- Nothing at all to do if conversion is to the identical type so remove
11240 -- the conversion completely, it is useless, except that it may carry
11241 -- an Assignment_OK attribute, which must be propagated to the operand.
11243 if Operand_Type
= Target_Type
then
11244 if Assignment_OK
(N
) then
11245 Set_Assignment_OK
(Operand
);
11248 Rewrite
(N
, Relocate_Node
(Operand
));
11252 -- Nothing to do if this is the second argument of read. This is a
11253 -- "backwards" conversion that will be handled by the specialized code
11254 -- in attribute processing.
11256 if Nkind
(Parent
(N
)) = N_Attribute_Reference
11257 and then Attribute_Name
(Parent
(N
)) = Name_Read
11258 and then Next
(First
(Expressions
(Parent
(N
)))) = N
11263 -- Check for case of converting to a type that has an invariant
11264 -- associated with it. This requires an invariant check. We insert
11267 -- invariant_check (typ (expr))
11269 -- in the code, after removing side effects from the expression.
11270 -- This is clearer than replacing the conversion into an expression
11271 -- with actions, because the context may impose additional actions
11272 -- (tag checks, membership tests, etc.) that conflict with this
11273 -- rewriting (used previously).
11275 -- Note: the Comes_From_Source check, and then the resetting of this
11276 -- flag prevents what would otherwise be an infinite recursion.
11278 if Has_Invariants
(Target_Type
)
11279 and then Present
(Invariant_Procedure
(Target_Type
))
11280 and then Comes_From_Source
(N
)
11282 Set_Comes_From_Source
(N
, False);
11283 Remove_Side_Effects
(N
);
11284 Insert_Action
(N
, Make_Invariant_Call
(Duplicate_Subexpr
(N
)));
11288 -- Here if we may need to expand conversion
11290 -- If the operand of the type conversion is an arithmetic operation on
11291 -- signed integers, and the based type of the signed integer type in
11292 -- question is smaller than Standard.Integer, we promote both of the
11293 -- operands to type Integer.
11295 -- For example, if we have
11297 -- target-type (opnd1 + opnd2)
11299 -- and opnd1 and opnd2 are of type short integer, then we rewrite
11302 -- target-type (integer(opnd1) + integer(opnd2))
11304 -- We do this because we are always allowed to compute in a larger type
11305 -- if we do the right thing with the result, and in this case we are
11306 -- going to do a conversion which will do an appropriate check to make
11307 -- sure that things are in range of the target type in any case. This
11308 -- avoids some unnecessary intermediate overflows.
11310 -- We might consider a similar transformation in the case where the
11311 -- target is a real type or a 64-bit integer type, and the operand
11312 -- is an arithmetic operation using a 32-bit integer type. However,
11313 -- we do not bother with this case, because it could cause significant
11314 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
11315 -- much cheaper, but we don't want different behavior on 32-bit and
11316 -- 64-bit machines. Note that the exclusion of the 64-bit case also
11317 -- handles the configurable run-time cases where 64-bit arithmetic
11318 -- may simply be unavailable.
11320 -- Note: this circuit is partially redundant with respect to the circuit
11321 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
11322 -- the processing here. Also we still need the Checks circuit, since we
11323 -- have to be sure not to generate junk overflow checks in the first
11324 -- place, since it would be trick to remove them here.
11326 if Integer_Promotion_Possible
(N
) then
11328 -- All conditions met, go ahead with transformation
11336 Make_Type_Conversion
(Loc
,
11337 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11338 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
11340 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
11341 Set_Right_Opnd
(Opnd
, R
);
11343 if Nkind
(Operand
) in N_Binary_Op
then
11345 Make_Type_Conversion
(Loc
,
11346 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11347 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
11349 Set_Left_Opnd
(Opnd
, L
);
11353 Make_Type_Conversion
(Loc
,
11354 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
11355 Expression
=> Opnd
));
11357 Analyze_And_Resolve
(N
, Target_Type
);
11362 -- Do validity check if validity checking operands
11364 if Validity_Checks_On
and Validity_Check_Operands
then
11365 Ensure_Valid
(Operand
);
11368 -- Special case of converting from non-standard boolean type
11370 if Is_Boolean_Type
(Operand_Type
)
11371 and then (Nonzero_Is_True
(Operand_Type
))
11373 Adjust_Condition
(Operand
);
11374 Set_Etype
(Operand
, Standard_Boolean
);
11375 Operand_Type
:= Standard_Boolean
;
11378 -- Case of converting to an access type
11380 if Is_Access_Type
(Target_Type
) then
11382 -- If this type conversion was internally generated by the front end
11383 -- to displace the pointer to the object to reference an interface
11384 -- type and the original node was an Unrestricted_Access attribute,
11385 -- then skip applying accessibility checks (because, according to the
11386 -- GNAT Reference Manual, this attribute is similar to 'Access except
11387 -- that all accessibility and aliased view checks are omitted).
11389 if not Comes_From_Source
(N
)
11390 and then Is_Interface
(Designated_Type
(Target_Type
))
11391 and then Nkind
(Original_Node
(N
)) = N_Attribute_Reference
11392 and then Attribute_Name
(Original_Node
(N
)) =
11393 Name_Unrestricted_Access
11397 -- Apply an accessibility check when the conversion operand is an
11398 -- access parameter (or a renaming thereof), unless conversion was
11399 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
11400 -- or for the actual of a class-wide interface parameter. Note that
11401 -- other checks may still need to be applied below (such as tagged
11404 elsif Is_Entity_Name
(Operand
)
11405 and then Has_Extra_Accessibility
(Entity
(Operand
))
11406 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
11407 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
11408 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
11410 if not Comes_From_Source
(N
)
11411 and then Nkind_In
(Parent
(N
), N_Function_Call
,
11412 N_Procedure_Call_Statement
)
11413 and then Is_Interface
(Designated_Type
(Target_Type
))
11414 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
11419 Apply_Accessibility_Check
11420 (Operand
, Target_Type
, Insert_Node
=> Operand
);
11423 -- If the level of the operand type is statically deeper than the
11424 -- level of the target type, then force Program_Error. Note that this
11425 -- can only occur for cases where the attribute is within the body of
11426 -- an instantiation, otherwise the conversion will already have been
11427 -- rejected as illegal.
11429 -- Note: warnings are issued by the analyzer for the instance cases
11431 elsif In_Instance_Body
11433 -- The case where the target type is an anonymous access type of
11434 -- a discriminant is excluded, because the level of such a type
11435 -- depends on the context and currently the level returned for such
11436 -- types is zero, resulting in warnings about about check failures
11437 -- in certain legal cases involving class-wide interfaces as the
11438 -- designated type (some cases, such as return statements, are
11439 -- checked at run time, but not clear if these are handled right
11440 -- in general, see 3.10.2(12/2-12.5/3) ???).
11443 not (Ekind
(Target_Type
) = E_Anonymous_Access_Type
11444 and then Present
(Associated_Node_For_Itype
(Target_Type
))
11445 and then Nkind
(Associated_Node_For_Itype
(Target_Type
)) =
11446 N_Discriminant_Specification
)
11448 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
11450 Raise_Accessibility_Error
;
11453 -- When the operand is a selected access discriminant the check needs
11454 -- to be made against the level of the object denoted by the prefix
11455 -- of the selected name. Force Program_Error for this case as well
11456 -- (this accessibility violation can only happen if within the body
11457 -- of an instantiation).
11459 elsif In_Instance_Body
11460 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
11461 and then Nkind
(Operand
) = N_Selected_Component
11462 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
11463 and then Object_Access_Level
(Operand
) >
11464 Type_Access_Level
(Target_Type
)
11466 Raise_Accessibility_Error
;
11471 -- Case of conversions of tagged types and access to tagged types
11473 -- When needed, that is to say when the expression is class-wide, Add
11474 -- runtime a tag check for (strict) downward conversion by using the
11475 -- membership test, generating:
11477 -- [constraint_error when Operand not in Target_Type'Class]
11479 -- or in the access type case
11481 -- [constraint_error
11482 -- when Operand /= null
11483 -- and then Operand.all not in
11484 -- Designated_Type (Target_Type)'Class]
11486 if (Is_Access_Type
(Target_Type
)
11487 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
11488 or else Is_Tagged_Type
(Target_Type
)
11490 -- Do not do any expansion in the access type case if the parent is a
11491 -- renaming, since this is an error situation which will be caught by
11492 -- Sem_Ch8, and the expansion can interfere with this error check.
11494 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
11498 -- Otherwise, proceed with processing tagged conversion
11500 Tagged_Conversion
: declare
11501 Actual_Op_Typ
: Entity_Id
;
11502 Actual_Targ_Typ
: Entity_Id
;
11503 Make_Conversion
: Boolean := False;
11504 Root_Op_Typ
: Entity_Id
;
11506 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
11507 -- Create a membership check to test whether Operand is a member
11508 -- of Targ_Typ. If the original Target_Type is an access, include
11509 -- a test for null value. The check is inserted at N.
11511 --------------------
11512 -- Make_Tag_Check --
11513 --------------------
11515 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
11520 -- [Constraint_Error
11521 -- when Operand /= null
11522 -- and then Operand.all not in Targ_Typ]
11524 if Is_Access_Type
(Target_Type
) then
11526 Make_And_Then
(Loc
,
11529 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
11530 Right_Opnd
=> Make_Null
(Loc
)),
11535 Make_Explicit_Dereference
(Loc
,
11536 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
11537 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
11540 -- [Constraint_Error when Operand not in Targ_Typ]
11545 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
11546 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
11550 Make_Raise_Constraint_Error
(Loc
,
11552 Reason
=> CE_Tag_Check_Failed
),
11553 Suppress
=> All_Checks
);
11554 end Make_Tag_Check
;
11556 -- Start of processing for Tagged_Conversion
11559 -- Handle entities from the limited view
11561 if Is_Access_Type
(Operand_Type
) then
11563 Available_View
(Designated_Type
(Operand_Type
));
11565 Actual_Op_Typ
:= Operand_Type
;
11568 if Is_Access_Type
(Target_Type
) then
11570 Available_View
(Designated_Type
(Target_Type
));
11572 Actual_Targ_Typ
:= Target_Type
;
11575 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
11577 -- Ada 2005 (AI-251): Handle interface type conversion
11579 if Is_Interface
(Actual_Op_Typ
)
11581 Is_Interface
(Actual_Targ_Typ
)
11583 Expand_Interface_Conversion
(N
);
11587 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
11589 -- Create a runtime tag check for a downward class-wide type
11592 if Is_Class_Wide_Type
(Actual_Op_Typ
)
11593 and then Actual_Op_Typ
/= Actual_Targ_Typ
11594 and then Root_Op_Typ
/= Actual_Targ_Typ
11595 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
11596 Use_Full_View
=> True)
11598 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
11599 Make_Conversion
:= True;
11602 -- AI05-0073: If the result subtype of the function is defined
11603 -- by an access_definition designating a specific tagged type
11604 -- T, a check is made that the result value is null or the tag
11605 -- of the object designated by the result value identifies T.
11606 -- Constraint_Error is raised if this check fails.
11608 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
11611 Func_Typ
: Entity_Id
;
11614 -- Climb scope stack looking for the enclosing function
11616 Func
:= Current_Scope
;
11617 while Present
(Func
)
11618 and then Ekind
(Func
) /= E_Function
11620 Func
:= Scope
(Func
);
11623 -- The function's return subtype must be defined using
11624 -- an access definition.
11626 if Nkind
(Result_Definition
(Parent
(Func
))) =
11627 N_Access_Definition
11629 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
11631 -- The return subtype denotes a specific tagged type,
11632 -- in other words, a non class-wide type.
11634 if Is_Tagged_Type
(Func_Typ
)
11635 and then not Is_Class_Wide_Type
(Func_Typ
)
11637 Make_Tag_Check
(Actual_Targ_Typ
);
11638 Make_Conversion
:= True;
11644 -- We have generated a tag check for either a class-wide type
11645 -- conversion or for AI05-0073.
11647 if Make_Conversion
then
11652 Make_Unchecked_Type_Conversion
(Loc
,
11653 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
11654 Expression
=> Relocate_Node
(Expression
(N
)));
11656 Analyze_And_Resolve
(N
, Target_Type
);
11660 end Tagged_Conversion
;
11662 -- Case of other access type conversions
11664 elsif Is_Access_Type
(Target_Type
) then
11665 Apply_Constraint_Check
(Operand
, Target_Type
);
11667 -- Case of conversions from a fixed-point type
11669 -- These conversions require special expansion and processing, found in
11670 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
11671 -- since from a semantic point of view, these are simple integer
11672 -- conversions, which do not need further processing.
11674 elsif Is_Fixed_Point_Type
(Operand_Type
)
11675 and then not Conversion_OK
(N
)
11677 -- We should never see universal fixed at this case, since the
11678 -- expansion of the constituent divide or multiply should have
11679 -- eliminated the explicit mention of universal fixed.
11681 pragma Assert
(Operand_Type
/= Universal_Fixed
);
11683 -- Check for special case of the conversion to universal real that
11684 -- occurs as a result of the use of a round attribute. In this case,
11685 -- the real type for the conversion is taken from the target type of
11686 -- the Round attribute and the result must be marked as rounded.
11688 if Target_Type
= Universal_Real
11689 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
11690 and then Attribute_Name
(Parent
(N
)) = Name_Round
11692 Set_Rounded_Result
(N
);
11693 Set_Etype
(N
, Etype
(Parent
(N
)));
11696 -- Otherwise do correct fixed-conversion, but skip these if the
11697 -- Conversion_OK flag is set, because from a semantic point of view
11698 -- these are simple integer conversions needing no further processing
11699 -- (the backend will simply treat them as integers).
11701 if not Conversion_OK
(N
) then
11702 if Is_Fixed_Point_Type
(Etype
(N
)) then
11703 Expand_Convert_Fixed_To_Fixed
(N
);
11706 elsif Is_Integer_Type
(Etype
(N
)) then
11707 Expand_Convert_Fixed_To_Integer
(N
);
11709 -- The result of the conversion might need a range check,
11710 -- so do not assume that the result is in bounds.
11712 Set_Etype
(N
, Base_Type
(Target_Type
));
11715 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
11716 Expand_Convert_Fixed_To_Float
(N
);
11721 -- Case of conversions to a fixed-point type
11723 -- These conversions require special expansion and processing, found in
11724 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
11725 -- since from a semantic point of view, these are simple integer
11726 -- conversions, which do not need further processing.
11728 elsif Is_Fixed_Point_Type
(Target_Type
)
11729 and then not Conversion_OK
(N
)
11731 if Is_Integer_Type
(Operand_Type
) then
11732 Expand_Convert_Integer_To_Fixed
(N
);
11735 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
11736 Expand_Convert_Float_To_Fixed
(N
);
11740 -- Case of float-to-integer conversions
11742 -- We also handle float-to-fixed conversions with Conversion_OK set
11743 -- since semantically the fixed-point target is treated as though it
11744 -- were an integer in such cases.
11746 elsif Is_Floating_Point_Type
(Operand_Type
)
11748 (Is_Integer_Type
(Target_Type
)
11750 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
11752 -- One more check here, gcc is still not able to do conversions of
11753 -- this type with proper overflow checking, and so gigi is doing an
11754 -- approximation of what is required by doing floating-point compares
11755 -- with the end-point. But that can lose precision in some cases, and
11756 -- give a wrong result. Converting the operand to Universal_Real is
11757 -- helpful, but still does not catch all cases with 64-bit integers
11758 -- on targets with only 64-bit floats.
11760 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
11761 -- Can this code be removed ???
11763 if Do_Range_Check
(Operand
) then
11765 Make_Type_Conversion
(Loc
,
11767 New_Occurrence_Of
(Universal_Real
, Loc
),
11769 Relocate_Node
(Operand
)));
11771 Set_Etype
(Operand
, Universal_Real
);
11772 Enable_Range_Check
(Operand
);
11773 Set_Do_Range_Check
(Expression
(Operand
), False);
11776 -- Case of array conversions
11778 -- Expansion of array conversions, add required length/range checks but
11779 -- only do this if there is no change of representation. For handling of
11780 -- this case, see Handle_Changed_Representation.
11782 elsif Is_Array_Type
(Target_Type
) then
11783 if Is_Constrained
(Target_Type
) then
11784 Apply_Length_Check
(Operand
, Target_Type
);
11786 Apply_Range_Check
(Operand
, Target_Type
);
11789 Handle_Changed_Representation
;
11791 -- Case of conversions of discriminated types
11793 -- Add required discriminant checks if target is constrained. Again this
11794 -- change is skipped if we have a change of representation.
11796 elsif Has_Discriminants
(Target_Type
)
11797 and then Is_Constrained
(Target_Type
)
11799 Apply_Discriminant_Check
(Operand
, Target_Type
);
11800 Handle_Changed_Representation
;
11802 -- Case of all other record conversions. The only processing required
11803 -- is to check for a change of representation requiring the special
11804 -- assignment processing.
11806 elsif Is_Record_Type
(Target_Type
) then
11808 -- Ada 2005 (AI-216): Program_Error is raised when converting from
11809 -- a derived Unchecked_Union type to an unconstrained type that is
11810 -- not Unchecked_Union if the operand lacks inferable discriminants.
11812 if Is_Derived_Type
(Operand_Type
)
11813 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
11814 and then not Is_Constrained
(Target_Type
)
11815 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
11816 and then not Has_Inferable_Discriminants
(Operand
)
11818 -- To prevent Gigi from generating illegal code, we generate a
11819 -- Program_Error node, but we give it the target type of the
11820 -- conversion (is this requirement documented somewhere ???)
11823 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
11824 Reason
=> PE_Unchecked_Union_Restriction
);
11827 Set_Etype
(PE
, Target_Type
);
11832 Handle_Changed_Representation
;
11835 -- Case of conversions of enumeration types
11837 elsif Is_Enumeration_Type
(Target_Type
) then
11839 -- Special processing is required if there is a change of
11840 -- representation (from enumeration representation clauses).
11842 if not Same_Representation
(Target_Type
, Operand_Type
) then
11844 -- Convert: x(y) to x'val (ytyp'val (y))
11847 Make_Attribute_Reference
(Loc
,
11848 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11849 Attribute_Name
=> Name_Val
,
11850 Expressions
=> New_List
(
11851 Make_Attribute_Reference
(Loc
,
11852 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
11853 Attribute_Name
=> Name_Pos
,
11854 Expressions
=> New_List
(Operand
)))));
11856 Analyze_And_Resolve
(N
, Target_Type
);
11859 -- Case of conversions to floating-point
11861 elsif Is_Floating_Point_Type
(Target_Type
) then
11865 -- At this stage, either the conversion node has been transformed into
11866 -- some other equivalent expression, or left as a conversion that can be
11867 -- handled by Gigi, in the following cases:
11869 -- Conversions with no change of representation or type
11871 -- Numeric conversions involving integer, floating- and fixed-point
11872 -- values. Fixed-point values are allowed only if Conversion_OK is
11873 -- set, i.e. if the fixed-point values are to be treated as integers.
11875 -- No other conversions should be passed to Gigi
11877 -- Check: are these rules stated in sinfo??? if so, why restate here???
11879 -- The only remaining step is to generate a range check if we still have
11880 -- a type conversion at this stage and Do_Range_Check is set. For now we
11881 -- do this only for conversions of discrete types and for float-to-float
11884 if Nkind
(N
) = N_Type_Conversion
then
11886 -- For now we only support floating-point cases where both source
11887 -- and target are floating-point types. Conversions where the source
11888 -- and target involve integer or fixed-point types are still TBD,
11889 -- though not clear whether those can even happen at this point, due
11890 -- to transformations above. ???
11892 if Is_Floating_Point_Type
(Etype
(N
))
11893 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
11895 if Do_Range_Check
(Expression
(N
))
11896 and then Is_Floating_Point_Type
(Target_Type
)
11898 Generate_Range_Check
11899 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
11902 -- Discrete-to-discrete conversions
11904 elsif Is_Discrete_Type
(Etype
(N
)) then
11906 Expr
: constant Node_Id
:= Expression
(N
);
11911 if Do_Range_Check
(Expr
)
11912 and then Is_Discrete_Type
(Etype
(Expr
))
11914 Set_Do_Range_Check
(Expr
, False);
11916 -- Before we do a range check, we have to deal with treating
11917 -- a fixed-point operand as an integer. The way we do this
11918 -- is simply to do an unchecked conversion to an appropriate
11919 -- integer type large enough to hold the result.
11921 -- This code is not active yet, because we are only dealing
11922 -- with discrete types so far ???
11924 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
11925 and then Treat_Fixed_As_Integer
(Expr
)
11927 Ftyp
:= Base_Type
(Etype
(Expr
));
11929 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
11930 Ityp
:= Standard_Long_Long_Integer
;
11932 Ityp
:= Standard_Integer
;
11935 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11938 -- Reset overflow flag, since the range check will include
11939 -- dealing with possible overflow, and generate the check.
11940 -- If Address is either a source type or target type,
11941 -- suppress range check to avoid typing anomalies when
11942 -- it is a visible integer type.
11944 Set_Do_Overflow_Check
(N
, False);
11946 if not Is_Descendant_Of_Address
(Etype
(Expr
))
11947 and then not Is_Descendant_Of_Address
(Target_Type
)
11949 Generate_Range_Check
11950 (Expr
, Target_Type
, CE_Range_Check_Failed
);
11957 -- Here at end of processing
11960 -- Apply predicate check if required. Note that we can't just call
11961 -- Apply_Predicate_Check here, because the type looks right after
11962 -- the conversion and it would omit the check. The Comes_From_Source
11963 -- guard is necessary to prevent infinite recursions when we generate
11964 -- internal conversions for the purpose of checking predicates.
11966 if Present
(Predicate_Function
(Target_Type
))
11967 and then not Predicates_Ignored
(Target_Type
)
11968 and then Target_Type
/= Operand_Type
11969 and then Comes_From_Source
(N
)
11972 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
11975 -- Avoid infinite recursion on the subsequent expansion of
11976 -- of the copy of the original type conversion.
11978 Set_Comes_From_Source
(New_Expr
, False);
11979 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
11982 end Expand_N_Type_Conversion
;
11984 -----------------------------------
11985 -- Expand_N_Unchecked_Expression --
11986 -----------------------------------
11988 -- Remove the unchecked expression node from the tree. Its job was simply
11989 -- to make sure that its constituent expression was handled with checks
11990 -- off, and now that that is done, we can remove it from the tree, and
11991 -- indeed must, since Gigi does not expect to see these nodes.
11993 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
11994 Exp
: constant Node_Id
:= Expression
(N
);
11996 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
11998 end Expand_N_Unchecked_Expression
;
12000 ----------------------------------------
12001 -- Expand_N_Unchecked_Type_Conversion --
12002 ----------------------------------------
12004 -- If this cannot be handled by Gigi and we haven't already made a
12005 -- temporary for it, do it now.
12007 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
12008 Target_Type
: constant Entity_Id
:= Etype
(N
);
12009 Operand
: constant Node_Id
:= Expression
(N
);
12010 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12013 -- Nothing at all to do if conversion is to the identical type so remove
12014 -- the conversion completely, it is useless, except that it may carry
12015 -- an Assignment_OK indication which must be propagated to the operand.
12017 if Operand_Type
= Target_Type
then
12019 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
12021 if Assignment_OK
(N
) then
12022 Set_Assignment_OK
(Operand
);
12025 Rewrite
(N
, Relocate_Node
(Operand
));
12029 -- If we have a conversion of a compile time known value to a target
12030 -- type and the value is in range of the target type, then we can simply
12031 -- replace the construct by an integer literal of the correct type. We
12032 -- only apply this to integer types being converted. Possibly it may
12033 -- apply in other cases, but it is too much trouble to worry about.
12035 -- Note that we do not do this transformation if the Kill_Range_Check
12036 -- flag is set, since then the value may be outside the expected range.
12037 -- This happens in the Normalize_Scalars case.
12039 -- We also skip this if either the target or operand type is biased
12040 -- because in this case, the unchecked conversion is supposed to
12041 -- preserve the bit pattern, not the integer value.
12043 if Is_Integer_Type
(Target_Type
)
12044 and then not Has_Biased_Representation
(Target_Type
)
12045 and then Is_Integer_Type
(Operand_Type
)
12046 and then not Has_Biased_Representation
(Operand_Type
)
12047 and then Compile_Time_Known_Value
(Operand
)
12048 and then not Kill_Range_Check
(N
)
12051 Val
: constant Uint
:= Expr_Value
(Operand
);
12054 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
12056 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
12058 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
12060 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
12062 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
12064 -- If Address is the target type, just set the type to avoid a
12065 -- spurious type error on the literal when Address is a visible
12068 if Is_Descendant_Of_Address
(Target_Type
) then
12069 Set_Etype
(N
, Target_Type
);
12071 Analyze_And_Resolve
(N
, Target_Type
);
12079 -- Nothing to do if conversion is safe
12081 if Safe_Unchecked_Type_Conversion
(N
) then
12085 -- Otherwise force evaluation unless Assignment_OK flag is set (this
12086 -- flag indicates ??? More comments needed here)
12088 if Assignment_OK
(N
) then
12091 Force_Evaluation
(N
);
12093 end Expand_N_Unchecked_Type_Conversion
;
12095 ----------------------------
12096 -- Expand_Record_Equality --
12097 ----------------------------
12099 -- For non-variant records, Equality is expanded when needed into:
12101 -- and then Lhs.Discr1 = Rhs.Discr1
12103 -- and then Lhs.Discrn = Rhs.Discrn
12104 -- and then Lhs.Cmp1 = Rhs.Cmp1
12106 -- and then Lhs.Cmpn = Rhs.Cmpn
12108 -- The expression is folded by the back end for adjacent fields. This
12109 -- function is called for tagged record in only one occasion: for imple-
12110 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12111 -- otherwise the primitive "=" is used directly.
12113 function Expand_Record_Equality
12118 Bodies
: List_Id
) return Node_Id
12120 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12125 First_Time
: Boolean := True;
12127 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
12128 -- Return the next discriminant or component to compare, starting with
12129 -- C, skipping inherited components.
12131 ------------------------
12132 -- Element_To_Compare --
12133 ------------------------
12135 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
12141 -- Exit loop when the next element to be compared is found, or
12142 -- there is no more such element.
12144 exit when No
(Comp
);
12146 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
12149 -- Skip inherited components
12151 -- Note: for a tagged type, we always generate the "=" primitive
12152 -- for the base type (not on the first subtype), so the test for
12153 -- Comp /= Original_Record_Component (Comp) is True for
12154 -- inherited components only.
12156 (Is_Tagged_Type
(Typ
)
12157 and then Comp
/= Original_Record_Component
(Comp
))
12161 or else Chars
(Comp
) = Name_uTag
12163 -- Skip interface elements (secondary tags???)
12165 or else Is_Interface
(Etype
(Comp
)));
12167 Next_Entity
(Comp
);
12171 end Element_To_Compare
;
12173 -- Start of processing for Expand_Record_Equality
12176 -- Generates the following code: (assuming that Typ has one Discr and
12177 -- component C2 is also a record)
12179 -- Lhs.Discr1 = Rhs.Discr1
12180 -- and then Lhs.C1 = Rhs.C1
12181 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12183 -- and then Lhs.Cmpn = Rhs.Cmpn
12185 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
12186 C
:= Element_To_Compare
(First_Entity
(Typ
));
12187 while Present
(C
) loop
12198 New_Lhs
:= New_Copy_Tree
(Lhs
);
12199 New_Rhs
:= New_Copy_Tree
(Rhs
);
12203 Expand_Composite_Equality
(Nod
, Etype
(C
),
12205 Make_Selected_Component
(Loc
,
12207 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12209 Make_Selected_Component
(Loc
,
12211 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12214 -- If some (sub)component is an unchecked_union, the whole
12215 -- operation will raise program error.
12217 if Nkind
(Check
) = N_Raise_Program_Error
then
12219 Set_Etype
(Result
, Standard_Boolean
);
12225 -- Generate logical "and" for CodePeer to simplify the
12226 -- generated code and analysis.
12228 elsif CodePeer_Mode
then
12231 Left_Opnd
=> Result
,
12232 Right_Opnd
=> Check
);
12236 Make_And_Then
(Loc
,
12237 Left_Opnd
=> Result
,
12238 Right_Opnd
=> Check
);
12243 First_Time
:= False;
12244 C
:= Element_To_Compare
(Next_Entity
(C
));
12248 end Expand_Record_Equality
;
12250 ---------------------------
12251 -- Expand_Set_Membership --
12252 ---------------------------
12254 procedure Expand_Set_Membership
(N
: Node_Id
) is
12255 Lop
: constant Node_Id
:= Left_Opnd
(N
);
12259 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
12260 -- If the alternative is a subtype mark, create a simple membership
12261 -- test. Otherwise create an equality test for it.
12267 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
12269 L
: constant Node_Id
:= New_Copy_Tree
(Lop
);
12270 R
: constant Node_Id
:= Relocate_Node
(Alt
);
12273 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
12274 or else Nkind
(Alt
) = N_Range
12277 Make_In
(Sloc
(Alt
),
12282 Make_Op_Eq
(Sloc
(Alt
),
12290 -- Start of processing for Expand_Set_Membership
12293 Remove_Side_Effects
(Lop
);
12295 Alt
:= Last
(Alternatives
(N
));
12296 Res
:= Make_Cond
(Alt
);
12299 while Present
(Alt
) loop
12301 Make_Or_Else
(Sloc
(Alt
),
12302 Left_Opnd
=> Make_Cond
(Alt
),
12303 Right_Opnd
=> Res
);
12308 Analyze_And_Resolve
(N
, Standard_Boolean
);
12309 end Expand_Set_Membership
;
12311 -----------------------------------
12312 -- Expand_Short_Circuit_Operator --
12313 -----------------------------------
12315 -- Deal with special expansion if actions are present for the right operand
12316 -- and deal with optimizing case of arguments being True or False. We also
12317 -- deal with the special case of non-standard boolean values.
12319 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
12320 Loc
: constant Source_Ptr
:= Sloc
(N
);
12321 Typ
: constant Entity_Id
:= Etype
(N
);
12322 Left
: constant Node_Id
:= Left_Opnd
(N
);
12323 Right
: constant Node_Id
:= Right_Opnd
(N
);
12324 LocR
: constant Source_Ptr
:= Sloc
(Right
);
12327 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
12328 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
12329 -- If Left = Shortcut_Value then Right need not be evaluated
12331 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
12332 -- For Opnd a boolean expression, return a Boolean expression equivalent
12333 -- to Opnd /= Shortcut_Value.
12335 --------------------
12336 -- Make_Test_Expr --
12337 --------------------
12339 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
12341 if Shortcut_Value
then
12342 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
12346 end Make_Test_Expr
;
12350 Op_Var
: Entity_Id
;
12351 -- Entity for a temporary variable holding the value of the operator,
12352 -- used for expansion in the case where actions are present.
12354 -- Start of processing for Expand_Short_Circuit_Operator
12357 -- Deal with non-standard booleans
12359 if Is_Boolean_Type
(Typ
) then
12360 Adjust_Condition
(Left
);
12361 Adjust_Condition
(Right
);
12362 Set_Etype
(N
, Standard_Boolean
);
12365 -- Check for cases where left argument is known to be True or False
12367 if Compile_Time_Known_Value
(Left
) then
12369 -- Mark SCO for left condition as compile time known
12371 if Generate_SCO
and then Comes_From_Source
(Left
) then
12372 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
12375 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
12376 -- Any actions associated with Right will be executed unconditionally
12377 -- and can thus be inserted into the tree unconditionally.
12379 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
12380 if Present
(Actions
(N
)) then
12381 Insert_Actions
(N
, Actions
(N
));
12384 Rewrite
(N
, Right
);
12386 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
12387 -- In this case we can forget the actions associated with Right,
12388 -- since they will never be executed.
12391 Kill_Dead_Code
(Right
);
12392 Kill_Dead_Code
(Actions
(N
));
12393 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
12396 Adjust_Result_Type
(N
, Typ
);
12400 -- If Actions are present for the right operand, we have to do some
12401 -- special processing. We can't just let these actions filter back into
12402 -- code preceding the short circuit (which is what would have happened
12403 -- if we had not trapped them in the short-circuit form), since they
12404 -- must only be executed if the right operand of the short circuit is
12405 -- executed and not otherwise.
12407 if Present
(Actions
(N
)) then
12408 Actlist
:= Actions
(N
);
12410 -- The old approach is to expand:
12412 -- left AND THEN right
12416 -- C : Boolean := False;
12424 -- and finally rewrite the operator into a reference to C. Similarly
12425 -- for left OR ELSE right, with negated values. Note that this
12426 -- rewrite causes some difficulties for coverage analysis because
12427 -- of the introduction of the new variable C, which obscures the
12428 -- structure of the test.
12430 -- We use this "old approach" if Minimize_Expression_With_Actions
12433 if Minimize_Expression_With_Actions
then
12434 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
12437 Make_Object_Declaration
(Loc
,
12438 Defining_Identifier
=> Op_Var
,
12439 Object_Definition
=>
12440 New_Occurrence_Of
(Standard_Boolean
, Loc
),
12442 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
12444 Append_To
(Actlist
,
12445 Make_Implicit_If_Statement
(Right
,
12446 Condition
=> Make_Test_Expr
(Right
),
12447 Then_Statements
=> New_List
(
12448 Make_Assignment_Statement
(LocR
,
12449 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
12452 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
12455 Make_Implicit_If_Statement
(Left
,
12456 Condition
=> Make_Test_Expr
(Left
),
12457 Then_Statements
=> Actlist
));
12459 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
12460 Analyze_And_Resolve
(N
, Standard_Boolean
);
12462 -- The new approach (the default) is to use an
12463 -- Expression_With_Actions node for the right operand of the
12464 -- short-circuit form. Note that this solves the traceability
12465 -- problems for coverage analysis.
12469 Make_Expression_With_Actions
(LocR
,
12470 Expression
=> Relocate_Node
(Right
),
12471 Actions
=> Actlist
));
12473 Set_Actions
(N
, No_List
);
12474 Analyze_And_Resolve
(Right
, Standard_Boolean
);
12477 Adjust_Result_Type
(N
, Typ
);
12481 -- No actions present, check for cases of right argument True/False
12483 if Compile_Time_Known_Value
(Right
) then
12485 -- Mark SCO for left condition as compile time known
12487 if Generate_SCO
and then Comes_From_Source
(Right
) then
12488 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
12491 -- Change (Left and then True), (Left or else False) to Left. Note
12492 -- that we know there are no actions associated with the right
12493 -- operand, since we just checked for this case above.
12495 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
12498 -- Change (Left and then False), (Left or else True) to Right,
12499 -- making sure to preserve any side effects associated with the Left
12503 Remove_Side_Effects
(Left
);
12504 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
12508 Adjust_Result_Type
(N
, Typ
);
12509 end Expand_Short_Circuit_Operator
;
12511 -------------------------------------
12512 -- Fixup_Universal_Fixed_Operation --
12513 -------------------------------------
12515 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
12516 Conv
: constant Node_Id
:= Parent
(N
);
12519 -- We must have a type conversion immediately above us
12521 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
12523 -- Normally the type conversion gives our target type. The exception
12524 -- occurs in the case of the Round attribute, where the conversion
12525 -- will be to universal real, and our real type comes from the Round
12526 -- attribute (as well as an indication that we must round the result)
12528 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
12529 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
12531 Set_Etype
(N
, Etype
(Parent
(Conv
)));
12532 Set_Rounded_Result
(N
);
12534 -- Normal case where type comes from conversion above us
12537 Set_Etype
(N
, Etype
(Conv
));
12539 end Fixup_Universal_Fixed_Operation
;
12541 ---------------------------------
12542 -- Has_Inferable_Discriminants --
12543 ---------------------------------
12545 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
12547 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
12548 -- Determines whether the left-most prefix of a selected component is a
12549 -- formal parameter in a subprogram. Assumes N is a selected component.
12551 --------------------------------
12552 -- Prefix_Is_Formal_Parameter --
12553 --------------------------------
12555 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
12556 Sel_Comp
: Node_Id
;
12559 -- Move to the left-most prefix by climbing up the tree
12562 while Present
(Parent
(Sel_Comp
))
12563 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
12565 Sel_Comp
:= Parent
(Sel_Comp
);
12568 return Is_Formal
(Entity
(Prefix
(Sel_Comp
)));
12569 end Prefix_Is_Formal_Parameter
;
12571 -- Start of processing for Has_Inferable_Discriminants
12574 -- For selected components, the subtype of the selector must be a
12575 -- constrained Unchecked_Union. If the component is subject to a
12576 -- per-object constraint, then the enclosing object must have inferable
12579 if Nkind
(N
) = N_Selected_Component
then
12580 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
12582 -- A small hack. If we have a per-object constrained selected
12583 -- component of a formal parameter, return True since we do not
12584 -- know the actual parameter association yet.
12586 if Prefix_Is_Formal_Parameter
(N
) then
12589 -- Otherwise, check the enclosing object and the selector
12592 return Has_Inferable_Discriminants
(Prefix
(N
))
12593 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
12596 -- The call to Has_Inferable_Discriminants will determine whether
12597 -- the selector has a constrained Unchecked_Union nominal type.
12600 return Has_Inferable_Discriminants
(Selector_Name
(N
));
12603 -- A qualified expression has inferable discriminants if its subtype
12604 -- mark is a constrained Unchecked_Union subtype.
12606 elsif Nkind
(N
) = N_Qualified_Expression
then
12607 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
12608 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
12610 -- For all other names, it is sufficient to have a constrained
12611 -- Unchecked_Union nominal subtype.
12614 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
12615 and then Is_Constrained
(Etype
(N
));
12617 end Has_Inferable_Discriminants
;
12619 -------------------------------
12620 -- Insert_Dereference_Action --
12621 -------------------------------
12623 procedure Insert_Dereference_Action
(N
: Node_Id
) is
12624 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
12625 -- Return true if type of P is derived from Checked_Pool;
12627 -----------------------------
12628 -- Is_Checked_Storage_Pool --
12629 -----------------------------
12631 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
12640 while T
/= Etype
(T
) loop
12641 if Is_RTE
(T
, RE_Checked_Pool
) then
12649 end Is_Checked_Storage_Pool
;
12653 Context
: constant Node_Id
:= Parent
(N
);
12654 Ptr_Typ
: constant Entity_Id
:= Etype
(N
);
12655 Desig_Typ
: constant Entity_Id
:=
12656 Available_View
(Designated_Type
(Ptr_Typ
));
12657 Loc
: constant Source_Ptr
:= Sloc
(N
);
12658 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
12664 Size_Bits
: Node_Id
;
12667 -- Start of processing for Insert_Dereference_Action
12670 pragma Assert
(Nkind
(Context
) = N_Explicit_Dereference
);
12672 -- Do not re-expand a dereference which has already been processed by
12675 if Has_Dereference_Action
(Context
) then
12678 -- Do not perform this type of expansion for internally-generated
12681 elsif not Comes_From_Source
(Original_Node
(Context
)) then
12684 -- A dereference action is only applicable to objects which have been
12685 -- allocated on a checked pool.
12687 elsif not Is_Checked_Storage_Pool
(Pool
) then
12691 -- Extract the address of the dereferenced object. Generate:
12693 -- Addr : System.Address := <N>'Pool_Address;
12695 Addr
:= Make_Temporary
(Loc
, 'P');
12698 Make_Object_Declaration
(Loc
,
12699 Defining_Identifier
=> Addr
,
12700 Object_Definition
=>
12701 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
12703 Make_Attribute_Reference
(Loc
,
12704 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
12705 Attribute_Name
=> Name_Pool_Address
)));
12707 -- Calculate the size of the dereferenced object. Generate:
12709 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
12712 Make_Explicit_Dereference
(Loc
,
12713 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
12714 Set_Has_Dereference_Action
(Deref
);
12717 Make_Attribute_Reference
(Loc
,
12719 Attribute_Name
=> Name_Size
);
12721 -- Special case of an unconstrained array: need to add descriptor size
12723 if Is_Array_Type
(Desig_Typ
)
12724 and then not Is_Constrained
(First_Subtype
(Desig_Typ
))
12729 Make_Attribute_Reference
(Loc
,
12731 New_Occurrence_Of
(First_Subtype
(Desig_Typ
), Loc
),
12732 Attribute_Name
=> Name_Descriptor_Size
),
12733 Right_Opnd
=> Size_Bits
);
12736 Size
:= Make_Temporary
(Loc
, 'S');
12738 Make_Object_Declaration
(Loc
,
12739 Defining_Identifier
=> Size
,
12740 Object_Definition
=>
12741 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
12743 Make_Op_Divide
(Loc
,
12744 Left_Opnd
=> Size_Bits
,
12745 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
12747 -- Calculate the alignment of the dereferenced object. Generate:
12748 -- Alig : constant Storage_Count := <N>.all'Alignment;
12751 Make_Explicit_Dereference
(Loc
,
12752 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
12753 Set_Has_Dereference_Action
(Deref
);
12755 Alig
:= Make_Temporary
(Loc
, 'A');
12757 Make_Object_Declaration
(Loc
,
12758 Defining_Identifier
=> Alig
,
12759 Object_Definition
=>
12760 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
12762 Make_Attribute_Reference
(Loc
,
12764 Attribute_Name
=> Name_Alignment
)));
12766 -- A dereference of a controlled object requires special processing. The
12767 -- finalization machinery requests additional space from the underlying
12768 -- pool to allocate and hide two pointers. As a result, a checked pool
12769 -- may mark the wrong memory as valid. Since checked pools do not have
12770 -- knowledge of hidden pointers, we have to bring the two pointers back
12771 -- in view in order to restore the original state of the object.
12773 -- The address manipulation is not performed for access types that are
12774 -- subject to pragma No_Heap_Finalization because the two pointers do
12775 -- not exist in the first place.
12777 if No_Heap_Finalization
(Ptr_Typ
) then
12780 elsif Needs_Finalization
(Desig_Typ
) then
12782 -- Adjust the address and size of the dereferenced object. Generate:
12783 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
12786 Make_Procedure_Call_Statement
(Loc
,
12788 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
12789 Parameter_Associations
=> New_List
(
12790 New_Occurrence_Of
(Addr
, Loc
),
12791 New_Occurrence_Of
(Size
, Loc
),
12792 New_Occurrence_Of
(Alig
, Loc
)));
12794 -- Class-wide types complicate things because we cannot determine
12795 -- statically whether the actual object is truly controlled. We must
12796 -- generate a runtime check to detect this property. Generate:
12798 -- if Needs_Finalization (<N>.all'Tag) then
12802 if Is_Class_Wide_Type
(Desig_Typ
) then
12804 Make_Explicit_Dereference
(Loc
,
12805 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
12806 Set_Has_Dereference_Action
(Deref
);
12809 Make_Implicit_If_Statement
(N
,
12811 Make_Function_Call
(Loc
,
12813 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
12814 Parameter_Associations
=> New_List
(
12815 Make_Attribute_Reference
(Loc
,
12817 Attribute_Name
=> Name_Tag
))),
12818 Then_Statements
=> New_List
(Stmt
));
12821 Insert_Action
(N
, Stmt
);
12825 -- Dereference (Pool, Addr, Size, Alig);
12828 Make_Procedure_Call_Statement
(Loc
,
12831 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
12832 Parameter_Associations
=> New_List
(
12833 New_Occurrence_Of
(Pool
, Loc
),
12834 New_Occurrence_Of
(Addr
, Loc
),
12835 New_Occurrence_Of
(Size
, Loc
),
12836 New_Occurrence_Of
(Alig
, Loc
))));
12838 -- Mark the explicit dereference as processed to avoid potential
12839 -- infinite expansion.
12841 Set_Has_Dereference_Action
(Context
);
12844 when RE_Not_Available
=>
12846 end Insert_Dereference_Action
;
12848 --------------------------------
12849 -- Integer_Promotion_Possible --
12850 --------------------------------
12852 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
12853 Operand
: constant Node_Id
:= Expression
(N
);
12854 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12855 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
12858 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
12862 -- We only do the transformation for source constructs. We assume
12863 -- that the expander knows what it is doing when it generates code.
12865 Comes_From_Source
(N
)
12867 -- If the operand type is Short_Integer or Short_Short_Integer,
12868 -- then we will promote to Integer, which is available on all
12869 -- targets, and is sufficient to ensure no intermediate overflow.
12870 -- Furthermore it is likely to be as efficient or more efficient
12871 -- than using the smaller type for the computation so we do this
12872 -- unconditionally.
12875 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
12877 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
12879 -- Test for interesting operation, which includes addition,
12880 -- division, exponentiation, multiplication, subtraction, absolute
12881 -- value and unary negation. Unary "+" is omitted since it is a
12882 -- no-op and thus can't overflow.
12884 and then Nkind_In
(Operand
, N_Op_Abs
,
12891 end Integer_Promotion_Possible
;
12893 ------------------------------
12894 -- Make_Array_Comparison_Op --
12895 ------------------------------
12897 -- This is a hand-coded expansion of the following generic function:
12900 -- type elem is (<>);
12901 -- type index is (<>);
12902 -- type a is array (index range <>) of elem;
12904 -- function Gnnn (X : a; Y: a) return boolean is
12905 -- J : index := Y'first;
12908 -- if X'length = 0 then
12911 -- elsif Y'length = 0 then
12915 -- for I in X'range loop
12916 -- if X (I) = Y (J) then
12917 -- if J = Y'last then
12920 -- J := index'succ (J);
12924 -- return X (I) > Y (J);
12928 -- return X'length > Y'length;
12932 -- Note that since we are essentially doing this expansion by hand, we
12933 -- do not need to generate an actual or formal generic part, just the
12934 -- instantiated function itself.
12936 -- Perhaps we could have the actual generic available in the run-time,
12937 -- obtained by rtsfind, and actually expand a real instantiation ???
12939 function Make_Array_Comparison_Op
12941 Nod
: Node_Id
) return Node_Id
12943 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12945 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
12946 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
12947 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
12948 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12950 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
12952 Loop_Statement
: Node_Id
;
12953 Loop_Body
: Node_Id
;
12955 Inner_If
: Node_Id
;
12956 Final_Expr
: Node_Id
;
12957 Func_Body
: Node_Id
;
12958 Func_Name
: Entity_Id
;
12964 -- if J = Y'last then
12967 -- J := index'succ (J);
12971 Make_Implicit_If_Statement
(Nod
,
12974 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
12976 Make_Attribute_Reference
(Loc
,
12977 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12978 Attribute_Name
=> Name_Last
)),
12980 Then_Statements
=> New_List
(
12981 Make_Exit_Statement
(Loc
)),
12985 Make_Assignment_Statement
(Loc
,
12986 Name
=> New_Occurrence_Of
(J
, Loc
),
12988 Make_Attribute_Reference
(Loc
,
12989 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
12990 Attribute_Name
=> Name_Succ
,
12991 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
12993 -- if X (I) = Y (J) then
12996 -- return X (I) > Y (J);
13000 Make_Implicit_If_Statement
(Nod
,
13004 Make_Indexed_Component
(Loc
,
13005 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13006 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13009 Make_Indexed_Component
(Loc
,
13010 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13011 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
13013 Then_Statements
=> New_List
(Inner_If
),
13015 Else_Statements
=> New_List
(
13016 Make_Simple_Return_Statement
(Loc
,
13020 Make_Indexed_Component
(Loc
,
13021 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13022 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13025 Make_Indexed_Component
(Loc
,
13026 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13027 Expressions
=> New_List
(
13028 New_Occurrence_Of
(J
, Loc
)))))));
13030 -- for I in X'range loop
13035 Make_Implicit_Loop_Statement
(Nod
,
13036 Identifier
=> Empty
,
13038 Iteration_Scheme
=>
13039 Make_Iteration_Scheme
(Loc
,
13040 Loop_Parameter_Specification
=>
13041 Make_Loop_Parameter_Specification
(Loc
,
13042 Defining_Identifier
=> I
,
13043 Discrete_Subtype_Definition
=>
13044 Make_Attribute_Reference
(Loc
,
13045 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13046 Attribute_Name
=> Name_Range
))),
13048 Statements
=> New_List
(Loop_Body
));
13050 -- if X'length = 0 then
13052 -- elsif Y'length = 0 then
13055 -- for ... loop ... end loop;
13056 -- return X'length > Y'length;
13060 Make_Attribute_Reference
(Loc
,
13061 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13062 Attribute_Name
=> Name_Length
);
13065 Make_Attribute_Reference
(Loc
,
13066 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13067 Attribute_Name
=> Name_Length
);
13071 Left_Opnd
=> Length1
,
13072 Right_Opnd
=> Length2
);
13075 Make_Implicit_If_Statement
(Nod
,
13079 Make_Attribute_Reference
(Loc
,
13080 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13081 Attribute_Name
=> Name_Length
),
13083 Make_Integer_Literal
(Loc
, 0)),
13087 Make_Simple_Return_Statement
(Loc
,
13088 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
13090 Elsif_Parts
=> New_List
(
13091 Make_Elsif_Part
(Loc
,
13095 Make_Attribute_Reference
(Loc
,
13096 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13097 Attribute_Name
=> Name_Length
),
13099 Make_Integer_Literal
(Loc
, 0)),
13103 Make_Simple_Return_Statement
(Loc
,
13104 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
13106 Else_Statements
=> New_List
(
13108 Make_Simple_Return_Statement
(Loc
,
13109 Expression
=> Final_Expr
)));
13113 Formals
:= New_List
(
13114 Make_Parameter_Specification
(Loc
,
13115 Defining_Identifier
=> X
,
13116 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13118 Make_Parameter_Specification
(Loc
,
13119 Defining_Identifier
=> Y
,
13120 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13122 -- function Gnnn (...) return boolean is
13123 -- J : index := Y'first;
13128 Func_Name
:= Make_Temporary
(Loc
, 'G');
13131 Make_Subprogram_Body
(Loc
,
13133 Make_Function_Specification
(Loc
,
13134 Defining_Unit_Name
=> Func_Name
,
13135 Parameter_Specifications
=> Formals
,
13136 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
13138 Declarations
=> New_List
(
13139 Make_Object_Declaration
(Loc
,
13140 Defining_Identifier
=> J
,
13141 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
13143 Make_Attribute_Reference
(Loc
,
13144 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13145 Attribute_Name
=> Name_First
))),
13147 Handled_Statement_Sequence
=>
13148 Make_Handled_Sequence_Of_Statements
(Loc
,
13149 Statements
=> New_List
(If_Stat
)));
13152 end Make_Array_Comparison_Op
;
13154 ---------------------------
13155 -- Make_Boolean_Array_Op --
13156 ---------------------------
13158 -- For logical operations on boolean arrays, expand in line the following,
13159 -- replacing 'and' with 'or' or 'xor' where needed:
13161 -- function Annn (A : typ; B: typ) return typ is
13164 -- for J in A'range loop
13165 -- C (J) := A (J) op B (J);
13170 -- Here typ is the boolean array type
13172 function Make_Boolean_Array_Op
13174 N
: Node_Id
) return Node_Id
13176 Loc
: constant Source_Ptr
:= Sloc
(N
);
13178 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
13179 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
13180 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
13181 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13189 Func_Name
: Entity_Id
;
13190 Func_Body
: Node_Id
;
13191 Loop_Statement
: Node_Id
;
13195 Make_Indexed_Component
(Loc
,
13196 Prefix
=> New_Occurrence_Of
(A
, Loc
),
13197 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13200 Make_Indexed_Component
(Loc
,
13201 Prefix
=> New_Occurrence_Of
(B
, Loc
),
13202 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13205 Make_Indexed_Component
(Loc
,
13206 Prefix
=> New_Occurrence_Of
(C
, Loc
),
13207 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13209 if Nkind
(N
) = N_Op_And
then
13213 Right_Opnd
=> B_J
);
13215 elsif Nkind
(N
) = N_Op_Or
then
13219 Right_Opnd
=> B_J
);
13225 Right_Opnd
=> B_J
);
13229 Make_Implicit_Loop_Statement
(N
,
13230 Identifier
=> Empty
,
13232 Iteration_Scheme
=>
13233 Make_Iteration_Scheme
(Loc
,
13234 Loop_Parameter_Specification
=>
13235 Make_Loop_Parameter_Specification
(Loc
,
13236 Defining_Identifier
=> J
,
13237 Discrete_Subtype_Definition
=>
13238 Make_Attribute_Reference
(Loc
,
13239 Prefix
=> New_Occurrence_Of
(A
, Loc
),
13240 Attribute_Name
=> Name_Range
))),
13242 Statements
=> New_List
(
13243 Make_Assignment_Statement
(Loc
,
13245 Expression
=> Op
)));
13247 Formals
:= New_List
(
13248 Make_Parameter_Specification
(Loc
,
13249 Defining_Identifier
=> A
,
13250 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13252 Make_Parameter_Specification
(Loc
,
13253 Defining_Identifier
=> B
,
13254 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13256 Func_Name
:= Make_Temporary
(Loc
, 'A');
13257 Set_Is_Inlined
(Func_Name
);
13260 Make_Subprogram_Body
(Loc
,
13262 Make_Function_Specification
(Loc
,
13263 Defining_Unit_Name
=> Func_Name
,
13264 Parameter_Specifications
=> Formals
,
13265 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
13267 Declarations
=> New_List
(
13268 Make_Object_Declaration
(Loc
,
13269 Defining_Identifier
=> C
,
13270 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
13272 Handled_Statement_Sequence
=>
13273 Make_Handled_Sequence_Of_Statements
(Loc
,
13274 Statements
=> New_List
(
13276 Make_Simple_Return_Statement
(Loc
,
13277 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
13280 end Make_Boolean_Array_Op
;
13282 -----------------------------------------
13283 -- Minimized_Eliminated_Overflow_Check --
13284 -----------------------------------------
13286 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
13289 Is_Signed_Integer_Type
(Etype
(N
))
13290 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
13291 end Minimized_Eliminated_Overflow_Check
;
13293 --------------------------------
13294 -- Optimize_Length_Comparison --
13295 --------------------------------
13297 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
13298 Loc
: constant Source_Ptr
:= Sloc
(N
);
13299 Typ
: constant Entity_Id
:= Etype
(N
);
13304 -- First and Last attribute reference nodes, which end up as left and
13305 -- right operands of the optimized result.
13308 -- True for comparison operand of zero
13311 -- Comparison operand, set only if Is_Zero is false
13313 Ent
: Entity_Id
:= Empty
;
13314 -- Entity whose length is being compared
13316 Index
: Node_Id
:= Empty
;
13317 -- Integer_Literal node for length attribute expression, or Empty
13318 -- if there is no such expression present.
13321 -- Type of array index to which 'Length is applied
13323 Op
: Node_Kind
:= Nkind
(N
);
13324 -- Kind of comparison operator, gets flipped if operands backwards
13326 function Is_Optimizable
(N
: Node_Id
) return Boolean;
13327 -- Tests N to see if it is an optimizable comparison value (defined as
13328 -- constant zero or one, or something else where the value is known to
13329 -- be positive and in the range of 32-bits, and where the corresponding
13330 -- Length value is also known to be 32-bits. If result is true, sets
13331 -- Is_Zero, Ityp, and Comp accordingly.
13333 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
13334 -- Tests if N is a length attribute applied to a simple entity. If so,
13335 -- returns True, and sets Ent to the entity, and Index to the integer
13336 -- literal provided as an attribute expression, or to Empty if none.
13337 -- Also returns True if the expression is a generated type conversion
13338 -- whose expression is of the desired form. This latter case arises
13339 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
13340 -- to check for being in range, which is not needed in this context.
13341 -- Returns False if neither condition holds.
13343 function Prepare_64
(N
: Node_Id
) return Node_Id
;
13344 -- Given a discrete expression, returns a Long_Long_Integer typed
13345 -- expression representing the underlying value of the expression.
13346 -- This is done with an unchecked conversion to the result type. We
13347 -- use unchecked conversion to handle the enumeration type case.
13349 ----------------------
13350 -- Is_Entity_Length --
13351 ----------------------
13353 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
13355 if Nkind
(N
) = N_Attribute_Reference
13356 and then Attribute_Name
(N
) = Name_Length
13357 and then Is_Entity_Name
(Prefix
(N
))
13359 Ent
:= Entity
(Prefix
(N
));
13361 if Present
(Expressions
(N
)) then
13362 Index
:= First
(Expressions
(N
));
13369 elsif Nkind
(N
) = N_Type_Conversion
13370 and then not Comes_From_Source
(N
)
13372 return Is_Entity_Length
(Expression
(N
));
13377 end Is_Entity_Length
;
13379 --------------------
13380 -- Is_Optimizable --
13381 --------------------
13383 function Is_Optimizable
(N
: Node_Id
) return Boolean is
13391 if Compile_Time_Known_Value
(N
) then
13392 Val
:= Expr_Value
(N
);
13394 if Val
= Uint_0
then
13399 elsif Val
= Uint_1
then
13406 -- Here we have to make sure of being within 32-bits
13408 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
13411 or else Lo
< Uint_1
13412 or else Hi
> UI_From_Int
(Int
'Last)
13417 -- Comparison value was within range, so now we must check the index
13418 -- value to make sure it is also within 32-bits.
13420 Indx
:= First_Index
(Etype
(Ent
));
13422 if Present
(Index
) then
13423 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
13428 Ityp
:= Etype
(Indx
);
13430 if Esize
(Ityp
) > 32 then
13437 end Is_Optimizable
;
13443 function Prepare_64
(N
: Node_Id
) return Node_Id
is
13445 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
13448 -- Start of processing for Optimize_Length_Comparison
13451 -- Nothing to do if not a comparison
13453 if Op
not in N_Op_Compare
then
13457 -- Nothing to do if special -gnatd.P debug flag set.
13459 if Debug_Flag_Dot_PP
then
13463 -- Ent'Length op 0/1
13465 if Is_Entity_Length
(Left_Opnd
(N
))
13466 and then Is_Optimizable
(Right_Opnd
(N
))
13470 -- 0/1 op Ent'Length
13472 elsif Is_Entity_Length
(Right_Opnd
(N
))
13473 and then Is_Optimizable
(Left_Opnd
(N
))
13475 -- Flip comparison to opposite sense
13478 when N_Op_Lt
=> Op
:= N_Op_Gt
;
13479 when N_Op_Le
=> Op
:= N_Op_Ge
;
13480 when N_Op_Gt
=> Op
:= N_Op_Lt
;
13481 when N_Op_Ge
=> Op
:= N_Op_Le
;
13482 when others => null;
13485 -- Else optimization not possible
13491 -- Fall through if we will do the optimization
13493 -- Cases to handle:
13495 -- X'Length = 0 => X'First > X'Last
13496 -- X'Length = 1 => X'First = X'Last
13497 -- X'Length = n => X'First + (n - 1) = X'Last
13499 -- X'Length /= 0 => X'First <= X'Last
13500 -- X'Length /= 1 => X'First /= X'Last
13501 -- X'Length /= n => X'First + (n - 1) /= X'Last
13503 -- X'Length >= 0 => always true, warn
13504 -- X'Length >= 1 => X'First <= X'Last
13505 -- X'Length >= n => X'First + (n - 1) <= X'Last
13507 -- X'Length > 0 => X'First <= X'Last
13508 -- X'Length > 1 => X'First < X'Last
13509 -- X'Length > n => X'First + (n - 1) < X'Last
13511 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
13512 -- X'Length <= 1 => X'First >= X'Last
13513 -- X'Length <= n => X'First + (n - 1) >= X'Last
13515 -- X'Length < 0 => always false (warn)
13516 -- X'Length < 1 => X'First > X'Last
13517 -- X'Length < n => X'First + (n - 1) > X'Last
13519 -- Note: for the cases of n (not constant 0,1), we require that the
13520 -- corresponding index type be integer or shorter (i.e. not 64-bit),
13521 -- and the same for the comparison value. Then we do the comparison
13522 -- using 64-bit arithmetic (actually long long integer), so that we
13523 -- cannot have overflow intefering with the result.
13525 -- First deal with warning cases
13534 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
13535 Analyze_And_Resolve
(N
, Typ
);
13536 Warn_On_Known_Condition
(N
);
13543 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
13544 Analyze_And_Resolve
(N
, Typ
);
13545 Warn_On_Known_Condition
(N
);
13549 if Constant_Condition_Warnings
13550 and then Comes_From_Source
(Original_Node
(N
))
13552 Error_Msg_N
("could replace by ""'=""?c?", N
);
13562 -- Build the First reference we will use
13565 Make_Attribute_Reference
(Loc
,
13566 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
13567 Attribute_Name
=> Name_First
);
13569 if Present
(Index
) then
13570 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
13573 -- If general value case, then do the addition of (n - 1), and
13574 -- also add the needed conversions to type Long_Long_Integer.
13576 if Present
(Comp
) then
13579 Left_Opnd
=> Prepare_64
(Left
),
13581 Make_Op_Subtract
(Loc
,
13582 Left_Opnd
=> Prepare_64
(Comp
),
13583 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
13586 -- Build the Last reference we will use
13589 Make_Attribute_Reference
(Loc
,
13590 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
13591 Attribute_Name
=> Name_Last
);
13593 if Present
(Index
) then
13594 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
13597 -- If general operand, convert Last reference to Long_Long_Integer
13599 if Present
(Comp
) then
13600 Right
:= Prepare_64
(Right
);
13603 -- Check for cases to optimize
13605 -- X'Length = 0 => X'First > X'Last
13606 -- X'Length < 1 => X'First > X'Last
13607 -- X'Length < n => X'First + (n - 1) > X'Last
13609 if (Is_Zero
and then Op
= N_Op_Eq
)
13610 or else (not Is_Zero
and then Op
= N_Op_Lt
)
13615 Right_Opnd
=> Right
);
13617 -- X'Length = 1 => X'First = X'Last
13618 -- X'Length = n => X'First + (n - 1) = X'Last
13620 elsif not Is_Zero
and then Op
= N_Op_Eq
then
13624 Right_Opnd
=> Right
);
13626 -- X'Length /= 0 => X'First <= X'Last
13627 -- X'Length > 0 => X'First <= X'Last
13629 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
13633 Right_Opnd
=> Right
);
13635 -- X'Length /= 1 => X'First /= X'Last
13636 -- X'Length /= n => X'First + (n - 1) /= X'Last
13638 elsif not Is_Zero
and then Op
= N_Op_Ne
then
13642 Right_Opnd
=> Right
);
13644 -- X'Length >= 1 => X'First <= X'Last
13645 -- X'Length >= n => X'First + (n - 1) <= X'Last
13647 elsif not Is_Zero
and then Op
= N_Op_Ge
then
13651 Right_Opnd
=> Right
);
13653 -- X'Length > 1 => X'First < X'Last
13654 -- X'Length > n => X'First + (n = 1) < X'Last
13656 elsif not Is_Zero
and then Op
= N_Op_Gt
then
13660 Right_Opnd
=> Right
);
13662 -- X'Length <= 1 => X'First >= X'Last
13663 -- X'Length <= n => X'First + (n - 1) >= X'Last
13665 elsif not Is_Zero
and then Op
= N_Op_Le
then
13669 Right_Opnd
=> Right
);
13671 -- Should not happen at this stage
13674 raise Program_Error
;
13677 -- Rewrite and finish up
13679 Rewrite
(N
, Result
);
13680 Analyze_And_Resolve
(N
, Typ
);
13682 end Optimize_Length_Comparison
;
13684 --------------------------------
13685 -- Process_If_Case_Statements --
13686 --------------------------------
13688 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
) is
13692 Decl
:= First
(Stmts
);
13693 while Present
(Decl
) loop
13694 if Nkind
(Decl
) = N_Object_Declaration
13695 and then Is_Finalizable_Transient
(Decl
, N
)
13697 Process_Transient_In_Expression
(Decl
, N
, Stmts
);
13702 end Process_If_Case_Statements
;
13704 -------------------------------------
13705 -- Process_Transient_In_Expression --
13706 -------------------------------------
13708 procedure Process_Transient_In_Expression
13709 (Obj_Decl
: Node_Id
;
13713 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
13714 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Obj_Decl
);
13716 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Expr
);
13717 -- The node on which to insert the hook as an action. This is usually
13718 -- the innermost enclosing non-transient construct.
13720 Fin_Call
: Node_Id
;
13721 Hook_Assign
: Node_Id
;
13722 Hook_Clear
: Node_Id
;
13723 Hook_Decl
: Node_Id
;
13724 Hook_Insert
: Node_Id
;
13725 Ptr_Decl
: Node_Id
;
13727 Fin_Context
: Node_Id
;
13728 -- The node after which to insert the finalization actions of the
13729 -- transient object.
13732 pragma Assert
(Nkind_In
(Expr
, N_Case_Expression
,
13733 N_Expression_With_Actions
,
13736 -- When the context is a Boolean evaluation, all three nodes capture the
13737 -- result of their computation in a local temporary:
13740 -- Trans_Id : Ctrl_Typ := ...;
13741 -- Result : constant Boolean := ... Trans_Id ...;
13742 -- <finalize Trans_Id>
13745 -- As a result, the finalization of any transient objects can safely
13746 -- take place after the result capture.
13748 -- ??? could this be extended to elementary types?
13750 if Is_Boolean_Type
(Etype
(Expr
)) then
13751 Fin_Context
:= Last
(Stmts
);
13753 -- Otherwise the immediate context may not be safe enough to carry
13754 -- out transient object finalization due to aliasing and nesting of
13755 -- constructs. Insert calls to [Deep_]Finalize after the innermost
13756 -- enclosing non-transient construct.
13759 Fin_Context
:= Hook_Context
;
13762 -- Mark the transient object as successfully processed to avoid double
13765 Set_Is_Finalized_Transient
(Obj_Id
);
13767 -- Construct all the pieces necessary to hook and finalize a transient
13770 Build_Transient_Object_Statements
13771 (Obj_Decl
=> Obj_Decl
,
13772 Fin_Call
=> Fin_Call
,
13773 Hook_Assign
=> Hook_Assign
,
13774 Hook_Clear
=> Hook_Clear
,
13775 Hook_Decl
=> Hook_Decl
,
13776 Ptr_Decl
=> Ptr_Decl
,
13777 Finalize_Obj
=> False);
13779 -- Add the access type which provides a reference to the transient
13780 -- object. Generate:
13782 -- type Ptr_Typ is access all Desig_Typ;
13784 Insert_Action
(Hook_Context
, Ptr_Decl
);
13786 -- Add the temporary which acts as a hook to the transient object.
13789 -- Hook : Ptr_Id := null;
13791 Insert_Action
(Hook_Context
, Hook_Decl
);
13793 -- When the transient object is initialized by an aggregate, the hook
13794 -- must capture the object after the last aggregate assignment takes
13795 -- place. Only then is the object considered initialized. Generate:
13797 -- Hook := Ptr_Typ (Obj_Id);
13799 -- Hook := Obj_Id'Unrestricted_Access;
13801 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
13802 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
13804 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
13806 -- Otherwise the hook seizes the related object immediately
13809 Hook_Insert
:= Obj_Decl
;
13812 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
13814 -- When the node is part of a return statement, there is no need to
13815 -- insert a finalization call, as the general finalization mechanism
13816 -- (see Build_Finalizer) would take care of the transient object on
13817 -- subprogram exit. Note that it would also be impossible to insert the
13818 -- finalization code after the return statement as this will render it
13821 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
13824 -- Finalize the hook after the context has been evaluated. Generate:
13826 -- if Hook /= null then
13827 -- [Deep_]Finalize (Hook.all);
13832 Insert_Action_After
(Fin_Context
,
13833 Make_Implicit_If_Statement
(Obj_Decl
,
13837 New_Occurrence_Of
(Defining_Entity
(Hook_Decl
), Loc
),
13838 Right_Opnd
=> Make_Null
(Loc
)),
13840 Then_Statements
=> New_List
(
13844 end Process_Transient_In_Expression
;
13846 ------------------------
13847 -- Rewrite_Comparison --
13848 ------------------------
13850 procedure Rewrite_Comparison
(N
: Node_Id
) is
13851 Typ
: constant Entity_Id
:= Etype
(N
);
13853 False_Result
: Boolean;
13854 True_Result
: Boolean;
13857 if Nkind
(N
) = N_Type_Conversion
then
13858 Rewrite_Comparison
(Expression
(N
));
13861 elsif Nkind
(N
) not in N_Op_Compare
then
13865 -- Determine the potential outcome of the comparison assuming that the
13866 -- operands are valid and emit a warning when the comparison evaluates
13867 -- to True or False only in the presence of invalid values.
13869 Warn_On_Constant_Valid_Condition
(N
);
13871 -- Determine the potential outcome of the comparison assuming that the
13872 -- operands are not valid.
13876 Assume_Valid
=> False,
13877 True_Result
=> True_Result
,
13878 False_Result
=> False_Result
);
13880 -- The outcome is a decisive False or True, rewrite the operator
13882 if False_Result
or True_Result
then
13885 New_Occurrence_Of
(Boolean_Literals
(True_Result
), Sloc
(N
))));
13887 Analyze_And_Resolve
(N
, Typ
);
13888 Warn_On_Known_Condition
(N
);
13890 end Rewrite_Comparison
;
13892 ----------------------------
13893 -- Safe_In_Place_Array_Op --
13894 ----------------------------
13896 function Safe_In_Place_Array_Op
13899 Op2
: Node_Id
) return Boolean
13901 Target
: Entity_Id
;
13903 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
13904 -- Operand is safe if it cannot overlap part of the target of the
13905 -- operation. If the operand and the target are identical, the operand
13906 -- is safe. The operand can be empty in the case of negation.
13908 function Is_Unaliased
(N
: Node_Id
) return Boolean;
13909 -- Check that N is a stand-alone entity
13915 function Is_Unaliased
(N
: Node_Id
) return Boolean is
13919 and then No
(Address_Clause
(Entity
(N
)))
13920 and then No
(Renamed_Object
(Entity
(N
)));
13923 ---------------------
13924 -- Is_Safe_Operand --
13925 ---------------------
13927 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
13932 elsif Is_Entity_Name
(Op
) then
13933 return Is_Unaliased
(Op
);
13935 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
13936 return Is_Unaliased
(Prefix
(Op
));
13938 elsif Nkind
(Op
) = N_Slice
then
13940 Is_Unaliased
(Prefix
(Op
))
13941 and then Entity
(Prefix
(Op
)) /= Target
;
13943 elsif Nkind
(Op
) = N_Op_Not
then
13944 return Is_Safe_Operand
(Right_Opnd
(Op
));
13949 end Is_Safe_Operand
;
13951 -- Start of processing for Safe_In_Place_Array_Op
13954 -- Skip this processing if the component size is different from system
13955 -- storage unit (since at least for NOT this would cause problems).
13957 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
13960 -- Cannot do in place stuff if non-standard Boolean representation
13962 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
13965 elsif not Is_Unaliased
(Lhs
) then
13969 Target
:= Entity
(Lhs
);
13970 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
13972 end Safe_In_Place_Array_Op
;
13974 -----------------------
13975 -- Tagged_Membership --
13976 -----------------------
13978 -- There are two different cases to consider depending on whether the right
13979 -- operand is a class-wide type or not. If not we just compare the actual
13980 -- tag of the left expr to the target type tag:
13982 -- Left_Expr.Tag = Right_Type'Tag;
13984 -- If it is a class-wide type we use the RT function CW_Membership which is
13985 -- usually implemented by looking in the ancestor tables contained in the
13986 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13988 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13989 -- function IW_Membership which is usually implemented by looking in the
13990 -- table of abstract interface types plus the ancestor table contained in
13991 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13993 procedure Tagged_Membership
13995 SCIL_Node
: out Node_Id
;
13996 Result
: out Node_Id
)
13998 Left
: constant Node_Id
:= Left_Opnd
(N
);
13999 Right
: constant Node_Id
:= Right_Opnd
(N
);
14000 Loc
: constant Source_Ptr
:= Sloc
(N
);
14002 Full_R_Typ
: Entity_Id
;
14003 Left_Type
: Entity_Id
;
14004 New_Node
: Node_Id
;
14005 Right_Type
: Entity_Id
;
14009 SCIL_Node
:= Empty
;
14011 -- Handle entities from the limited view
14013 Left_Type
:= Available_View
(Etype
(Left
));
14014 Right_Type
:= Available_View
(Etype
(Right
));
14016 -- In the case where the type is an access type, the test is applied
14017 -- using the designated types (needed in Ada 2012 for implicit anonymous
14018 -- access conversions, for AI05-0149).
14020 if Is_Access_Type
(Right_Type
) then
14021 Left_Type
:= Designated_Type
(Left_Type
);
14022 Right_Type
:= Designated_Type
(Right_Type
);
14025 if Is_Class_Wide_Type
(Left_Type
) then
14026 Left_Type
:= Root_Type
(Left_Type
);
14029 if Is_Class_Wide_Type
(Right_Type
) then
14030 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
14032 Full_R_Typ
:= Underlying_Type
(Right_Type
);
14036 Make_Selected_Component
(Loc
,
14037 Prefix
=> Relocate_Node
(Left
),
14039 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
14041 if Is_Class_Wide_Type
(Right_Type
) or else Is_Interface
(Left_Type
) then
14043 -- No need to issue a run-time check if we statically know that the
14044 -- result of this membership test is always true. For example,
14045 -- considering the following declarations:
14047 -- type Iface is interface;
14048 -- type T is tagged null record;
14049 -- type DT is new T and Iface with null record;
14054 -- These membership tests are always true:
14057 -- Obj2 in T'Class;
14058 -- Obj2 in Iface'Class;
14060 -- We do not need to handle cases where the membership is illegal.
14063 -- Obj1 in DT'Class; -- Compile time error
14064 -- Obj1 in Iface'Class; -- Compile time error
14066 if not Is_Class_Wide_Type
(Left_Type
)
14067 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
14068 Use_Full_View
=> True)
14069 or else (Is_Interface
(Etype
(Right_Type
))
14070 and then Interface_Present_In_Ancestor
14072 Iface
=> Etype
(Right_Type
))))
14074 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
14078 -- Ada 2005 (AI-251): Class-wide applied to interfaces
14080 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
14082 -- Support to: "Iface_CW_Typ in Typ'Class"
14084 or else Is_Interface
(Left_Type
)
14086 -- Issue error if IW_Membership operation not available in a
14087 -- configurable run time setting.
14089 if not RTE_Available
(RE_IW_Membership
) then
14091 ("dynamic membership test on interface types", N
);
14097 Make_Function_Call
(Loc
,
14098 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
14099 Parameter_Associations
=> New_List
(
14100 Make_Attribute_Reference
(Loc
,
14102 Attribute_Name
=> Name_Address
),
14103 New_Occurrence_Of
(
14104 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
14107 -- Ada 95: Normal case
14110 Build_CW_Membership
(Loc
,
14111 Obj_Tag_Node
=> Obj_Tag
,
14113 New_Occurrence_Of
(
14114 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
14116 New_Node
=> New_Node
);
14118 -- Generate the SCIL node for this class-wide membership test.
14119 -- Done here because the previous call to Build_CW_Membership
14120 -- relocates Obj_Tag.
14122 if Generate_SCIL
then
14123 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
14124 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
14125 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
14128 Result
:= New_Node
;
14131 -- Right_Type is not a class-wide type
14134 -- No need to check the tag of the object if Right_Typ is abstract
14136 if Is_Abstract_Type
(Right_Type
) then
14137 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
14142 Left_Opnd
=> Obj_Tag
,
14145 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
14148 end Tagged_Membership
;
14150 ------------------------------
14151 -- Unary_Op_Validity_Checks --
14152 ------------------------------
14154 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
14156 if Validity_Checks_On
and Validity_Check_Operands
then
14157 Ensure_Valid
(Right_Opnd
(N
));
14159 end Unary_Op_Validity_Checks
;