1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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_Short_Circuit_Operator
(N
: Node_Id
);
132 -- Common expansion processing for short-circuit boolean operators
134 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
);
135 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
136 -- where we allow comparison of "out of range" values.
138 function Expand_Composite_Equality
143 Bodies
: List_Id
) return Node_Id
;
144 -- Local recursive function used to expand equality for nested composite
145 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
146 -- to attach bodies of local functions that are created in the process. It
147 -- is the responsibility of the caller to insert those bodies at the right
148 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
149 -- the left and right sides for the comparison, and Typ is the type of the
150 -- objects to compare.
152 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
153 -- Routine to expand concatenation of a sequence of two or more operands
154 -- (in the list Operands) and replace node Cnode with the result of the
155 -- concatenation. The operands can be of any appropriate type, and can
156 -- include both arrays and singleton elements.
158 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
);
159 -- N is an N_In membership test mode, with the overflow check mode set to
160 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
161 -- integer type. This is a case where top level processing is required to
162 -- handle overflow checks in subtrees.
164 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
165 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
166 -- fixed. We do not have such a type at runtime, so the purpose of this
167 -- routine is to find the real type by looking up the tree. We also
168 -- determine if the operation must be rounded.
170 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
171 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
172 -- discriminants if it has a constrained nominal type, unless the object
173 -- is a component of an enclosing Unchecked_Union object that is subject
174 -- to a per-object constraint and the enclosing object lacks inferable
177 -- An expression of an Unchecked_Union type has inferable discriminants
178 -- if it is either a name of an object with inferable discriminants or a
179 -- qualified expression whose subtype mark denotes a constrained subtype.
181 procedure Insert_Dereference_Action
(N
: Node_Id
);
182 -- N is an expression whose type is an access. When the type of the
183 -- associated storage pool is derived from Checked_Pool, generate a
184 -- call to the 'Dereference' primitive operation.
186 function Make_Array_Comparison_Op
188 Nod
: Node_Id
) return Node_Id
;
189 -- Comparisons between arrays are expanded in line. This function produces
190 -- the body of the implementation of (a > b), where a and b are one-
191 -- dimensional arrays of some discrete type. The original node is then
192 -- expanded into the appropriate call to this function. Nod provides the
193 -- Sloc value for the generated code.
195 function Make_Boolean_Array_Op
197 N
: Node_Id
) return Node_Id
;
198 -- Boolean operations on boolean arrays are expanded in line. This function
199 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
200 -- b). It is used only the normal case and not the packed case. The type
201 -- involved, Typ, is the Boolean array type, and the logical operations in
202 -- the body are simple boolean operations. Note that Typ is always a
203 -- constrained type (the caller has ensured this by using
204 -- Convert_To_Actual_Subtype if necessary).
206 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean;
207 -- For signed arithmetic operations when the current overflow mode is
208 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
209 -- as the first thing we do. We then return. We count on the recursive
210 -- apparatus for overflow checks to call us back with an equivalent
211 -- operation that is in CHECKED mode, avoiding a recursive entry into this
212 -- routine, and that is when we will proceed with the expansion of the
213 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
214 -- these optimizations without first making this check, since there may be
215 -- operands further down the tree that are relying on the recursive calls
216 -- triggered by the top level nodes to properly process overflow checking
217 -- and remaining expansion on these nodes. Note that this call back may be
218 -- skipped if the operation is done in Bignum mode but that's fine, since
219 -- the Bignum call takes care of everything.
221 procedure Optimize_Length_Comparison
(N
: Node_Id
);
222 -- Given an expression, if it is of the form X'Length op N (or the other
223 -- way round), where N is known at compile time to be 0 or 1, and X is a
224 -- simple entity, and op is a comparison operator, optimizes it into a
225 -- comparison of First and Last.
227 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
);
228 -- Inspect and process statement list Stmt of if or case expression N for
229 -- transient controlled objects. If such objects are found, the routine
230 -- generates code to clean them up when the context of the expression is
231 -- evaluated or elaborated.
233 procedure Process_Transient_Object
237 -- Subsidiary routine to the expansion of expression_with_actions, if and
238 -- case expressions. Generate all necessary code to finalize a transient
239 -- controlled object when the enclosing context is elaborated or evaluated.
240 -- Decl denotes the declaration of the transient controlled object which is
241 -- usually the result of a controlled function call. N denotes the related
242 -- expression_with_actions, if expression, or case expression node. Stmts
243 -- denotes the statement list which contains Decl, either at the top level
244 -- or within a nested construct.
246 procedure Rewrite_Comparison
(N
: Node_Id
);
247 -- If N is the node for a comparison whose outcome can be determined at
248 -- compile time, then the node N can be rewritten with True or False. If
249 -- the outcome cannot be determined at compile time, the call has no
250 -- effect. If N is a type conversion, then this processing is applied to
251 -- its expression. If N is neither comparison nor a type conversion, the
252 -- call has no effect.
254 procedure Tagged_Membership
256 SCIL_Node
: out Node_Id
;
257 Result
: out Node_Id
);
258 -- Construct the expression corresponding to the tagged membership test.
259 -- Deals with a second operand being (or not) a class-wide type.
261 function Safe_In_Place_Array_Op
264 Op2
: Node_Id
) return Boolean;
265 -- In the context of an assignment, where the right-hand side is a boolean
266 -- operation on arrays, check whether operation can be performed in place.
268 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
269 pragma Inline
(Unary_Op_Validity_Checks
);
270 -- Performs validity checks for a unary operator
272 -------------------------------
273 -- Binary_Op_Validity_Checks --
274 -------------------------------
276 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
278 if Validity_Checks_On
and Validity_Check_Operands
then
279 Ensure_Valid
(Left_Opnd
(N
));
280 Ensure_Valid
(Right_Opnd
(N
));
282 end Binary_Op_Validity_Checks
;
284 ------------------------------------
285 -- Build_Boolean_Array_Proc_Call --
286 ------------------------------------
288 procedure Build_Boolean_Array_Proc_Call
293 Loc
: constant Source_Ptr
:= Sloc
(N
);
294 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
295 Target
: constant Node_Id
:=
296 Make_Attribute_Reference
(Loc
,
298 Attribute_Name
=> Name_Address
);
300 Arg1
: Node_Id
:= Op1
;
301 Arg2
: Node_Id
:= Op2
;
303 Proc_Name
: Entity_Id
;
306 if Kind
= N_Op_Not
then
307 if Nkind
(Op1
) in N_Binary_Op
then
309 -- Use negated version of the binary operators
311 if Nkind
(Op1
) = N_Op_And
then
312 Proc_Name
:= RTE
(RE_Vector_Nand
);
314 elsif Nkind
(Op1
) = N_Op_Or
then
315 Proc_Name
:= RTE
(RE_Vector_Nor
);
317 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
318 Proc_Name
:= RTE
(RE_Vector_Xor
);
322 Make_Procedure_Call_Statement
(Loc
,
323 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
325 Parameter_Associations
=> New_List
(
327 Make_Attribute_Reference
(Loc
,
328 Prefix
=> Left_Opnd
(Op1
),
329 Attribute_Name
=> Name_Address
),
331 Make_Attribute_Reference
(Loc
,
332 Prefix
=> Right_Opnd
(Op1
),
333 Attribute_Name
=> Name_Address
),
335 Make_Attribute_Reference
(Loc
,
336 Prefix
=> Left_Opnd
(Op1
),
337 Attribute_Name
=> Name_Length
)));
340 Proc_Name
:= RTE
(RE_Vector_Not
);
343 Make_Procedure_Call_Statement
(Loc
,
344 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
345 Parameter_Associations
=> New_List
(
348 Make_Attribute_Reference
(Loc
,
350 Attribute_Name
=> Name_Address
),
352 Make_Attribute_Reference
(Loc
,
354 Attribute_Name
=> Name_Length
)));
358 -- We use the following equivalences:
360 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
361 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
362 -- (not X) xor (not Y) = X xor Y
363 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
365 if Nkind
(Op1
) = N_Op_Not
then
366 Arg1
:= Right_Opnd
(Op1
);
367 Arg2
:= Right_Opnd
(Op2
);
369 if Kind
= N_Op_And
then
370 Proc_Name
:= RTE
(RE_Vector_Nor
);
371 elsif Kind
= N_Op_Or
then
372 Proc_Name
:= RTE
(RE_Vector_Nand
);
374 Proc_Name
:= RTE
(RE_Vector_Xor
);
378 if Kind
= N_Op_And
then
379 Proc_Name
:= RTE
(RE_Vector_And
);
380 elsif Kind
= N_Op_Or
then
381 Proc_Name
:= RTE
(RE_Vector_Or
);
382 elsif Nkind
(Op2
) = N_Op_Not
then
383 Proc_Name
:= RTE
(RE_Vector_Nxor
);
384 Arg2
:= Right_Opnd
(Op2
);
386 Proc_Name
:= RTE
(RE_Vector_Xor
);
391 Make_Procedure_Call_Statement
(Loc
,
392 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
393 Parameter_Associations
=> New_List
(
395 Make_Attribute_Reference
(Loc
,
397 Attribute_Name
=> Name_Address
),
398 Make_Attribute_Reference
(Loc
,
400 Attribute_Name
=> Name_Address
),
401 Make_Attribute_Reference
(Loc
,
403 Attribute_Name
=> Name_Length
)));
406 Rewrite
(N
, Call_Node
);
410 when RE_Not_Available
=>
412 end Build_Boolean_Array_Proc_Call
;
414 --------------------------------
415 -- Displace_Allocator_Pointer --
416 --------------------------------
418 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
419 Loc
: constant Source_Ptr
:= Sloc
(N
);
420 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
426 -- Do nothing in case of VM targets: the virtual machine will handle
427 -- interfaces directly.
429 if not Tagged_Type_Expansion
then
433 pragma Assert
(Nkind
(N
) = N_Identifier
434 and then Nkind
(Orig_Node
) = N_Allocator
);
436 PtrT
:= Etype
(Orig_Node
);
437 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
438 Etyp
:= Etype
(Expression
(Orig_Node
));
440 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
442 -- If the type of the allocator expression is not an interface type
443 -- we can generate code to reference the record component containing
444 -- the pointer to the secondary dispatch table.
446 if not Is_Interface
(Etyp
) then
448 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
451 -- 1) Get access to the allocated object
454 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
458 -- 2) Add the conversion to displace the pointer to reference
459 -- the secondary dispatch table.
461 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
462 Analyze_And_Resolve
(N
, Dtyp
);
464 -- 3) The 'access to the secondary dispatch table will be used
465 -- as the value returned by the allocator.
468 Make_Attribute_Reference
(Loc
,
469 Prefix
=> Relocate_Node
(N
),
470 Attribute_Name
=> Name_Access
));
471 Set_Etype
(N
, Saved_Typ
);
475 -- If the type of the allocator expression is an interface type we
476 -- generate a run-time call to displace "this" to reference the
477 -- component containing the pointer to the secondary dispatch table
478 -- or else raise Constraint_Error if the actual object does not
479 -- implement the target interface. This case corresponds to the
480 -- following example:
482 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
484 -- return new Iface_2'Class'(Obj);
489 Unchecked_Convert_To
(PtrT
,
490 Make_Function_Call
(Loc
,
491 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
492 Parameter_Associations
=> New_List
(
493 Unchecked_Convert_To
(RTE
(RE_Address
),
499 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
501 Analyze_And_Resolve
(N
, PtrT
);
504 end Displace_Allocator_Pointer
;
506 ---------------------------------
507 -- Expand_Allocator_Expression --
508 ---------------------------------
510 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
511 Loc
: constant Source_Ptr
:= Sloc
(N
);
512 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
513 PtrT
: constant Entity_Id
:= Etype
(N
);
514 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
516 procedure Apply_Accessibility_Check
518 Built_In_Place
: Boolean := False);
519 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
520 -- type, generate an accessibility check to verify that the level of the
521 -- type of the created object is not deeper than the level of the access
522 -- type. If the type of the qualified expression is class-wide, then
523 -- always generate the check (except in the case where it is known to be
524 -- unnecessary, see comment below). Otherwise, only generate the check
525 -- if the level of the qualified expression type is statically deeper
526 -- than the access type.
528 -- Although the static accessibility will generally have been performed
529 -- as a legality check, it won't have been done in cases where the
530 -- allocator appears in generic body, so a run-time check is needed in
531 -- general. One special case is when the access type is declared in the
532 -- same scope as the class-wide allocator, in which case the check can
533 -- never fail, so it need not be generated.
535 -- As an open issue, there seem to be cases where the static level
536 -- associated with the class-wide object's underlying type is not
537 -- sufficient to perform the proper accessibility check, such as for
538 -- allocators in nested subprograms or accept statements initialized by
539 -- class-wide formals when the actual originates outside at a deeper
540 -- static level. The nested subprogram case might require passing
541 -- accessibility levels along with class-wide parameters, and the task
542 -- case seems to be an actual gap in the language rules that needs to
543 -- be fixed by the ARG. ???
545 -------------------------------
546 -- Apply_Accessibility_Check --
547 -------------------------------
549 procedure Apply_Accessibility_Check
551 Built_In_Place
: Boolean := False)
553 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
561 if Ada_Version
>= Ada_2005
562 and then Is_Class_Wide_Type
(DesigT
)
563 and then Tagged_Type_Expansion
564 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
566 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
568 (Is_Class_Wide_Type
(Etype
(Exp
))
569 and then Scope
(PtrT
) /= Current_Scope
))
571 -- If the allocator was built in place, Ref is already a reference
572 -- to the access object initialized to the result of the allocator
573 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
574 -- Remove_Side_Effects for cases where the build-in-place call may
575 -- still be the prefix of the reference (to avoid generating
576 -- duplicate calls). Otherwise, it is the entity associated with
577 -- the object containing the address of the allocated object.
579 if Built_In_Place
then
580 Remove_Side_Effects
(Ref
);
581 Obj_Ref
:= New_Copy_Tree
(Ref
);
583 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
586 -- For access to interface types we must generate code to displace
587 -- the pointer to the base of the object since the subsequent code
588 -- references components located in the TSD of the object (which
589 -- is associated with the primary dispatch table --see a-tags.ads)
590 -- and also generates code invoking Free, which requires also a
591 -- reference to the base of the unallocated object.
593 if Is_Interface
(DesigT
) and then Tagged_Type_Expansion
then
595 Unchecked_Convert_To
(Etype
(Obj_Ref
),
596 Make_Function_Call
(Loc
,
598 New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
599 Parameter_Associations
=> New_List
(
600 Unchecked_Convert_To
(RTE
(RE_Address
),
601 New_Copy_Tree
(Obj_Ref
)))));
604 -- Step 1: Create the object clean up code
608 -- Deallocate the object if the accessibility check fails. This
609 -- is done only on targets or profiles that support deallocation.
613 if RTE_Available
(RE_Free
) then
614 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
615 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
617 Append_To
(Stmts
, Free_Stmt
);
619 -- The target or profile cannot deallocate objects
625 -- Finalize the object if applicable. Generate:
627 -- [Deep_]Finalize (Obj_Ref.all);
629 if Needs_Finalization
(DesigT
) then
633 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
636 -- When the target or profile supports deallocation, wrap the
637 -- finalization call in a block to ensure proper deallocation
638 -- even if finalization fails. Generate:
648 if Present
(Free_Stmt
) then
650 Make_Block_Statement
(Loc
,
651 Handled_Statement_Sequence
=>
652 Make_Handled_Sequence_Of_Statements
(Loc
,
653 Statements
=> New_List
(Fin_Call
),
655 Exception_Handlers
=> New_List
(
656 Make_Exception_Handler
(Loc
,
657 Exception_Choices
=> New_List
(
658 Make_Others_Choice
(Loc
)),
659 Statements
=> New_List
(
660 New_Copy_Tree
(Free_Stmt
),
661 Make_Raise_Statement
(Loc
))))));
664 Prepend_To
(Stmts
, Fin_Call
);
667 -- Signal the accessibility failure through a Program_Error
670 Make_Raise_Program_Error
(Loc
,
671 Condition
=> New_Occurrence_Of
(Standard_True
, Loc
),
672 Reason
=> PE_Accessibility_Check_Failed
));
674 -- Step 2: Create the accessibility comparison
680 Make_Attribute_Reference
(Loc
,
682 Attribute_Name
=> Name_Tag
);
684 -- For tagged types, determine the accessibility level by looking
685 -- at the type specific data of the dispatch table. Generate:
687 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
689 if Tagged_Type_Expansion
then
690 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
692 -- Use a runtime call to determine the accessibility level when
693 -- compiling on virtual machine targets. Generate:
695 -- Get_Access_Level (Ref'Tag)
699 Make_Function_Call
(Loc
,
701 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
702 Parameter_Associations
=> New_List
(Obj_Ref
));
709 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
711 -- Due to the complexity and side effects of the check, utilize an
712 -- if statement instead of the regular Program_Error circuitry.
715 Make_Implicit_If_Statement
(N
,
717 Then_Statements
=> Stmts
));
719 end Apply_Accessibility_Check
;
723 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
724 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
725 T
: constant Entity_Id
:= Entity
(Indic
);
727 Tag_Assign
: Node_Id
;
731 TagT
: Entity_Id
:= Empty
;
732 -- Type used as source for tag assignment
734 TagR
: Node_Id
:= Empty
;
735 -- Target reference for tag assignment
737 -- Start of processing for Expand_Allocator_Expression
740 -- Handle call to C++ constructor
742 if Is_CPP_Constructor_Call
(Exp
) then
743 Make_CPP_Constructor_Call_In_Allocator
745 Function_Call
=> Exp
);
749 -- In the case of an Ada 2012 allocator whose initial value comes from a
750 -- function call, pass "the accessibility level determined by the point
751 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
752 -- Expand_Call but it couldn't be done there (because the Etype of the
753 -- allocator wasn't set then) so we generate the parameter here. See
754 -- the Boolean variable Defer in (a block within) Expand_Call.
756 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
761 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
762 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
764 Subp
:= Entity
(Name
(Exp
));
767 Subp
:= Ultimate_Alias
(Subp
);
769 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
770 Add_Extra_Actual_To_Call
771 (Subprogram_Call
=> Exp
,
772 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
773 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
778 -- Case of tagged type or type requiring finalization
780 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
782 -- Ada 2005 (AI-318-02): If the initialization expression is a call
783 -- to a build-in-place function, then access to the allocated object
784 -- must be passed to the function. Currently we limit such functions
785 -- to those with constrained limited result subtypes, but eventually
786 -- we plan to expand the allowed forms of functions that are treated
787 -- as build-in-place.
789 if Ada_Version
>= Ada_2005
790 and then Is_Build_In_Place_Function_Call
(Exp
)
792 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
793 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
797 -- Actions inserted before:
798 -- Temp : constant ptr_T := new T'(Expression);
799 -- Temp._tag = T'tag; -- when not class-wide
800 -- [Deep_]Adjust (Temp.all);
802 -- We analyze by hand the new internal allocator to avoid any
803 -- recursion and inappropriate call to Initialize.
805 -- We don't want to remove side effects when the expression must be
806 -- built in place. In the case of a build-in-place function call,
807 -- that could lead to a duplication of the call, which was already
808 -- substituted for the allocator.
810 if not Aggr_In_Place
then
811 Remove_Side_Effects
(Exp
);
814 Temp
:= Make_Temporary
(Loc
, 'P', N
);
816 -- For a class wide allocation generate the following code:
818 -- type Equiv_Record is record ... end record;
819 -- implicit subtype CW is <Class_Wide_Subytpe>;
820 -- temp : PtrT := new CW'(CW!(expr));
822 if Is_Class_Wide_Type
(T
) then
823 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
825 -- Ada 2005 (AI-251): If the expression is a class-wide interface
826 -- object we generate code to move up "this" to reference the
827 -- base of the object before allocating the new object.
829 -- Note that Exp'Address is recursively expanded into a call
830 -- to Base_Address (Exp.Tag)
832 if Is_Class_Wide_Type
(Etype
(Exp
))
833 and then Is_Interface
(Etype
(Exp
))
834 and then Tagged_Type_Expansion
838 Unchecked_Convert_To
(Entity
(Indic
),
839 Make_Explicit_Dereference
(Loc
,
840 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
841 Make_Attribute_Reference
(Loc
,
843 Attribute_Name
=> Name_Address
)))));
847 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
850 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
853 -- Processing for allocators returning non-interface types
855 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
856 if Aggr_In_Place
then
858 Make_Object_Declaration
(Loc
,
859 Defining_Identifier
=> Temp
,
860 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
864 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
866 -- Copy the Comes_From_Source flag for the allocator we just
867 -- built, since logically this allocator is a replacement of
868 -- the original allocator node. This is for proper handling of
869 -- restriction No_Implicit_Heap_Allocations.
871 Set_Comes_From_Source
872 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
874 Set_No_Initialization
(Expression
(Temp_Decl
));
875 Insert_Action
(N
, Temp_Decl
);
877 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
878 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
881 Node
:= Relocate_Node
(N
);
885 Make_Object_Declaration
(Loc
,
886 Defining_Identifier
=> Temp
,
887 Constant_Present
=> True,
888 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
891 Insert_Action
(N
, Temp_Decl
);
892 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
895 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
896 -- interface type. In this case we use the type of the qualified
897 -- expression to allocate the object.
901 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
906 Make_Full_Type_Declaration
(Loc
,
907 Defining_Identifier
=> Def_Id
,
909 Make_Access_To_Object_Definition
(Loc
,
911 Null_Exclusion_Present
=> False,
913 Is_Access_Constant
(Etype
(N
)),
914 Subtype_Indication
=>
915 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
917 Insert_Action
(N
, New_Decl
);
919 -- Inherit the allocation-related attributes from the original
922 Set_Finalization_Master
923 (Def_Id
, Finalization_Master
(PtrT
));
925 Set_Associated_Storage_Pool
926 (Def_Id
, Associated_Storage_Pool
(PtrT
));
928 -- Declare the object using the previous type declaration
930 if Aggr_In_Place
then
932 Make_Object_Declaration
(Loc
,
933 Defining_Identifier
=> Temp
,
934 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
937 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
939 -- Copy the Comes_From_Source flag for the allocator we just
940 -- built, since logically this allocator is a replacement of
941 -- the original allocator node. This is for proper handling
942 -- of restriction No_Implicit_Heap_Allocations.
944 Set_Comes_From_Source
945 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
947 Set_No_Initialization
(Expression
(Temp_Decl
));
948 Insert_Action
(N
, Temp_Decl
);
950 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
951 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
954 Node
:= Relocate_Node
(N
);
958 Make_Object_Declaration
(Loc
,
959 Defining_Identifier
=> Temp
,
960 Constant_Present
=> True,
961 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
964 Insert_Action
(N
, Temp_Decl
);
965 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
968 -- Generate an additional object containing the address of the
969 -- returned object. The type of this second object declaration
970 -- is the correct type required for the common processing that
971 -- is still performed by this subprogram. The displacement of
972 -- this pointer to reference the component associated with the
973 -- interface type will be done at the end of common processing.
976 Make_Object_Declaration
(Loc
,
977 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
978 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
980 Unchecked_Convert_To
(PtrT
,
981 New_Occurrence_Of
(Temp
, Loc
)));
983 Insert_Action
(N
, New_Decl
);
985 Temp_Decl
:= New_Decl
;
986 Temp
:= Defining_Identifier
(New_Decl
);
990 -- Generate the tag assignment
992 -- Suppress the tag assignment for VM targets because VM tags are
993 -- represented implicitly in objects.
995 if not Tagged_Type_Expansion
then
998 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
999 -- interface objects because in this case the tag does not change.
1001 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1002 pragma Assert
(Is_Class_Wide_Type
1003 (Directly_Designated_Type
(Etype
(N
))));
1006 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1008 TagR
:= New_Occurrence_Of
(Temp
, Loc
);
1010 elsif Is_Private_Type
(T
)
1011 and then Is_Tagged_Type
(Underlying_Type
(T
))
1013 TagT
:= Underlying_Type
(T
);
1015 Unchecked_Convert_To
(Underlying_Type
(T
),
1016 Make_Explicit_Dereference
(Loc
,
1017 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
1020 if Present
(TagT
) then
1022 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1026 Make_Assignment_Statement
(Loc
,
1028 Make_Selected_Component
(Loc
,
1032 (First_Tag_Component
(Full_T
), Loc
)),
1035 Unchecked_Convert_To
(RTE
(RE_Tag
),
1038 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1041 -- The previous assignment has to be done in any case
1043 Set_Assignment_OK
(Name
(Tag_Assign
));
1044 Insert_Action
(N
, Tag_Assign
);
1047 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1048 -- the object may be inherently limited, in which case there is no
1049 -- Adjust procedure, and the object is built in place. In Ada 95, the
1050 -- object can be limited but not inherently limited if this allocator
1051 -- came from a return statement (we're allocating the result on the
1052 -- secondary stack). In that case, the object will be moved, so we do
1055 if Needs_Finalization
(DesigT
)
1056 and then Needs_Finalization
(T
)
1057 and then not Aggr_In_Place
1058 and then not Is_Limited_View
(T
)
1060 -- An unchecked conversion is needed in the classwide case because
1061 -- the designated type can be an ancestor of the subtype mark of
1067 Unchecked_Convert_To
(T
,
1068 Make_Explicit_Dereference
(Loc
,
1069 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
1073 -- Note: the accessibility check must be inserted after the call to
1074 -- [Deep_]Adjust to ensure proper completion of the assignment.
1076 Apply_Accessibility_Check
(Temp
);
1078 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1079 Analyze_And_Resolve
(N
, PtrT
);
1081 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1082 -- component containing the secondary dispatch table of the interface
1085 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1086 Displace_Allocator_Pointer
(N
);
1089 -- Always force the generation of a temporary for aggregates when
1090 -- generating C code, to simplify the work in the code generator.
1093 or else (Generate_C_Code
and then Nkind
(Exp
) = N_Aggregate
)
1095 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1097 Make_Object_Declaration
(Loc
,
1098 Defining_Identifier
=> Temp
,
1099 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1101 Make_Allocator
(Loc
,
1102 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1104 -- Copy the Comes_From_Source flag for the allocator we just built,
1105 -- since logically this allocator is a replacement of the original
1106 -- allocator node. This is for proper handling of restriction
1107 -- No_Implicit_Heap_Allocations.
1109 Set_Comes_From_Source
1110 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1112 Set_No_Initialization
(Expression
(Temp_Decl
));
1113 Insert_Action
(N
, Temp_Decl
);
1115 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1116 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1118 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1119 Analyze_And_Resolve
(N
, PtrT
);
1121 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1122 Install_Null_Excluding_Check
(Exp
);
1124 elsif Is_Access_Type
(DesigT
)
1125 and then Nkind
(Exp
) = N_Allocator
1126 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1128 -- Apply constraint to designated subtype indication
1130 Apply_Constraint_Check
1131 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1133 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1135 -- Propagate constraint_error to enclosing allocator
1137 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1141 Build_Allocate_Deallocate_Proc
(N
, True);
1144 -- type A is access T1;
1145 -- X : A := new T2'(...);
1146 -- T1 and T2 can be different subtypes, and we might need to check
1147 -- both constraints. First check against the type of the qualified
1150 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1152 if Do_Range_Check
(Exp
) then
1153 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1156 -- A check is also needed in cases where the designated subtype is
1157 -- constrained and differs from the subtype given in the qualified
1158 -- expression. Note that the check on the qualified expression does
1159 -- not allow sliding, but this check does (a relaxation from Ada 83).
1161 if Is_Constrained
(DesigT
)
1162 and then not Subtypes_Statically_Match
(T
, DesigT
)
1164 Apply_Constraint_Check
1165 (Exp
, DesigT
, No_Sliding
=> False);
1167 if Do_Range_Check
(Exp
) then
1168 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1172 -- For an access to unconstrained packed array, GIGI needs to see an
1173 -- expression with a constrained subtype in order to compute the
1174 -- proper size for the allocator.
1176 if Is_Array_Type
(T
)
1177 and then not Is_Constrained
(T
)
1178 and then Is_Packed
(T
)
1181 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1182 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1185 Make_Subtype_Declaration
(Loc
,
1186 Defining_Identifier
=> ConstrT
,
1187 Subtype_Indication
=>
1188 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1189 Freeze_Itype
(ConstrT
, Exp
);
1190 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1194 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1195 -- to a build-in-place function, then access to the allocated object
1196 -- must be passed to the function. Currently we limit such functions
1197 -- to those with constrained limited result subtypes, but eventually
1198 -- we plan to expand the allowed forms of functions that are treated
1199 -- as build-in-place.
1201 if Ada_Version
>= Ada_2005
1202 and then Is_Build_In_Place_Function_Call
(Exp
)
1204 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1209 when RE_Not_Available
=>
1211 end Expand_Allocator_Expression
;
1213 -----------------------------
1214 -- Expand_Array_Comparison --
1215 -----------------------------
1217 -- Expansion is only required in the case of array types. For the unpacked
1218 -- case, an appropriate runtime routine is called. For packed cases, and
1219 -- also in some other cases where a runtime routine cannot be called, the
1220 -- form of the expansion is:
1222 -- [body for greater_nn; boolean_expression]
1224 -- The body is built by Make_Array_Comparison_Op, and the form of the
1225 -- Boolean expression depends on the operator involved.
1227 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1228 Loc
: constant Source_Ptr
:= Sloc
(N
);
1229 Op1
: Node_Id
:= Left_Opnd
(N
);
1230 Op2
: Node_Id
:= Right_Opnd
(N
);
1231 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1232 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1235 Func_Body
: Node_Id
;
1236 Func_Name
: Entity_Id
;
1240 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1241 -- True for byte addressable target
1243 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1244 -- Returns True if the length of the given operand is known to be less
1245 -- than 4. Returns False if this length is known to be four or greater
1246 -- or is not known at compile time.
1248 ------------------------
1249 -- Length_Less_Than_4 --
1250 ------------------------
1252 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1253 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1256 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1257 return String_Literal_Length
(Otyp
) < 4;
1261 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1262 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1263 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1268 if Compile_Time_Known_Value
(Lo
) then
1269 Lov
:= Expr_Value
(Lo
);
1274 if Compile_Time_Known_Value
(Hi
) then
1275 Hiv
:= Expr_Value
(Hi
);
1280 return Hiv
< Lov
+ 3;
1283 end Length_Less_Than_4
;
1285 -- Start of processing for Expand_Array_Comparison
1288 -- Deal first with unpacked case, where we can call a runtime routine
1289 -- except that we avoid this for targets for which are not addressable
1292 if not Is_Bit_Packed_Array
(Typ1
)
1293 and then Byte_Addressable
1295 -- The call we generate is:
1297 -- Compare_Array_xn[_Unaligned]
1298 -- (left'address, right'address, left'length, right'length) <op> 0
1300 -- x = U for unsigned, S for signed
1301 -- n = 8,16,32,64 for component size
1302 -- Add _Unaligned if length < 4 and component size is 8.
1303 -- <op> is the standard comparison operator
1305 if Component_Size
(Typ1
) = 8 then
1306 if Length_Less_Than_4
(Op1
)
1308 Length_Less_Than_4
(Op2
)
1310 if Is_Unsigned_Type
(Ctyp
) then
1311 Comp
:= RE_Compare_Array_U8_Unaligned
;
1313 Comp
:= RE_Compare_Array_S8_Unaligned
;
1317 if Is_Unsigned_Type
(Ctyp
) then
1318 Comp
:= RE_Compare_Array_U8
;
1320 Comp
:= RE_Compare_Array_S8
;
1324 elsif Component_Size
(Typ1
) = 16 then
1325 if Is_Unsigned_Type
(Ctyp
) then
1326 Comp
:= RE_Compare_Array_U16
;
1328 Comp
:= RE_Compare_Array_S16
;
1331 elsif Component_Size
(Typ1
) = 32 then
1332 if Is_Unsigned_Type
(Ctyp
) then
1333 Comp
:= RE_Compare_Array_U32
;
1335 Comp
:= RE_Compare_Array_S32
;
1338 else pragma Assert
(Component_Size
(Typ1
) = 64);
1339 if Is_Unsigned_Type
(Ctyp
) then
1340 Comp
:= RE_Compare_Array_U64
;
1342 Comp
:= RE_Compare_Array_S64
;
1346 if RTE_Available
(Comp
) then
1348 -- Expand to a call only if the runtime function is available,
1349 -- otherwise fall back to inline code.
1351 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1352 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1355 Make_Function_Call
(Sloc
(Op1
),
1356 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1358 Parameter_Associations
=> New_List
(
1359 Make_Attribute_Reference
(Loc
,
1360 Prefix
=> Relocate_Node
(Op1
),
1361 Attribute_Name
=> Name_Address
),
1363 Make_Attribute_Reference
(Loc
,
1364 Prefix
=> Relocate_Node
(Op2
),
1365 Attribute_Name
=> Name_Address
),
1367 Make_Attribute_Reference
(Loc
,
1368 Prefix
=> Relocate_Node
(Op1
),
1369 Attribute_Name
=> Name_Length
),
1371 Make_Attribute_Reference
(Loc
,
1372 Prefix
=> Relocate_Node
(Op2
),
1373 Attribute_Name
=> Name_Length
))));
1376 Make_Integer_Literal
(Sloc
(Op2
),
1379 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1380 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1385 -- Cases where we cannot make runtime call
1387 -- For (a <= b) we convert to not (a > b)
1389 if Chars
(N
) = Name_Op_Le
then
1395 Right_Opnd
=> Op2
)));
1396 Analyze_And_Resolve
(N
, Standard_Boolean
);
1399 -- For < the Boolean expression is
1400 -- greater__nn (op2, op1)
1402 elsif Chars
(N
) = Name_Op_Lt
then
1403 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1407 Op1
:= Right_Opnd
(N
);
1408 Op2
:= Left_Opnd
(N
);
1410 -- For (a >= b) we convert to not (a < b)
1412 elsif Chars
(N
) = Name_Op_Ge
then
1418 Right_Opnd
=> Op2
)));
1419 Analyze_And_Resolve
(N
, Standard_Boolean
);
1422 -- For > the Boolean expression is
1423 -- greater__nn (op1, op2)
1426 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1427 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1430 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1432 Make_Function_Call
(Loc
,
1433 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1434 Parameter_Associations
=> New_List
(Op1
, Op2
));
1436 Insert_Action
(N
, Func_Body
);
1438 Analyze_And_Resolve
(N
, Standard_Boolean
);
1439 end Expand_Array_Comparison
;
1441 ---------------------------
1442 -- Expand_Array_Equality --
1443 ---------------------------
1445 -- Expand an equality function for multi-dimensional arrays. Here is an
1446 -- example of such a function for Nb_Dimension = 2
1448 -- function Enn (A : atyp; B : btyp) return boolean is
1450 -- if (A'length (1) = 0 or else A'length (2) = 0)
1452 -- (B'length (1) = 0 or else B'length (2) = 0)
1454 -- return True; -- RM 4.5.2(22)
1457 -- if A'length (1) /= B'length (1)
1459 -- A'length (2) /= B'length (2)
1461 -- return False; -- RM 4.5.2(23)
1465 -- A1 : Index_T1 := A'first (1);
1466 -- B1 : Index_T1 := B'first (1);
1470 -- A2 : Index_T2 := A'first (2);
1471 -- B2 : Index_T2 := B'first (2);
1474 -- if A (A1, A2) /= B (B1, B2) then
1478 -- exit when A2 = A'last (2);
1479 -- A2 := Index_T2'succ (A2);
1480 -- B2 := Index_T2'succ (B2);
1484 -- exit when A1 = A'last (1);
1485 -- A1 := Index_T1'succ (A1);
1486 -- B1 := Index_T1'succ (B1);
1493 -- Note on the formal types used (atyp and btyp). If either of the arrays
1494 -- is of a private type, we use the underlying type, and do an unchecked
1495 -- conversion of the actual. If either of the arrays has a bound depending
1496 -- on a discriminant, then we use the base type since otherwise we have an
1497 -- escaped discriminant in the function.
1499 -- If both arrays are constrained and have the same bounds, we can generate
1500 -- a loop with an explicit iteration scheme using a 'Range attribute over
1503 function Expand_Array_Equality
1508 Typ
: Entity_Id
) return Node_Id
1510 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1511 Decls
: constant List_Id
:= New_List
;
1512 Index_List1
: constant List_Id
:= New_List
;
1513 Index_List2
: constant List_Id
:= New_List
;
1517 Func_Name
: Entity_Id
;
1518 Func_Body
: Node_Id
;
1520 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1521 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1525 -- The parameter types to be used for the formals
1530 Num
: Int
) return Node_Id
;
1531 -- This builds the attribute reference Arr'Nam (Expr)
1533 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1534 -- Create one statement to compare corresponding components, designated
1535 -- by a full set of indexes.
1537 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1538 -- Given one of the arguments, computes the appropriate type to be used
1539 -- for that argument in the corresponding function formal
1541 function Handle_One_Dimension
1543 Index
: Node_Id
) return Node_Id
;
1544 -- This procedure returns the following code
1547 -- Bn : Index_T := B'First (N);
1551 -- exit when An = A'Last (N);
1552 -- An := Index_T'Succ (An)
1553 -- Bn := Index_T'Succ (Bn)
1557 -- If both indexes are constrained and identical, the procedure
1558 -- returns a simpler loop:
1560 -- for An in A'Range (N) loop
1564 -- N is the dimension for which we are generating a loop. Index is the
1565 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1566 -- xxx statement is either the loop or declare for the next dimension
1567 -- or if this is the last dimension the comparison of corresponding
1568 -- components of the arrays.
1570 -- The actual way the code works is to return the comparison of
1571 -- corresponding components for the N+1 call. That's neater.
1573 function Test_Empty_Arrays
return Node_Id
;
1574 -- This function constructs the test for both arrays being empty
1575 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1577 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1579 function Test_Lengths_Correspond
return Node_Id
;
1580 -- This function constructs the test for arrays having different lengths
1581 -- in at least one index position, in which case the resulting code is:
1583 -- A'length (1) /= B'length (1)
1585 -- A'length (2) /= B'length (2)
1596 Num
: Int
) return Node_Id
1600 Make_Attribute_Reference
(Loc
,
1601 Attribute_Name
=> Nam
,
1602 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1603 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1606 ------------------------
1607 -- Component_Equality --
1608 ------------------------
1610 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1615 -- if a(i1...) /= b(j1...) then return false; end if;
1618 Make_Indexed_Component
(Loc
,
1619 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1620 Expressions
=> Index_List1
);
1623 Make_Indexed_Component
(Loc
,
1624 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1625 Expressions
=> Index_List2
);
1627 Test
:= Expand_Composite_Equality
1628 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1630 -- If some (sub)component is an unchecked_union, the whole operation
1631 -- will raise program error.
1633 if Nkind
(Test
) = N_Raise_Program_Error
then
1635 -- This node is going to be inserted at a location where a
1636 -- statement is expected: clear its Etype so analysis will set
1637 -- it to the expected Standard_Void_Type.
1639 Set_Etype
(Test
, Empty
);
1644 Make_Implicit_If_Statement
(Nod
,
1645 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1646 Then_Statements
=> New_List
(
1647 Make_Simple_Return_Statement
(Loc
,
1648 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1650 end Component_Equality
;
1656 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1667 T
:= Underlying_Type
(T
);
1669 X
:= First_Index
(T
);
1670 while Present
(X
) loop
1671 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1673 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1686 --------------------------
1687 -- Handle_One_Dimension --
1688 ---------------------------
1690 function Handle_One_Dimension
1692 Index
: Node_Id
) return Node_Id
1694 Need_Separate_Indexes
: constant Boolean :=
1695 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1696 -- If the index types are identical, and we are working with
1697 -- constrained types, then we can use the same index for both
1700 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1703 Index_T
: Entity_Id
;
1708 if N
> Number_Dimensions
(Ltyp
) then
1709 return Component_Equality
(Ltyp
);
1712 -- Case where we generate a loop
1714 Index_T
:= Base_Type
(Etype
(Index
));
1716 if Need_Separate_Indexes
then
1717 Bn
:= Make_Temporary
(Loc
, 'B');
1722 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1723 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1725 Stm_List
:= New_List
(
1726 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1728 if Need_Separate_Indexes
then
1730 -- Generate guard for loop, followed by increments of indexes
1732 Append_To
(Stm_List
,
1733 Make_Exit_Statement
(Loc
,
1736 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1737 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1739 Append_To
(Stm_List
,
1740 Make_Assignment_Statement
(Loc
,
1741 Name
=> New_Occurrence_Of
(An
, Loc
),
1743 Make_Attribute_Reference
(Loc
,
1744 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1745 Attribute_Name
=> Name_Succ
,
1746 Expressions
=> New_List
(
1747 New_Occurrence_Of
(An
, Loc
)))));
1749 Append_To
(Stm_List
,
1750 Make_Assignment_Statement
(Loc
,
1751 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1753 Make_Attribute_Reference
(Loc
,
1754 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1755 Attribute_Name
=> Name_Succ
,
1756 Expressions
=> New_List
(
1757 New_Occurrence_Of
(Bn
, Loc
)))));
1760 -- If separate indexes, we need a declare block for An and Bn, and a
1761 -- loop without an iteration scheme.
1763 if Need_Separate_Indexes
then
1765 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1768 Make_Block_Statement
(Loc
,
1769 Declarations
=> New_List
(
1770 Make_Object_Declaration
(Loc
,
1771 Defining_Identifier
=> An
,
1772 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1773 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1775 Make_Object_Declaration
(Loc
,
1776 Defining_Identifier
=> Bn
,
1777 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1778 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1780 Handled_Statement_Sequence
=>
1781 Make_Handled_Sequence_Of_Statements
(Loc
,
1782 Statements
=> New_List
(Loop_Stm
)));
1784 -- If no separate indexes, return loop statement with explicit
1785 -- iteration scheme on its own
1789 Make_Implicit_Loop_Statement
(Nod
,
1790 Statements
=> Stm_List
,
1792 Make_Iteration_Scheme
(Loc
,
1793 Loop_Parameter_Specification
=>
1794 Make_Loop_Parameter_Specification
(Loc
,
1795 Defining_Identifier
=> An
,
1796 Discrete_Subtype_Definition
=>
1797 Arr_Attr
(A
, Name_Range
, N
))));
1800 end Handle_One_Dimension
;
1802 -----------------------
1803 -- Test_Empty_Arrays --
1804 -----------------------
1806 function Test_Empty_Arrays
return Node_Id
is
1816 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1819 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1820 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1824 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1825 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1834 Left_Opnd
=> Relocate_Node
(Alist
),
1835 Right_Opnd
=> Atest
);
1839 Left_Opnd
=> Relocate_Node
(Blist
),
1840 Right_Opnd
=> Btest
);
1847 Right_Opnd
=> Blist
);
1848 end Test_Empty_Arrays
;
1850 -----------------------------
1851 -- Test_Lengths_Correspond --
1852 -----------------------------
1854 function Test_Lengths_Correspond
return Node_Id
is
1860 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1863 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1864 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
1871 Left_Opnd
=> Relocate_Node
(Result
),
1872 Right_Opnd
=> Rtest
);
1877 end Test_Lengths_Correspond
;
1879 -- Start of processing for Expand_Array_Equality
1882 Ltyp
:= Get_Arg_Type
(Lhs
);
1883 Rtyp
:= Get_Arg_Type
(Rhs
);
1885 -- For now, if the argument types are not the same, go to the base type,
1886 -- since the code assumes that the formals have the same type. This is
1887 -- fixable in future ???
1889 if Ltyp
/= Rtyp
then
1890 Ltyp
:= Base_Type
(Ltyp
);
1891 Rtyp
:= Base_Type
(Rtyp
);
1892 pragma Assert
(Ltyp
= Rtyp
);
1895 -- Build list of formals for function
1897 Formals
:= New_List
(
1898 Make_Parameter_Specification
(Loc
,
1899 Defining_Identifier
=> A
,
1900 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
1902 Make_Parameter_Specification
(Loc
,
1903 Defining_Identifier
=> B
,
1904 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
1906 Func_Name
:= Make_Temporary
(Loc
, 'E');
1908 -- Build statement sequence for function
1911 Make_Subprogram_Body
(Loc
,
1913 Make_Function_Specification
(Loc
,
1914 Defining_Unit_Name
=> Func_Name
,
1915 Parameter_Specifications
=> Formals
,
1916 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1918 Declarations
=> Decls
,
1920 Handled_Statement_Sequence
=>
1921 Make_Handled_Sequence_Of_Statements
(Loc
,
1922 Statements
=> New_List
(
1924 Make_Implicit_If_Statement
(Nod
,
1925 Condition
=> Test_Empty_Arrays
,
1926 Then_Statements
=> New_List
(
1927 Make_Simple_Return_Statement
(Loc
,
1929 New_Occurrence_Of
(Standard_True
, Loc
)))),
1931 Make_Implicit_If_Statement
(Nod
,
1932 Condition
=> Test_Lengths_Correspond
,
1933 Then_Statements
=> New_List
(
1934 Make_Simple_Return_Statement
(Loc
,
1935 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
1937 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
1939 Make_Simple_Return_Statement
(Loc
,
1940 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1942 Set_Has_Completion
(Func_Name
, True);
1943 Set_Is_Inlined
(Func_Name
);
1945 -- If the array type is distinct from the type of the arguments, it
1946 -- is the full view of a private type. Apply an unchecked conversion
1947 -- to insure that analysis of the call succeeds.
1957 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1959 L
:= OK_Convert_To
(Ltyp
, Lhs
);
1963 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1965 R
:= OK_Convert_To
(Rtyp
, Rhs
);
1968 Actuals
:= New_List
(L
, R
);
1971 Append_To
(Bodies
, Func_Body
);
1974 Make_Function_Call
(Loc
,
1975 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1976 Parameter_Associations
=> Actuals
);
1977 end Expand_Array_Equality
;
1979 -----------------------------
1980 -- Expand_Boolean_Operator --
1981 -----------------------------
1983 -- Note that we first get the actual subtypes of the operands, since we
1984 -- always want to deal with types that have bounds.
1986 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
1987 Typ
: constant Entity_Id
:= Etype
(N
);
1990 -- Special case of bit packed array where both operands are known to be
1991 -- properly aligned. In this case we use an efficient run time routine
1992 -- to carry out the operation (see System.Bit_Ops).
1994 if Is_Bit_Packed_Array
(Typ
)
1995 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
1996 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
1998 Expand_Packed_Boolean_Operator
(N
);
2002 -- For the normal non-packed case, the general expansion is to build
2003 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2004 -- and then inserting it into the tree. The original operator node is
2005 -- then rewritten as a call to this function. We also use this in the
2006 -- packed case if either operand is a possibly unaligned object.
2009 Loc
: constant Source_Ptr
:= Sloc
(N
);
2010 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2011 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2012 Func_Body
: Node_Id
;
2013 Func_Name
: Entity_Id
;
2016 Convert_To_Actual_Subtype
(L
);
2017 Convert_To_Actual_Subtype
(R
);
2018 Ensure_Defined
(Etype
(L
), N
);
2019 Ensure_Defined
(Etype
(R
), N
);
2020 Apply_Length_Check
(R
, Etype
(L
));
2022 if Nkind
(N
) = N_Op_Xor
then
2023 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2026 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2027 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2029 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2031 elsif Nkind
(Parent
(N
)) = N_Op_Not
2032 and then Nkind
(N
) = N_Op_And
2033 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2034 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2039 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2040 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2041 Insert_Action
(N
, Func_Body
);
2043 -- Now rewrite the expression with a call
2046 Make_Function_Call
(Loc
,
2047 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2048 Parameter_Associations
=>
2051 Make_Type_Conversion
2052 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2054 Analyze_And_Resolve
(N
, Typ
);
2057 end Expand_Boolean_Operator
;
2059 ------------------------------------------------
2060 -- Expand_Compare_Minimize_Eliminate_Overflow --
2061 ------------------------------------------------
2063 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2064 Loc
: constant Source_Ptr
:= Sloc
(N
);
2066 Result_Type
: constant Entity_Id
:= Etype
(N
);
2067 -- Capture result type (could be a derived boolean type)
2072 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2073 -- Entity for Long_Long_Integer'Base
2075 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2076 -- Current overflow checking mode
2079 procedure Set_False
;
2080 -- These procedures rewrite N with an occurrence of Standard_True or
2081 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2087 procedure Set_False
is
2089 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2090 Warn_On_Known_Condition
(N
);
2097 procedure Set_True
is
2099 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2100 Warn_On_Known_Condition
(N
);
2103 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2106 -- Nothing to do unless we have a comparison operator with operands
2107 -- that are signed integer types, and we are operating in either
2108 -- MINIMIZED or ELIMINATED overflow checking mode.
2110 if Nkind
(N
) not in N_Op_Compare
2111 or else Check
not in Minimized_Or_Eliminated
2112 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2117 -- OK, this is the case we are interested in. First step is to process
2118 -- our operands using the Minimize_Eliminate circuitry which applies
2119 -- this processing to the two operand subtrees.
2121 Minimize_Eliminate_Overflows
2122 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2123 Minimize_Eliminate_Overflows
2124 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2126 -- See if the range information decides the result of the comparison.
2127 -- We can only do this if we in fact have full range information (which
2128 -- won't be the case if either operand is bignum at this stage).
2130 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2131 case N_Op_Compare
(Nkind
(N
)) is
2133 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2135 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2142 elsif Lhi
< Rlo
then
2149 elsif Lhi
<= Rlo
then
2156 elsif Lhi
<= Rlo
then
2163 elsif Lhi
< Rlo
then
2168 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2170 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2175 -- All done if we did the rewrite
2177 if Nkind
(N
) not in N_Op_Compare
then
2182 -- Otherwise, time to do the comparison
2185 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2186 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2189 -- If the two operands have the same signed integer type we are
2190 -- all set, nothing more to do. This is the case where either
2191 -- both operands were unchanged, or we rewrote both of them to
2192 -- be Long_Long_Integer.
2194 -- Note: Entity for the comparison may be wrong, but it's not worth
2195 -- the effort to change it, since the back end does not use it.
2197 if Is_Signed_Integer_Type
(Ltype
)
2198 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2202 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2204 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2206 Left
: Node_Id
:= Left_Opnd
(N
);
2207 Right
: Node_Id
:= Right_Opnd
(N
);
2208 -- Bignum references for left and right operands
2211 if not Is_RTE
(Ltype
, RE_Bignum
) then
2212 Left
:= Convert_To_Bignum
(Left
);
2213 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2214 Right
:= Convert_To_Bignum
(Right
);
2217 -- We rewrite our node with:
2220 -- Bnn : Result_Type;
2222 -- M : Mark_Id := SS_Mark;
2224 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2232 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2233 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2237 case N_Op_Compare
(Nkind
(N
)) is
2238 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2239 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2240 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2241 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2242 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2243 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2246 -- Insert assignment to Bnn into the bignum block
2249 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2250 Make_Assignment_Statement
(Loc
,
2251 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2253 Make_Function_Call
(Loc
,
2255 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2256 Parameter_Associations
=> New_List
(Left
, Right
))));
2258 -- Now do the rewrite with expression actions
2261 Make_Expression_With_Actions
(Loc
,
2262 Actions
=> New_List
(
2263 Make_Object_Declaration
(Loc
,
2264 Defining_Identifier
=> Bnn
,
2265 Object_Definition
=>
2266 New_Occurrence_Of
(Result_Type
, Loc
)),
2268 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2269 Analyze_And_Resolve
(N
, Result_Type
);
2273 -- No bignums involved, but types are different, so we must have
2274 -- rewritten one of the operands as a Long_Long_Integer but not
2277 -- If left operand is Long_Long_Integer, convert right operand
2278 -- and we are done (with a comparison of two Long_Long_Integers).
2280 elsif Ltype
= LLIB
then
2281 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2282 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2285 -- If right operand is Long_Long_Integer, convert left operand
2286 -- and we are done (with a comparison of two Long_Long_Integers).
2288 -- This is the only remaining possibility
2290 else pragma Assert
(Rtype
= LLIB
);
2291 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2292 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2296 end Expand_Compare_Minimize_Eliminate_Overflow
;
2298 -------------------------------
2299 -- Expand_Composite_Equality --
2300 -------------------------------
2302 -- This function is only called for comparing internal fields of composite
2303 -- types when these fields are themselves composites. This is a special
2304 -- case because it is not possible to respect normal Ada visibility rules.
2306 function Expand_Composite_Equality
2311 Bodies
: List_Id
) return Node_Id
2313 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2314 Full_Type
: Entity_Id
;
2318 function Find_Primitive_Eq
return Node_Id
;
2319 -- AI05-0123: Locate primitive equality for type if it exists, and
2320 -- build the corresponding call. If operation is abstract, replace
2321 -- call with an explicit raise. Return Empty if there is no primitive.
2323 -----------------------
2324 -- Find_Primitive_Eq --
2325 -----------------------
2327 function Find_Primitive_Eq
return Node_Id
is
2332 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2333 while Present
(Prim_E
) loop
2334 Prim
:= Node
(Prim_E
);
2336 -- Locate primitive equality with the right signature
2338 if Chars
(Prim
) = Name_Op_Eq
2339 and then Etype
(First_Formal
(Prim
)) =
2340 Etype
(Next_Formal
(First_Formal
(Prim
)))
2341 and then Etype
(Prim
) = Standard_Boolean
2343 if Is_Abstract_Subprogram
(Prim
) then
2345 Make_Raise_Program_Error
(Loc
,
2346 Reason
=> PE_Explicit_Raise
);
2350 Make_Function_Call
(Loc
,
2351 Name
=> New_Occurrence_Of
(Prim
, Loc
),
2352 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2359 -- If not found, predefined operation will be used
2362 end Find_Primitive_Eq
;
2364 -- Start of processing for Expand_Composite_Equality
2367 if Is_Private_Type
(Typ
) then
2368 Full_Type
:= Underlying_Type
(Typ
);
2373 -- If the private type has no completion the context may be the
2374 -- expansion of a composite equality for a composite type with some
2375 -- still incomplete components. The expression will not be analyzed
2376 -- until the enclosing type is completed, at which point this will be
2377 -- properly expanded, unless there is a bona fide completion error.
2379 if No
(Full_Type
) then
2380 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2383 Full_Type
:= Base_Type
(Full_Type
);
2385 -- When the base type itself is private, use the full view to expand
2386 -- the composite equality.
2388 if Is_Private_Type
(Full_Type
) then
2389 Full_Type
:= Underlying_Type
(Full_Type
);
2392 -- Case of array types
2394 if Is_Array_Type
(Full_Type
) then
2396 -- If the operand is an elementary type other than a floating-point
2397 -- type, then we can simply use the built-in block bitwise equality,
2398 -- since the predefined equality operators always apply and bitwise
2399 -- equality is fine for all these cases.
2401 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2402 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2404 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2406 -- For composite component types, and floating-point types, use the
2407 -- expansion. This deals with tagged component types (where we use
2408 -- the applicable equality routine) and floating-point, (where we
2409 -- need to worry about negative zeroes), and also the case of any
2410 -- composite type recursively containing such fields.
2413 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2416 -- Case of tagged record types
2418 elsif Is_Tagged_Type
(Full_Type
) then
2420 -- Call the primitive operation "=" of this type
2422 if Is_Class_Wide_Type
(Full_Type
) then
2423 Full_Type
:= Root_Type
(Full_Type
);
2426 -- If this is derived from an untagged private type completed with a
2427 -- tagged type, it does not have a full view, so we use the primitive
2428 -- operations of the private type. This check should no longer be
2429 -- necessary when these types receive their full views ???
2431 if Is_Private_Type
(Typ
)
2432 and then not Is_Tagged_Type
(Typ
)
2433 and then not Is_Controlled
(Typ
)
2434 and then Is_Derived_Type
(Typ
)
2435 and then No
(Full_View
(Typ
))
2437 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2439 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2443 Eq_Op
:= Node
(Prim
);
2444 exit when Chars
(Eq_Op
) = Name_Op_Eq
2445 and then Etype
(First_Formal
(Eq_Op
)) =
2446 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2447 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2449 pragma Assert
(Present
(Prim
));
2452 Eq_Op
:= Node
(Prim
);
2455 Make_Function_Call
(Loc
,
2456 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2457 Parameter_Associations
=>
2459 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2460 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2462 -- Case of untagged record types
2464 elsif Is_Record_Type
(Full_Type
) then
2465 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2467 if Present
(Eq_Op
) then
2468 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2470 -- Inherited equality from parent type. Convert the actuals to
2471 -- match signature of operation.
2474 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2478 Make_Function_Call
(Loc
,
2479 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2480 Parameter_Associations
=> New_List
(
2481 OK_Convert_To
(T
, Lhs
),
2482 OK_Convert_To
(T
, Rhs
)));
2486 -- Comparison between Unchecked_Union components
2488 if Is_Unchecked_Union
(Full_Type
) then
2490 Lhs_Type
: Node_Id
:= Full_Type
;
2491 Rhs_Type
: Node_Id
:= Full_Type
;
2492 Lhs_Discr_Val
: Node_Id
;
2493 Rhs_Discr_Val
: Node_Id
;
2498 if Nkind
(Lhs
) = N_Selected_Component
then
2499 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2504 if Nkind
(Rhs
) = N_Selected_Component
then
2505 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2508 -- Lhs of the composite equality
2510 if Is_Constrained
(Lhs_Type
) then
2512 -- Since the enclosing record type can never be an
2513 -- Unchecked_Union (this code is executed for records
2514 -- that do not have variants), we may reference its
2517 if Nkind
(Lhs
) = N_Selected_Component
2518 and then Has_Per_Object_Constraint
2519 (Entity
(Selector_Name
(Lhs
)))
2522 Make_Selected_Component
(Loc
,
2523 Prefix
=> Prefix
(Lhs
),
2526 (Get_Discriminant_Value
2527 (First_Discriminant
(Lhs_Type
),
2529 Stored_Constraint
(Lhs_Type
))));
2534 (Get_Discriminant_Value
2535 (First_Discriminant
(Lhs_Type
),
2537 Stored_Constraint
(Lhs_Type
)));
2541 -- It is not possible to infer the discriminant since
2542 -- the subtype is not constrained.
2545 Make_Raise_Program_Error
(Loc
,
2546 Reason
=> PE_Unchecked_Union_Restriction
);
2549 -- Rhs of the composite equality
2551 if Is_Constrained
(Rhs_Type
) then
2552 if Nkind
(Rhs
) = N_Selected_Component
2553 and then Has_Per_Object_Constraint
2554 (Entity
(Selector_Name
(Rhs
)))
2557 Make_Selected_Component
(Loc
,
2558 Prefix
=> Prefix
(Rhs
),
2561 (Get_Discriminant_Value
2562 (First_Discriminant
(Rhs_Type
),
2564 Stored_Constraint
(Rhs_Type
))));
2569 (Get_Discriminant_Value
2570 (First_Discriminant
(Rhs_Type
),
2572 Stored_Constraint
(Rhs_Type
)));
2577 Make_Raise_Program_Error
(Loc
,
2578 Reason
=> PE_Unchecked_Union_Restriction
);
2581 -- Call the TSS equality function with the inferred
2582 -- discriminant values.
2585 Make_Function_Call
(Loc
,
2586 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2587 Parameter_Associations
=> New_List
(
2594 -- All cases other than comparing Unchecked_Union types
2598 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2601 Make_Function_Call
(Loc
,
2603 New_Occurrence_Of
(Eq_Op
, Loc
),
2604 Parameter_Associations
=> New_List
(
2605 OK_Convert_To
(T
, Lhs
),
2606 OK_Convert_To
(T
, Rhs
)));
2611 -- Equality composes in Ada 2012 for untagged record types. It also
2612 -- composes for bounded strings, because they are part of the
2613 -- predefined environment. We could make it compose for bounded
2614 -- strings by making them tagged, or by making sure all subcomponents
2615 -- are set to the same value, even when not used. Instead, we have
2616 -- this special case in the compiler, because it's more efficient.
2618 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2620 -- If no TSS has been created for the type, check whether there is
2621 -- a primitive equality declared for it.
2624 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2627 -- Use user-defined primitive if it exists, otherwise use
2628 -- predefined equality.
2630 if Present
(Op
) then
2633 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2638 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2641 -- Non-composite types (always use predefined equality)
2644 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2646 end Expand_Composite_Equality
;
2648 ------------------------
2649 -- Expand_Concatenate --
2650 ------------------------
2652 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2653 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2655 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2656 -- Result type of concatenation
2658 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2659 -- Component type. Elements of this component type can appear as one
2660 -- of the operands of concatenation as well as arrays.
2662 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2665 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2666 -- Index type. This is the base type of the index subtype, and is used
2667 -- for all computed bounds (which may be out of range of Istyp in the
2668 -- case of null ranges).
2671 -- This is the type we use to do arithmetic to compute the bounds and
2672 -- lengths of operands. The choice of this type is a little subtle and
2673 -- is discussed in a separate section at the start of the body code.
2675 Concatenation_Error
: exception;
2676 -- Raised if concatenation is sure to raise a CE
2678 Result_May_Be_Null
: Boolean := True;
2679 -- Reset to False if at least one operand is encountered which is known
2680 -- at compile time to be non-null. Used for handling the special case
2681 -- of setting the high bound to the last operand high bound for a null
2682 -- result, thus ensuring a proper high bound in the super-flat case.
2684 N
: constant Nat
:= List_Length
(Opnds
);
2685 -- Number of concatenation operands including possibly null operands
2688 -- Number of operands excluding any known to be null, except that the
2689 -- last operand is always retained, in case it provides the bounds for
2693 -- Current operand being processed in the loop through operands. After
2694 -- this loop is complete, always contains the last operand (which is not
2695 -- the same as Operands (NN), since null operands are skipped).
2697 -- Arrays describing the operands, only the first NN entries of each
2698 -- array are set (NN < N when we exclude known null operands).
2700 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2701 -- True if length of corresponding operand known at compile time
2703 Operands
: array (1 .. N
) of Node_Id
;
2704 -- Set to the corresponding entry in the Opnds list (but note that null
2705 -- operands are excluded, so not all entries in the list are stored).
2707 Fixed_Length
: array (1 .. N
) of Uint
;
2708 -- Set to length of operand. Entries in this array are set only if the
2709 -- corresponding entry in Is_Fixed_Length is True.
2711 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2712 -- Set to lower bound of operand. Either an integer literal in the case
2713 -- where the bound is known at compile time, else actual lower bound.
2714 -- The operand low bound is of type Ityp.
2716 Var_Length
: array (1 .. N
) of Entity_Id
;
2717 -- Set to an entity of type Natural that contains the length of an
2718 -- operand whose length is not known at compile time. Entries in this
2719 -- array are set only if the corresponding entry in Is_Fixed_Length
2720 -- is False. The entity is of type Artyp.
2722 Aggr_Length
: array (0 .. N
) of Node_Id
;
2723 -- The J'th entry in an expression node that represents the total length
2724 -- of operands 1 through J. It is either an integer literal node, or a
2725 -- reference to a constant entity with the right value, so it is fine
2726 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2727 -- entry always is set to zero. The length is of type Artyp.
2729 Low_Bound
: Node_Id
;
2730 -- A tree node representing the low bound of the result (of type Ityp).
2731 -- This is either an integer literal node, or an identifier reference to
2732 -- a constant entity initialized to the appropriate value.
2734 Last_Opnd_Low_Bound
: Node_Id
;
2735 -- A tree node representing the low bound of the last operand. This
2736 -- need only be set if the result could be null. It is used for the
2737 -- special case of setting the right low bound for a null result.
2738 -- This is of type Ityp.
2740 Last_Opnd_High_Bound
: Node_Id
;
2741 -- A tree node representing the high bound of the last operand. This
2742 -- need only be set if the result could be null. It is used for the
2743 -- special case of setting the right high bound for a null result.
2744 -- This is of type Ityp.
2746 High_Bound
: Node_Id
;
2747 -- A tree node representing the high bound of the result (of type Ityp)
2750 -- Result of the concatenation (of type Ityp)
2752 Actions
: constant List_Id
:= New_List
;
2753 -- Collect actions to be inserted
2755 Known_Non_Null_Operand_Seen
: Boolean;
2756 -- Set True during generation of the assignments of operands into
2757 -- result once an operand known to be non-null has been seen.
2759 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2760 -- This function makes an N_Integer_Literal node that is returned in
2761 -- analyzed form with the type set to Artyp. Importantly this literal
2762 -- is not flagged as static, so that if we do computations with it that
2763 -- result in statically detected out of range conditions, we will not
2764 -- generate error messages but instead warning messages.
2766 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2767 -- Given a node of type Ityp, returns the corresponding value of type
2768 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2769 -- For enum types, the Pos of the value is returned.
2771 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2772 -- The inverse function (uses Val in the case of enumeration types)
2774 ------------------------
2775 -- Make_Artyp_Literal --
2776 ------------------------
2778 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2779 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2781 Set_Etype
(Result
, Artyp
);
2782 Set_Analyzed
(Result
, True);
2783 Set_Is_Static_Expression
(Result
, False);
2785 end Make_Artyp_Literal
;
2791 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2793 if Ityp
= Base_Type
(Artyp
) then
2796 elsif Is_Enumeration_Type
(Ityp
) then
2798 Make_Attribute_Reference
(Loc
,
2799 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2800 Attribute_Name
=> Name_Pos
,
2801 Expressions
=> New_List
(X
));
2804 return Convert_To
(Artyp
, X
);
2812 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2814 if Is_Enumeration_Type
(Ityp
) then
2816 Make_Attribute_Reference
(Loc
,
2817 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2818 Attribute_Name
=> Name_Val
,
2819 Expressions
=> New_List
(X
));
2821 -- Case where we will do a type conversion
2824 if Ityp
= Base_Type
(Artyp
) then
2827 return Convert_To
(Ityp
, X
);
2832 -- Local Declarations
2834 Lib_Level_Target
: constant Boolean :=
2835 Nkind
(Parent
(Cnode
)) = N_Object_Declaration
2837 Is_Library_Level_Entity
(Defining_Identifier
(Parent
(Cnode
)));
2839 -- If the concatenation declares a library level entity, we call the
2840 -- built-in concatenation routines to prevent code bloat, regardless
2841 -- of optimization level. This is space-efficient, and prevent linking
2842 -- problems when units are compiled with different optimizations.
2844 Opnd_Typ
: Entity_Id
;
2851 -- Start of processing for Expand_Concatenate
2854 -- Choose an appropriate computational type
2856 -- We will be doing calculations of lengths and bounds in this routine
2857 -- and computing one from the other in some cases, e.g. getting the high
2858 -- bound by adding the length-1 to the low bound.
2860 -- We can't just use the index type, or even its base type for this
2861 -- purpose for two reasons. First it might be an enumeration type which
2862 -- is not suitable for computations of any kind, and second it may
2863 -- simply not have enough range. For example if the index type is
2864 -- -128..+127 then lengths can be up to 256, which is out of range of
2867 -- For enumeration types, we can simply use Standard_Integer, this is
2868 -- sufficient since the actual number of enumeration literals cannot
2869 -- possibly exceed the range of integer (remember we will be doing the
2870 -- arithmetic with POS values, not representation values).
2872 if Is_Enumeration_Type
(Ityp
) then
2873 Artyp
:= Standard_Integer
;
2875 -- If index type is Positive, we use the standard unsigned type, to give
2876 -- more room on the top of the range, obviating the need for an overflow
2877 -- check when creating the upper bound. This is needed to avoid junk
2878 -- overflow checks in the common case of String types.
2880 -- ??? Disabled for now
2882 -- elsif Istyp = Standard_Positive then
2883 -- Artyp := Standard_Unsigned;
2885 -- For modular types, we use a 32-bit modular type for types whose size
2886 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2887 -- identity type, and for larger unsigned types we use 64-bits.
2889 elsif Is_Modular_Integer_Type
(Ityp
) then
2890 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
2891 Artyp
:= Standard_Unsigned
;
2892 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
2895 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
2898 -- Similar treatment for signed types
2901 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
2902 Artyp
:= Standard_Integer
;
2903 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
2906 Artyp
:= Standard_Long_Long_Integer
;
2910 -- Supply dummy entry at start of length array
2912 Aggr_Length
(0) := Make_Artyp_Literal
(0);
2914 -- Go through operands setting up the above arrays
2918 Opnd
:= Remove_Head
(Opnds
);
2919 Opnd_Typ
:= Etype
(Opnd
);
2921 -- The parent got messed up when we put the operands in a list,
2922 -- so now put back the proper parent for the saved operand, that
2923 -- is to say the concatenation node, to make sure that each operand
2924 -- is seen as a subexpression, e.g. if actions must be inserted.
2926 Set_Parent
(Opnd
, Cnode
);
2928 -- Set will be True when we have setup one entry in the array
2932 -- Singleton element (or character literal) case
2934 if Base_Type
(Opnd_Typ
) = Ctyp
then
2936 Operands
(NN
) := Opnd
;
2937 Is_Fixed_Length
(NN
) := True;
2938 Fixed_Length
(NN
) := Uint_1
;
2939 Result_May_Be_Null
:= False;
2941 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2942 -- since we know that the result cannot be null).
2944 Opnd_Low_Bound
(NN
) :=
2945 Make_Attribute_Reference
(Loc
,
2946 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
2947 Attribute_Name
=> Name_First
);
2951 -- String literal case (can only occur for strings of course)
2953 elsif Nkind
(Opnd
) = N_String_Literal
then
2954 Len
:= String_Literal_Length
(Opnd_Typ
);
2957 Result_May_Be_Null
:= False;
2960 -- Capture last operand low and high bound if result could be null
2962 if J
= N
and then Result_May_Be_Null
then
2963 Last_Opnd_Low_Bound
:=
2964 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2966 Last_Opnd_High_Bound
:=
2967 Make_Op_Subtract
(Loc
,
2969 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
2970 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
2973 -- Skip null string literal
2975 if J
< N
and then Len
= 0 then
2980 Operands
(NN
) := Opnd
;
2981 Is_Fixed_Length
(NN
) := True;
2983 -- Set length and bounds
2985 Fixed_Length
(NN
) := Len
;
2987 Opnd_Low_Bound
(NN
) :=
2988 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2995 -- Check constrained case with known bounds
2997 if Is_Constrained
(Opnd_Typ
) then
2999 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3000 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3001 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3002 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3005 -- Fixed length constrained array type with known at compile
3006 -- time bounds is last case of fixed length operand.
3008 if Compile_Time_Known_Value
(Lo
)
3010 Compile_Time_Known_Value
(Hi
)
3013 Loval
: constant Uint
:= Expr_Value
(Lo
);
3014 Hival
: constant Uint
:= Expr_Value
(Hi
);
3015 Len
: constant Uint
:=
3016 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3020 Result_May_Be_Null
:= False;
3023 -- Capture last operand bounds if result could be null
3025 if J
= N
and then Result_May_Be_Null
then
3026 Last_Opnd_Low_Bound
:=
3028 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3030 Last_Opnd_High_Bound
:=
3032 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3035 -- Exclude null length case unless last operand
3037 if J
< N
and then Len
= 0 then
3042 Operands
(NN
) := Opnd
;
3043 Is_Fixed_Length
(NN
) := True;
3044 Fixed_Length
(NN
) := Len
;
3046 Opnd_Low_Bound
(NN
) :=
3048 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3055 -- All cases where the length is not known at compile time, or the
3056 -- special case of an operand which is known to be null but has a
3057 -- lower bound other than 1 or is other than a string type.
3062 -- Capture operand bounds
3064 Opnd_Low_Bound
(NN
) :=
3065 Make_Attribute_Reference
(Loc
,
3067 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3068 Attribute_Name
=> Name_First
);
3070 -- Capture last operand bounds if result could be null
3072 if J
= N
and Result_May_Be_Null
then
3073 Last_Opnd_Low_Bound
:=
3075 Make_Attribute_Reference
(Loc
,
3077 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3078 Attribute_Name
=> Name_First
));
3080 Last_Opnd_High_Bound
:=
3082 Make_Attribute_Reference
(Loc
,
3084 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3085 Attribute_Name
=> Name_Last
));
3088 -- Capture length of operand in entity
3090 Operands
(NN
) := Opnd
;
3091 Is_Fixed_Length
(NN
) := False;
3093 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3096 Make_Object_Declaration
(Loc
,
3097 Defining_Identifier
=> Var_Length
(NN
),
3098 Constant_Present
=> True,
3099 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3101 Make_Attribute_Reference
(Loc
,
3103 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3104 Attribute_Name
=> Name_Length
)));
3108 -- Set next entry in aggregate length array
3110 -- For first entry, make either integer literal for fixed length
3111 -- or a reference to the saved length for variable length.
3114 if Is_Fixed_Length
(1) then
3115 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3117 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
3120 -- If entry is fixed length and only fixed lengths so far, make
3121 -- appropriate new integer literal adding new length.
3123 elsif Is_Fixed_Length
(NN
)
3124 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3127 Make_Integer_Literal
(Loc
,
3128 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3130 -- All other cases, construct an addition node for the length and
3131 -- create an entity initialized to this length.
3134 Ent
:= Make_Temporary
(Loc
, 'L');
3136 if Is_Fixed_Length
(NN
) then
3137 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3139 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3143 Make_Object_Declaration
(Loc
,
3144 Defining_Identifier
=> Ent
,
3145 Constant_Present
=> True,
3146 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3149 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
3150 Right_Opnd
=> Clen
)));
3152 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3159 -- If we have only skipped null operands, return the last operand
3166 -- If we have only one non-null operand, return it and we are done.
3167 -- There is one case in which this cannot be done, and that is when
3168 -- the sole operand is of the element type, in which case it must be
3169 -- converted to an array, and the easiest way of doing that is to go
3170 -- through the normal general circuit.
3172 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3173 Result
:= Operands
(1);
3177 -- Cases where we have a real concatenation
3179 -- Next step is to find the low bound for the result array that we
3180 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3182 -- If the ultimate ancestor of the index subtype is a constrained array
3183 -- definition, then the lower bound is that of the index subtype as
3184 -- specified by (RM 4.5.3(6)).
3186 -- The right test here is to go to the root type, and then the ultimate
3187 -- ancestor is the first subtype of this root type.
3189 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3191 Make_Attribute_Reference
(Loc
,
3193 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3194 Attribute_Name
=> Name_First
);
3196 -- If the first operand in the list has known length we know that
3197 -- the lower bound of the result is the lower bound of this operand.
3199 elsif Is_Fixed_Length
(1) then
3200 Low_Bound
:= Opnd_Low_Bound
(1);
3202 -- OK, we don't know the lower bound, we have to build a horrible
3203 -- if expression node of the form
3205 -- if Cond1'Length /= 0 then
3208 -- if Opnd2'Length /= 0 then
3213 -- The nesting ends either when we hit an operand whose length is known
3214 -- at compile time, or on reaching the last operand, whose low bound we
3215 -- take unconditionally whether or not it is null. It's easiest to do
3216 -- this with a recursive procedure:
3220 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3221 -- Returns the lower bound determined by operands J .. NN
3223 ---------------------
3224 -- Get_Known_Bound --
3225 ---------------------
3227 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3229 if Is_Fixed_Length
(J
) or else J
= NN
then
3230 return New_Copy
(Opnd_Low_Bound
(J
));
3234 Make_If_Expression
(Loc
,
3235 Expressions
=> New_List
(
3239 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3241 Make_Integer_Literal
(Loc
, 0)),
3243 New_Copy
(Opnd_Low_Bound
(J
)),
3244 Get_Known_Bound
(J
+ 1)));
3246 end Get_Known_Bound
;
3249 Ent
:= Make_Temporary
(Loc
, 'L');
3252 Make_Object_Declaration
(Loc
,
3253 Defining_Identifier
=> Ent
,
3254 Constant_Present
=> True,
3255 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3256 Expression
=> Get_Known_Bound
(1)));
3258 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3262 -- Now we can safely compute the upper bound, normally
3263 -- Low_Bound + Length - 1.
3268 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3270 Make_Op_Subtract
(Loc
,
3271 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3272 Right_Opnd
=> Make_Artyp_Literal
(1))));
3274 -- Note that calculation of the high bound may cause overflow in some
3275 -- very weird cases, so in the general case we need an overflow check on
3276 -- the high bound. We can avoid this for the common case of string types
3277 -- and other types whose index is Positive, since we chose a wider range
3278 -- for the arithmetic type.
3280 if Istyp
/= Standard_Positive
then
3281 Activate_Overflow_Check
(High_Bound
);
3284 -- Handle the exceptional case where the result is null, in which case
3285 -- case the bounds come from the last operand (so that we get the proper
3286 -- bounds if the last operand is super-flat).
3288 if Result_May_Be_Null
then
3290 Make_If_Expression
(Loc
,
3291 Expressions
=> New_List
(
3293 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3294 Right_Opnd
=> Make_Artyp_Literal
(0)),
3295 Last_Opnd_Low_Bound
,
3299 Make_If_Expression
(Loc
,
3300 Expressions
=> New_List
(
3302 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3303 Right_Opnd
=> Make_Artyp_Literal
(0)),
3304 Last_Opnd_High_Bound
,
3308 -- Here is where we insert the saved up actions
3310 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3312 -- Now we construct an array object with appropriate bounds. We mark
3313 -- the target as internal to prevent useless initialization when
3314 -- Initialize_Scalars is enabled. Also since this is the actual result
3315 -- entity, we make sure we have debug information for the result.
3317 Ent
:= Make_Temporary
(Loc
, 'S');
3318 Set_Is_Internal
(Ent
);
3319 Set_Needs_Debug_Info
(Ent
);
3321 -- If the bound is statically known to be out of range, we do not want
3322 -- to abort, we want a warning and a runtime constraint error. Note that
3323 -- we have arranged that the result will not be treated as a static
3324 -- constant, so we won't get an illegality during this insertion.
3326 Insert_Action
(Cnode
,
3327 Make_Object_Declaration
(Loc
,
3328 Defining_Identifier
=> Ent
,
3329 Object_Definition
=>
3330 Make_Subtype_Indication
(Loc
,
3331 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3333 Make_Index_Or_Discriminant_Constraint
(Loc
,
3334 Constraints
=> New_List
(
3336 Low_Bound
=> Low_Bound
,
3337 High_Bound
=> High_Bound
))))),
3338 Suppress
=> All_Checks
);
3340 -- If the result of the concatenation appears as the initializing
3341 -- expression of an object declaration, we can just rename the
3342 -- result, rather than copying it.
3344 Set_OK_To_Rename
(Ent
);
3346 -- Catch the static out of range case now
3348 if Raises_Constraint_Error
(High_Bound
) then
3349 raise Concatenation_Error
;
3352 -- Now we will generate the assignments to do the actual concatenation
3354 -- There is one case in which we will not do this, namely when all the
3355 -- following conditions are met:
3357 -- The result type is Standard.String
3359 -- There are nine or fewer retained (non-null) operands
3361 -- The optimization level is -O0
3363 -- The corresponding System.Concat_n.Str_Concat_n routine is
3364 -- available in the run time.
3366 -- The debug flag gnatd.c is not set
3368 -- If all these conditions are met then we generate a call to the
3369 -- relevant concatenation routine. The purpose of this is to avoid
3370 -- undesirable code bloat at -O0.
3372 if Atyp
= Standard_String
3373 and then NN
in 2 .. 9
3374 and then (Lib_Level_Target
3375 or else ((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3376 and then not Debug_Flag_Dot_C
))
3379 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3390 if RTE_Available
(RR
(NN
)) then
3392 Opnds
: constant List_Id
:=
3393 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3396 for J
in 1 .. NN
loop
3397 if Is_List_Member
(Operands
(J
)) then
3398 Remove
(Operands
(J
));
3401 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3403 Make_Aggregate
(Loc
,
3404 Component_Associations
=> New_List
(
3405 Make_Component_Association
(Loc
,
3406 Choices
=> New_List
(
3407 Make_Integer_Literal
(Loc
, 1)),
3408 Expression
=> Operands
(J
)))));
3411 Append_To
(Opnds
, Operands
(J
));
3415 Insert_Action
(Cnode
,
3416 Make_Procedure_Call_Statement
(Loc
,
3417 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3418 Parameter_Associations
=> Opnds
));
3420 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3427 -- Not special case so generate the assignments
3429 Known_Non_Null_Operand_Seen
:= False;
3431 for J
in 1 .. NN
loop
3433 Lo
: constant Node_Id
:=
3435 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3436 Right_Opnd
=> Aggr_Length
(J
- 1));
3438 Hi
: constant Node_Id
:=
3440 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3442 Make_Op_Subtract
(Loc
,
3443 Left_Opnd
=> Aggr_Length
(J
),
3444 Right_Opnd
=> Make_Artyp_Literal
(1)));
3447 -- Singleton case, simple assignment
3449 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3450 Known_Non_Null_Operand_Seen
:= True;
3451 Insert_Action
(Cnode
,
3452 Make_Assignment_Statement
(Loc
,
3454 Make_Indexed_Component
(Loc
,
3455 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3456 Expressions
=> New_List
(To_Ityp
(Lo
))),
3457 Expression
=> Operands
(J
)),
3458 Suppress
=> All_Checks
);
3460 -- Array case, slice assignment, skipped when argument is fixed
3461 -- length and known to be null.
3463 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3466 Make_Assignment_Statement
(Loc
,
3470 New_Occurrence_Of
(Ent
, Loc
),
3473 Low_Bound
=> To_Ityp
(Lo
),
3474 High_Bound
=> To_Ityp
(Hi
))),
3475 Expression
=> Operands
(J
));
3477 if Is_Fixed_Length
(J
) then
3478 Known_Non_Null_Operand_Seen
:= True;
3480 elsif not Known_Non_Null_Operand_Seen
then
3482 -- Here if operand length is not statically known and no
3483 -- operand known to be non-null has been processed yet.
3484 -- If operand length is 0, we do not need to perform the
3485 -- assignment, and we must avoid the evaluation of the
3486 -- high bound of the slice, since it may underflow if the
3487 -- low bound is Ityp'First.
3490 Make_Implicit_If_Statement
(Cnode
,
3494 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3495 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3496 Then_Statements
=> New_List
(Assign
));
3499 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3505 -- Finally we build the result, which is a reference to the array object
3507 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3510 Rewrite
(Cnode
, Result
);
3511 Analyze_And_Resolve
(Cnode
, Atyp
);
3514 when Concatenation_Error
=>
3516 -- Kill warning generated for the declaration of the static out of
3517 -- range high bound, and instead generate a Constraint_Error with
3518 -- an appropriate specific message.
3520 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3521 Apply_Compile_Time_Constraint_Error
3523 Msg
=> "concatenation result upper bound out of range??",
3524 Reason
=> CE_Range_Check_Failed
);
3525 end Expand_Concatenate
;
3527 ---------------------------------------------------
3528 -- Expand_Membership_Minimize_Eliminate_Overflow --
3529 ---------------------------------------------------
3531 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3532 pragma Assert
(Nkind
(N
) = N_In
);
3533 -- Despite the name, this routine applies only to N_In, not to
3534 -- N_Not_In. The latter is always rewritten as not (X in Y).
3536 Result_Type
: constant Entity_Id
:= Etype
(N
);
3537 -- Capture result type, may be a derived boolean type
3539 Loc
: constant Source_Ptr
:= Sloc
(N
);
3540 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3541 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3543 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3544 -- is thus tempting to capture these values, but due to the rewrites
3545 -- that occur as a result of overflow checking, these values change
3546 -- as we go along, and it is safe just to always use Etype explicitly.
3548 Restype
: constant Entity_Id
:= Etype
(N
);
3552 -- Bounds in Minimize calls, not used currently
3554 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3555 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3558 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3560 -- If right operand is a subtype name, and the subtype name has no
3561 -- predicate, then we can just replace the right operand with an
3562 -- explicit range T'First .. T'Last, and use the explicit range code.
3564 if Nkind
(Rop
) /= N_Range
3565 and then No
(Predicate_Function
(Etype
(Rop
)))
3568 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3573 Make_Attribute_Reference
(Loc
,
3574 Attribute_Name
=> Name_First
,
3575 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3577 Make_Attribute_Reference
(Loc
,
3578 Attribute_Name
=> Name_Last
,
3579 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3580 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3584 -- Here for the explicit range case. Note that the bounds of the range
3585 -- have not been processed for minimized or eliminated checks.
3587 if Nkind
(Rop
) = N_Range
then
3588 Minimize_Eliminate_Overflows
3589 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3590 Minimize_Eliminate_Overflows
3591 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3593 -- We have A in B .. C, treated as A >= B and then A <= C
3597 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3598 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3599 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3602 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3603 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3604 L
: constant Entity_Id
:=
3605 Make_Defining_Identifier
(Loc
, Name_uL
);
3606 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3607 Lbound
: constant Node_Id
:=
3608 Convert_To_Bignum
(Low_Bound
(Rop
));
3609 Hbound
: constant Node_Id
:=
3610 Convert_To_Bignum
(High_Bound
(Rop
));
3612 -- Now we rewrite the membership test node to look like
3615 -- Bnn : Result_Type;
3617 -- M : Mark_Id := SS_Mark;
3618 -- L : Bignum := Lopnd;
3620 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3628 -- Insert declaration of L into declarations of bignum block
3631 (Last
(Declarations
(Blk
)),
3632 Make_Object_Declaration
(Loc
,
3633 Defining_Identifier
=> L
,
3634 Object_Definition
=>
3635 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3636 Expression
=> Lopnd
));
3638 -- Insert assignment to Bnn into expressions of bignum block
3641 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3642 Make_Assignment_Statement
(Loc
,
3643 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3647 Make_Function_Call
(Loc
,
3649 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3650 Parameter_Associations
=> New_List
(
3651 New_Occurrence_Of
(L
, Loc
),
3655 Make_Function_Call
(Loc
,
3657 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3658 Parameter_Associations
=> New_List
(
3659 New_Occurrence_Of
(L
, Loc
),
3662 -- Now rewrite the node
3665 Make_Expression_With_Actions
(Loc
,
3666 Actions
=> New_List
(
3667 Make_Object_Declaration
(Loc
,
3668 Defining_Identifier
=> Bnn
,
3669 Object_Definition
=>
3670 New_Occurrence_Of
(Result_Type
, Loc
)),
3672 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3673 Analyze_And_Resolve
(N
, Result_Type
);
3677 -- Here if no bignums around
3680 -- Case where types are all the same
3682 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3684 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3688 -- If types are not all the same, it means that we have rewritten
3689 -- at least one of them to be of type Long_Long_Integer, and we
3690 -- will convert the other operands to Long_Long_Integer.
3693 Convert_To_And_Rewrite
(LLIB
, Lop
);
3694 Set_Analyzed
(Lop
, False);
3695 Analyze_And_Resolve
(Lop
, LLIB
);
3697 -- For the right operand, avoid unnecessary recursion into
3698 -- this routine, we know that overflow is not possible.
3700 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3701 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3702 Set_Analyzed
(Rop
, False);
3703 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3706 -- Now the three operands are of the same signed integer type,
3707 -- so we can use the normal expansion routine for membership,
3708 -- setting the flag to prevent recursion into this procedure.
3710 Set_No_Minimize_Eliminate
(N
);
3714 -- Right operand is a subtype name and the subtype has a predicate. We
3715 -- have to make sure the predicate is checked, and for that we need to
3716 -- use the standard N_In circuitry with appropriate types.
3719 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3721 -- If types are "right", just call Expand_N_In preventing recursion
3723 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3724 Set_No_Minimize_Eliminate
(N
);
3729 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3731 -- For X in T, we want to rewrite our node as
3734 -- Bnn : Result_Type;
3737 -- M : Mark_Id := SS_Mark;
3738 -- Lnn : Long_Long_Integer'Base
3744 -- if not Bignum_In_LLI_Range (Nnn) then
3747 -- Lnn := From_Bignum (Nnn);
3749 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3750 -- and then T'Base (Lnn) in T;
3759 -- A bit gruesome, but there doesn't seem to be a simpler way
3762 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3763 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3764 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3765 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3766 T
: constant Entity_Id
:= Etype
(Rop
);
3767 TB
: constant Entity_Id
:= Base_Type
(T
);
3771 -- Mark the last membership operation to prevent recursion
3775 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3776 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3777 Set_No_Minimize_Eliminate
(Nin
);
3779 -- Now decorate the block
3782 (Last
(Declarations
(Blk
)),
3783 Make_Object_Declaration
(Loc
,
3784 Defining_Identifier
=> Lnn
,
3785 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3788 (Last
(Declarations
(Blk
)),
3789 Make_Object_Declaration
(Loc
,
3790 Defining_Identifier
=> Nnn
,
3791 Object_Definition
=>
3792 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3795 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3797 Make_Assignment_Statement
(Loc
,
3798 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3799 Expression
=> Relocate_Node
(Lop
)),
3801 Make_Implicit_If_Statement
(N
,
3805 Make_Function_Call
(Loc
,
3808 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3809 Parameter_Associations
=> New_List
(
3810 New_Occurrence_Of
(Nnn
, Loc
)))),
3812 Then_Statements
=> New_List
(
3813 Make_Assignment_Statement
(Loc
,
3814 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3816 New_Occurrence_Of
(Standard_False
, Loc
))),
3818 Else_Statements
=> New_List
(
3819 Make_Assignment_Statement
(Loc
,
3820 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3822 Make_Function_Call
(Loc
,
3824 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3825 Parameter_Associations
=> New_List
(
3826 New_Occurrence_Of
(Nnn
, Loc
)))),
3828 Make_Assignment_Statement
(Loc
,
3829 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3834 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3839 Make_Attribute_Reference
(Loc
,
3840 Attribute_Name
=> Name_First
,
3842 New_Occurrence_Of
(TB
, Loc
))),
3846 Make_Attribute_Reference
(Loc
,
3847 Attribute_Name
=> Name_Last
,
3849 New_Occurrence_Of
(TB
, Loc
))))),
3851 Right_Opnd
=> Nin
))))));
3853 -- Now we can do the rewrite
3856 Make_Expression_With_Actions
(Loc
,
3857 Actions
=> New_List
(
3858 Make_Object_Declaration
(Loc
,
3859 Defining_Identifier
=> Bnn
,
3860 Object_Definition
=>
3861 New_Occurrence_Of
(Result_Type
, Loc
)),
3863 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3864 Analyze_And_Resolve
(N
, Result_Type
);
3868 -- Not bignum case, but types don't match (this means we rewrote the
3869 -- left operand to be Long_Long_Integer).
3872 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
3874 -- We rewrite the membership test as (where T is the type with
3875 -- the predicate, i.e. the type of the right operand)
3877 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3878 -- and then T'Base (Lop) in T
3881 T
: constant Entity_Id
:= Etype
(Rop
);
3882 TB
: constant Entity_Id
:= Base_Type
(T
);
3886 -- The last membership test is marked to prevent recursion
3890 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
3891 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3892 Set_No_Minimize_Eliminate
(Nin
);
3894 -- Now do the rewrite
3905 Make_Attribute_Reference
(Loc
,
3906 Attribute_Name
=> Name_First
,
3908 New_Occurrence_Of
(TB
, Loc
))),
3911 Make_Attribute_Reference
(Loc
,
3912 Attribute_Name
=> Name_Last
,
3914 New_Occurrence_Of
(TB
, Loc
))))),
3915 Right_Opnd
=> Nin
));
3916 Set_Analyzed
(N
, False);
3917 Analyze_And_Resolve
(N
, Restype
);
3921 end Expand_Membership_Minimize_Eliminate_Overflow
;
3923 ------------------------
3924 -- Expand_N_Allocator --
3925 ------------------------
3927 procedure Expand_N_Allocator
(N
: Node_Id
) is
3928 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
3929 Loc
: constant Source_Ptr
:= Sloc
(N
);
3930 PtrT
: constant Entity_Id
:= Etype
(N
);
3932 procedure Rewrite_Coextension
(N
: Node_Id
);
3933 -- Static coextensions have the same lifetime as the entity they
3934 -- constrain. Such occurrences can be rewritten as aliased objects
3935 -- and their unrestricted access used instead of the coextension.
3937 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
3938 -- Given a constrained array type E, returns a node representing the
3939 -- code to compute the size in storage elements for the given type.
3940 -- This is done without using the attribute (which malfunctions for
3943 -------------------------
3944 -- Rewrite_Coextension --
3945 -------------------------
3947 procedure Rewrite_Coextension
(N
: Node_Id
) is
3948 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
3949 Temp_Decl
: Node_Id
;
3953 -- Cnn : aliased Etyp;
3956 Make_Object_Declaration
(Loc
,
3957 Defining_Identifier
=> Temp_Id
,
3958 Aliased_Present
=> True,
3959 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
3961 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
3962 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
3965 Insert_Action
(N
, Temp_Decl
);
3967 Make_Attribute_Reference
(Loc
,
3968 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
3969 Attribute_Name
=> Name_Unrestricted_Access
));
3971 Analyze_And_Resolve
(N
, PtrT
);
3972 end Rewrite_Coextension
;
3974 ------------------------------
3975 -- Size_In_Storage_Elements --
3976 ------------------------------
3978 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
3980 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3981 -- However, the reason for the existence of this function is
3982 -- to construct a test for sizes too large, which means near the
3983 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3984 -- is that we get overflows when sizes are greater than 2**31.
3986 -- So what we end up doing for array types is to use the expression:
3988 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
3990 -- which avoids this problem. All this is a bit bogus, but it does
3991 -- mean we catch common cases of trying to allocate arrays that
3992 -- are too large, and which in the absence of a check results in
3993 -- undetected chaos ???
3995 -- Note in particular that this is a pessimistic estimate in the
3996 -- case of packed array types, where an array element might occupy
3997 -- just a fraction of a storage element???
4004 for J
in 1 .. Number_Dimensions
(E
) loop
4006 Make_Attribute_Reference
(Loc
,
4007 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4008 Attribute_Name
=> Name_Length
,
4009 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4016 Make_Op_Multiply
(Loc
,
4023 Make_Op_Multiply
(Loc
,
4026 Make_Attribute_Reference
(Loc
,
4027 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4028 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4030 end Size_In_Storage_Elements
;
4034 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4038 Rel_Typ
: Entity_Id
;
4041 -- Start of processing for Expand_N_Allocator
4044 -- RM E.2.3(22). We enforce that the expected type of an allocator
4045 -- shall not be a remote access-to-class-wide-limited-private type
4047 -- Why is this being done at expansion time, seems clearly wrong ???
4049 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4051 -- Processing for anonymous access-to-controlled types. These access
4052 -- types receive a special finalization master which appears in the
4053 -- declarations of the enclosing semantic unit. This expansion is done
4054 -- now to ensure that any additional types generated by this routine or
4055 -- Expand_Allocator_Expression inherit the proper type attributes.
4057 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4058 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4059 and then Needs_Finalization
(Dtyp
)
4061 -- Detect the allocation of an anonymous controlled object where the
4062 -- type of the context is named. For example:
4064 -- procedure Proc (Ptr : Named_Access_Typ);
4065 -- Proc (new Designated_Typ);
4067 -- Regardless of the anonymous-to-named access type conversion, the
4068 -- lifetime of the object must be associated with the named access
4069 -- type. Use the finalization-related attributes of this type.
4071 if Nkind_In
(Parent
(N
), N_Type_Conversion
,
4072 N_Unchecked_Type_Conversion
)
4073 and then Ekind_In
(Etype
(Parent
(N
)), E_Access_Subtype
,
4075 E_General_Access_Type
)
4077 Rel_Typ
:= Etype
(Parent
(N
));
4082 -- Anonymous access-to-controlled types allocate on the global pool.
4083 -- Note that this is a "root type only" attribute.
4085 if No
(Associated_Storage_Pool
(PtrT
)) then
4086 if Present
(Rel_Typ
) then
4087 Set_Associated_Storage_Pool
4088 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4090 Set_Associated_Storage_Pool
4091 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4095 -- The finalization master must be inserted and analyzed as part of
4096 -- the current semantic unit. Note that the master is updated when
4097 -- analysis changes current units. Note that this is a "root type
4100 if Present
(Rel_Typ
) then
4101 Set_Finalization_Master
4102 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4104 Build_Anonymous_Master
(Root_Type
(PtrT
));
4108 -- Set the storage pool and find the appropriate version of Allocate to
4109 -- call. Do not overwrite the storage pool if it is already set, which
4110 -- can happen for build-in-place function returns (see
4111 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4113 if No
(Storage_Pool
(N
)) then
4114 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4116 if Present
(Pool
) then
4117 Set_Storage_Pool
(N
, Pool
);
4119 if Is_RTE
(Pool
, RE_SS_Pool
) then
4120 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4122 -- In the case of an allocator for a simple storage pool, locate
4123 -- and save a reference to the pool type's Allocate routine.
4125 elsif Present
(Get_Rep_Pragma
4126 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4129 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4130 Alloc_Op
: Entity_Id
;
4132 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4133 while Present
(Alloc_Op
) loop
4134 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4135 and then Present
(First_Formal
(Alloc_Op
))
4136 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4138 Set_Procedure_To_Call
(N
, Alloc_Op
);
4141 Alloc_Op
:= Homonym
(Alloc_Op
);
4146 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4147 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4150 Set_Procedure_To_Call
(N
,
4151 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4156 -- Under certain circumstances we can replace an allocator by an access
4157 -- to statically allocated storage. The conditions, as noted in AARM
4158 -- 3.10 (10c) are as follows:
4160 -- Size and initial value is known at compile time
4161 -- Access type is access-to-constant
4163 -- The allocator is not part of a constraint on a record component,
4164 -- because in that case the inserted actions are delayed until the
4165 -- record declaration is fully analyzed, which is too late for the
4166 -- analysis of the rewritten allocator.
4168 if Is_Access_Constant
(PtrT
)
4169 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4170 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4171 and then Size_Known_At_Compile_Time
4172 (Etype
(Expression
(Expression
(N
))))
4173 and then not Is_Record_Type
(Current_Scope
)
4175 -- Here we can do the optimization. For the allocator
4179 -- We insert an object declaration
4181 -- Tnn : aliased x := y;
4183 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4184 -- marked as requiring static allocation.
4186 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4187 Desig
:= Subtype_Mark
(Expression
(N
));
4189 -- If context is constrained, use constrained subtype directly,
4190 -- so that the constant is not labelled as having a nominally
4191 -- unconstrained subtype.
4193 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4194 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4198 Make_Object_Declaration
(Loc
,
4199 Defining_Identifier
=> Temp
,
4200 Aliased_Present
=> True,
4201 Constant_Present
=> Is_Access_Constant
(PtrT
),
4202 Object_Definition
=> Desig
,
4203 Expression
=> Expression
(Expression
(N
))));
4206 Make_Attribute_Reference
(Loc
,
4207 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4208 Attribute_Name
=> Name_Unrestricted_Access
));
4210 Analyze_And_Resolve
(N
, PtrT
);
4212 -- We set the variable as statically allocated, since we don't want
4213 -- it going on the stack of the current procedure.
4215 Set_Is_Statically_Allocated
(Temp
);
4219 -- Same if the allocator is an access discriminant for a local object:
4220 -- instead of an allocator we create a local value and constrain the
4221 -- enclosing object with the corresponding access attribute.
4223 if Is_Static_Coextension
(N
) then
4224 Rewrite_Coextension
(N
);
4228 -- Check for size too large, we do this because the back end misses
4229 -- proper checks here and can generate rubbish allocation calls when
4230 -- we are near the limit. We only do this for the 32-bit address case
4231 -- since that is from a practical point of view where we see a problem.
4233 if System_Address_Size
= 32
4234 and then not Storage_Checks_Suppressed
(PtrT
)
4235 and then not Storage_Checks_Suppressed
(Dtyp
)
4236 and then not Storage_Checks_Suppressed
(Etyp
)
4238 -- The check we want to generate should look like
4240 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4241 -- raise Storage_Error;
4244 -- where 3.5 gigabytes is a constant large enough to accommodate any
4245 -- reasonable request for. But we can't do it this way because at
4246 -- least at the moment we don't compute this attribute right, and
4247 -- can silently give wrong results when the result gets large. Since
4248 -- this is all about large results, that's bad, so instead we only
4249 -- apply the check for constrained arrays, and manually compute the
4250 -- value of the attribute ???
4252 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4254 Make_Raise_Storage_Error
(Loc
,
4257 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4259 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4260 Reason
=> SE_Object_Too_Large
));
4264 -- If no storage pool has been specified and we have the restriction
4265 -- No_Standard_Allocators_After_Elaboration is present, then generate
4266 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4268 if Nkind
(N
) = N_Allocator
4269 and then No
(Storage_Pool
(N
))
4270 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4273 Make_Procedure_Call_Statement
(Loc
,
4275 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4278 -- Handle case of qualified expression (other than optimization above)
4279 -- First apply constraint checks, because the bounds or discriminants
4280 -- in the aggregate might not match the subtype mark in the allocator.
4282 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4283 Apply_Constraint_Check
4284 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
4286 Expand_Allocator_Expression
(N
);
4290 -- If the allocator is for a type which requires initialization, and
4291 -- there is no initial value (i.e. operand is a subtype indication
4292 -- rather than a qualified expression), then we must generate a call to
4293 -- the initialization routine using an expressions action node:
4295 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4297 -- Here ptr_T is the pointer type for the allocator, and T is the
4298 -- subtype of the allocator. A special case arises if the designated
4299 -- type of the access type is a task or contains tasks. In this case
4300 -- the call to Init (Temp.all ...) is replaced by code that ensures
4301 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4302 -- for details). In addition, if the type T is a task type, then the
4303 -- first argument to Init must be converted to the task record type.
4306 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4312 Init_Arg1
: Node_Id
;
4313 Temp_Decl
: Node_Id
;
4314 Temp_Type
: Entity_Id
;
4317 if No_Initialization
(N
) then
4319 -- Even though this might be a simple allocation, create a custom
4320 -- Allocate if the context requires it.
4322 if Present
(Finalization_Master
(PtrT
)) then
4323 Build_Allocate_Deallocate_Proc
4325 Is_Allocate
=> True);
4328 -- Case of no initialization procedure present
4330 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4332 -- Case of simple initialization required
4334 if Needs_Simple_Initialization
(T
) then
4335 Check_Restriction
(No_Default_Initialization
, N
);
4336 Rewrite
(Expression
(N
),
4337 Make_Qualified_Expression
(Loc
,
4338 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4339 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4341 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4342 Analyze_And_Resolve
(Expression
(N
), T
);
4343 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4344 Expand_N_Allocator
(N
);
4346 -- No initialization required
4352 -- Case of initialization procedure present, must be called
4355 Check_Restriction
(No_Default_Initialization
, N
);
4357 if not Restriction_Active
(No_Default_Initialization
) then
4358 Init
:= Base_Init_Proc
(T
);
4360 Temp
:= Make_Temporary
(Loc
, 'P');
4362 -- Construct argument list for the initialization routine call
4365 Make_Explicit_Dereference
(Loc
,
4367 New_Occurrence_Of
(Temp
, Loc
));
4369 Set_Assignment_OK
(Init_Arg1
);
4372 -- The initialization procedure expects a specific type. if the
4373 -- context is access to class wide, indicate that the object
4374 -- being allocated has the right specific type.
4376 if Is_Class_Wide_Type
(Dtyp
) then
4377 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4380 -- If designated type is a concurrent type or if it is private
4381 -- type whose definition is a concurrent type, the first
4382 -- argument in the Init routine has to be unchecked conversion
4383 -- to the corresponding record type. If the designated type is
4384 -- a derived type, also convert the argument to its root type.
4386 if Is_Concurrent_Type
(T
) then
4388 Unchecked_Convert_To
(
4389 Corresponding_Record_Type
(T
), Init_Arg1
);
4391 elsif Is_Private_Type
(T
)
4392 and then Present
(Full_View
(T
))
4393 and then Is_Concurrent_Type
(Full_View
(T
))
4396 Unchecked_Convert_To
4397 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4399 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4401 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4404 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4405 Set_Etype
(Init_Arg1
, Ftyp
);
4409 Args
:= New_List
(Init_Arg1
);
4411 -- For the task case, pass the Master_Id of the access type as
4412 -- the value of the _Master parameter, and _Chain as the value
4413 -- of the _Chain parameter (_Chain will be defined as part of
4414 -- the generated code for the allocator).
4416 -- In Ada 2005, the context may be a function that returns an
4417 -- anonymous access type. In that case the Master_Id has been
4418 -- created when expanding the function declaration.
4420 if Has_Task
(T
) then
4421 if No
(Master_Id
(Base_Type
(PtrT
))) then
4423 -- The designated type was an incomplete type, and the
4424 -- access type did not get expanded. Salvage it now.
4426 if not Restriction_Active
(No_Task_Hierarchy
) then
4427 if Present
(Parent
(Base_Type
(PtrT
))) then
4428 Expand_N_Full_Type_Declaration
4429 (Parent
(Base_Type
(PtrT
)));
4431 -- The only other possibility is an itype. For this
4432 -- case, the master must exist in the context. This is
4433 -- the case when the allocator initializes an access
4434 -- component in an init-proc.
4437 pragma Assert
(Is_Itype
(PtrT
));
4438 Build_Master_Renaming
(PtrT
, N
);
4443 -- If the context of the allocator is a declaration or an
4444 -- assignment, we can generate a meaningful image for it,
4445 -- even though subsequent assignments might remove the
4446 -- connection between task and entity. We build this image
4447 -- when the left-hand side is a simple variable, a simple
4448 -- indexed assignment or a simple selected component.
4450 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4452 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4455 if Is_Entity_Name
(Nam
) then
4457 Build_Task_Image_Decls
4460 (Entity
(Nam
), Sloc
(Nam
)), T
);
4462 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4463 N_Selected_Component
)
4464 and then Is_Entity_Name
(Prefix
(Nam
))
4467 Build_Task_Image_Decls
4468 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4470 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4474 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4476 Build_Task_Image_Decls
4477 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4480 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4483 if Restriction_Active
(No_Task_Hierarchy
) then
4485 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4489 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4492 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4494 Decl
:= Last
(Decls
);
4496 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4498 -- Has_Task is false, Decls not used
4504 -- Add discriminants if discriminated type
4507 Dis
: Boolean := False;
4511 if Has_Discriminants
(T
) then
4515 -- Type may be a private type with no visible discriminants
4516 -- in which case check full view if in scope, or the
4517 -- underlying_full_view if dealing with a type whose full
4518 -- view may be derived from a private type whose own full
4519 -- view has discriminants.
4521 elsif Is_Private_Type
(T
) then
4522 if Present
(Full_View
(T
))
4523 and then Has_Discriminants
(Full_View
(T
))
4526 Typ
:= Full_View
(T
);
4528 elsif Present
(Underlying_Full_View
(T
))
4529 and then Has_Discriminants
(Underlying_Full_View
(T
))
4532 Typ
:= Underlying_Full_View
(T
);
4538 -- If the allocated object will be constrained by the
4539 -- default values for discriminants, then build a subtype
4540 -- with those defaults, and change the allocated subtype
4541 -- to that. Note that this happens in fewer cases in Ada
4544 if not Is_Constrained
(Typ
)
4545 and then Present
(Discriminant_Default_Value
4546 (First_Discriminant
(Typ
)))
4547 and then (Ada_Version
< Ada_2005
4549 Object_Type_Has_Constrained_Partial_View
4550 (Typ
, Current_Scope
))
4552 Typ
:= Build_Default_Subtype
(Typ
, N
);
4553 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
4556 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4557 while Present
(Discr
) loop
4558 Nod
:= Node
(Discr
);
4559 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4561 -- AI-416: when the discriminant constraint is an
4562 -- anonymous access type make sure an accessibility
4563 -- check is inserted if necessary (3.10.2(22.q/2))
4565 if Ada_Version
>= Ada_2005
4567 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4569 Apply_Accessibility_Check
4570 (Nod
, Typ
, Insert_Node
=> Nod
);
4578 -- We set the allocator as analyzed so that when we analyze
4579 -- the if expression node, we do not get an unwanted recursive
4580 -- expansion of the allocator expression.
4582 Set_Analyzed
(N
, True);
4583 Nod
:= Relocate_Node
(N
);
4585 -- Here is the transformation:
4586 -- input: new Ctrl_Typ
4587 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4588 -- Ctrl_TypIP (Temp.all, ...);
4589 -- [Deep_]Initialize (Temp.all);
4591 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4592 -- is the subtype of the allocator.
4595 Make_Object_Declaration
(Loc
,
4596 Defining_Identifier
=> Temp
,
4597 Constant_Present
=> True,
4598 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
4601 Set_Assignment_OK
(Temp_Decl
);
4602 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4604 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
4606 -- If the designated type is a task type or contains tasks,
4607 -- create block to activate created tasks, and insert
4608 -- declaration for Task_Image variable ahead of call.
4610 if Has_Task
(T
) then
4612 L
: constant List_Id
:= New_List
;
4615 Build_Task_Allocate_Block
(L
, Nod
, Args
);
4617 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
4618 Insert_Actions
(N
, L
);
4623 Make_Procedure_Call_Statement
(Loc
,
4624 Name
=> New_Occurrence_Of
(Init
, Loc
),
4625 Parameter_Associations
=> Args
));
4628 if Needs_Finalization
(T
) then
4631 -- [Deep_]Initialize (Init_Arg1);
4635 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4639 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4640 Analyze_And_Resolve
(N
, PtrT
);
4645 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4646 -- object that has been rewritten as a reference, we displace "this"
4647 -- to reference properly its secondary dispatch table.
4649 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
4650 Displace_Allocator_Pointer
(N
);
4654 when RE_Not_Available
=>
4656 end Expand_N_Allocator
;
4658 -----------------------
4659 -- Expand_N_And_Then --
4660 -----------------------
4662 procedure Expand_N_And_Then
(N
: Node_Id
)
4663 renames Expand_Short_Circuit_Operator
;
4665 ------------------------------
4666 -- Expand_N_Case_Expression --
4667 ------------------------------
4669 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4670 Loc
: constant Source_Ptr
:= Sloc
(N
);
4671 Par
: constant Node_Id
:= Parent
(N
);
4672 Typ
: constant Entity_Id
:= Etype
(N
);
4675 Case_Stmt
: Node_Id
;
4679 Target_Typ
: Entity_Id
;
4681 In_Predicate
: Boolean := False;
4682 -- Flag set when the case expression appears within a predicate
4684 Optimize_Return_Stmt
: Boolean := False;
4685 -- Flag set when the case expression can be optimized in the context of
4686 -- a simple return statement.
4689 -- Check for MINIMIZED/ELIMINATED overflow mode
4691 if Minimized_Eliminated_Overflow_Check
(N
) then
4692 Apply_Arithmetic_Overflow_Check
(N
);
4696 -- If the case expression is a predicate specification, and the type
4697 -- to which it applies has a static predicate aspect, do not expand,
4698 -- because it will be converted to the proper predicate form later.
4700 if Ekind_In
(Current_Scope
, E_Function
, E_Procedure
)
4701 and then Is_Predicate_Function
(Current_Scope
)
4703 In_Predicate
:= True;
4705 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
4711 -- When the type of the case expression is elementary, expand
4713 -- (case X is when A => AX, when B => BX ...)
4728 -- In all other cases expand into
4731 -- type Ptr_Typ is access all Typ;
4732 -- Target : Ptr_Typ;
4735 -- Target := AX'Unrestricted_Access;
4737 -- Target := BX'Unrestricted_Access;
4740 -- in Target.all end;
4742 -- This approach avoids extra copies of potentially large objects. It
4743 -- also allows handling of values of limited or unconstrained types.
4745 -- Small optimization: when the case expression appears in the context
4746 -- of a simple return statement, expand into
4757 Make_Case_Statement
(Loc
,
4758 Expression
=> Expression
(N
),
4759 Alternatives
=> New_List
);
4761 -- Preserve the original context for which the case statement is being
4762 -- generated. This is needed by the finalization machinery to prevent
4763 -- the premature finalization of controlled objects found within the
4766 Set_From_Conditional_Expression
(Case_Stmt
);
4771 if Is_Elementary_Type
(Typ
) then
4774 -- ??? Do not perform the optimization when the return statement is
4775 -- within a predicate function as this causes supurious errors. Could
4776 -- this be a possible mismatch in handling this case somewhere else
4777 -- in semantic analysis?
4779 Optimize_Return_Stmt
:=
4780 Nkind
(Par
) = N_Simple_Return_Statement
and then not In_Predicate
;
4782 -- Otherwise create an access type to handle the general case using
4783 -- 'Unrestricted_Access.
4786 -- type Ptr_Typ is access all Typ;
4789 Target_Typ
:= Make_Temporary
(Loc
, 'P');
4792 Make_Full_Type_Declaration
(Loc
,
4793 Defining_Identifier
=> Target_Typ
,
4795 Make_Access_To_Object_Definition
(Loc
,
4796 All_Present
=> True,
4797 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
4800 -- Create the declaration of the target which captures the value of the
4804 -- Target : [Ptr_]Typ;
4806 if not Optimize_Return_Stmt
then
4807 Target
:= Make_Temporary
(Loc
, 'T');
4810 Make_Object_Declaration
(Loc
,
4811 Defining_Identifier
=> Target
,
4812 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
4813 Set_No_Initialization
(Decl
);
4815 Append_To
(Acts
, Decl
);
4818 -- Process the alternatives
4820 Alt
:= First
(Alternatives
(N
));
4821 while Present
(Alt
) loop
4823 Alt_Expr
: Node_Id
:= Expression
(Alt
);
4824 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
4828 -- Take the unrestricted access of the expression value for non-
4829 -- scalar types. This approach avoids big copies and covers the
4830 -- limited and unconstrained cases.
4833 -- AX'Unrestricted_Access
4835 if not Is_Elementary_Type
(Typ
) then
4837 Make_Attribute_Reference
(Alt_Loc
,
4838 Prefix
=> Relocate_Node
(Alt_Expr
),
4839 Attribute_Name
=> Name_Unrestricted_Access
);
4843 -- return AX['Unrestricted_Access];
4845 if Optimize_Return_Stmt
then
4847 Make_Simple_Return_Statement
(Alt_Loc
,
4848 Expression
=> Alt_Expr
));
4851 -- Target := AX['Unrestricted_Access];
4855 Make_Assignment_Statement
(Alt_Loc
,
4856 Name
=> New_Occurrence_Of
(Target
, Loc
),
4857 Expression
=> Alt_Expr
));
4860 -- Propagate declarations inserted in the node by Insert_Actions
4861 -- (for example, temporaries generated to remove side effects).
4862 -- These actions must remain attached to the alternative, given
4863 -- that they are generated by the corresponding expression.
4865 if Present
(Actions
(Alt
)) then
4866 Prepend_List
(Actions
(Alt
), Stmts
);
4869 -- Finalize any transient controlled objects on exit from the
4870 -- alternative. This is done only in the return optimization case
4871 -- because otherwise the case expression is converted into an
4872 -- expression with actions which already contains this form of
4875 if Optimize_Return_Stmt
then
4876 Process_If_Case_Statements
(N
, Stmts
);
4880 (Alternatives
(Case_Stmt
),
4881 Make_Case_Statement_Alternative
(Sloc
(Alt
),
4882 Discrete_Choices
=> Discrete_Choices
(Alt
),
4883 Statements
=> Stmts
));
4889 -- Rewrite the parent return statement as a case statement
4891 if Optimize_Return_Stmt
then
4892 Rewrite
(Par
, Case_Stmt
);
4895 -- Otherwise convert the case expression into an expression with actions
4898 Append_To
(Acts
, Case_Stmt
);
4900 if Is_Elementary_Type
(Typ
) then
4901 Expr
:= New_Occurrence_Of
(Target
, Loc
);
4905 Make_Explicit_Dereference
(Loc
,
4906 Prefix
=> New_Occurrence_Of
(Target
, Loc
));
4912 -- in Target[.all] end;
4915 Make_Expression_With_Actions
(Loc
,
4919 Analyze_And_Resolve
(N
, Typ
);
4921 end Expand_N_Case_Expression
;
4923 -----------------------------------
4924 -- Expand_N_Explicit_Dereference --
4925 -----------------------------------
4927 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
4929 -- Insert explicit dereference call for the checked storage pool case
4931 Insert_Dereference_Action
(Prefix
(N
));
4933 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
4934 -- we set the atomic sync flag.
4936 if Is_Atomic
(Etype
(N
))
4937 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
4939 Activate_Atomic_Synchronization
(N
);
4941 end Expand_N_Explicit_Dereference
;
4943 --------------------------------------
4944 -- Expand_N_Expression_With_Actions --
4945 --------------------------------------
4947 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
4948 Acts
: constant List_Id
:= Actions
(N
);
4950 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
4951 -- Force the evaluation of Boolean expression Expr
4953 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
4954 -- Inspect and process a single action of an expression_with_actions for
4955 -- transient controlled objects. If such objects are found, the routine
4956 -- generates code to clean them up when the context of the expression is
4957 -- evaluated or elaborated.
4959 ------------------------------
4960 -- Force_Boolean_Evaluation --
4961 ------------------------------
4963 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
4964 Loc
: constant Source_Ptr
:= Sloc
(N
);
4965 Flag_Decl
: Node_Id
;
4966 Flag_Id
: Entity_Id
;
4969 -- Relocate the expression to the actions list by capturing its value
4970 -- in a Boolean flag. Generate:
4971 -- Flag : constant Boolean := Expr;
4973 Flag_Id
:= Make_Temporary
(Loc
, 'F');
4976 Make_Object_Declaration
(Loc
,
4977 Defining_Identifier
=> Flag_Id
,
4978 Constant_Present
=> True,
4979 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4980 Expression
=> Relocate_Node
(Expr
));
4982 Append
(Flag_Decl
, Acts
);
4983 Analyze
(Flag_Decl
);
4985 -- Replace the expression with a reference to the flag
4987 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
4988 Analyze
(Expression
(N
));
4989 end Force_Boolean_Evaluation
;
4991 --------------------
4992 -- Process_Action --
4993 --------------------
4995 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
4997 if Nkind
(Act
) = N_Object_Declaration
4998 and then Is_Finalizable_Transient
(Act
, N
)
5000 Process_Transient_Object
(Act
, N
, Acts
);
5003 -- Avoid processing temporary function results multiple times when
5004 -- dealing with nested expression_with_actions.
5006 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5009 -- Do not process temporary function results in loops. This is done
5010 -- by Expand_N_Loop_Statement and Build_Finalizer.
5012 elsif Nkind
(Act
) = N_Loop_Statement
then
5019 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5025 -- Start of processing for Expand_N_Expression_With_Actions
5028 -- Do not evaluate the expression when it denotes an entity because the
5029 -- expression_with_actions node will be replaced by the reference.
5031 if Is_Entity_Name
(Expression
(N
)) then
5034 -- Do not evaluate the expression when there are no actions because the
5035 -- expression_with_actions node will be replaced by the expression.
5037 elsif No
(Acts
) or else Is_Empty_List
(Acts
) then
5040 -- Force the evaluation of the expression by capturing its value in a
5041 -- temporary. This ensures that aliases of transient controlled objects
5042 -- do not leak to the expression of the expression_with_actions node:
5045 -- Trans_Id : Ctrl_Typ := ...;
5046 -- Alias : ... := Trans_Id;
5047 -- in ... Alias ... end;
5049 -- In the example above, Trans_Id cannot be finalized at the end of the
5050 -- actions list because this may affect the alias and the final value of
5051 -- the expression_with_actions. Forcing the evaluation encapsulates the
5052 -- reference to the Alias within the actions list:
5055 -- Trans_Id : Ctrl_Typ := ...;
5056 -- Alias : ... := Trans_Id;
5057 -- Val : constant Boolean := ... Alias ...;
5058 -- <finalize Trans_Id>
5061 -- Once this transformation is performed, it is safe to finalize the
5062 -- transient controlled object at the end of the actions list.
5064 -- Note that Force_Evaluation does not remove side effects in operators
5065 -- because it assumes that all operands are evaluated and side effect
5066 -- free. This is not the case when an operand depends implicitly on the
5067 -- transient controlled object through the use of access types.
5069 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5070 Force_Boolean_Evaluation
(Expression
(N
));
5072 -- The expression of an expression_with_actions node may not necessarily
5073 -- be Boolean when the node appears in an if expression. In this case do
5074 -- the usual forced evaluation to encapsulate potential aliasing.
5077 Force_Evaluation
(Expression
(N
));
5080 -- Process all transient controlled objects found within the actions of
5083 Act
:= First
(Acts
);
5084 while Present
(Act
) loop
5085 Process_Single_Action
(Act
);
5089 -- Deal with case where there are no actions. In this case we simply
5090 -- rewrite the node with its expression since we don't need the actions
5091 -- and the specification of this node does not allow a null action list.
5093 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5094 -- the expanded tree and relying on being able to retrieve the original
5095 -- tree in cases like this. This raises a whole lot of issues of whether
5096 -- we have problems elsewhere, which will be addressed in the future???
5098 if Is_Empty_List
(Acts
) then
5099 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5101 end Expand_N_Expression_With_Actions
;
5103 ----------------------------
5104 -- Expand_N_If_Expression --
5105 ----------------------------
5107 -- Deal with limited types and condition actions
5109 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5110 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5111 Loc
: constant Source_Ptr
:= Sloc
(N
);
5112 Thenx
: constant Node_Id
:= Next
(Cond
);
5113 Elsex
: constant Node_Id
:= Next
(Thenx
);
5114 Typ
: constant Entity_Id
:= Etype
(N
);
5122 Ptr_Typ
: Entity_Id
;
5125 -- Check for MINIMIZED/ELIMINATED overflow mode
5127 if Minimized_Eliminated_Overflow_Check
(N
) then
5128 Apply_Arithmetic_Overflow_Check
(N
);
5132 -- Fold at compile time if condition known. We have already folded
5133 -- static if expressions, but it is possible to fold any case in which
5134 -- the condition is known at compile time, even though the result is
5137 -- Note that we don't do the fold of such cases in Sem_Elab because
5138 -- it can cause infinite loops with the expander adding a conditional
5139 -- expression, and Sem_Elab circuitry removing it repeatedly.
5141 if Compile_Time_Known_Value
(Cond
) then
5143 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5144 -- Fold at compile time. Assumes condition known. Return True if
5145 -- folding occurred, meaning we're done.
5147 ----------------------
5148 -- Fold_Known_Value --
5149 ----------------------
5151 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5153 if Is_True
(Expr_Value
(Cond
)) then
5155 Actions
:= Then_Actions
(N
);
5158 Actions
:= Else_Actions
(N
);
5163 if Present
(Actions
) then
5165 -- To minimize the use of Expression_With_Actions, just skip
5166 -- the optimization as it is not critical for correctness.
5168 if Minimize_Expression_With_Actions
then
5173 Make_Expression_With_Actions
(Loc
,
5174 Expression
=> Relocate_Node
(Expr
),
5175 Actions
=> Actions
));
5176 Analyze_And_Resolve
(N
, Typ
);
5179 Rewrite
(N
, Relocate_Node
(Expr
));
5182 -- Note that the result is never static (legitimate cases of
5183 -- static if expressions were folded in Sem_Eval).
5185 Set_Is_Static_Expression
(N
, False);
5187 end Fold_Known_Value
;
5190 if Fold_Known_Value
(Cond
) then
5196 -- If the type is limited, and the back end does not handle limited
5197 -- types, then we expand as follows to avoid the possibility of
5198 -- improper copying.
5200 -- type Ptr is access all Typ;
5204 -- Cnn := then-expr'Unrestricted_Access;
5207 -- Cnn := else-expr'Unrestricted_Access;
5210 -- and replace the if expression by a reference to Cnn.all.
5212 -- This special case can be skipped if the back end handles limited
5213 -- types properly and ensures that no incorrect copies are made.
5215 if Is_By_Reference_Type
(Typ
)
5216 and then not Back_End_Handles_Limited_Types
5218 -- When the "then" or "else" expressions involve controlled function
5219 -- calls, generated temporaries are chained on the corresponding list
5220 -- of actions. These temporaries need to be finalized after the if
5221 -- expression is evaluated.
5223 Process_If_Case_Statements
(N
, Then_Actions
(N
));
5224 Process_If_Case_Statements
(N
, Else_Actions
(N
));
5227 -- type Ann is access all Typ;
5229 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5232 Make_Full_Type_Declaration
(Loc
,
5233 Defining_Identifier
=> Ptr_Typ
,
5235 Make_Access_To_Object_Definition
(Loc
,
5236 All_Present
=> True,
5237 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5242 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5245 Make_Object_Declaration
(Loc
,
5246 Defining_Identifier
=> Cnn
,
5247 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5251 -- Cnn := <Thenx>'Unrestricted_Access;
5253 -- Cnn := <Elsex>'Unrestricted_Access;
5257 Make_Implicit_If_Statement
(N
,
5258 Condition
=> Relocate_Node
(Cond
),
5259 Then_Statements
=> New_List
(
5260 Make_Assignment_Statement
(Sloc
(Thenx
),
5261 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5263 Make_Attribute_Reference
(Loc
,
5264 Prefix
=> Relocate_Node
(Thenx
),
5265 Attribute_Name
=> Name_Unrestricted_Access
))),
5267 Else_Statements
=> New_List
(
5268 Make_Assignment_Statement
(Sloc
(Elsex
),
5269 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5271 Make_Attribute_Reference
(Loc
,
5272 Prefix
=> Relocate_Node
(Elsex
),
5273 Attribute_Name
=> Name_Unrestricted_Access
))));
5275 -- Preserve the original context for which the if statement is being
5276 -- generated. This is needed by the finalization machinery to prevent
5277 -- the premature finalization of controlled objects found within the
5280 Set_From_Conditional_Expression
(New_If
);
5283 Make_Explicit_Dereference
(Loc
,
5284 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5286 -- If the result is an unconstrained array and the if expression is in a
5287 -- context other than the initializing expression of the declaration of
5288 -- an object, then we pull out the if expression as follows:
5290 -- Cnn : constant typ := if-expression
5292 -- and then replace the if expression with an occurrence of Cnn. This
5293 -- avoids the need in the back end to create on-the-fly variable length
5294 -- temporaries (which it cannot do!)
5296 -- Note that the test for being in an object declaration avoids doing an
5297 -- unnecessary expansion, and also avoids infinite recursion.
5299 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
)
5300 and then (Nkind
(Parent
(N
)) /= N_Object_Declaration
5301 or else Expression
(Parent
(N
)) /= N
)
5304 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5307 Make_Object_Declaration
(Loc
,
5308 Defining_Identifier
=> Cnn
,
5309 Constant_Present
=> True,
5310 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5311 Expression
=> Relocate_Node
(N
),
5312 Has_Init_Expression
=> True));
5314 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
5318 -- For other types, we only need to expand if there are other actions
5319 -- associated with either branch.
5321 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5323 -- We now wrap the actions into the appropriate expression
5325 if Minimize_Expression_With_Actions
5326 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
5327 or else Is_Constrained
(Underlying_Type
(Typ
)))
5329 -- If we can't use N_Expression_With_Actions nodes, then we insert
5330 -- the following sequence of actions (using Insert_Actions):
5335 -- Cnn := then-expr;
5341 -- and replace the if expression by a reference to Cnn
5343 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5346 Make_Object_Declaration
(Loc
,
5347 Defining_Identifier
=> Cnn
,
5348 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
5351 Make_Implicit_If_Statement
(N
,
5352 Condition
=> Relocate_Node
(Cond
),
5354 Then_Statements
=> New_List
(
5355 Make_Assignment_Statement
(Sloc
(Thenx
),
5356 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5357 Expression
=> Relocate_Node
(Thenx
))),
5359 Else_Statements
=> New_List
(
5360 Make_Assignment_Statement
(Sloc
(Elsex
),
5361 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5362 Expression
=> Relocate_Node
(Elsex
))));
5364 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
5365 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
5367 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
5369 -- Regular path using Expression_With_Actions
5372 if Present
(Then_Actions
(N
)) then
5374 Make_Expression_With_Actions
(Sloc
(Thenx
),
5375 Actions
=> Then_Actions
(N
),
5376 Expression
=> Relocate_Node
(Thenx
)));
5378 Set_Then_Actions
(N
, No_List
);
5379 Analyze_And_Resolve
(Thenx
, Typ
);
5382 if Present
(Else_Actions
(N
)) then
5384 Make_Expression_With_Actions
(Sloc
(Elsex
),
5385 Actions
=> Else_Actions
(N
),
5386 Expression
=> Relocate_Node
(Elsex
)));
5388 Set_Else_Actions
(N
, No_List
);
5389 Analyze_And_Resolve
(Elsex
, Typ
);
5395 -- If no actions then no expansion needed, gigi will handle it using the
5396 -- same approach as a C conditional expression.
5402 -- Fall through here for either the limited expansion, or the case of
5403 -- inserting actions for non-limited types. In both these cases, we must
5404 -- move the SLOC of the parent If statement to the newly created one and
5405 -- change it to the SLOC of the expression which, after expansion, will
5406 -- correspond to what is being evaluated.
5408 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
5409 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5410 Set_Sloc
(Parent
(N
), Loc
);
5413 -- Make sure Then_Actions and Else_Actions are appropriately moved
5414 -- to the new if statement.
5416 if Present
(Then_Actions
(N
)) then
5418 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5421 if Present
(Else_Actions
(N
)) then
5423 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5426 Insert_Action
(N
, Decl
);
5427 Insert_Action
(N
, New_If
);
5429 Analyze_And_Resolve
(N
, Typ
);
5430 end Expand_N_If_Expression
;
5436 procedure Expand_N_In
(N
: Node_Id
) is
5437 Loc
: constant Source_Ptr
:= Sloc
(N
);
5438 Restyp
: constant Entity_Id
:= Etype
(N
);
5439 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5440 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5441 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5443 procedure Substitute_Valid_Check
;
5444 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5445 -- test for the left operand being in range of its subtype.
5447 ----------------------------
5448 -- Substitute_Valid_Check --
5449 ----------------------------
5451 procedure Substitute_Valid_Check
is
5452 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
5453 -- Determine whether arbitrary node Nod denotes a source object that
5454 -- may safely act as prefix of attribute 'Valid.
5456 ----------------------------
5457 -- Is_OK_Object_Reference --
5458 ----------------------------
5460 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
5464 -- Inspect the original operand
5466 Obj_Ref
:= Original_Node
(Nod
);
5468 -- The object reference must be a source construct, otherwise the
5469 -- codefix suggestion may refer to nonexistent code from a user
5472 if Comes_From_Source
(Obj_Ref
) then
5474 -- Recover the actual object reference. There may be more cases
5478 if Nkind_In
(Obj_Ref
, N_Type_Conversion
,
5479 N_Unchecked_Type_Conversion
)
5481 Obj_Ref
:= Expression
(Obj_Ref
);
5487 return Is_Object_Reference
(Obj_Ref
);
5491 end Is_OK_Object_Reference
;
5493 -- Start of processing for Substitute_Valid_Check
5497 Make_Attribute_Reference
(Loc
,
5498 Prefix
=> Relocate_Node
(Lop
),
5499 Attribute_Name
=> Name_Valid
));
5501 Analyze_And_Resolve
(N
, Restyp
);
5503 -- Emit a warning when the left-hand operand of the membership test
5504 -- is a source object, otherwise the use of attribute 'Valid would be
5505 -- illegal. The warning is not given when overflow checking is either
5506 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
5507 -- eliminated above.
5509 if Is_OK_Object_Reference
(Lop
)
5510 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
5513 ("??explicit membership test may be optimized away", N
);
5514 Error_Msg_N
-- CODEFIX
5515 ("\??use ''Valid attribute instead", N
);
5517 end Substitute_Valid_Check
;
5524 -- Start of processing for Expand_N_In
5527 -- If set membership case, expand with separate procedure
5529 if Present
(Alternatives
(N
)) then
5530 Expand_Set_Membership
(N
);
5534 -- Not set membership, proceed with expansion
5536 Ltyp
:= Etype
(Left_Opnd
(N
));
5537 Rtyp
:= Etype
(Right_Opnd
(N
));
5539 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5540 -- type, then expand with a separate procedure. Note the use of the
5541 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5543 if Overflow_Check_Mode
in Minimized_Or_Eliminated
5544 and then Is_Signed_Integer_Type
(Ltyp
)
5545 and then not No_Minimize_Eliminate
(N
)
5547 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
5551 -- Check case of explicit test for an expression in range of its
5552 -- subtype. This is suspicious usage and we replace it with a 'Valid
5553 -- test and give a warning for scalar types.
5555 if Is_Scalar_Type
(Ltyp
)
5557 -- Only relevant for source comparisons
5559 and then Comes_From_Source
(N
)
5561 -- In floating-point this is a standard way to check for finite values
5562 -- and using 'Valid would typically be a pessimization.
5564 and then not Is_Floating_Point_Type
(Ltyp
)
5566 -- Don't give the message unless right operand is a type entity and
5567 -- the type of the left operand matches this type. Note that this
5568 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5569 -- checks have changed the type of the left operand.
5571 and then Nkind
(Rop
) in N_Has_Entity
5572 and then Ltyp
= Entity
(Rop
)
5574 -- Skip this for predicated types, where such expressions are a
5575 -- reasonable way of testing if something meets the predicate.
5577 and then not Present
(Predicate_Function
(Ltyp
))
5579 Substitute_Valid_Check
;
5583 -- Do validity check on operands
5585 if Validity_Checks_On
and Validity_Check_Operands
then
5586 Ensure_Valid
(Left_Opnd
(N
));
5587 Validity_Check_Range
(Right_Opnd
(N
));
5590 -- Case of explicit range
5592 if Nkind
(Rop
) = N_Range
then
5594 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
5595 Hi
: constant Node_Id
:= High_Bound
(Rop
);
5597 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
5598 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
5600 Lcheck
: Compare_Result
;
5601 Ucheck
: Compare_Result
;
5603 Warn1
: constant Boolean :=
5604 Constant_Condition_Warnings
5605 and then Comes_From_Source
(N
)
5606 and then not In_Instance
;
5607 -- This must be true for any of the optimization warnings, we
5608 -- clearly want to give them only for source with the flag on. We
5609 -- also skip these warnings in an instance since it may be the
5610 -- case that different instantiations have different ranges.
5612 Warn2
: constant Boolean :=
5614 and then Nkind
(Original_Node
(Rop
)) = N_Range
5615 and then Is_Integer_Type
(Etype
(Lo
));
5616 -- For the case where only one bound warning is elided, we also
5617 -- insist on an explicit range and an integer type. The reason is
5618 -- that the use of enumeration ranges including an end point is
5619 -- common, as is the use of a subtype name, one of whose bounds is
5620 -- the same as the type of the expression.
5623 -- If test is explicit x'First .. x'Last, replace by valid check
5625 -- Could use some individual comments for this complex test ???
5627 if Is_Scalar_Type
(Ltyp
)
5629 -- And left operand is X'First where X matches left operand
5630 -- type (this eliminates cases of type mismatch, including
5631 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5632 -- type of the left operand.
5634 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
5635 and then Attribute_Name
(Lo_Orig
) = Name_First
5636 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
5637 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
5639 -- Same tests for right operand
5641 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
5642 and then Attribute_Name
(Hi_Orig
) = Name_Last
5643 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
5644 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
5646 -- Relevant only for source cases
5648 and then Comes_From_Source
(N
)
5650 Substitute_Valid_Check
;
5654 -- If bounds of type are known at compile time, and the end points
5655 -- are known at compile time and identical, this is another case
5656 -- for substituting a valid test. We only do this for discrete
5657 -- types, since it won't arise in practice for float types.
5659 if Comes_From_Source
(N
)
5660 and then Is_Discrete_Type
(Ltyp
)
5661 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
5662 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
5663 and then Compile_Time_Known_Value
(Lo
)
5664 and then Compile_Time_Known_Value
(Hi
)
5665 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
5666 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
5668 -- Kill warnings in instances, since they may be cases where we
5669 -- have a test in the generic that makes sense with some types
5670 -- and not with other types.
5672 and then not In_Instance
5674 Substitute_Valid_Check
;
5678 -- If we have an explicit range, do a bit of optimization based on
5679 -- range analysis (we may be able to kill one or both checks).
5681 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
5682 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
5684 -- If either check is known to fail, replace result by False since
5685 -- the other check does not matter. Preserve the static flag for
5686 -- legality checks, because we are constant-folding beyond RM 4.9.
5688 if Lcheck
= LT
or else Ucheck
= GT
then
5690 Error_Msg_N
("?c?range test optimized away", N
);
5691 Error_Msg_N
("\?c?value is known to be out of range", N
);
5694 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5695 Analyze_And_Resolve
(N
, Restyp
);
5696 Set_Is_Static_Expression
(N
, Static
);
5699 -- If both checks are known to succeed, replace result by True,
5700 -- since we know we are in range.
5702 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5704 Error_Msg_N
("?c?range test optimized away", N
);
5705 Error_Msg_N
("\?c?value is known to be in range", N
);
5708 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5709 Analyze_And_Resolve
(N
, Restyp
);
5710 Set_Is_Static_Expression
(N
, Static
);
5713 -- If lower bound check succeeds and upper bound check is not
5714 -- known to succeed or fail, then replace the range check with
5715 -- a comparison against the upper bound.
5717 elsif Lcheck
in Compare_GE
then
5718 if Warn2
and then not In_Instance
then
5719 Error_Msg_N
("??lower bound test optimized away", Lo
);
5720 Error_Msg_N
("\??value is known to be in range", Lo
);
5726 Right_Opnd
=> High_Bound
(Rop
)));
5727 Analyze_And_Resolve
(N
, Restyp
);
5730 -- If upper bound check succeeds and lower bound check is not
5731 -- known to succeed or fail, then replace the range check with
5732 -- a comparison against the lower bound.
5734 elsif Ucheck
in Compare_LE
then
5735 if Warn2
and then not In_Instance
then
5736 Error_Msg_N
("??upper bound test optimized away", Hi
);
5737 Error_Msg_N
("\??value is known to be in range", Hi
);
5743 Right_Opnd
=> Low_Bound
(Rop
)));
5744 Analyze_And_Resolve
(N
, Restyp
);
5748 -- We couldn't optimize away the range check, but there is one
5749 -- more issue. If we are checking constant conditionals, then we
5750 -- see if we can determine the outcome assuming everything is
5751 -- valid, and if so give an appropriate warning.
5753 if Warn1
and then not Assume_No_Invalid_Values
then
5754 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
5755 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
5757 -- Result is out of range for valid value
5759 if Lcheck
= LT
or else Ucheck
= GT
then
5761 ("?c?value can only be in range if it is invalid", N
);
5763 -- Result is in range for valid value
5765 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5767 ("?c?value can only be out of range if it is invalid", N
);
5769 -- Lower bound check succeeds if value is valid
5771 elsif Warn2
and then Lcheck
in Compare_GE
then
5773 ("?c?lower bound check only fails if it is invalid", Lo
);
5775 -- Upper bound check succeeds if value is valid
5777 elsif Warn2
and then Ucheck
in Compare_LE
then
5779 ("?c?upper bound check only fails for invalid values", Hi
);
5784 -- For all other cases of an explicit range, nothing to be done
5788 -- Here right operand is a subtype mark
5792 Typ
: Entity_Id
:= Etype
(Rop
);
5793 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
5794 Cond
: Node_Id
:= Empty
;
5796 Obj
: Node_Id
:= Lop
;
5797 SCIL_Node
: Node_Id
;
5800 Remove_Side_Effects
(Obj
);
5802 -- For tagged type, do tagged membership operation
5804 if Is_Tagged_Type
(Typ
) then
5806 -- No expansion will be performed for VM targets, as the VM
5807 -- back-ends will handle the membership tests directly.
5809 if Tagged_Type_Expansion
then
5810 Tagged_Membership
(N
, SCIL_Node
, New_N
);
5812 Analyze_And_Resolve
(N
, Restyp
);
5814 -- Update decoration of relocated node referenced by the
5817 if Generate_SCIL
and then Present
(SCIL_Node
) then
5818 Set_SCIL_Node
(N
, SCIL_Node
);
5824 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5825 -- This reason we do this is that the bounds may have the wrong
5826 -- type if they come from the original type definition. Also this
5827 -- way we get all the processing above for an explicit range.
5829 -- Don't do this for predicated types, since in this case we
5830 -- want to check the predicate.
5832 elsif Is_Scalar_Type
(Typ
) then
5833 if No
(Predicate_Function
(Typ
)) then
5837 Make_Attribute_Reference
(Loc
,
5838 Attribute_Name
=> Name_First
,
5839 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
5842 Make_Attribute_Reference
(Loc
,
5843 Attribute_Name
=> Name_Last
,
5844 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
5845 Analyze_And_Resolve
(N
, Restyp
);
5850 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5851 -- a membership test if the subtype mark denotes a constrained
5852 -- Unchecked_Union subtype and the expression lacks inferable
5855 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
5856 and then Is_Constrained
(Typ
)
5857 and then not Has_Inferable_Discriminants
(Lop
)
5860 Make_Raise_Program_Error
(Loc
,
5861 Reason
=> PE_Unchecked_Union_Restriction
));
5863 -- Prevent Gigi from generating incorrect code by rewriting the
5864 -- test as False. What is this undocumented thing about ???
5866 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5870 -- Here we have a non-scalar type
5873 Typ
:= Designated_Type
(Typ
);
5876 if not Is_Constrained
(Typ
) then
5877 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5878 Analyze_And_Resolve
(N
, Restyp
);
5880 -- For the constrained array case, we have to check the subscripts
5881 -- for an exact match if the lengths are non-zero (the lengths
5882 -- must match in any case).
5884 elsif Is_Array_Type
(Typ
) then
5885 Check_Subscripts
: declare
5886 function Build_Attribute_Reference
5889 Dim
: Nat
) return Node_Id
;
5890 -- Build attribute reference E'Nam (Dim)
5892 -------------------------------
5893 -- Build_Attribute_Reference --
5894 -------------------------------
5896 function Build_Attribute_Reference
5899 Dim
: Nat
) return Node_Id
5903 Make_Attribute_Reference
(Loc
,
5905 Attribute_Name
=> Nam
,
5906 Expressions
=> New_List
(
5907 Make_Integer_Literal
(Loc
, Dim
)));
5908 end Build_Attribute_Reference
;
5910 -- Start of processing for Check_Subscripts
5913 for J
in 1 .. Number_Dimensions
(Typ
) loop
5914 Evolve_And_Then
(Cond
,
5917 Build_Attribute_Reference
5918 (Duplicate_Subexpr_No_Checks
(Obj
),
5921 Build_Attribute_Reference
5922 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
5924 Evolve_And_Then
(Cond
,
5927 Build_Attribute_Reference
5928 (Duplicate_Subexpr_No_Checks
(Obj
),
5931 Build_Attribute_Reference
5932 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
5941 Right_Opnd
=> Make_Null
(Loc
)),
5942 Right_Opnd
=> Cond
);
5946 Analyze_And_Resolve
(N
, Restyp
);
5947 end Check_Subscripts
;
5949 -- These are the cases where constraint checks may be required,
5950 -- e.g. records with possible discriminants
5953 -- Expand the test into a series of discriminant comparisons.
5954 -- The expression that is built is the negation of the one that
5955 -- is used for checking discriminant constraints.
5957 Obj
:= Relocate_Node
(Left_Opnd
(N
));
5959 if Has_Discriminants
(Typ
) then
5960 Cond
:= Make_Op_Not
(Loc
,
5961 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
5964 Cond
:= Make_Or_Else
(Loc
,
5968 Right_Opnd
=> Make_Null
(Loc
)),
5969 Right_Opnd
=> Cond
);
5973 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
5977 Analyze_And_Resolve
(N
, Restyp
);
5980 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5981 -- expression of an anonymous access type. This can involve an
5982 -- accessibility test and a tagged type membership test in the
5983 -- case of tagged designated types.
5985 if Ada_Version
>= Ada_2012
5987 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
5990 Expr_Entity
: Entity_Id
:= Empty
;
5992 Param_Level
: Node_Id
;
5993 Type_Level
: Node_Id
;
5996 if Is_Entity_Name
(Lop
) then
5997 Expr_Entity
:= Param_Entity
(Lop
);
5999 if not Present
(Expr_Entity
) then
6000 Expr_Entity
:= Entity
(Lop
);
6004 -- If a conversion of the anonymous access value to the
6005 -- tested type would be illegal, then the result is False.
6007 if not Valid_Conversion
6008 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6010 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6011 Analyze_And_Resolve
(N
, Restyp
);
6013 -- Apply an accessibility check if the access object has an
6014 -- associated access level and when the level of the type is
6015 -- less deep than the level of the access parameter. This
6016 -- only occur for access parameters and stand-alone objects
6017 -- of an anonymous access type.
6020 if Present
(Expr_Entity
)
6023 (Effective_Extra_Accessibility
(Expr_Entity
))
6024 and then UI_Gt
(Object_Access_Level
(Lop
),
6025 Type_Access_Level
(Rtyp
))
6029 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
6032 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6034 -- Return True only if the accessibility level of the
6035 -- expression entity is not deeper than the level of
6036 -- the tested access type.
6040 Left_Opnd
=> Relocate_Node
(N
),
6041 Right_Opnd
=> Make_Op_Le
(Loc
,
6042 Left_Opnd
=> Param_Level
,
6043 Right_Opnd
=> Type_Level
)));
6045 Analyze_And_Resolve
(N
);
6048 -- If the designated type is tagged, do tagged membership
6051 -- *** NOTE: we have to check not null before doing the
6052 -- tagged membership test (but maybe that can be done
6053 -- inside Tagged_Membership?).
6055 if Is_Tagged_Type
(Typ
) then
6058 Left_Opnd
=> Relocate_Node
(N
),
6062 Right_Opnd
=> Make_Null
(Loc
))));
6064 -- No expansion will be performed for VM targets, as
6065 -- the VM back-ends will handle the membership tests
6068 if Tagged_Type_Expansion
then
6070 -- Note that we have to pass Original_Node, because
6071 -- the membership test might already have been
6072 -- rewritten by earlier parts of membership test.
6075 (Original_Node
(N
), SCIL_Node
, New_N
);
6077 -- Update decoration of relocated node referenced
6078 -- by the SCIL node.
6080 if Generate_SCIL
and then Present
(SCIL_Node
) then
6081 Set_SCIL_Node
(New_N
, SCIL_Node
);
6086 Left_Opnd
=> Relocate_Node
(N
),
6087 Right_Opnd
=> New_N
));
6089 Analyze_And_Resolve
(N
, Restyp
);
6098 -- At this point, we have done the processing required for the basic
6099 -- membership test, but not yet dealt with the predicate.
6103 -- If a predicate is present, then we do the predicate test, but we
6104 -- most certainly want to omit this if we are within the predicate
6105 -- function itself, since otherwise we have an infinite recursion.
6106 -- The check should also not be emitted when testing against a range
6107 -- (the check is only done when the right operand is a subtype; see
6108 -- RM12-4.5.2 (28.1/3-30/3)).
6110 Predicate_Check
: declare
6111 function In_Range_Check
return Boolean;
6112 -- Within an expanded range check that may raise Constraint_Error do
6113 -- not generate a predicate check as well. It is redundant because
6114 -- the context will add an explicit predicate check, and it will
6115 -- raise the wrong exception if it fails.
6117 --------------------
6118 -- In_Range_Check --
6119 --------------------
6121 function In_Range_Check
return Boolean is
6125 while Present
(P
) loop
6126 if Nkind
(P
) = N_Raise_Constraint_Error
then
6129 elsif Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6130 or else Nkind
(P
) = N_Procedure_Call_Statement
6131 or else Nkind
(P
) in N_Declaration
6144 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6147 -- Start of processing for Predicate_Check
6151 and then Current_Scope
/= PFunc
6152 and then Nkind
(Rop
) /= N_Range
6154 if not In_Range_Check
then
6155 R_Op
:= Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True);
6157 R_Op
:= New_Occurrence_Of
(Standard_True
, Loc
);
6162 Left_Opnd
=> Relocate_Node
(N
),
6163 Right_Opnd
=> R_Op
));
6165 -- Analyze new expression, mark left operand as analyzed to
6166 -- avoid infinite recursion adding predicate calls. Similarly,
6167 -- suppress further range checks on the call.
6169 Set_Analyzed
(Left_Opnd
(N
));
6170 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6172 -- All done, skip attempt at compile time determination of result
6176 end Predicate_Check
;
6179 --------------------------------
6180 -- Expand_N_Indexed_Component --
6181 --------------------------------
6183 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6184 Loc
: constant Source_Ptr
:= Sloc
(N
);
6185 Typ
: constant Entity_Id
:= Etype
(N
);
6186 P
: constant Node_Id
:= Prefix
(N
);
6187 T
: constant Entity_Id
:= Etype
(P
);
6191 -- A special optimization, if we have an indexed component that is
6192 -- selecting from a slice, then we can eliminate the slice, since, for
6193 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6194 -- the range check required by the slice. The range check for the slice
6195 -- itself has already been generated. The range check for the
6196 -- subscripting operation is ensured by converting the subject to
6197 -- the subtype of the slice.
6199 -- This optimization not only generates better code, avoiding slice
6200 -- messing especially in the packed case, but more importantly bypasses
6201 -- some problems in handling this peculiar case, for example, the issue
6202 -- of dealing specially with object renamings.
6204 if Nkind
(P
) = N_Slice
6206 -- This optimization is disabled for CodePeer because it can transform
6207 -- an index-check constraint_error into a range-check constraint_error
6208 -- and CodePeer cares about that distinction.
6210 and then not CodePeer_Mode
6213 Make_Indexed_Component
(Loc
,
6214 Prefix
=> Prefix
(P
),
6215 Expressions
=> New_List
(
6217 (Etype
(First_Index
(Etype
(P
))),
6218 First
(Expressions
(N
))))));
6219 Analyze_And_Resolve
(N
, Typ
);
6223 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6224 -- function, then additional actuals must be passed.
6226 if Ada_Version
>= Ada_2005
6227 and then Is_Build_In_Place_Function_Call
(P
)
6229 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6232 -- If the prefix is an access type, then we unconditionally rewrite if
6233 -- as an explicit dereference. This simplifies processing for several
6234 -- cases, including packed array cases and certain cases in which checks
6235 -- must be generated. We used to try to do this only when it was
6236 -- necessary, but it cleans up the code to do it all the time.
6238 if Is_Access_Type
(T
) then
6239 Insert_Explicit_Dereference
(P
);
6240 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6241 Atp
:= Designated_Type
(T
);
6246 -- Generate index and validity checks
6248 Generate_Index_Checks
(N
);
6250 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6251 Apply_Subscript_Validity_Checks
(N
);
6254 -- If selecting from an array with atomic components, and atomic sync
6255 -- is not suppressed for this array type, set atomic sync flag.
6257 if (Has_Atomic_Components
(Atp
)
6258 and then not Atomic_Synchronization_Disabled
(Atp
))
6259 or else (Is_Atomic
(Typ
)
6260 and then not Atomic_Synchronization_Disabled
(Typ
))
6261 or else (Is_Entity_Name
(P
)
6262 and then Has_Atomic_Components
(Entity
(P
))
6263 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
6265 Activate_Atomic_Synchronization
(N
);
6268 -- All done if the prefix is not a packed array implemented specially
6270 if not (Is_Packed
(Etype
(Prefix
(N
)))
6271 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(N
)))))
6276 -- For packed arrays that are not bit-packed (i.e. the case of an array
6277 -- with one or more index types with a non-contiguous enumeration type),
6278 -- we can always use the normal packed element get circuit.
6280 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6281 Expand_Packed_Element_Reference
(N
);
6285 -- For a reference to a component of a bit packed array, we convert it
6286 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6287 -- want to do this for simple references, and not for:
6289 -- Left side of assignment, or prefix of left side of assignment, or
6290 -- prefix of the prefix, to handle packed arrays of packed arrays,
6291 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6293 -- Renaming objects in renaming associations
6294 -- This case is handled when a use of the renamed variable occurs
6296 -- Actual parameters for a procedure call
6297 -- This case is handled in Exp_Ch6.Expand_Actuals
6299 -- The second expression in a 'Read attribute reference
6301 -- The prefix of an address or bit or size attribute reference
6303 -- The following circuit detects these exceptions. Note that we need to
6304 -- deal with implicit dereferences when climbing up the parent chain,
6305 -- with the additional difficulty that the type of parents may have yet
6306 -- to be resolved since prefixes are usually resolved first.
6309 Child
: Node_Id
:= N
;
6310 Parnt
: Node_Id
:= Parent
(N
);
6314 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6317 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6318 N_Procedure_Call_Statement
)
6319 or else (Nkind
(Parnt
) = N_Parameter_Association
6321 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6325 elsif Nkind
(Parnt
) = N_Attribute_Reference
6326 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
6329 and then Prefix
(Parnt
) = Child
6333 elsif Nkind
(Parnt
) = N_Assignment_Statement
6334 and then Name
(Parnt
) = Child
6338 -- If the expression is an index of an indexed component, it must
6339 -- be expanded regardless of context.
6341 elsif Nkind
(Parnt
) = N_Indexed_Component
6342 and then Child
/= Prefix
(Parnt
)
6344 Expand_Packed_Element_Reference
(N
);
6347 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6348 and then Name
(Parent
(Parnt
)) = Parnt
6352 elsif Nkind
(Parnt
) = N_Attribute_Reference
6353 and then Attribute_Name
(Parnt
) = Name_Read
6354 and then Next
(First
(Expressions
(Parnt
))) = Child
6358 elsif Nkind
(Parnt
) = N_Indexed_Component
6359 and then Prefix
(Parnt
) = Child
6363 elsif Nkind
(Parnt
) = N_Selected_Component
6364 and then Prefix
(Parnt
) = Child
6365 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
6367 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
6371 -- If the parent is a dereference, either implicit or explicit,
6372 -- then the packed reference needs to be expanded.
6375 Expand_Packed_Element_Reference
(N
);
6379 -- Keep looking up tree for unchecked expression, or if we are the
6380 -- prefix of a possible assignment left side.
6383 Parnt
:= Parent
(Child
);
6386 end Expand_N_Indexed_Component
;
6388 ---------------------
6389 -- Expand_N_Not_In --
6390 ---------------------
6392 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6393 -- can be done. This avoids needing to duplicate this expansion code.
6395 procedure Expand_N_Not_In
(N
: Node_Id
) is
6396 Loc
: constant Source_Ptr
:= Sloc
(N
);
6397 Typ
: constant Entity_Id
:= Etype
(N
);
6398 Cfs
: constant Boolean := Comes_From_Source
(N
);
6405 Left_Opnd
=> Left_Opnd
(N
),
6406 Right_Opnd
=> Right_Opnd
(N
))));
6408 -- If this is a set membership, preserve list of alternatives
6410 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6412 -- We want this to appear as coming from source if original does (see
6413 -- transformations in Expand_N_In).
6415 Set_Comes_From_Source
(N
, Cfs
);
6416 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6418 -- Now analyze transformed node
6420 Analyze_And_Resolve
(N
, Typ
);
6421 end Expand_N_Not_In
;
6427 -- The only replacement required is for the case of a null of a type that
6428 -- is an access to protected subprogram, or a subtype thereof. We represent
6429 -- such access values as a record, and so we must replace the occurrence of
6430 -- null by the equivalent record (with a null address and a null pointer in
6431 -- it), so that the backend creates the proper value.
6433 procedure Expand_N_Null
(N
: Node_Id
) is
6434 Loc
: constant Source_Ptr
:= Sloc
(N
);
6435 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6439 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6441 Make_Aggregate
(Loc
,
6442 Expressions
=> New_List
(
6443 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6447 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6449 -- For subsequent semantic analysis, the node must retain its type.
6450 -- Gigi in any case replaces this type by the corresponding record
6451 -- type before processing the node.
6457 when RE_Not_Available
=>
6461 ---------------------
6462 -- Expand_N_Op_Abs --
6463 ---------------------
6465 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6466 Loc
: constant Source_Ptr
:= Sloc
(N
);
6467 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6470 Unary_Op_Validity_Checks
(N
);
6472 -- Check for MINIMIZED/ELIMINATED overflow mode
6474 if Minimized_Eliminated_Overflow_Check
(N
) then
6475 Apply_Arithmetic_Overflow_Check
(N
);
6479 -- Deal with software overflow checking
6481 if not Backend_Overflow_Checks_On_Target
6482 and then Is_Signed_Integer_Type
(Etype
(N
))
6483 and then Do_Overflow_Check
(N
)
6485 -- The only case to worry about is when the argument is equal to the
6486 -- largest negative number, so what we do is to insert the check:
6488 -- [constraint_error when Expr = typ'Base'First]
6490 -- with the usual Duplicate_Subexpr use coding for expr
6493 Make_Raise_Constraint_Error
(Loc
,
6496 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6498 Make_Attribute_Reference
(Loc
,
6500 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6501 Attribute_Name
=> Name_First
)),
6502 Reason
=> CE_Overflow_Check_Failed
));
6504 end Expand_N_Op_Abs
;
6506 ---------------------
6507 -- Expand_N_Op_Add --
6508 ---------------------
6510 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6511 Typ
: constant Entity_Id
:= Etype
(N
);
6514 Binary_Op_Validity_Checks
(N
);
6516 -- Check for MINIMIZED/ELIMINATED overflow mode
6518 if Minimized_Eliminated_Overflow_Check
(N
) then
6519 Apply_Arithmetic_Overflow_Check
(N
);
6523 -- N + 0 = 0 + N = N for integer types
6525 if Is_Integer_Type
(Typ
) then
6526 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6527 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6529 Rewrite
(N
, Left_Opnd
(N
));
6532 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6533 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
6535 Rewrite
(N
, Right_Opnd
(N
));
6540 -- Arithmetic overflow checks for signed integer/fixed point types
6542 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
6543 Apply_Arithmetic_Overflow_Check
(N
);
6547 -- Overflow checks for floating-point if -gnateF mode active
6549 Check_Float_Op_Overflow
(N
);
6550 end Expand_N_Op_Add
;
6552 ---------------------
6553 -- Expand_N_Op_And --
6554 ---------------------
6556 procedure Expand_N_Op_And
(N
: Node_Id
) is
6557 Typ
: constant Entity_Id
:= Etype
(N
);
6560 Binary_Op_Validity_Checks
(N
);
6562 if Is_Array_Type
(Etype
(N
)) then
6563 Expand_Boolean_Operator
(N
);
6565 elsif Is_Boolean_Type
(Etype
(N
)) then
6566 Adjust_Condition
(Left_Opnd
(N
));
6567 Adjust_Condition
(Right_Opnd
(N
));
6568 Set_Etype
(N
, Standard_Boolean
);
6569 Adjust_Result_Type
(N
, Typ
);
6571 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
6572 Expand_Intrinsic_Call
(N
, Entity
(N
));
6575 end Expand_N_Op_And
;
6577 ------------------------
6578 -- Expand_N_Op_Concat --
6579 ------------------------
6581 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
6583 -- List of operands to be concatenated
6586 -- Node which is to be replaced by the result of concatenating the nodes
6587 -- in the list Opnds.
6590 -- Ensure validity of both operands
6592 Binary_Op_Validity_Checks
(N
);
6594 -- If we are the left operand of a concatenation higher up the tree,
6595 -- then do nothing for now, since we want to deal with a series of
6596 -- concatenations as a unit.
6598 if Nkind
(Parent
(N
)) = N_Op_Concat
6599 and then N
= Left_Opnd
(Parent
(N
))
6604 -- We get here with a concatenation whose left operand may be a
6605 -- concatenation itself with a consistent type. We need to process
6606 -- these concatenation operands from left to right, which means
6607 -- from the deepest node in the tree to the highest node.
6610 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
6611 Cnode
:= Left_Opnd
(Cnode
);
6614 -- Now Cnode is the deepest concatenation, and its parents are the
6615 -- concatenation nodes above, so now we process bottom up, doing the
6618 -- The outer loop runs more than once if more than one concatenation
6619 -- type is involved.
6622 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
6623 Set_Parent
(Opnds
, N
);
6625 -- The inner loop gathers concatenation operands
6627 Inner
: while Cnode
/= N
6628 and then Base_Type
(Etype
(Cnode
)) =
6629 Base_Type
(Etype
(Parent
(Cnode
)))
6631 Cnode
:= Parent
(Cnode
);
6632 Append
(Right_Opnd
(Cnode
), Opnds
);
6635 -- Note: The following code is a temporary workaround for N731-034
6636 -- and N829-028 and will be kept until the general issue of internal
6637 -- symbol serialization is addressed. The workaround is kept under a
6638 -- debug switch to avoid permiating into the general case.
6640 -- Wrap the node to concatenate into an expression actions node to
6641 -- keep it nicely packaged. This is useful in the case of an assert
6642 -- pragma with a concatenation where we want to be able to delete
6643 -- the concatenation and all its expansion stuff.
6645 if Debug_Flag_Dot_H
then
6647 Cnod
: constant Node_Id
:= Relocate_Node
(Cnode
);
6648 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
6651 -- Note: use Rewrite rather than Replace here, so that for
6652 -- example Why_Not_Static can find the original concatenation
6656 Make_Expression_With_Actions
(Sloc
(Cnode
),
6657 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
6658 Expression
=> Cnod
));
6660 Expand_Concatenate
(Cnod
, Opnds
);
6661 Analyze_And_Resolve
(Cnode
, Typ
);
6667 Expand_Concatenate
(Cnode
, Opnds
);
6670 exit Outer
when Cnode
= N
;
6671 Cnode
:= Parent
(Cnode
);
6673 end Expand_N_Op_Concat
;
6675 ------------------------
6676 -- Expand_N_Op_Divide --
6677 ------------------------
6679 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
6680 Loc
: constant Source_Ptr
:= Sloc
(N
);
6681 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
6682 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
6683 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
6684 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
6685 Typ
: Entity_Id
:= Etype
(N
);
6686 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
6688 Compile_Time_Known_Value
(Ropnd
);
6692 Binary_Op_Validity_Checks
(N
);
6694 -- Check for MINIMIZED/ELIMINATED overflow mode
6696 if Minimized_Eliminated_Overflow_Check
(N
) then
6697 Apply_Arithmetic_Overflow_Check
(N
);
6701 -- Otherwise proceed with expansion of division
6704 Rval
:= Expr_Value
(Ropnd
);
6707 -- N / 1 = N for integer types
6709 if Rknow
and then Rval
= Uint_1
then
6714 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6715 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6716 -- operand is an unsigned integer, as required for this to work.
6718 if Nkind
(Ropnd
) = N_Op_Expon
6719 and then Is_Power_Of_2_For_Shift
(Ropnd
)
6721 -- We cannot do this transformation in configurable run time mode if we
6722 -- have 64-bit integers and long shifts are not available.
6724 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
6727 Make_Op_Shift_Right
(Loc
,
6730 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
6731 Analyze_And_Resolve
(N
, Typ
);
6735 -- Do required fixup of universal fixed operation
6737 if Typ
= Universal_Fixed
then
6738 Fixup_Universal_Fixed_Operation
(N
);
6742 -- Divisions with fixed-point results
6744 if Is_Fixed_Point_Type
(Typ
) then
6746 -- Deal with divide-by-zero check if back end cannot handle them
6747 -- and the flag is set indicating that we need such a check. Note
6748 -- that we don't need to bother here with the case of mixed-mode
6749 -- (Right operand an integer type), since these will be rewritten
6750 -- with conversions to a divide with a fixed-point right operand.
6752 if Do_Division_Check
(N
)
6753 and then not Backend_Divide_Checks_On_Target
6754 and then not Is_Integer_Type
(Rtyp
)
6756 Set_Do_Division_Check
(N
, False);
6758 Make_Raise_Constraint_Error
(Loc
,
6761 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
6762 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
6763 Reason
=> CE_Divide_By_Zero
));
6766 -- No special processing if Treat_Fixed_As_Integer is set, since
6767 -- from a semantic point of view such operations are simply integer
6768 -- operations and will be treated that way.
6770 if not Treat_Fixed_As_Integer
(N
) then
6771 if Is_Integer_Type
(Rtyp
) then
6772 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
6774 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
6778 -- Other cases of division of fixed-point operands. Again we exclude the
6779 -- case where Treat_Fixed_As_Integer is set.
6781 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
6782 and then not Treat_Fixed_As_Integer
(N
)
6784 if Is_Integer_Type
(Typ
) then
6785 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
6787 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6788 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
6791 -- Mixed-mode operations can appear in a non-static universal context,
6792 -- in which case the integer argument must be converted explicitly.
6794 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
6796 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
6798 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
6800 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
6802 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
6804 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
6806 -- Non-fixed point cases, do integer zero divide and overflow checks
6808 elsif Is_Integer_Type
(Typ
) then
6809 Apply_Divide_Checks
(N
);
6812 -- Overflow checks for floating-point if -gnateF mode active
6814 Check_Float_Op_Overflow
(N
);
6815 end Expand_N_Op_Divide
;
6817 --------------------
6818 -- Expand_N_Op_Eq --
6819 --------------------
6821 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
6822 Loc
: constant Source_Ptr
:= Sloc
(N
);
6823 Typ
: constant Entity_Id
:= Etype
(N
);
6824 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
6825 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
6826 Bodies
: constant List_Id
:= New_List
;
6827 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
6829 Typl
: Entity_Id
:= A_Typ
;
6830 Op_Name
: Entity_Id
;
6833 procedure Build_Equality_Call
(Eq
: Entity_Id
);
6834 -- If a constructed equality exists for the type or for its parent,
6835 -- build and analyze call, adding conversions if the operation is
6838 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
6839 -- Determines whether a type has a subcomponent of an unconstrained
6840 -- Unchecked_Union subtype. Typ is a record type.
6842 -------------------------
6843 -- Build_Equality_Call --
6844 -------------------------
6846 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
6847 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
6848 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
6849 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
6852 -- Adjust operands if necessary to comparison type
6854 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
6855 and then not Is_Class_Wide_Type
(A_Typ
)
6857 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
6858 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
6861 -- If we have an Unchecked_Union, we need to add the inferred
6862 -- discriminant values as actuals in the function call. At this
6863 -- point, the expansion has determined that both operands have
6864 -- inferable discriminants.
6866 if Is_Unchecked_Union
(Op_Type
) then
6868 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
6869 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
6871 Lhs_Discr_Vals
: Elist_Id
;
6872 -- List of inferred discriminant values for left operand.
6874 Rhs_Discr_Vals
: Elist_Id
;
6875 -- List of inferred discriminant values for right operand.
6880 Lhs_Discr_Vals
:= New_Elmt_List
;
6881 Rhs_Discr_Vals
:= New_Elmt_List
;
6883 -- Per-object constrained selected components require special
6884 -- attention. If the enclosing scope of the component is an
6885 -- Unchecked_Union, we cannot reference its discriminants
6886 -- directly. This is why we use the extra parameters of the
6887 -- equality function of the enclosing Unchecked_Union.
6889 -- type UU_Type (Discr : Integer := 0) is
6892 -- pragma Unchecked_Union (UU_Type);
6894 -- 1. Unchecked_Union enclosing record:
6896 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6898 -- Comp : UU_Type (Discr);
6900 -- end Enclosing_UU_Type;
6901 -- pragma Unchecked_Union (Enclosing_UU_Type);
6903 -- Obj1 : Enclosing_UU_Type;
6904 -- Obj2 : Enclosing_UU_Type (1);
6906 -- [. . .] Obj1 = Obj2 [. . .]
6910 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6912 -- A and B are the formal parameters of the equality function
6913 -- of Enclosing_UU_Type. The function always has two extra
6914 -- formals to capture the inferred discriminant values for
6915 -- each discriminant of the type.
6917 -- 2. Non-Unchecked_Union enclosing record:
6920 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6923 -- Comp : UU_Type (Discr);
6925 -- end Enclosing_Non_UU_Type;
6927 -- Obj1 : Enclosing_Non_UU_Type;
6928 -- Obj2 : Enclosing_Non_UU_Type (1);
6930 -- ... Obj1 = Obj2 ...
6934 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6935 -- obj1.discr, obj2.discr)) then
6937 -- In this case we can directly reference the discriminants of
6938 -- the enclosing record.
6940 -- Process left operand of equality
6942 if Nkind
(Lhs
) = N_Selected_Component
6944 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
6946 -- If enclosing record is an Unchecked_Union, use formals
6947 -- corresponding to each discriminant. The name of the
6948 -- formal is that of the discriminant, with added suffix,
6949 -- see Exp_Ch3.Build_Record_Equality for details.
6951 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Lhs
))))
6955 (Scope
(Entity
(Selector_Name
(Lhs
))));
6956 while Present
(Discr
) loop
6958 (Make_Identifier
(Loc
,
6959 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
6960 To
=> Lhs_Discr_Vals
);
6961 Next_Discriminant
(Discr
);
6964 -- If enclosing record is of a non-Unchecked_Union type, it
6965 -- is possible to reference its discriminants directly.
6968 Discr
:= First_Discriminant
(Lhs_Type
);
6969 while Present
(Discr
) loop
6971 (Make_Selected_Component
(Loc
,
6972 Prefix
=> Prefix
(Lhs
),
6975 (Get_Discriminant_Value
(Discr
,
6977 Stored_Constraint
(Lhs_Type
)))),
6978 To
=> Lhs_Discr_Vals
);
6979 Next_Discriminant
(Discr
);
6983 -- Otherwise operand is on object with a constrained type.
6984 -- Infer the discriminant values from the constraint.
6988 Discr
:= First_Discriminant
(Lhs_Type
);
6989 while Present
(Discr
) loop
6992 (Get_Discriminant_Value
(Discr
,
6994 Stored_Constraint
(Lhs_Type
))),
6995 To
=> Lhs_Discr_Vals
);
6996 Next_Discriminant
(Discr
);
7000 -- Similar processing for right operand of equality
7002 if Nkind
(Rhs
) = N_Selected_Component
7004 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
7006 if Is_Unchecked_Union
7007 (Scope
(Entity
(Selector_Name
(Rhs
))))
7011 (Scope
(Entity
(Selector_Name
(Rhs
))));
7012 while Present
(Discr
) loop
7014 (Make_Identifier
(Loc
,
7015 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
7016 To
=> Rhs_Discr_Vals
);
7017 Next_Discriminant
(Discr
);
7021 Discr
:= First_Discriminant
(Rhs_Type
);
7022 while Present
(Discr
) loop
7024 (Make_Selected_Component
(Loc
,
7025 Prefix
=> Prefix
(Rhs
),
7027 New_Copy
(Get_Discriminant_Value
7030 Stored_Constraint
(Rhs_Type
)))),
7031 To
=> Rhs_Discr_Vals
);
7032 Next_Discriminant
(Discr
);
7037 Discr
:= First_Discriminant
(Rhs_Type
);
7038 while Present
(Discr
) loop
7040 (New_Copy
(Get_Discriminant_Value
7043 Stored_Constraint
(Rhs_Type
))),
7044 To
=> Rhs_Discr_Vals
);
7045 Next_Discriminant
(Discr
);
7049 -- Now merge the list of discriminant values so that values
7050 -- of corresponding discriminants are adjacent.
7058 Params
:= New_List
(L_Exp
, R_Exp
);
7059 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
7060 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
7061 while Present
(L_Elmt
) loop
7062 Append_To
(Params
, Node
(L_Elmt
));
7063 Append_To
(Params
, Node
(R_Elmt
));
7069 Make_Function_Call
(Loc
,
7070 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7071 Parameter_Associations
=> Params
));
7075 -- Normal case, not an unchecked union
7079 Make_Function_Call
(Loc
,
7080 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7081 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7084 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7085 end Build_Equality_Call
;
7087 ------------------------------------
7088 -- Has_Unconstrained_UU_Component --
7089 ------------------------------------
7091 function Has_Unconstrained_UU_Component
7092 (Typ
: Node_Id
) return Boolean
7094 Tdef
: constant Node_Id
:=
7095 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
7099 function Component_Is_Unconstrained_UU
7100 (Comp
: Node_Id
) return Boolean;
7101 -- Determines whether the subtype of the component is an
7102 -- unconstrained Unchecked_Union.
7104 function Variant_Is_Unconstrained_UU
7105 (Variant
: Node_Id
) return Boolean;
7106 -- Determines whether a component of the variant has an unconstrained
7107 -- Unchecked_Union subtype.
7109 -----------------------------------
7110 -- Component_Is_Unconstrained_UU --
7111 -----------------------------------
7113 function Component_Is_Unconstrained_UU
7114 (Comp
: Node_Id
) return Boolean
7117 if Nkind
(Comp
) /= N_Component_Declaration
then
7122 Sindic
: constant Node_Id
:=
7123 Subtype_Indication
(Component_Definition
(Comp
));
7126 -- Unconstrained nominal type. In the case of a constraint
7127 -- present, the node kind would have been N_Subtype_Indication.
7129 if Nkind
(Sindic
) = N_Identifier
then
7130 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
7135 end Component_Is_Unconstrained_UU
;
7137 ---------------------------------
7138 -- Variant_Is_Unconstrained_UU --
7139 ---------------------------------
7141 function Variant_Is_Unconstrained_UU
7142 (Variant
: Node_Id
) return Boolean
7144 Clist
: constant Node_Id
:= Component_List
(Variant
);
7147 if Is_Empty_List
(Component_Items
(Clist
)) then
7151 -- We only need to test one component
7154 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7157 while Present
(Comp
) loop
7158 if Component_Is_Unconstrained_UU
(Comp
) then
7166 -- None of the components withing the variant were of
7167 -- unconstrained Unchecked_Union type.
7170 end Variant_Is_Unconstrained_UU
;
7172 -- Start of processing for Has_Unconstrained_UU_Component
7175 if Null_Present
(Tdef
) then
7179 Clist
:= Component_List
(Tdef
);
7180 Vpart
:= Variant_Part
(Clist
);
7182 -- Inspect available components
7184 if Present
(Component_Items
(Clist
)) then
7186 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7189 while Present
(Comp
) loop
7191 -- One component is sufficient
7193 if Component_Is_Unconstrained_UU
(Comp
) then
7202 -- Inspect available components withing variants
7204 if Present
(Vpart
) then
7206 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7209 while Present
(Variant
) loop
7211 -- One component within a variant is sufficient
7213 if Variant_Is_Unconstrained_UU
(Variant
) then
7222 -- Neither the available components, nor the components inside the
7223 -- variant parts were of an unconstrained Unchecked_Union subtype.
7226 end Has_Unconstrained_UU_Component
;
7228 -- Start of processing for Expand_N_Op_Eq
7231 Binary_Op_Validity_Checks
(N
);
7233 -- Deal with private types
7235 if Ekind
(Typl
) = E_Private_Type
then
7236 Typl
:= Underlying_Type
(Typl
);
7237 elsif Ekind
(Typl
) = E_Private_Subtype
then
7238 Typl
:= Underlying_Type
(Base_Type
(Typl
));
7243 -- It may happen in error situations that the underlying type is not
7244 -- set. The error will be detected later, here we just defend the
7251 -- Now get the implementation base type (note that plain Base_Type here
7252 -- might lead us back to the private type, which is not what we want!)
7254 Typl
:= Implementation_Base_Type
(Typl
);
7256 -- Equality between variant records results in a call to a routine
7257 -- that has conditional tests of the discriminant value(s), and hence
7258 -- violates the No_Implicit_Conditionals restriction.
7260 if Has_Variant_Part
(Typl
) then
7265 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
7269 ("\comparison of variant records tests discriminants", N
);
7275 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7276 -- means we no longer have a comparison operation, we are all done.
7278 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7280 if Nkind
(N
) /= N_Op_Eq
then
7284 -- Boolean types (requiring handling of non-standard case)
7286 if Is_Boolean_Type
(Typl
) then
7287 Adjust_Condition
(Left_Opnd
(N
));
7288 Adjust_Condition
(Right_Opnd
(N
));
7289 Set_Etype
(N
, Standard_Boolean
);
7290 Adjust_Result_Type
(N
, Typ
);
7294 elsif Is_Array_Type
(Typl
) then
7296 -- If we are doing full validity checking, and it is possible for the
7297 -- array elements to be invalid then expand out array comparisons to
7298 -- make sure that we check the array elements.
7300 if Validity_Check_Operands
7301 and then not Is_Known_Valid
(Component_Type
(Typl
))
7304 Save_Force_Validity_Checks
: constant Boolean :=
7305 Force_Validity_Checks
;
7307 Force_Validity_Checks
:= True;
7309 Expand_Array_Equality
7311 Relocate_Node
(Lhs
),
7312 Relocate_Node
(Rhs
),
7315 Insert_Actions
(N
, Bodies
);
7316 Analyze_And_Resolve
(N
, Standard_Boolean
);
7317 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7320 -- Packed case where both operands are known aligned
7322 elsif Is_Bit_Packed_Array
(Typl
)
7323 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7324 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7326 Expand_Packed_Eq
(N
);
7328 -- Where the component type is elementary we can use a block bit
7329 -- comparison (if supported on the target) exception in the case
7330 -- of floating-point (negative zero issues require element by
7331 -- element comparison), and atomic/VFA types (where we must be sure
7332 -- to load elements independently) and possibly unaligned arrays.
7334 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7335 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7336 and then not Is_Atomic_Or_VFA
(Component_Type
(Typl
))
7337 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7338 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7339 and then Support_Composite_Compare_On_Target
7343 -- For composite and floating-point cases, expand equality loop to
7344 -- make sure of using proper comparisons for tagged types, and
7345 -- correctly handling the floating-point case.
7349 Expand_Array_Equality
7351 Relocate_Node
(Lhs
),
7352 Relocate_Node
(Rhs
),
7355 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7356 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7361 elsif Is_Record_Type
(Typl
) then
7363 -- For tagged types, use the primitive "="
7365 if Is_Tagged_Type
(Typl
) then
7367 -- No need to do anything else compiling under restriction
7368 -- No_Dispatching_Calls. During the semantic analysis we
7369 -- already notified such violation.
7371 if Restriction_Active
(No_Dispatching_Calls
) then
7375 -- If this is derived from an untagged private type completed with
7376 -- a tagged type, it does not have a full view, so we use the
7377 -- primitive operations of the private type. This check should no
7378 -- longer be necessary when these types get their full views???
7380 if Is_Private_Type
(A_Typ
)
7381 and then not Is_Tagged_Type
(A_Typ
)
7382 and then Is_Derived_Type
(A_Typ
)
7383 and then No
(Full_View
(A_Typ
))
7385 -- Search for equality operation, checking that the operands
7386 -- have the same type. Note that we must find a matching entry,
7387 -- or something is very wrong.
7389 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7391 while Present
(Prim
) loop
7392 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7393 and then Etype
(First_Formal
(Node
(Prim
))) =
7394 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7396 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7401 pragma Assert
(Present
(Prim
));
7402 Op_Name
:= Node
(Prim
);
7404 -- Find the type's predefined equality or an overriding
7405 -- user-defined equality. The reason for not simply calling
7406 -- Find_Prim_Op here is that there may be a user-defined
7407 -- overloaded equality op that precedes the equality that we
7408 -- want, so we have to explicitly search (e.g., there could be
7409 -- an equality with two different parameter types).
7412 if Is_Class_Wide_Type
(Typl
) then
7413 Typl
:= Find_Specific_Type
(Typl
);
7416 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7417 while Present
(Prim
) loop
7418 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7419 and then Etype
(First_Formal
(Node
(Prim
))) =
7420 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7422 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7427 pragma Assert
(Present
(Prim
));
7428 Op_Name
:= Node
(Prim
);
7431 Build_Equality_Call
(Op_Name
);
7433 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7434 -- predefined equality operator for a type which has a subcomponent
7435 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7437 elsif Has_Unconstrained_UU_Component
(Typl
) then
7439 Make_Raise_Program_Error
(Loc
,
7440 Reason
=> PE_Unchecked_Union_Restriction
));
7442 -- Prevent Gigi from generating incorrect code by rewriting the
7443 -- equality as a standard False. (is this documented somewhere???)
7446 New_Occurrence_Of
(Standard_False
, Loc
));
7448 elsif Is_Unchecked_Union
(Typl
) then
7450 -- If we can infer the discriminants of the operands, we make a
7451 -- call to the TSS equality function.
7453 if Has_Inferable_Discriminants
(Lhs
)
7455 Has_Inferable_Discriminants
(Rhs
)
7458 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7461 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7462 -- the predefined equality operator for an Unchecked_Union type
7463 -- if either of the operands lack inferable discriminants.
7466 Make_Raise_Program_Error
(Loc
,
7467 Reason
=> PE_Unchecked_Union_Restriction
));
7469 -- Emit a warning on source equalities only, otherwise the
7470 -- message may appear out of place due to internal use. The
7471 -- warning is unconditional because it is required by the
7474 if Comes_From_Source
(N
) then
7476 ("Unchecked_Union discriminants cannot be determined??",
7479 ("\Program_Error will be raised for equality operation??",
7483 -- Prevent Gigi from generating incorrect code by rewriting
7484 -- the equality as a standard False (documented where???).
7487 New_Occurrence_Of
(Standard_False
, Loc
));
7490 -- If a type support function is present (for complex cases), use it
7492 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7494 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7496 -- When comparing two Bounded_Strings, use the primitive equality of
7497 -- the root Super_String type.
7499 elsif Is_Bounded_String
(Typl
) then
7501 First_Elmt
(Collect_Primitive_Operations
(Root_Type
(Typl
)));
7503 while Present
(Prim
) loop
7504 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7505 and then Etype
(First_Formal
(Node
(Prim
))) =
7506 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7507 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7512 -- A Super_String type should always have a primitive equality
7514 pragma Assert
(Present
(Prim
));
7515 Build_Equality_Call
(Node
(Prim
));
7517 -- Otherwise expand the component by component equality. Note that
7518 -- we never use block-bit comparisons for records, because of the
7519 -- problems with gaps. The backend will often be able to recombine
7520 -- the separate comparisons that we generate here.
7523 Remove_Side_Effects
(Lhs
);
7524 Remove_Side_Effects
(Rhs
);
7526 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7528 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7529 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7533 -- Test if result is known at compile time
7535 Rewrite_Comparison
(N
);
7537 -- Special optimization of length comparison
7539 Optimize_Length_Comparison
(N
);
7541 -- One more special case: if we have a comparison of X'Result = expr
7542 -- in floating-point, then if not already there, change expr to be
7543 -- f'Machine (expr) to eliminate surprise from extra precision.
7545 if Is_Floating_Point_Type
(Typl
)
7546 and then Nkind
(Original_Node
(Lhs
)) = N_Attribute_Reference
7547 and then Attribute_Name
(Original_Node
(Lhs
)) = Name_Result
7549 -- Stick in the Typ'Machine call if not already there
7551 if Nkind
(Rhs
) /= N_Attribute_Reference
7552 or else Attribute_Name
(Rhs
) /= Name_Machine
7555 Make_Attribute_Reference
(Loc
,
7556 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
7557 Attribute_Name
=> Name_Machine
,
7558 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
7559 Analyze_And_Resolve
(Rhs
, Typl
);
7564 -----------------------
7565 -- Expand_N_Op_Expon --
7566 -----------------------
7568 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
7569 Loc
: constant Source_Ptr
:= Sloc
(N
);
7570 Typ
: constant Entity_Id
:= Etype
(N
);
7571 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
7572 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
7573 Bastyp
: constant Node_Id
:= Etype
(Base
);
7574 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
7575 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
7576 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
7584 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
7585 -- Given an expression Exp, if the root type is Float or Long_Float,
7586 -- then wrap the expression in a call of Bastyp'Machine, to stop any
7587 -- extra precision. This is done to ensure that X**A = X**B when A is
7588 -- a static constant and B is a variable with the same value. For any
7589 -- other type, the node Exp is returned unchanged.
7595 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
7596 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
7598 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
7600 Make_Attribute_Reference
(Loc
,
7601 Attribute_Name
=> Name_Machine
,
7602 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
7603 Expressions
=> New_List
(Relocate_Node
(Exp
)));
7609 -- Start of processing for Expand_N_Op
7612 Binary_Op_Validity_Checks
(N
);
7614 -- CodePeer wants to see the unexpanded N_Op_Expon node
7616 if CodePeer_Mode
then
7620 -- If either operand is of a private type, then we have the use of an
7621 -- intrinsic operator, and we get rid of the privateness, by using root
7622 -- types of underlying types for the actual operation. Otherwise the
7623 -- private types will cause trouble if we expand multiplications or
7624 -- shifts etc. We also do this transformation if the result type is
7625 -- different from the base type.
7627 if Is_Private_Type
(Etype
(Base
))
7628 or else Is_Private_Type
(Typ
)
7629 or else Is_Private_Type
(Exptyp
)
7630 or else Rtyp
/= Root_Type
(Bastyp
)
7633 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
7634 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
7637 Unchecked_Convert_To
(Typ
,
7639 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
7640 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
7641 Analyze_And_Resolve
(N
, Typ
);
7646 -- Check for MINIMIZED/ELIMINATED overflow mode
7648 if Minimized_Eliminated_Overflow_Check
(N
) then
7649 Apply_Arithmetic_Overflow_Check
(N
);
7653 -- Test for case of known right argument where we can replace the
7654 -- exponentiation by an equivalent expression using multiplication.
7656 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7657 -- configurable run-time mode, we may not have the exponentiation
7658 -- routine available, and we don't want the legality of the program
7659 -- to depend on how clever the compiler is in knowing values.
7661 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
7662 Expv
:= Expr_Value
(Exp
);
7664 -- We only fold small non-negative exponents. You might think we
7665 -- could fold small negative exponents for the real case, but we
7666 -- can't because we are required to raise Constraint_Error for
7667 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7668 -- See ACVC test C4A012B, and it is not worth generating the test.
7670 if Expv
>= 0 and then Expv
<= 4 then
7672 -- X ** 0 = 1 (or 1.0)
7676 -- Call Remove_Side_Effects to ensure that any side effects
7677 -- in the ignored left operand (in particular function calls
7678 -- to user defined functions) are properly executed.
7680 Remove_Side_Effects
(Base
);
7682 if Ekind
(Typ
) in Integer_Kind
then
7683 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
7685 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
7698 Make_Op_Multiply
(Loc
,
7699 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7700 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
7702 -- X ** 3 = X * X * X
7707 Make_Op_Multiply
(Loc
,
7709 Make_Op_Multiply
(Loc
,
7710 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7711 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
7712 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
7717 -- En : constant base'type := base * base;
7722 pragma Assert
(Expv
= 4);
7723 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
7726 Make_Expression_With_Actions
(Loc
,
7727 Actions
=> New_List
(
7728 Make_Object_Declaration
(Loc
,
7729 Defining_Identifier
=> Temp
,
7730 Constant_Present
=> True,
7731 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7734 Make_Op_Multiply
(Loc
,
7736 Duplicate_Subexpr
(Base
),
7738 Duplicate_Subexpr_No_Checks
(Base
))))),
7742 Make_Op_Multiply
(Loc
,
7743 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
7744 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
7748 Analyze_And_Resolve
(N
, Typ
);
7753 -- Deal with optimizing 2 ** expression to shift where possible
7755 -- Note: we used to check that Exptyp was an unsigned type. But that is
7756 -- an unnecessary check, since if Exp is negative, we have a run-time
7757 -- error that is either caught (so we get the right result) or we have
7758 -- suppressed the check, in which case the code is erroneous anyway.
7760 if Is_Integer_Type
(Rtyp
)
7762 -- The base value must be "safe compile-time known", and exactly 2
7764 and then Nkind
(Base
) = N_Integer_Literal
7765 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
7766 and then Expr_Value
(Base
) = Uint_2
7768 -- We only handle cases where the right type is a integer
7770 and then Is_Integer_Type
(Root_Type
(Exptyp
))
7771 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
7773 -- This transformation is not applicable for a modular type with a
7774 -- nonbinary modulus because we do not handle modular reduction in
7775 -- a correct manner if we attempt this transformation in this case.
7777 and then not Non_Binary_Modulus
(Typ
)
7779 -- Handle the cases where our parent is a division or multiplication
7780 -- specially. In these cases we can convert to using a shift at the
7781 -- parent level if we are not doing overflow checking, since it is
7782 -- too tricky to combine the overflow check at the parent level.
7785 and then Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
)
7788 P
: constant Node_Id
:= Parent
(N
);
7789 L
: constant Node_Id
:= Left_Opnd
(P
);
7790 R
: constant Node_Id
:= Right_Opnd
(P
);
7793 if (Nkind
(P
) = N_Op_Multiply
7795 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
7797 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
7798 and then not Do_Overflow_Check
(P
))
7801 (Nkind
(P
) = N_Op_Divide
7802 and then Is_Integer_Type
(Etype
(L
))
7803 and then Is_Unsigned_Type
(Etype
(L
))
7805 and then not Do_Overflow_Check
(P
))
7807 Set_Is_Power_Of_2_For_Shift
(N
);
7812 -- Here we just have 2 ** N on its own, so we can convert this to a
7813 -- shift node. We are prepared to deal with overflow here, and we
7814 -- also have to handle proper modular reduction for binary modular.
7823 -- Maximum shift count with no overflow
7826 -- Set True if we must test the shift count
7829 -- Node for test against TestS
7832 -- Compute maximum shift based on the underlying size. For a
7833 -- modular type this is one less than the size.
7835 if Is_Modular_Integer_Type
(Typ
) then
7837 -- For modular integer types, this is the size of the value
7838 -- being shifted minus one. Any larger values will cause
7839 -- modular reduction to a result of zero. Note that we do
7840 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
7841 -- of 6, since 2**7 should be reduced to zero).
7843 MaxS
:= RM_Size
(Rtyp
) - 1;
7845 -- For signed integer types, we use the size of the value
7846 -- being shifted minus 2. Larger values cause overflow.
7849 MaxS
:= Esize
(Rtyp
) - 2;
7852 -- Determine range to see if it can be larger than MaxS
7855 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
7856 TestS
:= (not OK
) or else Hi
> MaxS
;
7858 -- Signed integer case
7860 if Is_Signed_Integer_Type
(Typ
) then
7862 -- Generate overflow check if overflow is active. Note that
7863 -- we can simply ignore the possibility of overflow if the
7864 -- flag is not set (means that overflow cannot happen or
7865 -- that overflow checks are suppressed).
7867 if Ovflo
and TestS
then
7869 Make_Raise_Constraint_Error
(Loc
,
7872 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
7873 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
7874 Reason
=> CE_Overflow_Check_Failed
));
7877 -- Now rewrite node as Shift_Left (1, right-operand)
7880 Make_Op_Shift_Left
(Loc
,
7881 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7882 Right_Opnd
=> Right_Opnd
(N
)));
7884 -- Modular integer case
7886 else pragma Assert
(Is_Modular_Integer_Type
(Typ
));
7888 -- If shift count can be greater than MaxS, we need to wrap
7889 -- the shift in a test that will reduce the result value to
7890 -- zero if this shift count is exceeded.
7894 -- Note: build node for the comparison first, before we
7895 -- reuse the Right_Opnd, so that we have proper parents
7896 -- in place for the Duplicate_Subexpr call.
7900 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
7901 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
));
7904 Make_If_Expression
(Loc
,
7905 Expressions
=> New_List
(
7907 Make_Integer_Literal
(Loc
, Uint_0
),
7908 Make_Op_Shift_Left
(Loc
,
7909 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7910 Right_Opnd
=> Right_Opnd
(N
)))));
7912 -- If we know shift count cannot be greater than MaxS, then
7913 -- it is safe to just rewrite as a shift with no test.
7917 Make_Op_Shift_Left
(Loc
,
7918 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7919 Right_Opnd
=> Right_Opnd
(N
)));
7923 Analyze_And_Resolve
(N
, Typ
);
7929 -- Fall through if exponentiation must be done using a runtime routine
7931 -- First deal with modular case
7933 if Is_Modular_Integer_Type
(Rtyp
) then
7935 -- Nonbinary modular case, we call the special exponentiation
7936 -- routine for the nonbinary case, converting the argument to
7937 -- Long_Long_Integer and passing the modulus value. Then the
7938 -- result is converted back to the base type.
7940 if Non_Binary_Modulus
(Rtyp
) then
7943 Make_Function_Call
(Loc
,
7945 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
7946 Parameter_Associations
=> New_List
(
7947 Convert_To
(RTE
(RE_Unsigned
), Base
),
7948 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
7951 -- Binary modular case, in this case, we call one of two routines,
7952 -- either the unsigned integer case, or the unsigned long long
7953 -- integer case, with a final "and" operation to do the required mod.
7956 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
7957 Ent
:= RTE
(RE_Exp_Unsigned
);
7959 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
7966 Make_Function_Call
(Loc
,
7967 Name
=> New_Occurrence_Of
(Ent
, Loc
),
7968 Parameter_Associations
=> New_List
(
7969 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
7972 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
7976 -- Common exit point for modular type case
7978 Analyze_And_Resolve
(N
, Typ
);
7981 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7982 -- It is not worth having routines for Short_[Short_]Integer, since for
7983 -- most machines it would not help, and it would generate more code that
7984 -- might need certification when a certified run time is required.
7986 -- In the integer cases, we have two routines, one for when overflow
7987 -- checks are required, and one when they are not required, since there
7988 -- is a real gain in omitting checks on many machines.
7990 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
7991 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
7993 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
7994 or else Rtyp
= Universal_Integer
7996 Etyp
:= Standard_Long_Long_Integer
;
7999 Rent
:= RE_Exp_Long_Long_Integer
;
8001 Rent
:= RE_Exn_Long_Long_Integer
;
8004 elsif Is_Signed_Integer_Type
(Rtyp
) then
8005 Etyp
:= Standard_Integer
;
8008 Rent
:= RE_Exp_Integer
;
8010 Rent
:= RE_Exn_Integer
;
8013 -- Floating-point cases. We do not need separate routines for the
8014 -- overflow case here, since in the case of floating-point, we generate
8015 -- infinities anyway as a rule (either that or we automatically trap
8016 -- overflow), and if there is an infinity generated and a range check
8017 -- is required, the check will fail anyway.
8019 -- Historical note: we used to convert everything to Long_Long_Float
8020 -- and call a single common routine, but this had the undesirable effect
8021 -- of giving different results for small static exponent values and the
8022 -- same dynamic values.
8025 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
8027 if Rtyp
= Standard_Float
then
8028 Etyp
:= Standard_Float
;
8029 Rent
:= RE_Exn_Float
;
8031 elsif Rtyp
= Standard_Long_Float
then
8032 Etyp
:= Standard_Long_Float
;
8033 Rent
:= RE_Exn_Long_Float
;
8036 Etyp
:= Standard_Long_Long_Float
;
8037 Rent
:= RE_Exn_Long_Long_Float
;
8041 -- Common processing for integer cases and floating-point cases.
8042 -- If we are in the right type, we can call runtime routine directly
8045 and then Rtyp
/= Universal_Integer
8046 and then Rtyp
/= Universal_Real
8050 Make_Function_Call
(Loc
,
8051 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8052 Parameter_Associations
=> New_List
(Base
, Exp
))));
8054 -- Otherwise we have to introduce conversions (conversions are also
8055 -- required in the universal cases, since the runtime routine is
8056 -- typed using one of the standard types).
8061 Make_Function_Call
(Loc
,
8062 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8063 Parameter_Associations
=> New_List
(
8064 Convert_To
(Etyp
, Base
),
8068 Analyze_And_Resolve
(N
, Typ
);
8072 when RE_Not_Available
=>
8074 end Expand_N_Op_Expon
;
8076 --------------------
8077 -- Expand_N_Op_Ge --
8078 --------------------
8080 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
8081 Typ
: constant Entity_Id
:= Etype
(N
);
8082 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8083 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8084 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8087 Binary_Op_Validity_Checks
(N
);
8089 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8090 -- means we no longer have a comparison operation, we are all done.
8092 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8094 if Nkind
(N
) /= N_Op_Ge
then
8100 if Is_Array_Type
(Typ1
) then
8101 Expand_Array_Comparison
(N
);
8105 -- Deal with boolean operands
8107 if Is_Boolean_Type
(Typ1
) then
8108 Adjust_Condition
(Op1
);
8109 Adjust_Condition
(Op2
);
8110 Set_Etype
(N
, Standard_Boolean
);
8111 Adjust_Result_Type
(N
, Typ
);
8114 Rewrite_Comparison
(N
);
8116 Optimize_Length_Comparison
(N
);
8119 --------------------
8120 -- Expand_N_Op_Gt --
8121 --------------------
8123 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
8124 Typ
: constant Entity_Id
:= Etype
(N
);
8125 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8126 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8127 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8130 Binary_Op_Validity_Checks
(N
);
8132 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8133 -- means we no longer have a comparison operation, we are all done.
8135 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8137 if Nkind
(N
) /= N_Op_Gt
then
8141 -- Deal with array type operands
8143 if Is_Array_Type
(Typ1
) then
8144 Expand_Array_Comparison
(N
);
8148 -- Deal with boolean type operands
8150 if Is_Boolean_Type
(Typ1
) then
8151 Adjust_Condition
(Op1
);
8152 Adjust_Condition
(Op2
);
8153 Set_Etype
(N
, Standard_Boolean
);
8154 Adjust_Result_Type
(N
, Typ
);
8157 Rewrite_Comparison
(N
);
8159 Optimize_Length_Comparison
(N
);
8162 --------------------
8163 -- Expand_N_Op_Le --
8164 --------------------
8166 procedure Expand_N_Op_Le
(N
: Node_Id
) is
8167 Typ
: constant Entity_Id
:= Etype
(N
);
8168 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8169 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8170 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8173 Binary_Op_Validity_Checks
(N
);
8175 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8176 -- means we no longer have a comparison operation, we are all done.
8178 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8180 if Nkind
(N
) /= N_Op_Le
then
8184 -- Deal with array type operands
8186 if Is_Array_Type
(Typ1
) then
8187 Expand_Array_Comparison
(N
);
8191 -- Deal with Boolean type operands
8193 if Is_Boolean_Type
(Typ1
) then
8194 Adjust_Condition
(Op1
);
8195 Adjust_Condition
(Op2
);
8196 Set_Etype
(N
, Standard_Boolean
);
8197 Adjust_Result_Type
(N
, Typ
);
8200 Rewrite_Comparison
(N
);
8202 Optimize_Length_Comparison
(N
);
8205 --------------------
8206 -- Expand_N_Op_Lt --
8207 --------------------
8209 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
8210 Typ
: constant Entity_Id
:= Etype
(N
);
8211 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8212 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8213 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8216 Binary_Op_Validity_Checks
(N
);
8218 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8219 -- means we no longer have a comparison operation, we are all done.
8221 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8223 if Nkind
(N
) /= N_Op_Lt
then
8227 -- Deal with array type operands
8229 if Is_Array_Type
(Typ1
) then
8230 Expand_Array_Comparison
(N
);
8234 -- Deal with Boolean type operands
8236 if Is_Boolean_Type
(Typ1
) then
8237 Adjust_Condition
(Op1
);
8238 Adjust_Condition
(Op2
);
8239 Set_Etype
(N
, Standard_Boolean
);
8240 Adjust_Result_Type
(N
, Typ
);
8243 Rewrite_Comparison
(N
);
8245 Optimize_Length_Comparison
(N
);
8248 -----------------------
8249 -- Expand_N_Op_Minus --
8250 -----------------------
8252 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
8253 Loc
: constant Source_Ptr
:= Sloc
(N
);
8254 Typ
: constant Entity_Id
:= Etype
(N
);
8257 Unary_Op_Validity_Checks
(N
);
8259 -- Check for MINIMIZED/ELIMINATED overflow mode
8261 if Minimized_Eliminated_Overflow_Check
(N
) then
8262 Apply_Arithmetic_Overflow_Check
(N
);
8266 if not Backend_Overflow_Checks_On_Target
8267 and then Is_Signed_Integer_Type
(Etype
(N
))
8268 and then Do_Overflow_Check
(N
)
8270 -- Software overflow checking expands -expr into (0 - expr)
8273 Make_Op_Subtract
(Loc
,
8274 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
8275 Right_Opnd
=> Right_Opnd
(N
)));
8277 Analyze_And_Resolve
(N
, Typ
);
8279 end Expand_N_Op_Minus
;
8281 ---------------------
8282 -- Expand_N_Op_Mod --
8283 ---------------------
8285 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
8286 Loc
: constant Source_Ptr
:= Sloc
(N
);
8287 Typ
: constant Entity_Id
:= Etype
(N
);
8288 DDC
: constant Boolean := Do_Division_Check
(N
);
8301 pragma Warnings
(Off
, Lhi
);
8304 Binary_Op_Validity_Checks
(N
);
8306 -- Check for MINIMIZED/ELIMINATED overflow mode
8308 if Minimized_Eliminated_Overflow_Check
(N
) then
8309 Apply_Arithmetic_Overflow_Check
(N
);
8313 if Is_Integer_Type
(Etype
(N
)) then
8314 Apply_Divide_Checks
(N
);
8316 -- All done if we don't have a MOD any more, which can happen as a
8317 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8319 if Nkind
(N
) /= N_Op_Mod
then
8324 -- Proceed with expansion of mod operator
8326 Left
:= Left_Opnd
(N
);
8327 Right
:= Right_Opnd
(N
);
8329 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
8330 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
8332 -- Convert mod to rem if operands are both known to be non-negative, or
8333 -- both known to be non-positive (these are the cases in which rem and
8334 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8335 -- likely that this will improve the quality of code, (the operation now
8336 -- corresponds to the hardware remainder), and it does not seem likely
8337 -- that it could be harmful. It also avoids some cases of the elaborate
8338 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8341 and then ((Llo
>= 0 and then Rlo
>= 0)
8343 (Lhi
<= 0 and then Rhi
<= 0))
8346 Make_Op_Rem
(Sloc
(N
),
8347 Left_Opnd
=> Left_Opnd
(N
),
8348 Right_Opnd
=> Right_Opnd
(N
)));
8350 -- Instead of reanalyzing the node we do the analysis manually. This
8351 -- avoids anomalies when the replacement is done in an instance and
8352 -- is epsilon more efficient.
8354 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
8356 Set_Do_Division_Check
(N
, DDC
);
8357 Expand_N_Op_Rem
(N
);
8361 -- Otherwise, normal mod processing
8364 -- Apply optimization x mod 1 = 0. We don't really need that with
8365 -- gcc, but it is useful with other back ends and is certainly
8368 if Is_Integer_Type
(Etype
(N
))
8369 and then Compile_Time_Known_Value
(Right
)
8370 and then Expr_Value
(Right
) = Uint_1
8372 -- Call Remove_Side_Effects to ensure that any side effects in
8373 -- the ignored left operand (in particular function calls to
8374 -- user defined functions) are properly executed.
8376 Remove_Side_Effects
(Left
);
8378 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8379 Analyze_And_Resolve
(N
, Typ
);
8383 -- If we still have a mod operator and we are in Modify_Tree_For_C
8384 -- mode, and we have a signed integer type, then here is where we do
8385 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8386 -- for the special handling of the annoying case of largest negative
8387 -- number mod minus one.
8389 if Nkind
(N
) = N_Op_Mod
8390 and then Is_Signed_Integer_Type
(Typ
)
8391 and then Modify_Tree_For_C
8393 -- In the general case, we expand A mod B as
8395 -- Tnn : constant typ := A rem B;
8397 -- (if (A >= 0) = (B >= 0) then Tnn
8398 -- elsif Tnn = 0 then 0
8401 -- The comparison can be written simply as A >= 0 if we know that
8402 -- B >= 0 which is a very common case.
8404 -- An important optimization is when B is known at compile time
8405 -- to be 2**K for some constant. In this case we can simply AND
8406 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8407 -- and that works for both the positive and negative cases.
8410 P2
: constant Nat
:= Power_Of_Two
(Right
);
8415 Unchecked_Convert_To
(Typ
,
8418 Unchecked_Convert_To
8419 (Corresponding_Unsigned_Type
(Typ
), Left
),
8421 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
8422 Analyze_And_Resolve
(N
, Typ
);
8427 -- Here for the full rewrite
8430 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
8436 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
8437 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
8439 if not LOK
or else Rlo
< 0 then
8445 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
8446 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
8450 Make_Object_Declaration
(Loc
,
8451 Defining_Identifier
=> Tnn
,
8452 Constant_Present
=> True,
8453 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8457 Right_Opnd
=> Right
)));
8460 Make_If_Expression
(Loc
,
8461 Expressions
=> New_List
(
8463 New_Occurrence_Of
(Tnn
, Loc
),
8464 Make_If_Expression
(Loc
,
8466 Expressions
=> New_List
(
8468 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8469 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
8470 Make_Integer_Literal
(Loc
, 0),
8472 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8474 Duplicate_Subexpr_No_Checks
(Right
)))))));
8476 Analyze_And_Resolve
(N
, Typ
);
8481 -- Deal with annoying case of largest negative number mod minus one.
8482 -- Gigi may not handle this case correctly, because on some targets,
8483 -- the mod value is computed using a divide instruction which gives
8484 -- an overflow trap for this case.
8486 -- It would be a bit more efficient to figure out which targets
8487 -- this is really needed for, but in practice it is reasonable
8488 -- to do the following special check in all cases, since it means
8489 -- we get a clearer message, and also the overhead is minimal given
8490 -- that division is expensive in any case.
8492 -- In fact the check is quite easy, if the right operand is -1, then
8493 -- the mod value is always 0, and we can just ignore the left operand
8494 -- completely in this case.
8496 -- This only applies if we still have a mod operator. Skip if we
8497 -- have already rewritten this (e.g. in the case of eliminated
8498 -- overflow checks which have driven us into bignum mode).
8500 if Nkind
(N
) = N_Op_Mod
then
8502 -- The operand type may be private (e.g. in the expansion of an
8503 -- intrinsic operation) so we must use the underlying type to get
8504 -- the bounds, and convert the literals explicitly.
8508 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
8510 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
8511 and then ((not LOK
) or else (Llo
= LLB
))
8514 Make_If_Expression
(Loc
,
8515 Expressions
=> New_List
(
8517 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8519 Unchecked_Convert_To
(Typ
,
8520 Make_Integer_Literal
(Loc
, -1))),
8521 Unchecked_Convert_To
(Typ
,
8522 Make_Integer_Literal
(Loc
, Uint_0
)),
8523 Relocate_Node
(N
))));
8525 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8526 Analyze_And_Resolve
(N
, Typ
);
8530 end Expand_N_Op_Mod
;
8532 --------------------------
8533 -- Expand_N_Op_Multiply --
8534 --------------------------
8536 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
8537 Loc
: constant Source_Ptr
:= Sloc
(N
);
8538 Lop
: constant Node_Id
:= Left_Opnd
(N
);
8539 Rop
: constant Node_Id
:= Right_Opnd
(N
);
8541 Lp2
: constant Boolean :=
8542 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
8543 Rp2
: constant Boolean :=
8544 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
8546 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
8547 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
8548 Typ
: Entity_Id
:= Etype
(N
);
8551 Binary_Op_Validity_Checks
(N
);
8553 -- Check for MINIMIZED/ELIMINATED overflow mode
8555 if Minimized_Eliminated_Overflow_Check
(N
) then
8556 Apply_Arithmetic_Overflow_Check
(N
);
8560 -- Special optimizations for integer types
8562 if Is_Integer_Type
(Typ
) then
8564 -- N * 0 = 0 for integer types
8566 if Compile_Time_Known_Value
(Rop
)
8567 and then Expr_Value
(Rop
) = Uint_0
8569 -- Call Remove_Side_Effects to ensure that any side effects in
8570 -- the ignored left operand (in particular function calls to
8571 -- user defined functions) are properly executed.
8573 Remove_Side_Effects
(Lop
);
8575 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8576 Analyze_And_Resolve
(N
, Typ
);
8580 -- Similar handling for 0 * N = 0
8582 if Compile_Time_Known_Value
(Lop
)
8583 and then Expr_Value
(Lop
) = Uint_0
8585 Remove_Side_Effects
(Rop
);
8586 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8587 Analyze_And_Resolve
(N
, Typ
);
8591 -- N * 1 = 1 * N = N for integer types
8593 -- This optimisation is not done if we are going to
8594 -- rewrite the product 1 * 2 ** N to a shift.
8596 if Compile_Time_Known_Value
(Rop
)
8597 and then Expr_Value
(Rop
) = Uint_1
8603 elsif Compile_Time_Known_Value
(Lop
)
8604 and then Expr_Value
(Lop
) = Uint_1
8612 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8613 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8614 -- operand is an integer, as required for this to work.
8619 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8623 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
8626 Left_Opnd
=> Right_Opnd
(Lop
),
8627 Right_Opnd
=> Right_Opnd
(Rop
))));
8628 Analyze_And_Resolve
(N
, Typ
);
8632 -- If the result is modular, perform the reduction of the result
8635 if Is_Modular_Integer_Type
(Typ
)
8636 and then not Non_Binary_Modulus
(Typ
)
8641 Make_Op_Shift_Left
(Loc
,
8644 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
8646 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8650 Make_Op_Shift_Left
(Loc
,
8653 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
8656 Analyze_And_Resolve
(N
, Typ
);
8660 -- Same processing for the operands the other way round
8663 if Is_Modular_Integer_Type
(Typ
)
8664 and then not Non_Binary_Modulus
(Typ
)
8669 Make_Op_Shift_Left
(Loc
,
8672 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
8674 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8678 Make_Op_Shift_Left
(Loc
,
8681 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
8684 Analyze_And_Resolve
(N
, Typ
);
8688 -- Do required fixup of universal fixed operation
8690 if Typ
= Universal_Fixed
then
8691 Fixup_Universal_Fixed_Operation
(N
);
8695 -- Multiplications with fixed-point results
8697 if Is_Fixed_Point_Type
(Typ
) then
8699 -- No special processing if Treat_Fixed_As_Integer is set, since from
8700 -- a semantic point of view such operations are simply integer
8701 -- operations and will be treated that way.
8703 if not Treat_Fixed_As_Integer
(N
) then
8705 -- Case of fixed * integer => fixed
8707 if Is_Integer_Type
(Rtyp
) then
8708 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
8710 -- Case of integer * fixed => fixed
8712 elsif Is_Integer_Type
(Ltyp
) then
8713 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
8715 -- Case of fixed * fixed => fixed
8718 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
8722 -- Other cases of multiplication of fixed-point operands. Again we
8723 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8725 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
8726 and then not Treat_Fixed_As_Integer
(N
)
8728 if Is_Integer_Type
(Typ
) then
8729 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
8731 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8732 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
8735 -- Mixed-mode operations can appear in a non-static universal context,
8736 -- in which case the integer argument must be converted explicitly.
8738 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
8739 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
8740 Analyze_And_Resolve
(Rop
, Universal_Real
);
8742 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
8743 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
8744 Analyze_And_Resolve
(Lop
, Universal_Real
);
8746 -- Non-fixed point cases, check software overflow checking required
8748 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
8749 Apply_Arithmetic_Overflow_Check
(N
);
8752 -- Overflow checks for floating-point if -gnateF mode active
8754 Check_Float_Op_Overflow
(N
);
8755 end Expand_N_Op_Multiply
;
8757 --------------------
8758 -- Expand_N_Op_Ne --
8759 --------------------
8761 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
8762 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
8765 -- Case of elementary type with standard operator
8767 if Is_Elementary_Type
(Typ
)
8768 and then Sloc
(Entity
(N
)) = Standard_Location
8770 Binary_Op_Validity_Checks
(N
);
8772 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8773 -- means we no longer have a /= operation, we are all done.
8775 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8777 if Nkind
(N
) /= N_Op_Ne
then
8781 -- Boolean types (requiring handling of non-standard case)
8783 if Is_Boolean_Type
(Typ
) then
8784 Adjust_Condition
(Left_Opnd
(N
));
8785 Adjust_Condition
(Right_Opnd
(N
));
8786 Set_Etype
(N
, Standard_Boolean
);
8787 Adjust_Result_Type
(N
, Typ
);
8790 Rewrite_Comparison
(N
);
8792 -- For all cases other than elementary types, we rewrite node as the
8793 -- negation of an equality operation, and reanalyze. The equality to be
8794 -- used is defined in the same scope and has the same signature. This
8795 -- signature must be set explicitly since in an instance it may not have
8796 -- the same visibility as in the generic unit. This avoids duplicating
8797 -- or factoring the complex code for record/array equality tests etc.
8801 Loc
: constant Source_Ptr
:= Sloc
(N
);
8803 Ne
: constant Entity_Id
:= Entity
(N
);
8806 Binary_Op_Validity_Checks
(N
);
8812 Left_Opnd
=> Left_Opnd
(N
),
8813 Right_Opnd
=> Right_Opnd
(N
)));
8814 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
8816 if Scope
(Ne
) /= Standard_Standard
then
8817 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
8820 -- For navigation purposes, we want to treat the inequality as an
8821 -- implicit reference to the corresponding equality. Preserve the
8822 -- Comes_From_ source flag to generate proper Xref entries.
8824 Preserve_Comes_From_Source
(Neg
, N
);
8825 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
8827 Analyze_And_Resolve
(N
, Standard_Boolean
);
8831 Optimize_Length_Comparison
(N
);
8834 ---------------------
8835 -- Expand_N_Op_Not --
8836 ---------------------
8838 -- If the argument is other than a Boolean array type, there is no special
8839 -- expansion required, except for dealing with validity checks, and non-
8840 -- standard boolean representations.
8842 -- For the packed array case, we call the special routine in Exp_Pakd,
8843 -- except that if the component size is greater than one, we use the
8844 -- standard routine generating a gruesome loop (it is so peculiar to have
8845 -- packed arrays with non-standard Boolean representations anyway, so it
8846 -- does not matter that we do not handle this case efficiently).
8848 -- For the unpacked array case (and for the special packed case where we
8849 -- have non standard Booleans, as discussed above), we generate and insert
8850 -- into the tree the following function definition:
8852 -- function Nnnn (A : arr) is
8855 -- for J in a'range loop
8856 -- B (J) := not A (J);
8861 -- Here arr is the actual subtype of the parameter (and hence always
8862 -- constrained). Then we replace the not with a call to this function.
8864 procedure Expand_N_Op_Not
(N
: Node_Id
) is
8865 Loc
: constant Source_Ptr
:= Sloc
(N
);
8866 Typ
: constant Entity_Id
:= Etype
(N
);
8875 Func_Name
: Entity_Id
;
8876 Loop_Statement
: Node_Id
;
8879 Unary_Op_Validity_Checks
(N
);
8881 -- For boolean operand, deal with non-standard booleans
8883 if Is_Boolean_Type
(Typ
) then
8884 Adjust_Condition
(Right_Opnd
(N
));
8885 Set_Etype
(N
, Standard_Boolean
);
8886 Adjust_Result_Type
(N
, Typ
);
8890 -- Only array types need any other processing
8892 if not Is_Array_Type
(Typ
) then
8896 -- Case of array operand. If bit packed with a component size of 1,
8897 -- handle it in Exp_Pakd if the operand is known to be aligned.
8899 if Is_Bit_Packed_Array
(Typ
)
8900 and then Component_Size
(Typ
) = 1
8901 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
8903 Expand_Packed_Not
(N
);
8907 -- Case of array operand which is not bit-packed. If the context is
8908 -- a safe assignment, call in-place operation, If context is a larger
8909 -- boolean expression in the context of a safe assignment, expansion is
8910 -- done by enclosing operation.
8912 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
8913 Convert_To_Actual_Subtype
(Opnd
);
8914 Arr
:= Etype
(Opnd
);
8915 Ensure_Defined
(Arr
, N
);
8916 Silly_Boolean_Array_Not_Test
(N
, Arr
);
8918 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
8919 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
8920 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8923 -- Special case the negation of a binary operation
8925 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
8926 and then Safe_In_Place_Array_Op
8927 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
8929 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8933 elsif Nkind
(Parent
(N
)) in N_Binary_Op
8934 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
8937 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
8938 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
8939 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
8942 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
8944 -- (not A) op (not B) can be reduced to a single call
8946 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
8949 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
8952 -- A xor (not B) can also be special-cased
8954 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
8961 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
8962 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8963 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
8966 Make_Indexed_Component
(Loc
,
8967 Prefix
=> New_Occurrence_Of
(A
, Loc
),
8968 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8971 Make_Indexed_Component
(Loc
,
8972 Prefix
=> New_Occurrence_Of
(B
, Loc
),
8973 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8976 Make_Implicit_Loop_Statement
(N
,
8977 Identifier
=> Empty
,
8980 Make_Iteration_Scheme
(Loc
,
8981 Loop_Parameter_Specification
=>
8982 Make_Loop_Parameter_Specification
(Loc
,
8983 Defining_Identifier
=> J
,
8984 Discrete_Subtype_Definition
=>
8985 Make_Attribute_Reference
(Loc
,
8986 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
8987 Attribute_Name
=> Name_Range
))),
8989 Statements
=> New_List
(
8990 Make_Assignment_Statement
(Loc
,
8992 Expression
=> Make_Op_Not
(Loc
, A_J
))));
8994 Func_Name
:= Make_Temporary
(Loc
, 'N');
8995 Set_Is_Inlined
(Func_Name
);
8998 Make_Subprogram_Body
(Loc
,
9000 Make_Function_Specification
(Loc
,
9001 Defining_Unit_Name
=> Func_Name
,
9002 Parameter_Specifications
=> New_List
(
9003 Make_Parameter_Specification
(Loc
,
9004 Defining_Identifier
=> A
,
9005 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9006 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9008 Declarations
=> New_List
(
9009 Make_Object_Declaration
(Loc
,
9010 Defining_Identifier
=> B
,
9011 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
9013 Handled_Statement_Sequence
=>
9014 Make_Handled_Sequence_Of_Statements
(Loc
,
9015 Statements
=> New_List
(
9017 Make_Simple_Return_Statement
(Loc
,
9018 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
9021 Make_Function_Call
(Loc
,
9022 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
9023 Parameter_Associations
=> New_List
(Opnd
)));
9025 Analyze_And_Resolve
(N
, Typ
);
9026 end Expand_N_Op_Not
;
9028 --------------------
9029 -- Expand_N_Op_Or --
9030 --------------------
9032 procedure Expand_N_Op_Or
(N
: Node_Id
) is
9033 Typ
: constant Entity_Id
:= Etype
(N
);
9036 Binary_Op_Validity_Checks
(N
);
9038 if Is_Array_Type
(Etype
(N
)) then
9039 Expand_Boolean_Operator
(N
);
9041 elsif Is_Boolean_Type
(Etype
(N
)) then
9042 Adjust_Condition
(Left_Opnd
(N
));
9043 Adjust_Condition
(Right_Opnd
(N
));
9044 Set_Etype
(N
, Standard_Boolean
);
9045 Adjust_Result_Type
(N
, Typ
);
9047 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9048 Expand_Intrinsic_Call
(N
, Entity
(N
));
9053 ----------------------
9054 -- Expand_N_Op_Plus --
9055 ----------------------
9057 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
9059 Unary_Op_Validity_Checks
(N
);
9061 -- Check for MINIMIZED/ELIMINATED overflow mode
9063 if Minimized_Eliminated_Overflow_Check
(N
) then
9064 Apply_Arithmetic_Overflow_Check
(N
);
9067 end Expand_N_Op_Plus
;
9069 ---------------------
9070 -- Expand_N_Op_Rem --
9071 ---------------------
9073 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
9074 Loc
: constant Source_Ptr
:= Sloc
(N
);
9075 Typ
: constant Entity_Id
:= Etype
(N
);
9086 -- Set if corresponding operand can be negative
9088 pragma Unreferenced
(Hi
);
9091 Binary_Op_Validity_Checks
(N
);
9093 -- Check for MINIMIZED/ELIMINATED overflow mode
9095 if Minimized_Eliminated_Overflow_Check
(N
) then
9096 Apply_Arithmetic_Overflow_Check
(N
);
9100 if Is_Integer_Type
(Etype
(N
)) then
9101 Apply_Divide_Checks
(N
);
9103 -- All done if we don't have a REM any more, which can happen as a
9104 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9106 if Nkind
(N
) /= N_Op_Rem
then
9111 -- Proceed with expansion of REM
9113 Left
:= Left_Opnd
(N
);
9114 Right
:= Right_Opnd
(N
);
9116 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9117 -- but it is useful with other back ends, and is certainly harmless.
9119 if Is_Integer_Type
(Etype
(N
))
9120 and then Compile_Time_Known_Value
(Right
)
9121 and then Expr_Value
(Right
) = Uint_1
9123 -- Call Remove_Side_Effects to ensure that any side effects in the
9124 -- ignored left operand (in particular function calls to user defined
9125 -- functions) are properly executed.
9127 Remove_Side_Effects
(Left
);
9129 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9130 Analyze_And_Resolve
(N
, Typ
);
9134 -- Deal with annoying case of largest negative number remainder minus
9135 -- one. Gigi may not handle this case correctly, because on some
9136 -- targets, the mod value is computed using a divide instruction
9137 -- which gives an overflow trap for this case.
9139 -- It would be a bit more efficient to figure out which targets this
9140 -- is really needed for, but in practice it is reasonable to do the
9141 -- following special check in all cases, since it means we get a clearer
9142 -- message, and also the overhead is minimal given that division is
9143 -- expensive in any case.
9145 -- In fact the check is quite easy, if the right operand is -1, then
9146 -- the remainder is always 0, and we can just ignore the left operand
9147 -- completely in this case.
9149 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9150 Lneg
:= (not OK
) or else Lo
< 0;
9152 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9153 Rneg
:= (not OK
) or else Lo
< 0;
9155 -- We won't mess with trying to find out if the left operand can really
9156 -- be the largest negative number (that's a pain in the case of private
9157 -- types and this is really marginal). We will just assume that we need
9158 -- the test if the left operand can be negative at all.
9160 if Lneg
and Rneg
then
9162 Make_If_Expression
(Loc
,
9163 Expressions
=> New_List
(
9165 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9167 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
9169 Unchecked_Convert_To
(Typ
,
9170 Make_Integer_Literal
(Loc
, Uint_0
)),
9172 Relocate_Node
(N
))));
9174 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9175 Analyze_And_Resolve
(N
, Typ
);
9177 end Expand_N_Op_Rem
;
9179 -----------------------------
9180 -- Expand_N_Op_Rotate_Left --
9181 -----------------------------
9183 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
9185 Binary_Op_Validity_Checks
(N
);
9187 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9188 -- so we rewrite in terms of logical shifts
9190 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9192 -- where Bits is the shift count mod Esize (the mod operation here
9193 -- deals with ludicrous large shift counts, which are apparently OK).
9195 -- What about nonbinary modulus ???
9198 Loc
: constant Source_Ptr
:= Sloc
(N
);
9199 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9200 Typ
: constant Entity_Id
:= Etype
(N
);
9203 if Modify_Tree_For_C
then
9204 Rewrite
(Right_Opnd
(N
),
9206 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9207 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9209 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9214 Make_Op_Shift_Left
(Loc
,
9215 Left_Opnd
=> Left_Opnd
(N
),
9216 Right_Opnd
=> Right_Opnd
(N
)),
9219 Make_Op_Shift_Right
(Loc
,
9220 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9222 Make_Op_Subtract
(Loc
,
9223 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9225 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9227 Analyze_And_Resolve
(N
, Typ
);
9230 end Expand_N_Op_Rotate_Left
;
9232 ------------------------------
9233 -- Expand_N_Op_Rotate_Right --
9234 ------------------------------
9236 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
9238 Binary_Op_Validity_Checks
(N
);
9240 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9241 -- so we rewrite in terms of logical shifts
9243 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9245 -- where Bits is the shift count mod Esize (the mod operation here
9246 -- deals with ludicrous large shift counts, which are apparently OK).
9248 -- What about nonbinary modulus ???
9251 Loc
: constant Source_Ptr
:= Sloc
(N
);
9252 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9253 Typ
: constant Entity_Id
:= Etype
(N
);
9256 Rewrite
(Right_Opnd
(N
),
9258 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9259 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9261 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9263 if Modify_Tree_For_C
then
9267 Make_Op_Shift_Right
(Loc
,
9268 Left_Opnd
=> Left_Opnd
(N
),
9269 Right_Opnd
=> Right_Opnd
(N
)),
9272 Make_Op_Shift_Left
(Loc
,
9273 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9275 Make_Op_Subtract
(Loc
,
9276 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9278 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9280 Analyze_And_Resolve
(N
, Typ
);
9283 end Expand_N_Op_Rotate_Right
;
9285 ----------------------------
9286 -- Expand_N_Op_Shift_Left --
9287 ----------------------------
9289 -- Note: nothing in this routine depends on left as opposed to right shifts
9290 -- so we share the routine for expanding shift right operations.
9292 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
9294 Binary_Op_Validity_Checks
(N
);
9296 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9297 -- operand is not greater than the word size (since that would not
9298 -- be defined properly by the corresponding C shift operator).
9300 if Modify_Tree_For_C
then
9302 Right
: constant Node_Id
:= Right_Opnd
(N
);
9303 Loc
: constant Source_Ptr
:= Sloc
(Right
);
9304 Typ
: constant Entity_Id
:= Etype
(N
);
9305 Siz
: constant Uint
:= Esize
(Typ
);
9312 if Compile_Time_Known_Value
(Right
) then
9313 if Expr_Value
(Right
) >= Siz
then
9314 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9315 Analyze_And_Resolve
(N
, Typ
);
9318 -- Not compile time known, find range
9321 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9323 -- Nothing to do if known to be OK range, otherwise expand
9325 if not OK
or else Hi
>= Siz
then
9327 -- Prevent recursion on copy of shift node
9329 Orig
:= Relocate_Node
(N
);
9330 Set_Analyzed
(Orig
);
9332 -- Now do the rewrite
9335 Make_If_Expression
(Loc
,
9336 Expressions
=> New_List
(
9338 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
9339 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
9340 Make_Integer_Literal
(Loc
, 0),
9342 Analyze_And_Resolve
(N
, Typ
);
9347 end Expand_N_Op_Shift_Left
;
9349 -----------------------------
9350 -- Expand_N_Op_Shift_Right --
9351 -----------------------------
9353 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
9355 -- Share shift left circuit
9357 Expand_N_Op_Shift_Left
(N
);
9358 end Expand_N_Op_Shift_Right
;
9360 ----------------------------------------
9361 -- Expand_N_Op_Shift_Right_Arithmetic --
9362 ----------------------------------------
9364 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
9366 Binary_Op_Validity_Checks
(N
);
9368 -- If we are in Modify_Tree_For_C mode, there is no shift right
9369 -- arithmetic in C, so we rewrite in terms of logical shifts.
9371 -- Shift_Right (Num, Bits) or
9373 -- then not (Shift_Right (Mask, bits))
9376 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9378 -- Note: in almost all C compilers it would work to just shift a
9379 -- signed integer right, but it's undefined and we cannot rely on it.
9381 -- Note: the above works fine for shift counts greater than or equal
9382 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9383 -- generates all 1'bits.
9385 -- What about nonbinary modulus ???
9388 Loc
: constant Source_Ptr
:= Sloc
(N
);
9389 Typ
: constant Entity_Id
:= Etype
(N
);
9390 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
9391 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
9392 Left
: constant Node_Id
:= Left_Opnd
(N
);
9393 Right
: constant Node_Id
:= Right_Opnd
(N
);
9397 if Modify_Tree_For_C
then
9399 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9400 -- compile time as a single constant.
9402 if Compile_Time_Known_Value
(Right
) then
9404 Val
: constant Uint
:= Expr_Value
(Right
);
9407 if Val
>= Esize
(Typ
) then
9408 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
9412 Make_Integer_Literal
(Loc
,
9413 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
9421 Make_Op_Shift_Right
(Loc
,
9422 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
9423 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
9426 -- Now do the rewrite
9431 Make_Op_Shift_Right
(Loc
,
9433 Right_Opnd
=> Right
),
9435 Make_If_Expression
(Loc
,
9436 Expressions
=> New_List
(
9438 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9439 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
9441 Make_Integer_Literal
(Loc
, 0)))));
9442 Analyze_And_Resolve
(N
, Typ
);
9445 end Expand_N_Op_Shift_Right_Arithmetic
;
9447 --------------------------
9448 -- Expand_N_Op_Subtract --
9449 --------------------------
9451 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
9452 Typ
: constant Entity_Id
:= Etype
(N
);
9455 Binary_Op_Validity_Checks
(N
);
9457 -- Check for MINIMIZED/ELIMINATED overflow mode
9459 if Minimized_Eliminated_Overflow_Check
(N
) then
9460 Apply_Arithmetic_Overflow_Check
(N
);
9464 -- N - 0 = N for integer types
9466 if Is_Integer_Type
(Typ
)
9467 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
9468 and then Expr_Value
(Right_Opnd
(N
)) = 0
9470 Rewrite
(N
, Left_Opnd
(N
));
9474 -- Arithmetic overflow checks for signed integer/fixed point types
9476 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
9477 Apply_Arithmetic_Overflow_Check
(N
);
9480 -- Overflow checks for floating-point if -gnateF mode active
9482 Check_Float_Op_Overflow
(N
);
9483 end Expand_N_Op_Subtract
;
9485 ---------------------
9486 -- Expand_N_Op_Xor --
9487 ---------------------
9489 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
9490 Typ
: constant Entity_Id
:= Etype
(N
);
9493 Binary_Op_Validity_Checks
(N
);
9495 if Is_Array_Type
(Etype
(N
)) then
9496 Expand_Boolean_Operator
(N
);
9498 elsif Is_Boolean_Type
(Etype
(N
)) then
9499 Adjust_Condition
(Left_Opnd
(N
));
9500 Adjust_Condition
(Right_Opnd
(N
));
9501 Set_Etype
(N
, Standard_Boolean
);
9502 Adjust_Result_Type
(N
, Typ
);
9504 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9505 Expand_Intrinsic_Call
(N
, Entity
(N
));
9508 end Expand_N_Op_Xor
;
9510 ----------------------
9511 -- Expand_N_Or_Else --
9512 ----------------------
9514 procedure Expand_N_Or_Else
(N
: Node_Id
)
9515 renames Expand_Short_Circuit_Operator
;
9517 -----------------------------------
9518 -- Expand_N_Qualified_Expression --
9519 -----------------------------------
9521 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
9522 Operand
: constant Node_Id
:= Expression
(N
);
9523 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
9526 -- Do validity check if validity checking operands
9528 if Validity_Checks_On
and Validity_Check_Operands
then
9529 Ensure_Valid
(Operand
);
9532 -- Apply possible constraint check
9534 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
9536 if Do_Range_Check
(Operand
) then
9537 Set_Do_Range_Check
(Operand
, False);
9538 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
9540 end Expand_N_Qualified_Expression
;
9542 ------------------------------------
9543 -- Expand_N_Quantified_Expression --
9544 ------------------------------------
9548 -- for all X in range => Cond
9553 -- for X in range loop
9560 -- Similarly, an existentially quantified expression:
9562 -- for some X in range => Cond
9567 -- for X in range loop
9574 -- In both cases, the iteration may be over a container in which case it is
9575 -- given by an iterator specification, not a loop parameter specification.
9577 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
9578 Actions
: constant List_Id
:= New_List
;
9579 For_All
: constant Boolean := All_Present
(N
);
9580 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
9581 Loc
: constant Source_Ptr
:= Sloc
(N
);
9582 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
9589 -- Create the declaration of the flag which tracks the status of the
9590 -- quantified expression. Generate:
9592 -- Flag : Boolean := (True | False);
9594 Flag
:= Make_Temporary
(Loc
, 'T', N
);
9597 Make_Object_Declaration
(Loc
,
9598 Defining_Identifier
=> Flag
,
9599 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
9601 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
9603 -- Construct the circuitry which tracks the status of the quantified
9604 -- expression. Generate:
9606 -- if [not] Cond then
9607 -- Flag := (False | True);
9611 Cond
:= Relocate_Node
(Condition
(N
));
9614 Cond
:= Make_Op_Not
(Loc
, Cond
);
9618 Make_Implicit_If_Statement
(N
,
9620 Then_Statements
=> New_List
(
9621 Make_Assignment_Statement
(Loc
,
9622 Name
=> New_Occurrence_Of
(Flag
, Loc
),
9624 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
9625 Make_Exit_Statement
(Loc
))));
9627 -- Build the loop equivalent of the quantified expression
9629 if Present
(Iter_Spec
) then
9631 Make_Iteration_Scheme
(Loc
,
9632 Iterator_Specification
=> Iter_Spec
);
9635 Make_Iteration_Scheme
(Loc
,
9636 Loop_Parameter_Specification
=> Loop_Spec
);
9640 Make_Loop_Statement
(Loc
,
9641 Iteration_Scheme
=> Scheme
,
9642 Statements
=> Stmts
,
9643 End_Label
=> Empty
));
9645 -- Transform the quantified expression
9648 Make_Expression_With_Actions
(Loc
,
9649 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
9650 Actions
=> Actions
));
9651 Analyze_And_Resolve
(N
, Standard_Boolean
);
9652 end Expand_N_Quantified_Expression
;
9654 ---------------------------------
9655 -- Expand_N_Selected_Component --
9656 ---------------------------------
9658 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
9659 Loc
: constant Source_Ptr
:= Sloc
(N
);
9660 Par
: constant Node_Id
:= Parent
(N
);
9661 P
: constant Node_Id
:= Prefix
(N
);
9662 S
: constant Node_Id
:= Selector_Name
(N
);
9663 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
9669 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
9670 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9671 -- unless the context of an assignment can provide size information.
9672 -- Don't we have a general routine that does this???
9674 function Is_Subtype_Declaration
return Boolean;
9675 -- The replacement of a discriminant reference by its value is required
9676 -- if this is part of the initialization of an temporary generated by a
9677 -- change of representation. This shows up as the construction of a
9678 -- discriminant constraint for a subtype declared at the same point as
9679 -- the entity in the prefix of the selected component. We recognize this
9680 -- case when the context of the reference is:
9681 -- subtype ST is T(Obj.D);
9682 -- where the entity for Obj comes from source, and ST has the same sloc.
9684 -----------------------
9685 -- In_Left_Hand_Side --
9686 -----------------------
9688 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
9690 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
9691 and then Comp
= Name
(Parent
(Comp
)))
9692 or else (Present
(Parent
(Comp
))
9693 and then Nkind
(Parent
(Comp
)) in N_Subexpr
9694 and then In_Left_Hand_Side
(Parent
(Comp
)));
9695 end In_Left_Hand_Side
;
9697 -----------------------------
9698 -- Is_Subtype_Declaration --
9699 -----------------------------
9701 function Is_Subtype_Declaration
return Boolean is
9702 Par
: constant Node_Id
:= Parent
(N
);
9705 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
9706 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
9707 and then Comes_From_Source
(Entity
(Prefix
(N
)))
9708 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
9709 end Is_Subtype_Declaration
;
9711 -- Start of processing for Expand_N_Selected_Component
9714 -- Insert explicit dereference if required
9716 if Is_Access_Type
(Ptyp
) then
9718 -- First set prefix type to proper access type, in case it currently
9719 -- has a private (non-access) view of this type.
9721 Set_Etype
(P
, Ptyp
);
9723 Insert_Explicit_Dereference
(P
);
9724 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
9726 if Ekind
(Etype
(P
)) = E_Private_Subtype
9727 and then Is_For_Access_Subtype
(Etype
(P
))
9729 Set_Etype
(P
, Base_Type
(Etype
(P
)));
9735 -- Deal with discriminant check required
9737 if Do_Discriminant_Check
(N
) then
9738 if Present
(Discriminant_Checking_Func
9739 (Original_Record_Component
(Entity
(S
))))
9741 -- Present the discriminant checking function to the backend, so
9742 -- that it can inline the call to the function.
9745 (Discriminant_Checking_Func
9746 (Original_Record_Component
(Entity
(S
))),
9749 -- Now reset the flag and generate the call
9751 Set_Do_Discriminant_Check
(N
, False);
9752 Generate_Discriminant_Check
(N
);
9754 -- In the case of Unchecked_Union, no discriminant checking is
9755 -- actually performed.
9758 Set_Do_Discriminant_Check
(N
, False);
9762 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9763 -- function, then additional actuals must be passed.
9765 if Ada_Version
>= Ada_2005
9766 and then Is_Build_In_Place_Function_Call
(P
)
9768 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
9771 -- Gigi cannot handle unchecked conversions that are the prefix of a
9772 -- selected component with discriminants. This must be checked during
9773 -- expansion, because during analysis the type of the selector is not
9774 -- known at the point the prefix is analyzed. If the conversion is the
9775 -- target of an assignment, then we cannot force the evaluation.
9777 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
9778 and then Has_Discriminants
(Etype
(N
))
9779 and then not In_Left_Hand_Side
(N
)
9781 Force_Evaluation
(Prefix
(N
));
9784 -- Remaining processing applies only if selector is a discriminant
9786 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
9788 -- If the selector is a discriminant of a constrained record type,
9789 -- we may be able to rewrite the expression with the actual value
9790 -- of the discriminant, a useful optimization in some cases.
9792 if Is_Record_Type
(Ptyp
)
9793 and then Has_Discriminants
(Ptyp
)
9794 and then Is_Constrained
(Ptyp
)
9796 -- Do this optimization for discrete types only, and not for
9797 -- access types (access discriminants get us into trouble).
9799 if not Is_Discrete_Type
(Etype
(N
)) then
9802 -- Don't do this on the left-hand side of an assignment statement.
9803 -- Normally one would think that references like this would not
9804 -- occur, but they do in generated code, and mean that we really
9805 -- do want to assign the discriminant.
9807 elsif Nkind
(Par
) = N_Assignment_Statement
9808 and then Name
(Par
) = N
9812 -- Don't do this optimization for the prefix of an attribute or
9813 -- the name of an object renaming declaration since these are
9814 -- contexts where we do not want the value anyway.
9816 elsif (Nkind
(Par
) = N_Attribute_Reference
9817 and then Prefix
(Par
) = N
)
9818 or else Is_Renamed_Object
(N
)
9822 -- Don't do this optimization if we are within the code for a
9823 -- discriminant check, since the whole point of such a check may
9824 -- be to verify the condition on which the code below depends.
9826 elsif Is_In_Discriminant_Check
(N
) then
9829 -- Green light to see if we can do the optimization. There is
9830 -- still one condition that inhibits the optimization below but
9831 -- now is the time to check the particular discriminant.
9834 -- Loop through discriminants to find the matching discriminant
9835 -- constraint to see if we can copy it.
9837 Disc
:= First_Discriminant
(Ptyp
);
9838 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
9839 Discr_Loop
: while Present
(Dcon
) loop
9840 Dval
:= Node
(Dcon
);
9842 -- Check if this is the matching discriminant and if the
9843 -- discriminant value is simple enough to make sense to
9844 -- copy. We don't want to copy complex expressions, and
9845 -- indeed to do so can cause trouble (before we put in
9846 -- this guard, a discriminant expression containing an
9847 -- AND THEN was copied, causing problems for coverage
9850 -- However, if the reference is part of the initialization
9851 -- code generated for an object declaration, we must use
9852 -- the discriminant value from the subtype constraint,
9853 -- because the selected component may be a reference to the
9854 -- object being initialized, whose discriminant is not yet
9855 -- set. This only happens in complex cases involving changes
9856 -- or representation.
9858 if Disc
= Entity
(Selector_Name
(N
))
9859 and then (Is_Entity_Name
(Dval
)
9860 or else Compile_Time_Known_Value
(Dval
)
9861 or else Is_Subtype_Declaration
)
9863 -- Here we have the matching discriminant. Check for
9864 -- the case of a discriminant of a component that is
9865 -- constrained by an outer discriminant, which cannot
9866 -- be optimized away.
9868 if Denotes_Discriminant
9869 (Dval
, Check_Concurrent
=> True)
9873 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
9875 Denotes_Discriminant
9876 (Selector_Name
(Original_Node
(Dval
)), True)
9880 -- Do not retrieve value if constraint is not static. It
9881 -- is generally not useful, and the constraint may be a
9882 -- rewritten outer discriminant in which case it is in
9885 elsif Is_Entity_Name
(Dval
)
9887 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
9888 and then Present
(Expression
(Parent
(Entity
(Dval
))))
9890 Is_OK_Static_Expression
9891 (Expression
(Parent
(Entity
(Dval
))))
9895 -- In the context of a case statement, the expression may
9896 -- have the base type of the discriminant, and we need to
9897 -- preserve the constraint to avoid spurious errors on
9900 elsif Nkind
(Parent
(N
)) = N_Case_Statement
9901 and then Etype
(Dval
) /= Etype
(Disc
)
9904 Make_Qualified_Expression
(Loc
,
9906 New_Occurrence_Of
(Etype
(Disc
), Loc
),
9908 New_Copy_Tree
(Dval
)));
9909 Analyze_And_Resolve
(N
, Etype
(Disc
));
9911 -- In case that comes out as a static expression,
9912 -- reset it (a selected component is never static).
9914 Set_Is_Static_Expression
(N
, False);
9917 -- Otherwise we can just copy the constraint, but the
9918 -- result is certainly not static. In some cases the
9919 -- discriminant constraint has been analyzed in the
9920 -- context of the original subtype indication, but for
9921 -- itypes the constraint might not have been analyzed
9922 -- yet, and this must be done now.
9925 Rewrite
(N
, New_Copy_Tree
(Dval
));
9926 Analyze_And_Resolve
(N
);
9927 Set_Is_Static_Expression
(N
, False);
9933 Next_Discriminant
(Disc
);
9934 end loop Discr_Loop
;
9936 -- Note: the above loop should always find a matching
9937 -- discriminant, but if it does not, we just missed an
9938 -- optimization due to some glitch (perhaps a previous
9939 -- error), so ignore.
9944 -- The only remaining processing is in the case of a discriminant of
9945 -- a concurrent object, where we rewrite the prefix to denote the
9946 -- corresponding record type. If the type is derived and has renamed
9947 -- discriminants, use corresponding discriminant, which is the one
9948 -- that appears in the corresponding record.
9950 if not Is_Concurrent_Type
(Ptyp
) then
9954 Disc
:= Entity
(Selector_Name
(N
));
9956 if Is_Derived_Type
(Ptyp
)
9957 and then Present
(Corresponding_Discriminant
(Disc
))
9959 Disc
:= Corresponding_Discriminant
(Disc
);
9963 Make_Selected_Component
(Loc
,
9965 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
9967 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
9973 -- Set Atomic_Sync_Required if necessary for atomic component
9975 if Nkind
(N
) = N_Selected_Component
then
9977 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
9981 -- If component is atomic, but type is not, setting depends on
9982 -- disable/enable state for the component.
9984 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
9985 Set
:= not Atomic_Synchronization_Disabled
(E
);
9987 -- If component is not atomic, but its type is atomic, setting
9988 -- depends on disable/enable state for the type.
9990 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9991 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
9993 -- If both component and type are atomic, we disable if either
9994 -- component or its type have sync disabled.
9996 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9997 Set
:= (not Atomic_Synchronization_Disabled
(E
))
9999 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
10005 -- Set flag if required
10008 Activate_Atomic_Synchronization
(N
);
10012 end Expand_N_Selected_Component
;
10014 --------------------
10015 -- Expand_N_Slice --
10016 --------------------
10018 procedure Expand_N_Slice
(N
: Node_Id
) is
10019 Loc
: constant Source_Ptr
:= Sloc
(N
);
10020 Typ
: constant Entity_Id
:= Etype
(N
);
10022 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
10023 -- Check whether the argument is an actual for a procedure call, in
10024 -- which case the expansion of a bit-packed slice is deferred until the
10025 -- call itself is expanded. The reason this is required is that we might
10026 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10027 -- that copy out would be missed if we created a temporary here in
10028 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10029 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10030 -- is harmless to defer expansion in the IN case, since the call
10031 -- processing will still generate the appropriate copy in operation,
10032 -- which will take care of the slice.
10034 procedure Make_Temporary_For_Slice
;
10035 -- Create a named variable for the value of the slice, in cases where
10036 -- the back-end cannot handle it properly, e.g. when packed types or
10037 -- unaligned slices are involved.
10039 -------------------------
10040 -- Is_Procedure_Actual --
10041 -------------------------
10043 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
10044 Par
: Node_Id
:= Parent
(N
);
10048 -- If our parent is a procedure call we can return
10050 if Nkind
(Par
) = N_Procedure_Call_Statement
then
10053 -- If our parent is a type conversion, keep climbing the tree,
10054 -- since a type conversion can be a procedure actual. Also keep
10055 -- climbing if parameter association or a qualified expression,
10056 -- since these are additional cases that do can appear on
10057 -- procedure actuals.
10059 elsif Nkind_In
(Par
, N_Type_Conversion
,
10060 N_Parameter_Association
,
10061 N_Qualified_Expression
)
10063 Par
:= Parent
(Par
);
10065 -- Any other case is not what we are looking for
10071 end Is_Procedure_Actual
;
10073 ------------------------------
10074 -- Make_Temporary_For_Slice --
10075 ------------------------------
10077 procedure Make_Temporary_For_Slice
is
10078 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
10083 Make_Object_Declaration
(Loc
,
10084 Defining_Identifier
=> Ent
,
10085 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10087 Set_No_Initialization
(Decl
);
10089 Insert_Actions
(N
, New_List
(
10091 Make_Assignment_Statement
(Loc
,
10092 Name
=> New_Occurrence_Of
(Ent
, Loc
),
10093 Expression
=> Relocate_Node
(N
))));
10095 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
10096 Analyze_And_Resolve
(N
, Typ
);
10097 end Make_Temporary_For_Slice
;
10101 Pref
: constant Node_Id
:= Prefix
(N
);
10102 Pref_Typ
: Entity_Id
:= Etype
(Pref
);
10104 -- Start of processing for Expand_N_Slice
10107 -- Special handling for access types
10109 if Is_Access_Type
(Pref_Typ
) then
10110 Pref_Typ
:= Designated_Type
(Pref_Typ
);
10113 Make_Explicit_Dereference
(Sloc
(N
),
10114 Prefix
=> Relocate_Node
(Pref
)));
10116 Analyze_And_Resolve
(Pref
, Pref_Typ
);
10119 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10120 -- function, then additional actuals must be passed.
10122 if Ada_Version
>= Ada_2005
10123 and then Is_Build_In_Place_Function_Call
(Pref
)
10125 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
10128 -- The remaining case to be handled is packed slices. We can leave
10129 -- packed slices as they are in the following situations:
10131 -- 1. Right or left side of an assignment (we can handle this
10132 -- situation correctly in the assignment statement expansion).
10134 -- 2. Prefix of indexed component (the slide is optimized away in this
10135 -- case, see the start of Expand_N_Slice.)
10137 -- 3. Object renaming declaration, since we want the name of the
10138 -- slice, not the value.
10140 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10141 -- be required, and this is handled in the expansion of call
10144 -- 5. Prefix of an address attribute (this is an error which is caught
10145 -- elsewhere, and the expansion would interfere with generating the
10148 if not Is_Packed
(Typ
) then
10150 -- Apply transformation for actuals of a function call, where
10151 -- Expand_Actuals is not used.
10153 if Nkind
(Parent
(N
)) = N_Function_Call
10154 and then Is_Possibly_Unaligned_Slice
(N
)
10156 Make_Temporary_For_Slice
;
10159 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
10160 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
10161 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
10165 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
10166 or else Is_Renamed_Object
(N
)
10167 or else Is_Procedure_Actual
(N
)
10171 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
10172 and then Attribute_Name
(Parent
(N
)) = Name_Address
10177 Make_Temporary_For_Slice
;
10179 end Expand_N_Slice
;
10181 ------------------------------
10182 -- Expand_N_Type_Conversion --
10183 ------------------------------
10185 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
10186 Loc
: constant Source_Ptr
:= Sloc
(N
);
10187 Operand
: constant Node_Id
:= Expression
(N
);
10188 Target_Type
: constant Entity_Id
:= Etype
(N
);
10189 Operand_Type
: Entity_Id
:= Etype
(Operand
);
10191 procedure Handle_Changed_Representation
;
10192 -- This is called in the case of record and array type conversions to
10193 -- see if there is a change of representation to be handled. Change of
10194 -- representation is actually handled at the assignment statement level,
10195 -- and what this procedure does is rewrite node N conversion as an
10196 -- assignment to temporary. If there is no change of representation,
10197 -- then the conversion node is unchanged.
10199 procedure Raise_Accessibility_Error
;
10200 -- Called when we know that an accessibility check will fail. Rewrites
10201 -- node N to an appropriate raise statement and outputs warning msgs.
10202 -- The Etype of the raise node is set to Target_Type. Note that in this
10203 -- case the rest of the processing should be skipped (i.e. the call to
10204 -- this procedure will be followed by "goto Done").
10206 procedure Real_Range_Check
;
10207 -- Handles generation of range check for real target value
10209 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
10210 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
10211 -- evaluates to True.
10213 -----------------------------------
10214 -- Handle_Changed_Representation --
10215 -----------------------------------
10217 procedure Handle_Changed_Representation
is
10226 -- Nothing else to do if no change of representation
10228 if Same_Representation
(Operand_Type
, Target_Type
) then
10231 -- The real change of representation work is done by the assignment
10232 -- statement processing. So if this type conversion is appearing as
10233 -- the expression of an assignment statement, nothing needs to be
10234 -- done to the conversion.
10236 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
10239 -- Otherwise we need to generate a temporary variable, and do the
10240 -- change of representation assignment into that temporary variable.
10241 -- The conversion is then replaced by a reference to this variable.
10246 -- If type is unconstrained we have to add a constraint, copied
10247 -- from the actual value of the left-hand side.
10249 if not Is_Constrained
(Target_Type
) then
10250 if Has_Discriminants
(Operand_Type
) then
10251 Disc
:= First_Discriminant
(Operand_Type
);
10253 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
10254 Disc
:= First_Stored_Discriminant
(Operand_Type
);
10258 while Present
(Disc
) loop
10260 Make_Selected_Component
(Loc
,
10262 Duplicate_Subexpr_Move_Checks
(Operand
),
10264 Make_Identifier
(Loc
, Chars
(Disc
))));
10265 Next_Discriminant
(Disc
);
10268 elsif Is_Array_Type
(Operand_Type
) then
10269 N_Ix
:= First_Index
(Target_Type
);
10272 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
10274 -- We convert the bounds explicitly. We use an unchecked
10275 -- conversion because bounds checks are done elsewhere.
10280 Unchecked_Convert_To
(Etype
(N_Ix
),
10281 Make_Attribute_Reference
(Loc
,
10283 Duplicate_Subexpr_No_Checks
10284 (Operand
, Name_Req
=> True),
10285 Attribute_Name
=> Name_First
,
10286 Expressions
=> New_List
(
10287 Make_Integer_Literal
(Loc
, J
)))),
10290 Unchecked_Convert_To
(Etype
(N_Ix
),
10291 Make_Attribute_Reference
(Loc
,
10293 Duplicate_Subexpr_No_Checks
10294 (Operand
, Name_Req
=> True),
10295 Attribute_Name
=> Name_Last
,
10296 Expressions
=> New_List
(
10297 Make_Integer_Literal
(Loc
, J
))))));
10304 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
10306 if Present
(Cons
) then
10308 Make_Subtype_Indication
(Loc
,
10309 Subtype_Mark
=> Odef
,
10311 Make_Index_Or_Discriminant_Constraint
(Loc
,
10312 Constraints
=> Cons
));
10315 Temp
:= Make_Temporary
(Loc
, 'C');
10317 Make_Object_Declaration
(Loc
,
10318 Defining_Identifier
=> Temp
,
10319 Object_Definition
=> Odef
);
10321 Set_No_Initialization
(Decl
, True);
10323 -- Insert required actions. It is essential to suppress checks
10324 -- since we have suppressed default initialization, which means
10325 -- that the variable we create may have no discriminants.
10330 Make_Assignment_Statement
(Loc
,
10331 Name
=> New_Occurrence_Of
(Temp
, Loc
),
10332 Expression
=> Relocate_Node
(N
))),
10333 Suppress
=> All_Checks
);
10335 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
10338 end Handle_Changed_Representation
;
10340 -------------------------------
10341 -- Raise_Accessibility_Error --
10342 -------------------------------
10344 procedure Raise_Accessibility_Error
is
10346 Error_Msg_Warn
:= SPARK_Mode
/= On
;
10348 Make_Raise_Program_Error
(Sloc
(N
),
10349 Reason
=> PE_Accessibility_Check_Failed
));
10350 Set_Etype
(N
, Target_Type
);
10352 Error_Msg_N
("<<accessibility check failure", N
);
10353 Error_Msg_NE
("\<<& [", N
, Standard_Program_Error
);
10354 end Raise_Accessibility_Error
;
10356 ----------------------
10357 -- Real_Range_Check --
10358 ----------------------
10360 -- Case of conversions to floating-point or fixed-point. If range checks
10361 -- are enabled and the target type has a range constraint, we convert:
10367 -- Tnn : typ'Base := typ'Base (x);
10368 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10371 -- This is necessary when there is a conversion of integer to float or
10372 -- to fixed-point to ensure that the correct checks are made. It is not
10373 -- necessary for float to float where it is enough to simply set the
10374 -- Do_Range_Check flag.
10376 procedure Real_Range_Check
is
10377 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
10378 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
10379 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
10380 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
10385 -- Nothing to do if conversion was rewritten
10387 if Nkind
(N
) /= N_Type_Conversion
then
10391 -- Nothing to do if range checks suppressed, or target has the same
10392 -- range as the base type (or is the base type).
10394 if Range_Checks_Suppressed
(Target_Type
)
10395 or else (Lo
= Type_Low_Bound
(Btyp
)
10397 Hi
= Type_High_Bound
(Btyp
))
10402 -- Nothing to do if expression is an entity on which checks have been
10405 if Is_Entity_Name
(Operand
)
10406 and then Range_Checks_Suppressed
(Entity
(Operand
))
10411 -- Nothing to do if bounds are all static and we can tell that the
10412 -- expression is within the bounds of the target. Note that if the
10413 -- operand is of an unconstrained floating-point type, then we do
10414 -- not trust it to be in range (might be infinite)
10417 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
10418 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
10421 if (not Is_Floating_Point_Type
(Xtyp
)
10422 or else Is_Constrained
(Xtyp
))
10423 and then Compile_Time_Known_Value
(S_Lo
)
10424 and then Compile_Time_Known_Value
(S_Hi
)
10425 and then Compile_Time_Known_Value
(Hi
)
10426 and then Compile_Time_Known_Value
(Lo
)
10429 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
10430 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
10435 if Is_Real_Type
(Xtyp
) then
10436 S_Lov
:= Expr_Value_R
(S_Lo
);
10437 S_Hiv
:= Expr_Value_R
(S_Hi
);
10439 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
10440 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
10444 and then S_Lov
>= D_Lov
10445 and then S_Hiv
<= D_Hiv
10447 -- Unset the range check flag on the current value of
10448 -- Expression (N), since the captured Operand may have
10449 -- been rewritten (such as for the case of a conversion
10450 -- to a fixed-point type).
10452 Set_Do_Range_Check
(Expression
(N
), False);
10460 -- For float to float conversions, we are done
10462 if Is_Floating_Point_Type
(Xtyp
)
10464 Is_Floating_Point_Type
(Btyp
)
10469 -- Otherwise rewrite the conversion as described above
10471 Conv
:= Relocate_Node
(N
);
10472 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
10473 Set_Etype
(Conv
, Btyp
);
10475 -- Enable overflow except for case of integer to float conversions,
10476 -- where it is never required, since we can never have overflow in
10479 if not Is_Integer_Type
(Etype
(Operand
)) then
10480 Enable_Overflow_Check
(Conv
);
10483 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
10485 Insert_Actions
(N
, New_List
(
10486 Make_Object_Declaration
(Loc
,
10487 Defining_Identifier
=> Tnn
,
10488 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
10489 Constant_Present
=> True,
10490 Expression
=> Conv
),
10492 Make_Raise_Constraint_Error
(Loc
,
10497 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10499 Make_Attribute_Reference
(Loc
,
10500 Attribute_Name
=> Name_First
,
10502 New_Occurrence_Of
(Target_Type
, Loc
))),
10506 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10508 Make_Attribute_Reference
(Loc
,
10509 Attribute_Name
=> Name_Last
,
10511 New_Occurrence_Of
(Target_Type
, Loc
)))),
10512 Reason
=> CE_Range_Check_Failed
)));
10514 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
10515 Analyze_And_Resolve
(N
, Btyp
);
10516 end Real_Range_Check
;
10518 -----------------------------
10519 -- Has_Extra_Accessibility --
10520 -----------------------------
10522 -- Returns true for a formal of an anonymous access type or for
10523 -- an Ada 2012-style stand-alone object of an anonymous access type.
10525 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
10527 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
10528 return Present
(Effective_Extra_Accessibility
(Id
));
10532 end Has_Extra_Accessibility
;
10534 -- Start of processing for Expand_N_Type_Conversion
10537 -- First remove check marks put by the semantic analysis on the type
10538 -- conversion between array types. We need these checks, and they will
10539 -- be generated by this expansion routine, but we do not depend on these
10540 -- flags being set, and since we do intend to expand the checks in the
10541 -- front end, we don't want them on the tree passed to the back end.
10543 if Is_Array_Type
(Target_Type
) then
10544 if Is_Constrained
(Target_Type
) then
10545 Set_Do_Length_Check
(N
, False);
10547 Set_Do_Range_Check
(Operand
, False);
10551 -- Nothing at all to do if conversion is to the identical type so remove
10552 -- the conversion completely, it is useless, except that it may carry
10553 -- an Assignment_OK attribute, which must be propagated to the operand.
10555 if Operand_Type
= Target_Type
then
10556 if Assignment_OK
(N
) then
10557 Set_Assignment_OK
(Operand
);
10560 Rewrite
(N
, Relocate_Node
(Operand
));
10564 -- Nothing to do if this is the second argument of read. This is a
10565 -- "backwards" conversion that will be handled by the specialized code
10566 -- in attribute processing.
10568 if Nkind
(Parent
(N
)) = N_Attribute_Reference
10569 and then Attribute_Name
(Parent
(N
)) = Name_Read
10570 and then Next
(First
(Expressions
(Parent
(N
)))) = N
10575 -- Check for case of converting to a type that has an invariant
10576 -- associated with it. This required an invariant check. We convert
10582 -- do invariant_check (typ (expr)) in typ (expr);
10584 -- using Duplicate_Subexpr to avoid multiple side effects
10586 -- Note: the Comes_From_Source check, and then the resetting of this
10587 -- flag prevents what would otherwise be an infinite recursion.
10589 if Has_Invariants
(Target_Type
)
10590 and then Present
(Invariant_Procedure
(Target_Type
))
10591 and then Comes_From_Source
(N
)
10593 Set_Comes_From_Source
(N
, False);
10595 Make_Expression_With_Actions
(Loc
,
10596 Actions
=> New_List
(
10597 Make_Invariant_Call
(Duplicate_Subexpr
(N
))),
10598 Expression
=> Duplicate_Subexpr_No_Checks
(N
)));
10599 Analyze_And_Resolve
(N
, Target_Type
);
10603 -- Here if we may need to expand conversion
10605 -- If the operand of the type conversion is an arithmetic operation on
10606 -- signed integers, and the based type of the signed integer type in
10607 -- question is smaller than Standard.Integer, we promote both of the
10608 -- operands to type Integer.
10610 -- For example, if we have
10612 -- target-type (opnd1 + opnd2)
10614 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10617 -- target-type (integer(opnd1) + integer(opnd2))
10619 -- We do this because we are always allowed to compute in a larger type
10620 -- if we do the right thing with the result, and in this case we are
10621 -- going to do a conversion which will do an appropriate check to make
10622 -- sure that things are in range of the target type in any case. This
10623 -- avoids some unnecessary intermediate overflows.
10625 -- We might consider a similar transformation in the case where the
10626 -- target is a real type or a 64-bit integer type, and the operand
10627 -- is an arithmetic operation using a 32-bit integer type. However,
10628 -- we do not bother with this case, because it could cause significant
10629 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10630 -- much cheaper, but we don't want different behavior on 32-bit and
10631 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10632 -- handles the configurable run-time cases where 64-bit arithmetic
10633 -- may simply be unavailable.
10635 -- Note: this circuit is partially redundant with respect to the circuit
10636 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10637 -- the processing here. Also we still need the Checks circuit, since we
10638 -- have to be sure not to generate junk overflow checks in the first
10639 -- place, since it would be trick to remove them here.
10641 if Integer_Promotion_Possible
(N
) then
10643 -- All conditions met, go ahead with transformation
10651 Make_Type_Conversion
(Loc
,
10652 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10653 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
10655 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
10656 Set_Right_Opnd
(Opnd
, R
);
10658 if Nkind
(Operand
) in N_Binary_Op
then
10660 Make_Type_Conversion
(Loc
,
10661 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10662 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
10664 Set_Left_Opnd
(Opnd
, L
);
10668 Make_Type_Conversion
(Loc
,
10669 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
10670 Expression
=> Opnd
));
10672 Analyze_And_Resolve
(N
, Target_Type
);
10677 -- Do validity check if validity checking operands
10679 if Validity_Checks_On
and Validity_Check_Operands
then
10680 Ensure_Valid
(Operand
);
10683 -- Special case of converting from non-standard boolean type
10685 if Is_Boolean_Type
(Operand_Type
)
10686 and then (Nonzero_Is_True
(Operand_Type
))
10688 Adjust_Condition
(Operand
);
10689 Set_Etype
(Operand
, Standard_Boolean
);
10690 Operand_Type
:= Standard_Boolean
;
10693 -- Case of converting to an access type
10695 if Is_Access_Type
(Target_Type
) then
10697 -- Apply an accessibility check when the conversion operand is an
10698 -- access parameter (or a renaming thereof), unless conversion was
10699 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10700 -- Note that other checks may still need to be applied below (such
10701 -- as tagged type checks).
10703 if Is_Entity_Name
(Operand
)
10704 and then Has_Extra_Accessibility
(Entity
(Operand
))
10705 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
10706 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
10707 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
10709 Apply_Accessibility_Check
10710 (Operand
, Target_Type
, Insert_Node
=> Operand
);
10712 -- If the level of the operand type is statically deeper than the
10713 -- level of the target type, then force Program_Error. Note that this
10714 -- can only occur for cases where the attribute is within the body of
10715 -- an instantiation, otherwise the conversion will already have been
10716 -- rejected as illegal.
10718 -- Note: warnings are issued by the analyzer for the instance cases
10720 elsif In_Instance_Body
10722 -- The case where the target type is an anonymous access type of
10723 -- a discriminant is excluded, because the level of such a type
10724 -- depends on the context and currently the level returned for such
10725 -- types is zero, resulting in warnings about about check failures
10726 -- in certain legal cases involving class-wide interfaces as the
10727 -- designated type (some cases, such as return statements, are
10728 -- checked at run time, but not clear if these are handled right
10729 -- in general, see 3.10.2(12/2-12.5/3) ???).
10732 not (Ekind
(Target_Type
) = E_Anonymous_Access_Type
10733 and then Present
(Associated_Node_For_Itype
(Target_Type
))
10734 and then Nkind
(Associated_Node_For_Itype
(Target_Type
)) =
10735 N_Discriminant_Specification
)
10737 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
10739 Raise_Accessibility_Error
;
10742 -- When the operand is a selected access discriminant the check needs
10743 -- to be made against the level of the object denoted by the prefix
10744 -- of the selected name. Force Program_Error for this case as well
10745 -- (this accessibility violation can only happen if within the body
10746 -- of an instantiation).
10748 elsif In_Instance_Body
10749 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
10750 and then Nkind
(Operand
) = N_Selected_Component
10751 and then Object_Access_Level
(Operand
) >
10752 Type_Access_Level
(Target_Type
)
10754 Raise_Accessibility_Error
;
10759 -- Case of conversions of tagged types and access to tagged types
10761 -- When needed, that is to say when the expression is class-wide, Add
10762 -- runtime a tag check for (strict) downward conversion by using the
10763 -- membership test, generating:
10765 -- [constraint_error when Operand not in Target_Type'Class]
10767 -- or in the access type case
10769 -- [constraint_error
10770 -- when Operand /= null
10771 -- and then Operand.all not in
10772 -- Designated_Type (Target_Type)'Class]
10774 if (Is_Access_Type
(Target_Type
)
10775 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
10776 or else Is_Tagged_Type
(Target_Type
)
10778 -- Do not do any expansion in the access type case if the parent is a
10779 -- renaming, since this is an error situation which will be caught by
10780 -- Sem_Ch8, and the expansion can interfere with this error check.
10782 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
10786 -- Otherwise, proceed with processing tagged conversion
10788 Tagged_Conversion
: declare
10789 Actual_Op_Typ
: Entity_Id
;
10790 Actual_Targ_Typ
: Entity_Id
;
10791 Make_Conversion
: Boolean := False;
10792 Root_Op_Typ
: Entity_Id
;
10794 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
10795 -- Create a membership check to test whether Operand is a member
10796 -- of Targ_Typ. If the original Target_Type is an access, include
10797 -- a test for null value. The check is inserted at N.
10799 --------------------
10800 -- Make_Tag_Check --
10801 --------------------
10803 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
10808 -- [Constraint_Error
10809 -- when Operand /= null
10810 -- and then Operand.all not in Targ_Typ]
10812 if Is_Access_Type
(Target_Type
) then
10814 Make_And_Then
(Loc
,
10817 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10818 Right_Opnd
=> Make_Null
(Loc
)),
10823 Make_Explicit_Dereference
(Loc
,
10824 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
10825 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
10828 -- [Constraint_Error when Operand not in Targ_Typ]
10833 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10834 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
10838 Make_Raise_Constraint_Error
(Loc
,
10840 Reason
=> CE_Tag_Check_Failed
));
10841 end Make_Tag_Check
;
10843 -- Start of processing for Tagged_Conversion
10846 -- Handle entities from the limited view
10848 if Is_Access_Type
(Operand_Type
) then
10850 Available_View
(Designated_Type
(Operand_Type
));
10852 Actual_Op_Typ
:= Operand_Type
;
10855 if Is_Access_Type
(Target_Type
) then
10857 Available_View
(Designated_Type
(Target_Type
));
10859 Actual_Targ_Typ
:= Target_Type
;
10862 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
10864 -- Ada 2005 (AI-251): Handle interface type conversion
10866 if Is_Interface
(Actual_Op_Typ
)
10868 Is_Interface
(Actual_Targ_Typ
)
10870 Expand_Interface_Conversion
(N
);
10874 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
10876 -- Create a runtime tag check for a downward class-wide type
10879 if Is_Class_Wide_Type
(Actual_Op_Typ
)
10880 and then Actual_Op_Typ
/= Actual_Targ_Typ
10881 and then Root_Op_Typ
/= Actual_Targ_Typ
10882 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
10883 Use_Full_View
=> True)
10885 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
10886 Make_Conversion
:= True;
10889 -- AI05-0073: If the result subtype of the function is defined
10890 -- by an access_definition designating a specific tagged type
10891 -- T, a check is made that the result value is null or the tag
10892 -- of the object designated by the result value identifies T.
10893 -- Constraint_Error is raised if this check fails.
10895 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
10898 Func_Typ
: Entity_Id
;
10901 -- Climb scope stack looking for the enclosing function
10903 Func
:= Current_Scope
;
10904 while Present
(Func
)
10905 and then Ekind
(Func
) /= E_Function
10907 Func
:= Scope
(Func
);
10910 -- The function's return subtype must be defined using
10911 -- an access definition.
10913 if Nkind
(Result_Definition
(Parent
(Func
))) =
10914 N_Access_Definition
10916 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
10918 -- The return subtype denotes a specific tagged type,
10919 -- in other words, a non class-wide type.
10921 if Is_Tagged_Type
(Func_Typ
)
10922 and then not Is_Class_Wide_Type
(Func_Typ
)
10924 Make_Tag_Check
(Actual_Targ_Typ
);
10925 Make_Conversion
:= True;
10931 -- We have generated a tag check for either a class-wide type
10932 -- conversion or for AI05-0073.
10934 if Make_Conversion
then
10939 Make_Unchecked_Type_Conversion
(Loc
,
10940 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
10941 Expression
=> Relocate_Node
(Expression
(N
)));
10943 Analyze_And_Resolve
(N
, Target_Type
);
10947 end Tagged_Conversion
;
10949 -- Case of other access type conversions
10951 elsif Is_Access_Type
(Target_Type
) then
10952 Apply_Constraint_Check
(Operand
, Target_Type
);
10954 -- Case of conversions from a fixed-point type
10956 -- These conversions require special expansion and processing, found in
10957 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10958 -- since from a semantic point of view, these are simple integer
10959 -- conversions, which do not need further processing.
10961 elsif Is_Fixed_Point_Type
(Operand_Type
)
10962 and then not Conversion_OK
(N
)
10964 -- We should never see universal fixed at this case, since the
10965 -- expansion of the constituent divide or multiply should have
10966 -- eliminated the explicit mention of universal fixed.
10968 pragma Assert
(Operand_Type
/= Universal_Fixed
);
10970 -- Check for special case of the conversion to universal real that
10971 -- occurs as a result of the use of a round attribute. In this case,
10972 -- the real type for the conversion is taken from the target type of
10973 -- the Round attribute and the result must be marked as rounded.
10975 if Target_Type
= Universal_Real
10976 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
10977 and then Attribute_Name
(Parent
(N
)) = Name_Round
10979 Set_Rounded_Result
(N
);
10980 Set_Etype
(N
, Etype
(Parent
(N
)));
10983 -- Otherwise do correct fixed-conversion, but skip these if the
10984 -- Conversion_OK flag is set, because from a semantic point of view
10985 -- these are simple integer conversions needing no further processing
10986 -- (the backend will simply treat them as integers).
10988 if not Conversion_OK
(N
) then
10989 if Is_Fixed_Point_Type
(Etype
(N
)) then
10990 Expand_Convert_Fixed_To_Fixed
(N
);
10993 elsif Is_Integer_Type
(Etype
(N
)) then
10994 Expand_Convert_Fixed_To_Integer
(N
);
10997 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
10998 Expand_Convert_Fixed_To_Float
(N
);
11003 -- Case of conversions to a fixed-point type
11005 -- These conversions require special expansion and processing, found in
11006 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
11007 -- since from a semantic point of view, these are simple integer
11008 -- conversions, which do not need further processing.
11010 elsif Is_Fixed_Point_Type
(Target_Type
)
11011 and then not Conversion_OK
(N
)
11013 if Is_Integer_Type
(Operand_Type
) then
11014 Expand_Convert_Integer_To_Fixed
(N
);
11017 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
11018 Expand_Convert_Float_To_Fixed
(N
);
11022 -- Case of float-to-integer conversions
11024 -- We also handle float-to-fixed conversions with Conversion_OK set
11025 -- since semantically the fixed-point target is treated as though it
11026 -- were an integer in such cases.
11028 elsif Is_Floating_Point_Type
(Operand_Type
)
11030 (Is_Integer_Type
(Target_Type
)
11032 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
11034 -- One more check here, gcc is still not able to do conversions of
11035 -- this type with proper overflow checking, and so gigi is doing an
11036 -- approximation of what is required by doing floating-point compares
11037 -- with the end-point. But that can lose precision in some cases, and
11038 -- give a wrong result. Converting the operand to Universal_Real is
11039 -- helpful, but still does not catch all cases with 64-bit integers
11040 -- on targets with only 64-bit floats.
11042 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
11043 -- Can this code be removed ???
11045 if Do_Range_Check
(Operand
) then
11047 Make_Type_Conversion
(Loc
,
11049 New_Occurrence_Of
(Universal_Real
, Loc
),
11051 Relocate_Node
(Operand
)));
11053 Set_Etype
(Operand
, Universal_Real
);
11054 Enable_Range_Check
(Operand
);
11055 Set_Do_Range_Check
(Expression
(Operand
), False);
11058 -- Case of array conversions
11060 -- Expansion of array conversions, add required length/range checks but
11061 -- only do this if there is no change of representation. For handling of
11062 -- this case, see Handle_Changed_Representation.
11064 elsif Is_Array_Type
(Target_Type
) then
11065 if Is_Constrained
(Target_Type
) then
11066 Apply_Length_Check
(Operand
, Target_Type
);
11068 Apply_Range_Check
(Operand
, Target_Type
);
11071 Handle_Changed_Representation
;
11073 -- Case of conversions of discriminated types
11075 -- Add required discriminant checks if target is constrained. Again this
11076 -- change is skipped if we have a change of representation.
11078 elsif Has_Discriminants
(Target_Type
)
11079 and then Is_Constrained
(Target_Type
)
11081 Apply_Discriminant_Check
(Operand
, Target_Type
);
11082 Handle_Changed_Representation
;
11084 -- Case of all other record conversions. The only processing required
11085 -- is to check for a change of representation requiring the special
11086 -- assignment processing.
11088 elsif Is_Record_Type
(Target_Type
) then
11090 -- Ada 2005 (AI-216): Program_Error is raised when converting from
11091 -- a derived Unchecked_Union type to an unconstrained type that is
11092 -- not Unchecked_Union if the operand lacks inferable discriminants.
11094 if Is_Derived_Type
(Operand_Type
)
11095 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
11096 and then not Is_Constrained
(Target_Type
)
11097 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
11098 and then not Has_Inferable_Discriminants
(Operand
)
11100 -- To prevent Gigi from generating illegal code, we generate a
11101 -- Program_Error node, but we give it the target type of the
11102 -- conversion (is this requirement documented somewhere ???)
11105 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
11106 Reason
=> PE_Unchecked_Union_Restriction
);
11109 Set_Etype
(PE
, Target_Type
);
11114 Handle_Changed_Representation
;
11117 -- Case of conversions of enumeration types
11119 elsif Is_Enumeration_Type
(Target_Type
) then
11121 -- Special processing is required if there is a change of
11122 -- representation (from enumeration representation clauses).
11124 if not Same_Representation
(Target_Type
, Operand_Type
) then
11126 -- Convert: x(y) to x'val (ytyp'val (y))
11129 Make_Attribute_Reference
(Loc
,
11130 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11131 Attribute_Name
=> Name_Val
,
11132 Expressions
=> New_List
(
11133 Make_Attribute_Reference
(Loc
,
11134 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
11135 Attribute_Name
=> Name_Pos
,
11136 Expressions
=> New_List
(Operand
)))));
11138 Analyze_And_Resolve
(N
, Target_Type
);
11141 -- Case of conversions to floating-point
11143 elsif Is_Floating_Point_Type
(Target_Type
) then
11147 -- At this stage, either the conversion node has been transformed into
11148 -- some other equivalent expression, or left as a conversion that can be
11149 -- handled by Gigi, in the following cases:
11151 -- Conversions with no change of representation or type
11153 -- Numeric conversions involving integer, floating- and fixed-point
11154 -- values. Fixed-point values are allowed only if Conversion_OK is
11155 -- set, i.e. if the fixed-point values are to be treated as integers.
11157 -- No other conversions should be passed to Gigi
11159 -- Check: are these rules stated in sinfo??? if so, why restate here???
11161 -- The only remaining step is to generate a range check if we still have
11162 -- a type conversion at this stage and Do_Range_Check is set. For now we
11163 -- do this only for conversions of discrete types and for float-to-float
11166 if Nkind
(N
) = N_Type_Conversion
then
11168 -- For now we only support floating-point cases where both source
11169 -- and target are floating-point types. Conversions where the source
11170 -- and target involve integer or fixed-point types are still TBD,
11171 -- though not clear whether those can even happen at this point, due
11172 -- to transformations above. ???
11174 if Is_Floating_Point_Type
(Etype
(N
))
11175 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
11177 if Do_Range_Check
(Expression
(N
))
11178 and then Is_Floating_Point_Type
(Target_Type
)
11180 Generate_Range_Check
11181 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
11184 -- Discrete-to-discrete conversions
11186 elsif Is_Discrete_Type
(Etype
(N
)) then
11188 Expr
: constant Node_Id
:= Expression
(N
);
11193 if Do_Range_Check
(Expr
)
11194 and then Is_Discrete_Type
(Etype
(Expr
))
11196 Set_Do_Range_Check
(Expr
, False);
11198 -- Before we do a range check, we have to deal with treating
11199 -- a fixed-point operand as an integer. The way we do this
11200 -- is simply to do an unchecked conversion to an appropriate
11201 -- integer type large enough to hold the result.
11203 -- This code is not active yet, because we are only dealing
11204 -- with discrete types so far ???
11206 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
11207 and then Treat_Fixed_As_Integer
(Expr
)
11209 Ftyp
:= Base_Type
(Etype
(Expr
));
11211 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
11212 Ityp
:= Standard_Long_Long_Integer
;
11214 Ityp
:= Standard_Integer
;
11217 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11220 -- Reset overflow flag, since the range check will include
11221 -- dealing with possible overflow, and generate the check.
11222 -- If Address is either a source type or target type,
11223 -- suppress range check to avoid typing anomalies when
11224 -- it is a visible integer type.
11226 Set_Do_Overflow_Check
(N
, False);
11228 if not Is_Descendant_Of_Address
(Etype
(Expr
))
11229 and then not Is_Descendant_Of_Address
(Target_Type
)
11231 Generate_Range_Check
11232 (Expr
, Target_Type
, CE_Range_Check_Failed
);
11239 -- Here at end of processing
11242 -- Apply predicate check if required. Note that we can't just call
11243 -- Apply_Predicate_Check here, because the type looks right after
11244 -- the conversion and it would omit the check. The Comes_From_Source
11245 -- guard is necessary to prevent infinite recursions when we generate
11246 -- internal conversions for the purpose of checking predicates.
11248 if Present
(Predicate_Function
(Target_Type
))
11249 and then not Predicates_Ignored
(Target_Type
)
11250 and then Target_Type
/= Operand_Type
11251 and then Comes_From_Source
(N
)
11254 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
11257 -- Avoid infinite recursion on the subsequent expansion of
11258 -- of the copy of the original type conversion.
11260 Set_Comes_From_Source
(New_Expr
, False);
11261 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
11264 end Expand_N_Type_Conversion
;
11266 -----------------------------------
11267 -- Expand_N_Unchecked_Expression --
11268 -----------------------------------
11270 -- Remove the unchecked expression node from the tree. Its job was simply
11271 -- to make sure that its constituent expression was handled with checks
11272 -- off, and now that that is done, we can remove it from the tree, and
11273 -- indeed must, since Gigi does not expect to see these nodes.
11275 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
11276 Exp
: constant Node_Id
:= Expression
(N
);
11278 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
11280 end Expand_N_Unchecked_Expression
;
11282 ----------------------------------------
11283 -- Expand_N_Unchecked_Type_Conversion --
11284 ----------------------------------------
11286 -- If this cannot be handled by Gigi and we haven't already made a
11287 -- temporary for it, do it now.
11289 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
11290 Target_Type
: constant Entity_Id
:= Etype
(N
);
11291 Operand
: constant Node_Id
:= Expression
(N
);
11292 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11295 -- Nothing at all to do if conversion is to the identical type so remove
11296 -- the conversion completely, it is useless, except that it may carry
11297 -- an Assignment_OK indication which must be propagated to the operand.
11299 if Operand_Type
= Target_Type
then
11301 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
11303 if Assignment_OK
(N
) then
11304 Set_Assignment_OK
(Operand
);
11307 Rewrite
(N
, Relocate_Node
(Operand
));
11311 -- If we have a conversion of a compile time known value to a target
11312 -- type and the value is in range of the target type, then we can simply
11313 -- replace the construct by an integer literal of the correct type. We
11314 -- only apply this to integer types being converted. Possibly it may
11315 -- apply in other cases, but it is too much trouble to worry about.
11317 -- Note that we do not do this transformation if the Kill_Range_Check
11318 -- flag is set, since then the value may be outside the expected range.
11319 -- This happens in the Normalize_Scalars case.
11321 -- We also skip this if either the target or operand type is biased
11322 -- because in this case, the unchecked conversion is supposed to
11323 -- preserve the bit pattern, not the integer value.
11325 if Is_Integer_Type
(Target_Type
)
11326 and then not Has_Biased_Representation
(Target_Type
)
11327 and then Is_Integer_Type
(Operand_Type
)
11328 and then not Has_Biased_Representation
(Operand_Type
)
11329 and then Compile_Time_Known_Value
(Operand
)
11330 and then not Kill_Range_Check
(N
)
11333 Val
: constant Uint
:= Expr_Value
(Operand
);
11336 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
11338 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
11340 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
11342 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
11344 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
11346 -- If Address is the target type, just set the type to avoid a
11347 -- spurious type error on the literal when Address is a visible
11350 if Is_Descendant_Of_Address
(Target_Type
) then
11351 Set_Etype
(N
, Target_Type
);
11353 Analyze_And_Resolve
(N
, Target_Type
);
11361 -- Nothing to do if conversion is safe
11363 if Safe_Unchecked_Type_Conversion
(N
) then
11367 -- Otherwise force evaluation unless Assignment_OK flag is set (this
11368 -- flag indicates ??? More comments needed here)
11370 if Assignment_OK
(N
) then
11373 Force_Evaluation
(N
);
11375 end Expand_N_Unchecked_Type_Conversion
;
11377 ----------------------------
11378 -- Expand_Record_Equality --
11379 ----------------------------
11381 -- For non-variant records, Equality is expanded when needed into:
11383 -- and then Lhs.Discr1 = Rhs.Discr1
11385 -- and then Lhs.Discrn = Rhs.Discrn
11386 -- and then Lhs.Cmp1 = Rhs.Cmp1
11388 -- and then Lhs.Cmpn = Rhs.Cmpn
11390 -- The expression is folded by the back-end for adjacent fields. This
11391 -- function is called for tagged record in only one occasion: for imple-
11392 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11393 -- otherwise the primitive "=" is used directly.
11395 function Expand_Record_Equality
11400 Bodies
: List_Id
) return Node_Id
11402 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11407 First_Time
: Boolean := True;
11409 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
11410 -- Return the next discriminant or component to compare, starting with
11411 -- C, skipping inherited components.
11413 ------------------------
11414 -- Element_To_Compare --
11415 ------------------------
11417 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
11423 -- Exit loop when the next element to be compared is found, or
11424 -- there is no more such element.
11426 exit when No
(Comp
);
11428 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
11431 -- Skip inherited components
11433 -- Note: for a tagged type, we always generate the "=" primitive
11434 -- for the base type (not on the first subtype), so the test for
11435 -- Comp /= Original_Record_Component (Comp) is True for
11436 -- inherited components only.
11438 (Is_Tagged_Type
(Typ
)
11439 and then Comp
/= Original_Record_Component
(Comp
))
11443 or else Chars
(Comp
) = Name_uTag
11445 -- Skip interface elements (secondary tags???)
11447 or else Is_Interface
(Etype
(Comp
)));
11449 Next_Entity
(Comp
);
11453 end Element_To_Compare
;
11455 -- Start of processing for Expand_Record_Equality
11458 -- Generates the following code: (assuming that Typ has one Discr and
11459 -- component C2 is also a record)
11462 -- and then Lhs.Discr1 = Rhs.Discr1
11463 -- and then Lhs.C1 = Rhs.C1
11464 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11466 -- and then Lhs.Cmpn = Rhs.Cmpn
11468 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
11469 C
:= Element_To_Compare
(First_Entity
(Typ
));
11470 while Present
(C
) loop
11478 First_Time
:= False;
11482 New_Lhs
:= New_Copy_Tree
(Lhs
);
11483 New_Rhs
:= New_Copy_Tree
(Rhs
);
11487 Expand_Composite_Equality
(Nod
, Etype
(C
),
11489 Make_Selected_Component
(Loc
,
11491 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11493 Make_Selected_Component
(Loc
,
11495 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11498 -- If some (sub)component is an unchecked_union, the whole
11499 -- operation will raise program error.
11501 if Nkind
(Check
) = N_Raise_Program_Error
then
11503 Set_Etype
(Result
, Standard_Boolean
);
11507 Make_And_Then
(Loc
,
11508 Left_Opnd
=> Result
,
11509 Right_Opnd
=> Check
);
11513 C
:= Element_To_Compare
(Next_Entity
(C
));
11517 end Expand_Record_Equality
;
11519 ---------------------------
11520 -- Expand_Set_Membership --
11521 ---------------------------
11523 procedure Expand_Set_Membership
(N
: Node_Id
) is
11524 Lop
: constant Node_Id
:= Left_Opnd
(N
);
11528 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
11529 -- If the alternative is a subtype mark, create a simple membership
11530 -- test. Otherwise create an equality test for it.
11536 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
11538 L
: constant Node_Id
:= New_Copy
(Lop
);
11539 R
: constant Node_Id
:= Relocate_Node
(Alt
);
11542 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
11543 or else Nkind
(Alt
) = N_Range
11546 Make_In
(Sloc
(Alt
),
11551 Make_Op_Eq
(Sloc
(Alt
),
11559 -- Start of processing for Expand_Set_Membership
11562 Remove_Side_Effects
(Lop
);
11564 Alt
:= Last
(Alternatives
(N
));
11565 Res
:= Make_Cond
(Alt
);
11568 while Present
(Alt
) loop
11570 Make_Or_Else
(Sloc
(Alt
),
11571 Left_Opnd
=> Make_Cond
(Alt
),
11572 Right_Opnd
=> Res
);
11577 Analyze_And_Resolve
(N
, Standard_Boolean
);
11578 end Expand_Set_Membership
;
11580 -----------------------------------
11581 -- Expand_Short_Circuit_Operator --
11582 -----------------------------------
11584 -- Deal with special expansion if actions are present for the right operand
11585 -- and deal with optimizing case of arguments being True or False. We also
11586 -- deal with the special case of non-standard boolean values.
11588 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
11589 Loc
: constant Source_Ptr
:= Sloc
(N
);
11590 Typ
: constant Entity_Id
:= Etype
(N
);
11591 Left
: constant Node_Id
:= Left_Opnd
(N
);
11592 Right
: constant Node_Id
:= Right_Opnd
(N
);
11593 LocR
: constant Source_Ptr
:= Sloc
(Right
);
11596 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
11597 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
11598 -- If Left = Shortcut_Value then Right need not be evaluated
11600 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
11601 -- For Opnd a boolean expression, return a Boolean expression equivalent
11602 -- to Opnd /= Shortcut_Value.
11604 --------------------
11605 -- Make_Test_Expr --
11606 --------------------
11608 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
11610 if Shortcut_Value
then
11611 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
11615 end Make_Test_Expr
;
11619 Op_Var
: Entity_Id
;
11620 -- Entity for a temporary variable holding the value of the operator,
11621 -- used for expansion in the case where actions are present.
11623 -- Start of processing for Expand_Short_Circuit_Operator
11626 -- Deal with non-standard booleans
11628 if Is_Boolean_Type
(Typ
) then
11629 Adjust_Condition
(Left
);
11630 Adjust_Condition
(Right
);
11631 Set_Etype
(N
, Standard_Boolean
);
11634 -- Check for cases where left argument is known to be True or False
11636 if Compile_Time_Known_Value
(Left
) then
11638 -- Mark SCO for left condition as compile time known
11640 if Generate_SCO
and then Comes_From_Source
(Left
) then
11641 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
11644 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11645 -- Any actions associated with Right will be executed unconditionally
11646 -- and can thus be inserted into the tree unconditionally.
11648 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
11649 if Present
(Actions
(N
)) then
11650 Insert_Actions
(N
, Actions
(N
));
11653 Rewrite
(N
, Right
);
11655 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11656 -- In this case we can forget the actions associated with Right,
11657 -- since they will never be executed.
11660 Kill_Dead_Code
(Right
);
11661 Kill_Dead_Code
(Actions
(N
));
11662 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11665 Adjust_Result_Type
(N
, Typ
);
11669 -- If Actions are present for the right operand, we have to do some
11670 -- special processing. We can't just let these actions filter back into
11671 -- code preceding the short circuit (which is what would have happened
11672 -- if we had not trapped them in the short-circuit form), since they
11673 -- must only be executed if the right operand of the short circuit is
11674 -- executed and not otherwise.
11676 if Present
(Actions
(N
)) then
11677 Actlist
:= Actions
(N
);
11679 -- The old approach is to expand:
11681 -- left AND THEN right
11685 -- C : Boolean := False;
11693 -- and finally rewrite the operator into a reference to C. Similarly
11694 -- for left OR ELSE right, with negated values. Note that this
11695 -- rewrite causes some difficulties for coverage analysis because
11696 -- of the introduction of the new variable C, which obscures the
11697 -- structure of the test.
11699 -- We use this "old approach" if Minimize_Expression_With_Actions
11702 if Minimize_Expression_With_Actions
then
11703 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
11706 Make_Object_Declaration
(Loc
,
11707 Defining_Identifier
=> Op_Var
,
11708 Object_Definition
=>
11709 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11711 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
11713 Append_To
(Actlist
,
11714 Make_Implicit_If_Statement
(Right
,
11715 Condition
=> Make_Test_Expr
(Right
),
11716 Then_Statements
=> New_List
(
11717 Make_Assignment_Statement
(LocR
,
11718 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
11721 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
11724 Make_Implicit_If_Statement
(Left
,
11725 Condition
=> Make_Test_Expr
(Left
),
11726 Then_Statements
=> Actlist
));
11728 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
11729 Analyze_And_Resolve
(N
, Standard_Boolean
);
11731 -- The new approach (the default) is to use an
11732 -- Expression_With_Actions node for the right operand of the
11733 -- short-circuit form. Note that this solves the traceability
11734 -- problems for coverage analysis.
11738 Make_Expression_With_Actions
(LocR
,
11739 Expression
=> Relocate_Node
(Right
),
11740 Actions
=> Actlist
));
11742 Set_Actions
(N
, No_List
);
11743 Analyze_And_Resolve
(Right
, Standard_Boolean
);
11746 Adjust_Result_Type
(N
, Typ
);
11750 -- No actions present, check for cases of right argument True/False
11752 if Compile_Time_Known_Value
(Right
) then
11754 -- Mark SCO for left condition as compile time known
11756 if Generate_SCO
and then Comes_From_Source
(Right
) then
11757 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
11760 -- Change (Left and then True), (Left or else False) to Left. Note
11761 -- that we know there are no actions associated with the right
11762 -- operand, since we just checked for this case above.
11764 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
11767 -- Change (Left and then False), (Left or else True) to Right,
11768 -- making sure to preserve any side effects associated with the Left
11772 Remove_Side_Effects
(Left
);
11773 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11777 Adjust_Result_Type
(N
, Typ
);
11778 end Expand_Short_Circuit_Operator
;
11780 -------------------------------------
11781 -- Fixup_Universal_Fixed_Operation --
11782 -------------------------------------
11784 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
11785 Conv
: constant Node_Id
:= Parent
(N
);
11788 -- We must have a type conversion immediately above us
11790 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
11792 -- Normally the type conversion gives our target type. The exception
11793 -- occurs in the case of the Round attribute, where the conversion
11794 -- will be to universal real, and our real type comes from the Round
11795 -- attribute (as well as an indication that we must round the result)
11797 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
11798 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
11800 Set_Etype
(N
, Etype
(Parent
(Conv
)));
11801 Set_Rounded_Result
(N
);
11803 -- Normal case where type comes from conversion above us
11806 Set_Etype
(N
, Etype
(Conv
));
11808 end Fixup_Universal_Fixed_Operation
;
11810 ---------------------------------
11811 -- Has_Inferable_Discriminants --
11812 ---------------------------------
11814 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
11816 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
11817 -- Determines whether the left-most prefix of a selected component is a
11818 -- formal parameter in a subprogram. Assumes N is a selected component.
11820 --------------------------------
11821 -- Prefix_Is_Formal_Parameter --
11822 --------------------------------
11824 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
11825 Sel_Comp
: Node_Id
;
11828 -- Move to the left-most prefix by climbing up the tree
11831 while Present
(Parent
(Sel_Comp
))
11832 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
11834 Sel_Comp
:= Parent
(Sel_Comp
);
11837 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
11838 end Prefix_Is_Formal_Parameter
;
11840 -- Start of processing for Has_Inferable_Discriminants
11843 -- For selected components, the subtype of the selector must be a
11844 -- constrained Unchecked_Union. If the component is subject to a
11845 -- per-object constraint, then the enclosing object must have inferable
11848 if Nkind
(N
) = N_Selected_Component
then
11849 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
11851 -- A small hack. If we have a per-object constrained selected
11852 -- component of a formal parameter, return True since we do not
11853 -- know the actual parameter association yet.
11855 if Prefix_Is_Formal_Parameter
(N
) then
11858 -- Otherwise, check the enclosing object and the selector
11861 return Has_Inferable_Discriminants
(Prefix
(N
))
11862 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
11865 -- The call to Has_Inferable_Discriminants will determine whether
11866 -- the selector has a constrained Unchecked_Union nominal type.
11869 return Has_Inferable_Discriminants
(Selector_Name
(N
));
11872 -- A qualified expression has inferable discriminants if its subtype
11873 -- mark is a constrained Unchecked_Union subtype.
11875 elsif Nkind
(N
) = N_Qualified_Expression
then
11876 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
11877 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
11879 -- For all other names, it is sufficient to have a constrained
11880 -- Unchecked_Union nominal subtype.
11883 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
11884 and then Is_Constrained
(Etype
(N
));
11886 end Has_Inferable_Discriminants
;
11888 -------------------------------
11889 -- Insert_Dereference_Action --
11890 -------------------------------
11892 procedure Insert_Dereference_Action
(N
: Node_Id
) is
11894 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
11895 -- Return true if type of P is derived from Checked_Pool;
11897 -----------------------------
11898 -- Is_Checked_Storage_Pool --
11899 -----------------------------
11901 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
11910 while T
/= Etype
(T
) loop
11911 if Is_RTE
(T
, RE_Checked_Pool
) then
11919 end Is_Checked_Storage_Pool
;
11923 Typ
: constant Entity_Id
:= Etype
(N
);
11924 Desig
: constant Entity_Id
:= Available_View
(Designated_Type
(Typ
));
11925 Loc
: constant Source_Ptr
:= Sloc
(N
);
11926 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
11927 Pnod
: constant Node_Id
:= Parent
(N
);
11933 Size_Bits
: Node_Id
;
11936 -- Start of processing for Insert_Dereference_Action
11939 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
11941 -- Do not re-expand a dereference which has already been processed by
11944 if Has_Dereference_Action
(Pnod
) then
11947 -- Do not perform this type of expansion for internally-generated
11950 elsif not Comes_From_Source
(Original_Node
(Pnod
)) then
11953 -- A dereference action is only applicable to objects which have been
11954 -- allocated on a checked pool.
11956 elsif not Is_Checked_Storage_Pool
(Pool
) then
11960 -- Extract the address of the dereferenced object. Generate:
11962 -- Addr : System.Address := <N>'Pool_Address;
11964 Addr
:= Make_Temporary
(Loc
, 'P');
11967 Make_Object_Declaration
(Loc
,
11968 Defining_Identifier
=> Addr
,
11969 Object_Definition
=>
11970 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
11972 Make_Attribute_Reference
(Loc
,
11973 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
11974 Attribute_Name
=> Name_Pool_Address
)));
11976 -- Calculate the size of the dereferenced object. Generate:
11978 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11981 Make_Explicit_Dereference
(Loc
,
11982 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11983 Set_Has_Dereference_Action
(Deref
);
11986 Make_Attribute_Reference
(Loc
,
11988 Attribute_Name
=> Name_Size
);
11990 -- Special case of an unconstrained array: need to add descriptor size
11992 if Is_Array_Type
(Desig
)
11993 and then not Is_Constrained
(First_Subtype
(Desig
))
11998 Make_Attribute_Reference
(Loc
,
12000 New_Occurrence_Of
(First_Subtype
(Desig
), Loc
),
12001 Attribute_Name
=> Name_Descriptor_Size
),
12002 Right_Opnd
=> Size_Bits
);
12005 Size
:= Make_Temporary
(Loc
, 'S');
12007 Make_Object_Declaration
(Loc
,
12008 Defining_Identifier
=> Size
,
12009 Object_Definition
=>
12010 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
12012 Make_Op_Divide
(Loc
,
12013 Left_Opnd
=> Size_Bits
,
12014 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
12016 -- Calculate the alignment of the dereferenced object. Generate:
12017 -- Alig : constant Storage_Count := <N>.all'Alignment;
12020 Make_Explicit_Dereference
(Loc
,
12021 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
12022 Set_Has_Dereference_Action
(Deref
);
12024 Alig
:= Make_Temporary
(Loc
, 'A');
12026 Make_Object_Declaration
(Loc
,
12027 Defining_Identifier
=> Alig
,
12028 Object_Definition
=>
12029 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
12031 Make_Attribute_Reference
(Loc
,
12033 Attribute_Name
=> Name_Alignment
)));
12035 -- A dereference of a controlled object requires special processing. The
12036 -- finalization machinery requests additional space from the underlying
12037 -- pool to allocate and hide two pointers. As a result, a checked pool
12038 -- may mark the wrong memory as valid. Since checked pools do not have
12039 -- knowledge of hidden pointers, we have to bring the two pointers back
12040 -- in view in order to restore the original state of the object.
12042 if Needs_Finalization
(Desig
) then
12044 -- Adjust the address and size of the dereferenced object. Generate:
12045 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
12048 Make_Procedure_Call_Statement
(Loc
,
12050 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
12051 Parameter_Associations
=> New_List
(
12052 New_Occurrence_Of
(Addr
, Loc
),
12053 New_Occurrence_Of
(Size
, Loc
),
12054 New_Occurrence_Of
(Alig
, Loc
)));
12056 -- Class-wide types complicate things because we cannot determine
12057 -- statically whether the actual object is truly controlled. We must
12058 -- generate a runtime check to detect this property. Generate:
12060 -- if Needs_Finalization (<N>.all'Tag) then
12064 if Is_Class_Wide_Type
(Desig
) then
12066 Make_Explicit_Dereference
(Loc
,
12067 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
12068 Set_Has_Dereference_Action
(Deref
);
12071 Make_Implicit_If_Statement
(N
,
12073 Make_Function_Call
(Loc
,
12075 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
12076 Parameter_Associations
=> New_List
(
12077 Make_Attribute_Reference
(Loc
,
12079 Attribute_Name
=> Name_Tag
))),
12080 Then_Statements
=> New_List
(Stmt
));
12083 Insert_Action
(N
, Stmt
);
12087 -- Dereference (Pool, Addr, Size, Alig);
12090 Make_Procedure_Call_Statement
(Loc
,
12093 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
12094 Parameter_Associations
=> New_List
(
12095 New_Occurrence_Of
(Pool
, Loc
),
12096 New_Occurrence_Of
(Addr
, Loc
),
12097 New_Occurrence_Of
(Size
, Loc
),
12098 New_Occurrence_Of
(Alig
, Loc
))));
12100 -- Mark the explicit dereference as processed to avoid potential
12101 -- infinite expansion.
12103 Set_Has_Dereference_Action
(Pnod
);
12106 when RE_Not_Available
=>
12108 end Insert_Dereference_Action
;
12110 --------------------------------
12111 -- Integer_Promotion_Possible --
12112 --------------------------------
12114 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
12115 Operand
: constant Node_Id
:= Expression
(N
);
12116 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12117 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
12120 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
12124 -- We only do the transformation for source constructs. We assume
12125 -- that the expander knows what it is doing when it generates code.
12127 Comes_From_Source
(N
)
12129 -- If the operand type is Short_Integer or Short_Short_Integer,
12130 -- then we will promote to Integer, which is available on all
12131 -- targets, and is sufficient to ensure no intermediate overflow.
12132 -- Furthermore it is likely to be as efficient or more efficient
12133 -- than using the smaller type for the computation so we do this
12134 -- unconditionally.
12137 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
12139 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
12141 -- Test for interesting operation, which includes addition,
12142 -- division, exponentiation, multiplication, subtraction, absolute
12143 -- value and unary negation. Unary "+" is omitted since it is a
12144 -- no-op and thus can't overflow.
12146 and then Nkind_In
(Operand
, N_Op_Abs
,
12153 end Integer_Promotion_Possible
;
12155 ------------------------------
12156 -- Make_Array_Comparison_Op --
12157 ------------------------------
12159 -- This is a hand-coded expansion of the following generic function:
12162 -- type elem is (<>);
12163 -- type index is (<>);
12164 -- type a is array (index range <>) of elem;
12166 -- function Gnnn (X : a; Y: a) return boolean is
12167 -- J : index := Y'first;
12170 -- if X'length = 0 then
12173 -- elsif Y'length = 0 then
12177 -- for I in X'range loop
12178 -- if X (I) = Y (J) then
12179 -- if J = Y'last then
12182 -- J := index'succ (J);
12186 -- return X (I) > Y (J);
12190 -- return X'length > Y'length;
12194 -- Note that since we are essentially doing this expansion by hand, we
12195 -- do not need to generate an actual or formal generic part, just the
12196 -- instantiated function itself.
12198 -- Perhaps we could have the actual generic available in the run-time,
12199 -- obtained by rtsfind, and actually expand a real instantiation ???
12201 function Make_Array_Comparison_Op
12203 Nod
: Node_Id
) return Node_Id
12205 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12207 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
12208 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
12209 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
12210 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12212 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
12214 Loop_Statement
: Node_Id
;
12215 Loop_Body
: Node_Id
;
12217 Inner_If
: Node_Id
;
12218 Final_Expr
: Node_Id
;
12219 Func_Body
: Node_Id
;
12220 Func_Name
: Entity_Id
;
12226 -- if J = Y'last then
12229 -- J := index'succ (J);
12233 Make_Implicit_If_Statement
(Nod
,
12236 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
12238 Make_Attribute_Reference
(Loc
,
12239 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12240 Attribute_Name
=> Name_Last
)),
12242 Then_Statements
=> New_List
(
12243 Make_Exit_Statement
(Loc
)),
12247 Make_Assignment_Statement
(Loc
,
12248 Name
=> New_Occurrence_Of
(J
, Loc
),
12250 Make_Attribute_Reference
(Loc
,
12251 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
12252 Attribute_Name
=> Name_Succ
,
12253 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
12255 -- if X (I) = Y (J) then
12258 -- return X (I) > Y (J);
12262 Make_Implicit_If_Statement
(Nod
,
12266 Make_Indexed_Component
(Loc
,
12267 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12268 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
12271 Make_Indexed_Component
(Loc
,
12272 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12273 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
12275 Then_Statements
=> New_List
(Inner_If
),
12277 Else_Statements
=> New_List
(
12278 Make_Simple_Return_Statement
(Loc
,
12282 Make_Indexed_Component
(Loc
,
12283 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12284 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
12287 Make_Indexed_Component
(Loc
,
12288 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12289 Expressions
=> New_List
(
12290 New_Occurrence_Of
(J
, Loc
)))))));
12292 -- for I in X'range loop
12297 Make_Implicit_Loop_Statement
(Nod
,
12298 Identifier
=> Empty
,
12300 Iteration_Scheme
=>
12301 Make_Iteration_Scheme
(Loc
,
12302 Loop_Parameter_Specification
=>
12303 Make_Loop_Parameter_Specification
(Loc
,
12304 Defining_Identifier
=> I
,
12305 Discrete_Subtype_Definition
=>
12306 Make_Attribute_Reference
(Loc
,
12307 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12308 Attribute_Name
=> Name_Range
))),
12310 Statements
=> New_List
(Loop_Body
));
12312 -- if X'length = 0 then
12314 -- elsif Y'length = 0 then
12317 -- for ... loop ... end loop;
12318 -- return X'length > Y'length;
12322 Make_Attribute_Reference
(Loc
,
12323 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12324 Attribute_Name
=> Name_Length
);
12327 Make_Attribute_Reference
(Loc
,
12328 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12329 Attribute_Name
=> Name_Length
);
12333 Left_Opnd
=> Length1
,
12334 Right_Opnd
=> Length2
);
12337 Make_Implicit_If_Statement
(Nod
,
12341 Make_Attribute_Reference
(Loc
,
12342 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12343 Attribute_Name
=> Name_Length
),
12345 Make_Integer_Literal
(Loc
, 0)),
12349 Make_Simple_Return_Statement
(Loc
,
12350 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
12352 Elsif_Parts
=> New_List
(
12353 Make_Elsif_Part
(Loc
,
12357 Make_Attribute_Reference
(Loc
,
12358 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12359 Attribute_Name
=> Name_Length
),
12361 Make_Integer_Literal
(Loc
, 0)),
12365 Make_Simple_Return_Statement
(Loc
,
12366 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
12368 Else_Statements
=> New_List
(
12370 Make_Simple_Return_Statement
(Loc
,
12371 Expression
=> Final_Expr
)));
12375 Formals
:= New_List
(
12376 Make_Parameter_Specification
(Loc
,
12377 Defining_Identifier
=> X
,
12378 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12380 Make_Parameter_Specification
(Loc
,
12381 Defining_Identifier
=> Y
,
12382 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12384 -- function Gnnn (...) return boolean is
12385 -- J : index := Y'first;
12390 Func_Name
:= Make_Temporary
(Loc
, 'G');
12393 Make_Subprogram_Body
(Loc
,
12395 Make_Function_Specification
(Loc
,
12396 Defining_Unit_Name
=> Func_Name
,
12397 Parameter_Specifications
=> Formals
,
12398 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
12400 Declarations
=> New_List
(
12401 Make_Object_Declaration
(Loc
,
12402 Defining_Identifier
=> J
,
12403 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
12405 Make_Attribute_Reference
(Loc
,
12406 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12407 Attribute_Name
=> Name_First
))),
12409 Handled_Statement_Sequence
=>
12410 Make_Handled_Sequence_Of_Statements
(Loc
,
12411 Statements
=> New_List
(If_Stat
)));
12414 end Make_Array_Comparison_Op
;
12416 ---------------------------
12417 -- Make_Boolean_Array_Op --
12418 ---------------------------
12420 -- For logical operations on boolean arrays, expand in line the following,
12421 -- replacing 'and' with 'or' or 'xor' where needed:
12423 -- function Annn (A : typ; B: typ) return typ is
12426 -- for J in A'range loop
12427 -- C (J) := A (J) op B (J);
12432 -- Here typ is the boolean array type
12434 function Make_Boolean_Array_Op
12436 N
: Node_Id
) return Node_Id
12438 Loc
: constant Source_Ptr
:= Sloc
(N
);
12440 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
12441 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12442 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
12443 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12451 Func_Name
: Entity_Id
;
12452 Func_Body
: Node_Id
;
12453 Loop_Statement
: Node_Id
;
12457 Make_Indexed_Component
(Loc
,
12458 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12459 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12462 Make_Indexed_Component
(Loc
,
12463 Prefix
=> New_Occurrence_Of
(B
, Loc
),
12464 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12467 Make_Indexed_Component
(Loc
,
12468 Prefix
=> New_Occurrence_Of
(C
, Loc
),
12469 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12471 if Nkind
(N
) = N_Op_And
then
12475 Right_Opnd
=> B_J
);
12477 elsif Nkind
(N
) = N_Op_Or
then
12481 Right_Opnd
=> B_J
);
12487 Right_Opnd
=> B_J
);
12491 Make_Implicit_Loop_Statement
(N
,
12492 Identifier
=> Empty
,
12494 Iteration_Scheme
=>
12495 Make_Iteration_Scheme
(Loc
,
12496 Loop_Parameter_Specification
=>
12497 Make_Loop_Parameter_Specification
(Loc
,
12498 Defining_Identifier
=> J
,
12499 Discrete_Subtype_Definition
=>
12500 Make_Attribute_Reference
(Loc
,
12501 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12502 Attribute_Name
=> Name_Range
))),
12504 Statements
=> New_List
(
12505 Make_Assignment_Statement
(Loc
,
12507 Expression
=> Op
)));
12509 Formals
:= New_List
(
12510 Make_Parameter_Specification
(Loc
,
12511 Defining_Identifier
=> A
,
12512 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12514 Make_Parameter_Specification
(Loc
,
12515 Defining_Identifier
=> B
,
12516 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12518 Func_Name
:= Make_Temporary
(Loc
, 'A');
12519 Set_Is_Inlined
(Func_Name
);
12522 Make_Subprogram_Body
(Loc
,
12524 Make_Function_Specification
(Loc
,
12525 Defining_Unit_Name
=> Func_Name
,
12526 Parameter_Specifications
=> Formals
,
12527 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
12529 Declarations
=> New_List
(
12530 Make_Object_Declaration
(Loc
,
12531 Defining_Identifier
=> C
,
12532 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
12534 Handled_Statement_Sequence
=>
12535 Make_Handled_Sequence_Of_Statements
(Loc
,
12536 Statements
=> New_List
(
12538 Make_Simple_Return_Statement
(Loc
,
12539 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
12542 end Make_Boolean_Array_Op
;
12544 -----------------------------------------
12545 -- Minimized_Eliminated_Overflow_Check --
12546 -----------------------------------------
12548 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
12551 Is_Signed_Integer_Type
(Etype
(N
))
12552 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
12553 end Minimized_Eliminated_Overflow_Check
;
12555 --------------------------------
12556 -- Optimize_Length_Comparison --
12557 --------------------------------
12559 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
12560 Loc
: constant Source_Ptr
:= Sloc
(N
);
12561 Typ
: constant Entity_Id
:= Etype
(N
);
12566 -- First and Last attribute reference nodes, which end up as left and
12567 -- right operands of the optimized result.
12570 -- True for comparison operand of zero
12573 -- Comparison operand, set only if Is_Zero is false
12576 -- Entity whose length is being compared
12579 -- Integer_Literal node for length attribute expression, or Empty
12580 -- if there is no such expression present.
12583 -- Type of array index to which 'Length is applied
12585 Op
: Node_Kind
:= Nkind
(N
);
12586 -- Kind of comparison operator, gets flipped if operands backwards
12588 function Is_Optimizable
(N
: Node_Id
) return Boolean;
12589 -- Tests N to see if it is an optimizable comparison value (defined as
12590 -- constant zero or one, or something else where the value is known to
12591 -- be positive and in the range of 32-bits, and where the corresponding
12592 -- Length value is also known to be 32-bits. If result is true, sets
12593 -- Is_Zero, Ityp, and Comp accordingly.
12595 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
12596 -- Tests if N is a length attribute applied to a simple entity. If so,
12597 -- returns True, and sets Ent to the entity, and Index to the integer
12598 -- literal provided as an attribute expression, or to Empty if none.
12599 -- Also returns True if the expression is a generated type conversion
12600 -- whose expression is of the desired form. This latter case arises
12601 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12602 -- to check for being in range, which is not needed in this context.
12603 -- Returns False if neither condition holds.
12605 function Prepare_64
(N
: Node_Id
) return Node_Id
;
12606 -- Given a discrete expression, returns a Long_Long_Integer typed
12607 -- expression representing the underlying value of the expression.
12608 -- This is done with an unchecked conversion to the result type. We
12609 -- use unchecked conversion to handle the enumeration type case.
12611 ----------------------
12612 -- Is_Entity_Length --
12613 ----------------------
12615 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
12617 if Nkind
(N
) = N_Attribute_Reference
12618 and then Attribute_Name
(N
) = Name_Length
12619 and then Is_Entity_Name
(Prefix
(N
))
12621 Ent
:= Entity
(Prefix
(N
));
12623 if Present
(Expressions
(N
)) then
12624 Index
:= First
(Expressions
(N
));
12631 elsif Nkind
(N
) = N_Type_Conversion
12632 and then not Comes_From_Source
(N
)
12634 return Is_Entity_Length
(Expression
(N
));
12639 end Is_Entity_Length
;
12641 --------------------
12642 -- Is_Optimizable --
12643 --------------------
12645 function Is_Optimizable
(N
: Node_Id
) return Boolean is
12653 if Compile_Time_Known_Value
(N
) then
12654 Val
:= Expr_Value
(N
);
12656 if Val
= Uint_0
then
12661 elsif Val
= Uint_1
then
12668 -- Here we have to make sure of being within 32-bits
12670 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12673 or else Lo
< Uint_1
12674 or else Hi
> UI_From_Int
(Int
'Last)
12679 -- Comparison value was within range, so now we must check the index
12680 -- value to make sure it is also within 32-bits.
12682 Indx
:= First_Index
(Etype
(Ent
));
12684 if Present
(Index
) then
12685 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
12690 Ityp
:= Etype
(Indx
);
12692 if Esize
(Ityp
) > 32 then
12699 end Is_Optimizable
;
12705 function Prepare_64
(N
: Node_Id
) return Node_Id
is
12707 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
12710 -- Start of processing for Optimize_Length_Comparison
12713 -- Nothing to do if not a comparison
12715 if Op
not in N_Op_Compare
then
12719 -- Nothing to do if special -gnatd.P debug flag set.
12721 if Debug_Flag_Dot_PP
then
12725 -- Ent'Length op 0/1
12727 if Is_Entity_Length
(Left_Opnd
(N
))
12728 and then Is_Optimizable
(Right_Opnd
(N
))
12732 -- 0/1 op Ent'Length
12734 elsif Is_Entity_Length
(Right_Opnd
(N
))
12735 and then Is_Optimizable
(Left_Opnd
(N
))
12737 -- Flip comparison to opposite sense
12740 when N_Op_Lt
=> Op
:= N_Op_Gt
;
12741 when N_Op_Le
=> Op
:= N_Op_Ge
;
12742 when N_Op_Gt
=> Op
:= N_Op_Lt
;
12743 when N_Op_Ge
=> Op
:= N_Op_Le
;
12744 when others => null;
12747 -- Else optimization not possible
12753 -- Fall through if we will do the optimization
12755 -- Cases to handle:
12757 -- X'Length = 0 => X'First > X'Last
12758 -- X'Length = 1 => X'First = X'Last
12759 -- X'Length = n => X'First + (n - 1) = X'Last
12761 -- X'Length /= 0 => X'First <= X'Last
12762 -- X'Length /= 1 => X'First /= X'Last
12763 -- X'Length /= n => X'First + (n - 1) /= X'Last
12765 -- X'Length >= 0 => always true, warn
12766 -- X'Length >= 1 => X'First <= X'Last
12767 -- X'Length >= n => X'First + (n - 1) <= X'Last
12769 -- X'Length > 0 => X'First <= X'Last
12770 -- X'Length > 1 => X'First < X'Last
12771 -- X'Length > n => X'First + (n - 1) < X'Last
12773 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12774 -- X'Length <= 1 => X'First >= X'Last
12775 -- X'Length <= n => X'First + (n - 1) >= X'Last
12777 -- X'Length < 0 => always false (warn)
12778 -- X'Length < 1 => X'First > X'Last
12779 -- X'Length < n => X'First + (n - 1) > X'Last
12781 -- Note: for the cases of n (not constant 0,1), we require that the
12782 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12783 -- and the same for the comparison value. Then we do the comparison
12784 -- using 64-bit arithmetic (actually long long integer), so that we
12785 -- cannot have overflow intefering with the result.
12787 -- First deal with warning cases
12796 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
12797 Analyze_And_Resolve
(N
, Typ
);
12798 Warn_On_Known_Condition
(N
);
12805 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
12806 Analyze_And_Resolve
(N
, Typ
);
12807 Warn_On_Known_Condition
(N
);
12811 if Constant_Condition_Warnings
12812 and then Comes_From_Source
(Original_Node
(N
))
12814 Error_Msg_N
("could replace by ""'=""?c?", N
);
12824 -- Build the First reference we will use
12827 Make_Attribute_Reference
(Loc
,
12828 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12829 Attribute_Name
=> Name_First
);
12831 if Present
(Index
) then
12832 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
12835 -- If general value case, then do the addition of (n - 1), and
12836 -- also add the needed conversions to type Long_Long_Integer.
12838 if Present
(Comp
) then
12841 Left_Opnd
=> Prepare_64
(Left
),
12843 Make_Op_Subtract
(Loc
,
12844 Left_Opnd
=> Prepare_64
(Comp
),
12845 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
12848 -- Build the Last reference we will use
12851 Make_Attribute_Reference
(Loc
,
12852 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12853 Attribute_Name
=> Name_Last
);
12855 if Present
(Index
) then
12856 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
12859 -- If general operand, convert Last reference to Long_Long_Integer
12861 if Present
(Comp
) then
12862 Right
:= Prepare_64
(Right
);
12865 -- Check for cases to optimize
12867 -- X'Length = 0 => X'First > X'Last
12868 -- X'Length < 1 => X'First > X'Last
12869 -- X'Length < n => X'First + (n - 1) > X'Last
12871 if (Is_Zero
and then Op
= N_Op_Eq
)
12872 or else (not Is_Zero
and then Op
= N_Op_Lt
)
12877 Right_Opnd
=> Right
);
12879 -- X'Length = 1 => X'First = X'Last
12880 -- X'Length = n => X'First + (n - 1) = X'Last
12882 elsif not Is_Zero
and then Op
= N_Op_Eq
then
12886 Right_Opnd
=> Right
);
12888 -- X'Length /= 0 => X'First <= X'Last
12889 -- X'Length > 0 => X'First <= X'Last
12891 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
12895 Right_Opnd
=> Right
);
12897 -- X'Length /= 1 => X'First /= X'Last
12898 -- X'Length /= n => X'First + (n - 1) /= X'Last
12900 elsif not Is_Zero
and then Op
= N_Op_Ne
then
12904 Right_Opnd
=> Right
);
12906 -- X'Length >= 1 => X'First <= X'Last
12907 -- X'Length >= n => X'First + (n - 1) <= X'Last
12909 elsif not Is_Zero
and then Op
= N_Op_Ge
then
12913 Right_Opnd
=> Right
);
12915 -- X'Length > 1 => X'First < X'Last
12916 -- X'Length > n => X'First + (n = 1) < X'Last
12918 elsif not Is_Zero
and then Op
= N_Op_Gt
then
12922 Right_Opnd
=> Right
);
12924 -- X'Length <= 1 => X'First >= X'Last
12925 -- X'Length <= n => X'First + (n - 1) >= X'Last
12927 elsif not Is_Zero
and then Op
= N_Op_Le
then
12931 Right_Opnd
=> Right
);
12933 -- Should not happen at this stage
12936 raise Program_Error
;
12939 -- Rewrite and finish up
12941 Rewrite
(N
, Result
);
12942 Analyze_And_Resolve
(N
, Typ
);
12944 end Optimize_Length_Comparison
;
12946 --------------------------------
12947 -- Process_If_Case_Statements --
12948 --------------------------------
12950 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
) is
12954 Decl
:= First
(Stmts
);
12955 while Present
(Decl
) loop
12956 if Nkind
(Decl
) = N_Object_Declaration
12957 and then Is_Finalizable_Transient
(Decl
, N
)
12959 Process_Transient_Object
(Decl
, N
, Stmts
);
12964 end Process_If_Case_Statements
;
12966 ------------------------------
12967 -- Process_Transient_Object --
12968 ------------------------------
12970 procedure Process_Transient_Object
12975 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
12976 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
12977 Obj_Typ
: constant Node_Id
:= Etype
(Obj_Id
);
12979 Desig_Typ
: Entity_Id
;
12981 Hook_Id
: Entity_Id
;
12982 Hook_Insert
: Node_Id
;
12983 Ptr_Id
: Entity_Id
;
12985 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(N
);
12986 -- The node on which to insert the hook as an action. This is usually
12987 -- the innermost enclosing non-transient construct.
12989 Fin_Context
: Node_Id
;
12990 -- The node after which to insert the finalization actions of the
12991 -- transient controlled object.
12994 pragma Assert
(Nkind_In
(N
, N_Case_Expression
,
12995 N_Expression_With_Actions
,
12998 -- When the context is a Boolean evaluation, all three nodes capture the
12999 -- result of their computation in a local temporary:
13002 -- Trans_Id : Ctrl_Typ := ...;
13003 -- Result : constant Boolean := ... Trans_Id ...;
13004 -- <finalize Trans_Id>
13007 -- As a result, the finalization of any transient controlled objects can
13008 -- safely take place after the result capture.
13010 -- ??? could this be extended to elementary types?
13012 if Is_Boolean_Type
(Etype
(N
)) then
13013 Fin_Context
:= Last
(Stmts
);
13015 -- Otherwise the immediate context may not be safe enough to carry out
13016 -- transient controlled object finalization due to aliasing and nesting
13017 -- of constructs. Insert calls to [Deep_]Finalize after the innermost
13018 -- enclosing non-transient construct.
13021 Fin_Context
:= Hook_Context
;
13024 -- Step 1: Create the access type which provides a reference to the
13025 -- transient controlled object.
13027 if Is_Access_Type
(Obj_Typ
) then
13028 Desig_Typ
:= Directly_Designated_Type
(Obj_Typ
);
13030 Desig_Typ
:= Obj_Typ
;
13033 Desig_Typ
:= Base_Type
(Desig_Typ
);
13036 -- Ann : access [all] <Desig_Typ>;
13038 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
13040 Insert_Action
(Hook_Context
,
13041 Make_Full_Type_Declaration
(Loc
,
13042 Defining_Identifier
=> Ptr_Id
,
13044 Make_Access_To_Object_Definition
(Loc
,
13045 All_Present
=> Ekind
(Obj_Typ
) = E_General_Access_Type
,
13046 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))));
13048 -- Step 2: Create a temporary which acts as a hook to the transient
13049 -- controlled object. Generate:
13051 -- Hook : Ptr_Id := null;
13053 Hook_Id
:= Make_Temporary
(Loc
, 'T');
13055 Insert_Action
(Hook_Context
,
13056 Make_Object_Declaration
(Loc
,
13057 Defining_Identifier
=> Hook_Id
,
13058 Object_Definition
=> New_Occurrence_Of
(Ptr_Id
, Loc
)));
13060 -- Mark the hook as created for the purposes of exporting the transient
13061 -- controlled object out of the expression_with_action or if expression.
13062 -- This signals the machinery in Build_Finalizer to treat this case in
13063 -- a special manner.
13065 Set_Status_Flag_Or_Transient_Decl
(Hook_Id
, Decl
);
13067 -- Step 3: Associate the transient object to the hook
13069 -- This must be inserted right after the object declaration, so that
13070 -- the assignment is executed if, and only if, the object is actually
13071 -- created (whereas the declaration of the hook pointer, and the
13072 -- finalization call, may be inserted at an outer level, and may
13073 -- remain unused for some executions, if the actual creation of
13074 -- the object is conditional).
13076 -- The use of unchecked conversion / unrestricted access is needed to
13077 -- avoid an accessibility violation. Note that the finalization code is
13078 -- structured in such a way that the "hook" is processed only when it
13079 -- points to an existing object.
13081 if Is_Access_Type
(Obj_Typ
) then
13083 Unchecked_Convert_To
13085 Expr
=> New_Occurrence_Of
(Obj_Id
, Loc
));
13088 Make_Attribute_Reference
(Loc
,
13089 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
13090 Attribute_Name
=> Name_Unrestricted_Access
);
13094 -- Hook := Ptr_Id (Obj_Id);
13096 -- Hook := Obj_Id'Unrestricted_Access;
13098 -- When the transient object is initialized by an aggregate, the hook
13099 -- must capture the object after the last component assignment takes
13100 -- place. Only then is the object fully initialized.
13102 if Ekind
(Obj_Id
) = E_Variable
13103 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
13105 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
13107 -- Otherwise the hook seizes the related object immediately
13110 Hook_Insert
:= Decl
;
13113 Insert_After_And_Analyze
(Hook_Insert
,
13114 Make_Assignment_Statement
(Loc
,
13115 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13116 Expression
=> Expr
));
13118 -- Step 4: Finalize the hook after the context has been evaluated or
13119 -- elaborated. Generate:
13121 -- if Hook /= null then
13122 -- [Deep_]Finalize (Hook.all);
13126 -- When the node is part of a return statement, there is no need to
13127 -- insert a finalization call, as the general finalization mechanism
13128 -- (see Build_Finalizer) would take care of the transient controlled
13129 -- object on subprogram exit. Note that it would also be impossible to
13130 -- insert the finalization code after the return statement as this will
13131 -- render it unreachable.
13133 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
13136 -- Otherwise finalize the hook
13139 Insert_Action_After
(Fin_Context
,
13140 Make_Implicit_If_Statement
(Decl
,
13143 Left_Opnd
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13144 Right_Opnd
=> Make_Null
(Loc
)),
13146 Then_Statements
=> New_List
(
13149 Make_Explicit_Dereference
(Loc
,
13150 Prefix
=> New_Occurrence_Of
(Hook_Id
, Loc
)),
13153 Make_Assignment_Statement
(Loc
,
13154 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13155 Expression
=> Make_Null
(Loc
)))));
13157 end Process_Transient_Object
;
13159 ------------------------
13160 -- Rewrite_Comparison --
13161 ------------------------
13163 procedure Rewrite_Comparison
(N
: Node_Id
) is
13164 Warning_Generated
: Boolean := False;
13165 -- Set to True if first pass with Assume_Valid generates a warning in
13166 -- which case we skip the second pass to avoid warning overloaded.
13169 -- Set to Standard_True or Standard_False
13172 if Nkind
(N
) = N_Type_Conversion
then
13173 Rewrite_Comparison
(Expression
(N
));
13176 elsif Nkind
(N
) not in N_Op_Compare
then
13180 -- Now start looking at the comparison in detail. We potentially go
13181 -- through this loop twice. The first time, Assume_Valid is set False
13182 -- in the call to Compile_Time_Compare. If this call results in a
13183 -- clear result of always True or Always False, that's decisive and
13184 -- we are done. Otherwise we repeat the processing with Assume_Valid
13185 -- set to True to generate additional warnings. We can skip that step
13186 -- if Constant_Condition_Warnings is False.
13188 for AV
in False .. True loop
13190 Typ
: constant Entity_Id
:= Etype
(N
);
13191 Op1
: constant Node_Id
:= Left_Opnd
(N
);
13192 Op2
: constant Node_Id
:= Right_Opnd
(N
);
13194 Res
: constant Compare_Result
:=
13195 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
13196 -- Res indicates if compare outcome can be compile time determined
13198 True_Result
: Boolean;
13199 False_Result
: Boolean;
13202 case N_Op_Compare
(Nkind
(N
)) is
13204 True_Result
:= Res
= EQ
;
13205 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
13208 True_Result
:= Res
in Compare_GE
;
13209 False_Result
:= Res
= LT
;
13212 and then Constant_Condition_Warnings
13213 and then Comes_From_Source
(Original_Node
(N
))
13214 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
13215 and then not In_Instance
13216 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
13217 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
13220 ("can never be greater than, could replace by ""'=""?c?",
13222 Warning_Generated
:= True;
13226 True_Result
:= Res
= GT
;
13227 False_Result
:= Res
in Compare_LE
;
13230 True_Result
:= Res
= LT
;
13231 False_Result
:= Res
in Compare_GE
;
13234 True_Result
:= Res
in Compare_LE
;
13235 False_Result
:= Res
= GT
;
13238 and then Constant_Condition_Warnings
13239 and then Comes_From_Source
(Original_Node
(N
))
13240 and then Nkind
(Original_Node
(N
)) = N_Op_Le
13241 and then not In_Instance
13242 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
13243 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
13246 ("can never be less than, could replace by ""'=""?c?", N
);
13247 Warning_Generated
:= True;
13251 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
13252 False_Result
:= Res
= EQ
;
13255 -- If this is the first iteration, then we actually convert the
13256 -- comparison into True or False, if the result is certain.
13259 if True_Result
or False_Result
then
13260 Result
:= Boolean_Literals
(True_Result
);
13263 New_Occurrence_Of
(Result
, Sloc
(N
))));
13264 Analyze_And_Resolve
(N
, Typ
);
13265 Warn_On_Known_Condition
(N
);
13269 -- If this is the second iteration (AV = True), and the original
13270 -- node comes from source and we are not in an instance, then give
13271 -- a warning if we know result would be True or False. Note: we
13272 -- know Constant_Condition_Warnings is set if we get here.
13274 elsif Comes_From_Source
(Original_Node
(N
))
13275 and then not In_Instance
13277 if True_Result
then
13279 ("condition can only be False if invalid values present??",
13281 elsif False_Result
then
13283 ("condition can only be True if invalid values present??",
13289 -- Skip second iteration if not warning on constant conditions or
13290 -- if the first iteration already generated a warning of some kind or
13291 -- if we are in any case assuming all values are valid (so that the
13292 -- first iteration took care of the valid case).
13294 exit when not Constant_Condition_Warnings
;
13295 exit when Warning_Generated
;
13296 exit when Assume_No_Invalid_Values
;
13298 end Rewrite_Comparison
;
13300 ----------------------------
13301 -- Safe_In_Place_Array_Op --
13302 ----------------------------
13304 function Safe_In_Place_Array_Op
13307 Op2
: Node_Id
) return Boolean
13309 Target
: Entity_Id
;
13311 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
13312 -- Operand is safe if it cannot overlap part of the target of the
13313 -- operation. If the operand and the target are identical, the operand
13314 -- is safe. The operand can be empty in the case of negation.
13316 function Is_Unaliased
(N
: Node_Id
) return Boolean;
13317 -- Check that N is a stand-alone entity
13323 function Is_Unaliased
(N
: Node_Id
) return Boolean is
13327 and then No
(Address_Clause
(Entity
(N
)))
13328 and then No
(Renamed_Object
(Entity
(N
)));
13331 ---------------------
13332 -- Is_Safe_Operand --
13333 ---------------------
13335 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
13340 elsif Is_Entity_Name
(Op
) then
13341 return Is_Unaliased
(Op
);
13343 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
13344 return Is_Unaliased
(Prefix
(Op
));
13346 elsif Nkind
(Op
) = N_Slice
then
13348 Is_Unaliased
(Prefix
(Op
))
13349 and then Entity
(Prefix
(Op
)) /= Target
;
13351 elsif Nkind
(Op
) = N_Op_Not
then
13352 return Is_Safe_Operand
(Right_Opnd
(Op
));
13357 end Is_Safe_Operand
;
13359 -- Start of processing for Safe_In_Place_Array_Op
13362 -- Skip this processing if the component size is different from system
13363 -- storage unit (since at least for NOT this would cause problems).
13365 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
13368 -- Cannot do in place stuff if non-standard Boolean representation
13370 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
13373 elsif not Is_Unaliased
(Lhs
) then
13377 Target
:= Entity
(Lhs
);
13378 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
13380 end Safe_In_Place_Array_Op
;
13382 -----------------------
13383 -- Tagged_Membership --
13384 -----------------------
13386 -- There are two different cases to consider depending on whether the right
13387 -- operand is a class-wide type or not. If not we just compare the actual
13388 -- tag of the left expr to the target type tag:
13390 -- Left_Expr.Tag = Right_Type'Tag;
13392 -- If it is a class-wide type we use the RT function CW_Membership which is
13393 -- usually implemented by looking in the ancestor tables contained in the
13394 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13396 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13397 -- function IW_Membership which is usually implemented by looking in the
13398 -- table of abstract interface types plus the ancestor table contained in
13399 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13401 procedure Tagged_Membership
13403 SCIL_Node
: out Node_Id
;
13404 Result
: out Node_Id
)
13406 Left
: constant Node_Id
:= Left_Opnd
(N
);
13407 Right
: constant Node_Id
:= Right_Opnd
(N
);
13408 Loc
: constant Source_Ptr
:= Sloc
(N
);
13410 Full_R_Typ
: Entity_Id
;
13411 Left_Type
: Entity_Id
;
13412 New_Node
: Node_Id
;
13413 Right_Type
: Entity_Id
;
13417 SCIL_Node
:= Empty
;
13419 -- Handle entities from the limited view
13421 Left_Type
:= Available_View
(Etype
(Left
));
13422 Right_Type
:= Available_View
(Etype
(Right
));
13424 -- In the case where the type is an access type, the test is applied
13425 -- using the designated types (needed in Ada 2012 for implicit anonymous
13426 -- access conversions, for AI05-0149).
13428 if Is_Access_Type
(Right_Type
) then
13429 Left_Type
:= Designated_Type
(Left_Type
);
13430 Right_Type
:= Designated_Type
(Right_Type
);
13433 if Is_Class_Wide_Type
(Left_Type
) then
13434 Left_Type
:= Root_Type
(Left_Type
);
13437 if Is_Class_Wide_Type
(Right_Type
) then
13438 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
13440 Full_R_Typ
:= Underlying_Type
(Right_Type
);
13444 Make_Selected_Component
(Loc
,
13445 Prefix
=> Relocate_Node
(Left
),
13447 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
13449 if Is_Class_Wide_Type
(Right_Type
) then
13451 -- No need to issue a run-time check if we statically know that the
13452 -- result of this membership test is always true. For example,
13453 -- considering the following declarations:
13455 -- type Iface is interface;
13456 -- type T is tagged null record;
13457 -- type DT is new T and Iface with null record;
13462 -- These membership tests are always true:
13465 -- Obj2 in T'Class;
13466 -- Obj2 in Iface'Class;
13468 -- We do not need to handle cases where the membership is illegal.
13471 -- Obj1 in DT'Class; -- Compile time error
13472 -- Obj1 in Iface'Class; -- Compile time error
13474 if not Is_Class_Wide_Type
(Left_Type
)
13475 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
13476 Use_Full_View
=> True)
13477 or else (Is_Interface
(Etype
(Right_Type
))
13478 and then Interface_Present_In_Ancestor
13480 Iface
=> Etype
(Right_Type
))))
13482 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
13486 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13488 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
13490 -- Support to: "Iface_CW_Typ in Typ'Class"
13492 or else Is_Interface
(Left_Type
)
13494 -- Issue error if IW_Membership operation not available in a
13495 -- configurable run time setting.
13497 if not RTE_Available
(RE_IW_Membership
) then
13499 ("dynamic membership test on interface types", N
);
13505 Make_Function_Call
(Loc
,
13506 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
13507 Parameter_Associations
=> New_List
(
13508 Make_Attribute_Reference
(Loc
,
13510 Attribute_Name
=> Name_Address
),
13511 New_Occurrence_Of
(
13512 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
13515 -- Ada 95: Normal case
13518 Build_CW_Membership
(Loc
,
13519 Obj_Tag_Node
=> Obj_Tag
,
13521 New_Occurrence_Of
(
13522 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
13524 New_Node
=> New_Node
);
13526 -- Generate the SCIL node for this class-wide membership test.
13527 -- Done here because the previous call to Build_CW_Membership
13528 -- relocates Obj_Tag.
13530 if Generate_SCIL
then
13531 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
13532 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
13533 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
13536 Result
:= New_Node
;
13539 -- Right_Type is not a class-wide type
13542 -- No need to check the tag of the object if Right_Typ is abstract
13544 if Is_Abstract_Type
(Right_Type
) then
13545 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
13550 Left_Opnd
=> Obj_Tag
,
13553 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
13556 end Tagged_Membership
;
13558 ------------------------------
13559 -- Unary_Op_Validity_Checks --
13560 ------------------------------
13562 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
13564 if Validity_Checks_On
and Validity_Check_Operands
then
13565 Ensure_Valid
(Right_Opnd
(N
));
13567 end Unary_Op_Validity_Checks
;