1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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
;
75 with Warnsw
; use Warnsw
;
77 package body Exp_Ch4
is
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
84 pragma Inline
(Binary_Op_Validity_Checks
);
85 -- Performs validity checks for a binary operator
87 procedure Build_Boolean_Array_Proc_Call
91 -- If a boolean array assignment can be done in place, build call to
92 -- corresponding library procedure.
94 procedure Displace_Allocator_Pointer
(N
: Node_Id
);
95 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
96 -- Expand_Allocator_Expression. Allocating class-wide interface objects
97 -- this routine displaces the pointer to the allocated object to reference
98 -- the component referencing the corresponding secondary dispatch table.
100 procedure Expand_Allocator_Expression
(N
: Node_Id
);
101 -- Subsidiary to Expand_N_Allocator, for the case when the expression
102 -- is a qualified expression or an aggregate.
104 procedure Expand_Array_Comparison
(N
: Node_Id
);
105 -- This routine handles expansion of the comparison operators (N_Op_Lt,
106 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
107 -- code for these operators is similar, differing only in the details of
108 -- the actual comparison call that is made. Special processing (call a
111 function Expand_Array_Equality
116 Typ
: Entity_Id
) return Node_Id
;
117 -- Expand an array equality into a call to a function implementing this
118 -- equality, and a call to it. Loc is the location for the generated nodes.
119 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
120 -- on which to attach bodies of local functions that are created in the
121 -- process. It is the responsibility of the caller to insert those bodies
122 -- at the right place. Nod provides the Sloc value for the generated code.
123 -- Normally the types used for the generated equality routine are taken
124 -- from Lhs and Rhs. However, in some situations of generated code, the
125 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
126 -- the type to be used for the formal parameters.
128 procedure Expand_Boolean_Operator
(N
: Node_Id
);
129 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
130 -- case of array type arguments.
132 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
);
133 -- When generating C code, convert nonbinary modular arithmetic operations
134 -- into code that relies on the front-end expansion of operator Mod. No
135 -- expansion is performed if N is not a nonbinary modular operand.
137 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
);
138 -- Common expansion processing for short-circuit boolean operators
140 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
);
141 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
142 -- where we allow comparison of "out of range" values.
144 function Expand_Composite_Equality
149 Bodies
: List_Id
) return Node_Id
;
150 -- Local recursive function used to expand equality for nested composite
151 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
152 -- to attach bodies of local functions that are created in the process. It
153 -- is the responsibility of the caller to insert those bodies at the right
154 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
155 -- the left and right sides for the comparison, and Typ is the type of the
156 -- objects to compare.
158 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
159 -- Routine to expand concatenation of a sequence of two or more operands
160 -- (in the list Operands) and replace node Cnode with the result of the
161 -- concatenation. The operands can be of any appropriate type, and can
162 -- include both arrays and singleton elements.
164 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
);
165 -- N is an N_In membership test mode, with the overflow check mode set to
166 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
167 -- integer type. This is a case where top level processing is required to
168 -- handle overflow checks in subtrees.
170 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
171 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
172 -- fixed. We do not have such a type at runtime, so the purpose of this
173 -- routine is to find the real type by looking up the tree. We also
174 -- determine if the operation must be rounded.
176 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
177 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
178 -- discriminants if it has a constrained nominal type, unless the object
179 -- is a component of an enclosing Unchecked_Union object that is subject
180 -- to a per-object constraint and the enclosing object lacks inferable
183 -- An expression of an Unchecked_Union type has inferable discriminants
184 -- if it is either a name of an object with inferable discriminants or a
185 -- qualified expression whose subtype mark denotes a constrained subtype.
187 procedure Insert_Dereference_Action
(N
: Node_Id
);
188 -- N is an expression whose type is an access. When the type of the
189 -- associated storage pool is derived from Checked_Pool, generate a
190 -- call to the 'Dereference' primitive operation.
192 function Make_Array_Comparison_Op
194 Nod
: Node_Id
) return Node_Id
;
195 -- Comparisons between arrays are expanded in line. This function produces
196 -- the body of the implementation of (a > b), where a and b are one-
197 -- dimensional arrays of some discrete type. The original node is then
198 -- expanded into the appropriate call to this function. Nod provides the
199 -- Sloc value for the generated code.
201 function Make_Boolean_Array_Op
203 N
: Node_Id
) return Node_Id
;
204 -- Boolean operations on boolean arrays are expanded in line. This function
205 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
206 -- b). It is used only the normal case and not the packed case. The type
207 -- involved, Typ, is the Boolean array type, and the logical operations in
208 -- the body are simple boolean operations. Note that Typ is always a
209 -- constrained type (the caller has ensured this by using
210 -- Convert_To_Actual_Subtype if necessary).
212 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean;
213 -- For signed arithmetic operations when the current overflow mode is
214 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
215 -- as the first thing we do. We then return. We count on the recursive
216 -- apparatus for overflow checks to call us back with an equivalent
217 -- operation that is in CHECKED mode, avoiding a recursive entry into this
218 -- routine, and that is when we will proceed with the expansion of the
219 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
220 -- these optimizations without first making this check, since there may be
221 -- operands further down the tree that are relying on the recursive calls
222 -- triggered by the top level nodes to properly process overflow checking
223 -- and remaining expansion on these nodes. Note that this call back may be
224 -- skipped if the operation is done in Bignum mode but that's fine, since
225 -- the Bignum call takes care of everything.
227 procedure Optimize_Length_Comparison
(N
: Node_Id
);
228 -- Given an expression, if it is of the form X'Length op N (or the other
229 -- way round), where N is known at compile time to be 0 or 1, and X is a
230 -- simple entity, and op is a comparison operator, optimizes it into a
231 -- comparison of First and Last.
233 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
);
234 -- Inspect and process statement list Stmt of if or case expression N for
235 -- transient objects. If such objects are found, the routine generates code
236 -- to clean them up when the context of the expression is evaluated.
238 procedure Process_Transient_In_Expression
242 -- Subsidiary routine to the expansion of expression_with_actions, if and
243 -- case expressions. Generate all necessary code to finalize a transient
244 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
245 -- denotes the declaration of the transient object, which is usually the
246 -- result of a controlled function call. Expr denotes the expression with
247 -- actions, if expression, or case expression node. Stmts denotes the
248 -- statement list which contains Decl, either at the top level or within a
251 procedure Rewrite_Comparison
(N
: Node_Id
);
252 -- If N is the node for a comparison whose outcome can be determined at
253 -- compile time, then the node N can be rewritten with True or False. If
254 -- the outcome cannot be determined at compile time, the call has no
255 -- effect. If N is a type conversion, then this processing is applied to
256 -- its expression. If N is neither comparison nor a type conversion, the
257 -- call has no effect.
259 procedure Tagged_Membership
261 SCIL_Node
: out Node_Id
;
262 Result
: out Node_Id
);
263 -- Construct the expression corresponding to the tagged membership test.
264 -- Deals with a second operand being (or not) a class-wide type.
266 function Safe_In_Place_Array_Op
269 Op2
: Node_Id
) return Boolean;
270 -- In the context of an assignment, where the right-hand side is a boolean
271 -- operation on arrays, check whether operation can be performed in place.
273 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
274 pragma Inline
(Unary_Op_Validity_Checks
);
275 -- Performs validity checks for a unary operator
277 -------------------------------
278 -- Binary_Op_Validity_Checks --
279 -------------------------------
281 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
283 if Validity_Checks_On
and Validity_Check_Operands
then
284 Ensure_Valid
(Left_Opnd
(N
));
285 Ensure_Valid
(Right_Opnd
(N
));
287 end Binary_Op_Validity_Checks
;
289 ------------------------------------
290 -- Build_Boolean_Array_Proc_Call --
291 ------------------------------------
293 procedure Build_Boolean_Array_Proc_Call
298 Loc
: constant Source_Ptr
:= Sloc
(N
);
299 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
300 Target
: constant Node_Id
:=
301 Make_Attribute_Reference
(Loc
,
303 Attribute_Name
=> Name_Address
);
305 Arg1
: Node_Id
:= Op1
;
306 Arg2
: Node_Id
:= Op2
;
308 Proc_Name
: Entity_Id
;
311 if Kind
= N_Op_Not
then
312 if Nkind
(Op1
) in N_Binary_Op
then
314 -- Use negated version of the binary operators
316 if Nkind
(Op1
) = N_Op_And
then
317 Proc_Name
:= RTE
(RE_Vector_Nand
);
319 elsif Nkind
(Op1
) = N_Op_Or
then
320 Proc_Name
:= RTE
(RE_Vector_Nor
);
322 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
323 Proc_Name
:= RTE
(RE_Vector_Xor
);
327 Make_Procedure_Call_Statement
(Loc
,
328 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
330 Parameter_Associations
=> New_List
(
332 Make_Attribute_Reference
(Loc
,
333 Prefix
=> Left_Opnd
(Op1
),
334 Attribute_Name
=> Name_Address
),
336 Make_Attribute_Reference
(Loc
,
337 Prefix
=> Right_Opnd
(Op1
),
338 Attribute_Name
=> Name_Address
),
340 Make_Attribute_Reference
(Loc
,
341 Prefix
=> Left_Opnd
(Op1
),
342 Attribute_Name
=> Name_Length
)));
345 Proc_Name
:= RTE
(RE_Vector_Not
);
348 Make_Procedure_Call_Statement
(Loc
,
349 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
350 Parameter_Associations
=> New_List
(
353 Make_Attribute_Reference
(Loc
,
355 Attribute_Name
=> Name_Address
),
357 Make_Attribute_Reference
(Loc
,
359 Attribute_Name
=> Name_Length
)));
363 -- We use the following equivalences:
365 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
366 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
367 -- (not X) xor (not Y) = X xor Y
368 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
370 if Nkind
(Op1
) = N_Op_Not
then
371 Arg1
:= Right_Opnd
(Op1
);
372 Arg2
:= Right_Opnd
(Op2
);
374 if Kind
= N_Op_And
then
375 Proc_Name
:= RTE
(RE_Vector_Nor
);
376 elsif Kind
= N_Op_Or
then
377 Proc_Name
:= RTE
(RE_Vector_Nand
);
379 Proc_Name
:= RTE
(RE_Vector_Xor
);
383 if Kind
= N_Op_And
then
384 Proc_Name
:= RTE
(RE_Vector_And
);
385 elsif Kind
= N_Op_Or
then
386 Proc_Name
:= RTE
(RE_Vector_Or
);
387 elsif Nkind
(Op2
) = N_Op_Not
then
388 Proc_Name
:= RTE
(RE_Vector_Nxor
);
389 Arg2
:= Right_Opnd
(Op2
);
391 Proc_Name
:= RTE
(RE_Vector_Xor
);
396 Make_Procedure_Call_Statement
(Loc
,
397 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
398 Parameter_Associations
=> New_List
(
400 Make_Attribute_Reference
(Loc
,
402 Attribute_Name
=> Name_Address
),
403 Make_Attribute_Reference
(Loc
,
405 Attribute_Name
=> Name_Address
),
406 Make_Attribute_Reference
(Loc
,
408 Attribute_Name
=> Name_Length
)));
411 Rewrite
(N
, Call_Node
);
415 when RE_Not_Available
=>
417 end Build_Boolean_Array_Proc_Call
;
419 -----------------------
421 -----------------------
423 function Build_Eq_Call
427 Rhs
: Node_Id
) return Node_Id
433 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
434 while Present
(Prim_E
) loop
435 Prim
:= Node
(Prim_E
);
437 -- Locate primitive equality with the right signature
439 if Chars
(Prim
) = Name_Op_Eq
440 and then Etype
(First_Formal
(Prim
)) =
441 Etype
(Next_Formal
(First_Formal
(Prim
)))
442 and then Etype
(Prim
) = Standard_Boolean
444 if Is_Abstract_Subprogram
(Prim
) then
446 Make_Raise_Program_Error
(Loc
,
447 Reason
=> PE_Explicit_Raise
);
451 Make_Function_Call
(Loc
,
452 Name
=> New_Occurrence_Of
(Prim
, Loc
),
453 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
460 -- If not found, predefined operation will be used
465 --------------------------------
466 -- Displace_Allocator_Pointer --
467 --------------------------------
469 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
470 Loc
: constant Source_Ptr
:= Sloc
(N
);
471 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
477 -- Do nothing in case of VM targets: the virtual machine will handle
478 -- interfaces directly.
480 if not Tagged_Type_Expansion
then
484 pragma Assert
(Nkind
(N
) = N_Identifier
485 and then Nkind
(Orig_Node
) = N_Allocator
);
487 PtrT
:= Etype
(Orig_Node
);
488 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
489 Etyp
:= Etype
(Expression
(Orig_Node
));
491 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
493 -- If the type of the allocator expression is not an interface type
494 -- we can generate code to reference the record component containing
495 -- the pointer to the secondary dispatch table.
497 if not Is_Interface
(Etyp
) then
499 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
502 -- 1) Get access to the allocated object
505 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
509 -- 2) Add the conversion to displace the pointer to reference
510 -- the secondary dispatch table.
512 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
513 Analyze_And_Resolve
(N
, Dtyp
);
515 -- 3) The 'access to the secondary dispatch table will be used
516 -- as the value returned by the allocator.
519 Make_Attribute_Reference
(Loc
,
520 Prefix
=> Relocate_Node
(N
),
521 Attribute_Name
=> Name_Access
));
522 Set_Etype
(N
, Saved_Typ
);
526 -- If the type of the allocator expression is an interface type we
527 -- generate a run-time call to displace "this" to reference the
528 -- component containing the pointer to the secondary dispatch table
529 -- or else raise Constraint_Error if the actual object does not
530 -- implement the target interface. This case corresponds to the
531 -- following example:
533 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
535 -- return new Iface_2'Class'(Obj);
540 Unchecked_Convert_To
(PtrT
,
541 Make_Function_Call
(Loc
,
542 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
543 Parameter_Associations
=> New_List
(
544 Unchecked_Convert_To
(RTE
(RE_Address
),
550 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
552 Analyze_And_Resolve
(N
, PtrT
);
555 end Displace_Allocator_Pointer
;
557 ---------------------------------
558 -- Expand_Allocator_Expression --
559 ---------------------------------
561 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
562 Loc
: constant Source_Ptr
:= Sloc
(N
);
563 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
564 PtrT
: constant Entity_Id
:= Etype
(N
);
565 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
567 procedure Apply_Accessibility_Check
569 Built_In_Place
: Boolean := False);
570 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
571 -- type, generate an accessibility check to verify that the level of the
572 -- type of the created object is not deeper than the level of the access
573 -- type. If the type of the qualified expression is class-wide, then
574 -- always generate the check (except in the case where it is known to be
575 -- unnecessary, see comment below). Otherwise, only generate the check
576 -- if the level of the qualified expression type is statically deeper
577 -- than the access type.
579 -- Although the static accessibility will generally have been performed
580 -- as a legality check, it won't have been done in cases where the
581 -- allocator appears in generic body, so a run-time check is needed in
582 -- general. One special case is when the access type is declared in the
583 -- same scope as the class-wide allocator, in which case the check can
584 -- never fail, so it need not be generated.
586 -- As an open issue, there seem to be cases where the static level
587 -- associated with the class-wide object's underlying type is not
588 -- sufficient to perform the proper accessibility check, such as for
589 -- allocators in nested subprograms or accept statements initialized by
590 -- class-wide formals when the actual originates outside at a deeper
591 -- static level. The nested subprogram case might require passing
592 -- accessibility levels along with class-wide parameters, and the task
593 -- case seems to be an actual gap in the language rules that needs to
594 -- be fixed by the ARG. ???
596 -------------------------------
597 -- Apply_Accessibility_Check --
598 -------------------------------
600 procedure Apply_Accessibility_Check
602 Built_In_Place
: Boolean := False)
604 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
612 if Ada_Version
>= Ada_2005
613 and then Is_Class_Wide_Type
(DesigT
)
614 and then Tagged_Type_Expansion
615 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
617 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
619 (Is_Class_Wide_Type
(Etype
(Exp
))
620 and then Scope
(PtrT
) /= Current_Scope
))
622 -- If the allocator was built in place, Ref is already a reference
623 -- to the access object initialized to the result of the allocator
624 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
625 -- Remove_Side_Effects for cases where the build-in-place call may
626 -- still be the prefix of the reference (to avoid generating
627 -- duplicate calls). Otherwise, it is the entity associated with
628 -- the object containing the address of the allocated object.
630 if Built_In_Place
then
631 Remove_Side_Effects
(Ref
);
632 Obj_Ref
:= New_Copy_Tree
(Ref
);
634 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
637 -- For access to interface types we must generate code to displace
638 -- the pointer to the base of the object since the subsequent code
639 -- references components located in the TSD of the object (which
640 -- is associated with the primary dispatch table --see a-tags.ads)
641 -- and also generates code invoking Free, which requires also a
642 -- reference to the base of the unallocated object.
644 if Is_Interface
(DesigT
) and then Tagged_Type_Expansion
then
646 Unchecked_Convert_To
(Etype
(Obj_Ref
),
647 Make_Function_Call
(Loc
,
649 New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
650 Parameter_Associations
=> New_List
(
651 Unchecked_Convert_To
(RTE
(RE_Address
),
652 New_Copy_Tree
(Obj_Ref
)))));
655 -- Step 1: Create the object clean up code
659 -- Deallocate the object if the accessibility check fails. This
660 -- is done only on targets or profiles that support deallocation.
664 if RTE_Available
(RE_Free
) then
665 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
666 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
668 Append_To
(Stmts
, Free_Stmt
);
670 -- The target or profile cannot deallocate objects
676 -- Finalize the object if applicable. Generate:
678 -- [Deep_]Finalize (Obj_Ref.all);
680 if Needs_Finalization
(DesigT
)
681 and then not No_Heap_Finalization
(PtrT
)
686 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
689 -- Guard against a missing [Deep_]Finalize when the designated
690 -- type was not properly frozen.
692 if No
(Fin_Call
) then
693 Fin_Call
:= Make_Null_Statement
(Loc
);
696 -- When the target or profile supports deallocation, wrap the
697 -- finalization call in a block to ensure proper deallocation
698 -- even if finalization fails. Generate:
708 if Present
(Free_Stmt
) then
710 Make_Block_Statement
(Loc
,
711 Handled_Statement_Sequence
=>
712 Make_Handled_Sequence_Of_Statements
(Loc
,
713 Statements
=> New_List
(Fin_Call
),
715 Exception_Handlers
=> New_List
(
716 Make_Exception_Handler
(Loc
,
717 Exception_Choices
=> New_List
(
718 Make_Others_Choice
(Loc
)),
719 Statements
=> New_List
(
720 New_Copy_Tree
(Free_Stmt
),
721 Make_Raise_Statement
(Loc
))))));
724 Prepend_To
(Stmts
, Fin_Call
);
727 -- Signal the accessibility failure through a Program_Error
730 Make_Raise_Program_Error
(Loc
,
731 Condition
=> New_Occurrence_Of
(Standard_True
, Loc
),
732 Reason
=> PE_Accessibility_Check_Failed
));
734 -- Step 2: Create the accessibility comparison
740 Make_Attribute_Reference
(Loc
,
742 Attribute_Name
=> Name_Tag
);
744 -- For tagged types, determine the accessibility level by looking
745 -- at the type specific data of the dispatch table. Generate:
747 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
749 if Tagged_Type_Expansion
then
750 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
752 -- Use a runtime call to determine the accessibility level when
753 -- compiling on virtual machine targets. Generate:
755 -- Get_Access_Level (Ref'Tag)
759 Make_Function_Call
(Loc
,
761 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
762 Parameter_Associations
=> New_List
(Obj_Ref
));
769 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
771 -- Due to the complexity and side effects of the check, utilize an
772 -- if statement instead of the regular Program_Error circuitry.
775 Make_Implicit_If_Statement
(N
,
777 Then_Statements
=> Stmts
));
779 end Apply_Accessibility_Check
;
783 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
784 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
785 T
: constant Entity_Id
:= Entity
(Indic
);
788 Tag_Assign
: Node_Id
;
792 TagT
: Entity_Id
:= Empty
;
793 -- Type used as source for tag assignment
795 TagR
: Node_Id
:= Empty
;
796 -- Target reference for tag assignment
798 -- Start of processing for Expand_Allocator_Expression
801 -- Handle call to C++ constructor
803 if Is_CPP_Constructor_Call
(Exp
) then
804 Make_CPP_Constructor_Call_In_Allocator
806 Function_Call
=> Exp
);
810 -- In the case of an Ada 2012 allocator whose initial value comes from a
811 -- function call, pass "the accessibility level determined by the point
812 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
813 -- Expand_Call but it couldn't be done there (because the Etype of the
814 -- allocator wasn't set then) so we generate the parameter here. See
815 -- the Boolean variable Defer in (a block within) Expand_Call.
817 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
822 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
823 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
825 Subp
:= Entity
(Name
(Exp
));
828 Subp
:= Ultimate_Alias
(Subp
);
830 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
831 Add_Extra_Actual_To_Call
832 (Subprogram_Call
=> Exp
,
833 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
834 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
839 -- Case of tagged type or type requiring finalization
841 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
843 -- Ada 2005 (AI-318-02): If the initialization expression is a call
844 -- to a build-in-place function, then access to the allocated object
845 -- must be passed to the function.
847 if Is_Build_In_Place_Function_Call
(Exp
) then
848 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
849 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
852 -- Ada 2005 (AI-318-02): Specialization of the previous case for
853 -- expressions containing a build-in-place function call whose
854 -- returned object covers interface types, and Expr has calls to
855 -- Ada.Tags.Displace to displace the pointer to the returned build-
856 -- in-place object to reference the secondary dispatch table of a
857 -- covered interface type.
859 elsif Present
(Unqual_BIP_Iface_Function_Call
(Exp
)) then
860 Make_Build_In_Place_Iface_Call_In_Allocator
(N
, Exp
);
861 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
865 -- Actions inserted before:
866 -- Temp : constant ptr_T := new T'(Expression);
867 -- Temp._tag = T'tag; -- when not class-wide
868 -- [Deep_]Adjust (Temp.all);
870 -- We analyze by hand the new internal allocator to avoid any
871 -- recursion and inappropriate call to Initialize.
873 -- We don't want to remove side effects when the expression must be
874 -- built in place. In the case of a build-in-place function call,
875 -- that could lead to a duplication of the call, which was already
876 -- substituted for the allocator.
878 if not Aggr_In_Place
then
879 Remove_Side_Effects
(Exp
);
882 Temp
:= Make_Temporary
(Loc
, 'P', N
);
884 -- For a class wide allocation generate the following code:
886 -- type Equiv_Record is record ... end record;
887 -- implicit subtype CW is <Class_Wide_Subytpe>;
888 -- temp : PtrT := new CW'(CW!(expr));
890 if Is_Class_Wide_Type
(T
) then
891 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
893 -- Ada 2005 (AI-251): If the expression is a class-wide interface
894 -- object we generate code to move up "this" to reference the
895 -- base of the object before allocating the new object.
897 -- Note that Exp'Address is recursively expanded into a call
898 -- to Base_Address (Exp.Tag)
900 if Is_Class_Wide_Type
(Etype
(Exp
))
901 and then Is_Interface
(Etype
(Exp
))
902 and then Tagged_Type_Expansion
906 Unchecked_Convert_To
(Entity
(Indic
),
907 Make_Explicit_Dereference
(Loc
,
908 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
909 Make_Attribute_Reference
(Loc
,
911 Attribute_Name
=> Name_Address
)))));
915 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
918 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
921 -- Processing for allocators returning non-interface types
923 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
924 if Aggr_In_Place
then
926 Make_Object_Declaration
(Loc
,
927 Defining_Identifier
=> Temp
,
928 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
932 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
934 -- Copy the Comes_From_Source flag for the allocator we just
935 -- built, since logically this allocator is a replacement of
936 -- the original allocator node. This is for proper handling of
937 -- restriction No_Implicit_Heap_Allocations.
939 Set_Comes_From_Source
940 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
942 Set_No_Initialization
(Expression
(Temp_Decl
));
943 Insert_Action
(N
, Temp_Decl
);
945 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
946 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
949 Node
:= Relocate_Node
(N
);
953 Make_Object_Declaration
(Loc
,
954 Defining_Identifier
=> Temp
,
955 Constant_Present
=> True,
956 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
959 Insert_Action
(N
, Temp_Decl
);
960 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
963 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
964 -- interface type. In this case we use the type of the qualified
965 -- expression to allocate the object.
969 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
974 Make_Full_Type_Declaration
(Loc
,
975 Defining_Identifier
=> Def_Id
,
977 Make_Access_To_Object_Definition
(Loc
,
979 Null_Exclusion_Present
=> False,
981 Is_Access_Constant
(Etype
(N
)),
982 Subtype_Indication
=>
983 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
985 Insert_Action
(N
, New_Decl
);
987 -- Inherit the allocation-related attributes from the original
990 Set_Finalization_Master
991 (Def_Id
, Finalization_Master
(PtrT
));
993 Set_Associated_Storage_Pool
994 (Def_Id
, Associated_Storage_Pool
(PtrT
));
996 -- Declare the object using the previous type declaration
998 if Aggr_In_Place
then
1000 Make_Object_Declaration
(Loc
,
1001 Defining_Identifier
=> Temp
,
1002 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1004 Make_Allocator
(Loc
,
1005 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1007 -- Copy the Comes_From_Source flag for the allocator we just
1008 -- built, since logically this allocator is a replacement of
1009 -- the original allocator node. This is for proper handling
1010 -- of restriction No_Implicit_Heap_Allocations.
1012 Set_Comes_From_Source
1013 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1015 Set_No_Initialization
(Expression
(Temp_Decl
));
1016 Insert_Action
(N
, Temp_Decl
);
1018 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1019 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1022 Node
:= Relocate_Node
(N
);
1023 Set_Analyzed
(Node
);
1026 Make_Object_Declaration
(Loc
,
1027 Defining_Identifier
=> Temp
,
1028 Constant_Present
=> True,
1029 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1030 Expression
=> Node
);
1032 Insert_Action
(N
, Temp_Decl
);
1033 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1036 -- Generate an additional object containing the address of the
1037 -- returned object. The type of this second object declaration
1038 -- is the correct type required for the common processing that
1039 -- is still performed by this subprogram. The displacement of
1040 -- this pointer to reference the component associated with the
1041 -- interface type will be done at the end of common processing.
1044 Make_Object_Declaration
(Loc
,
1045 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
1046 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1048 Unchecked_Convert_To
(PtrT
,
1049 New_Occurrence_Of
(Temp
, Loc
)));
1051 Insert_Action
(N
, New_Decl
);
1053 Temp_Decl
:= New_Decl
;
1054 Temp
:= Defining_Identifier
(New_Decl
);
1058 -- Generate the tag assignment
1060 -- Suppress the tag assignment for VM targets because VM tags are
1061 -- represented implicitly in objects.
1063 if not Tagged_Type_Expansion
then
1066 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1067 -- interface objects because in this case the tag does not change.
1069 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1070 pragma Assert
(Is_Class_Wide_Type
1071 (Directly_Designated_Type
(Etype
(N
))));
1074 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1076 TagR
:= New_Occurrence_Of
(Temp
, Loc
);
1078 elsif Is_Private_Type
(T
)
1079 and then Is_Tagged_Type
(Underlying_Type
(T
))
1081 TagT
:= Underlying_Type
(T
);
1083 Unchecked_Convert_To
(Underlying_Type
(T
),
1084 Make_Explicit_Dereference
(Loc
,
1085 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
1088 if Present
(TagT
) then
1090 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1094 Make_Assignment_Statement
(Loc
,
1096 Make_Selected_Component
(Loc
,
1100 (First_Tag_Component
(Full_T
), Loc
)),
1103 Unchecked_Convert_To
(RTE
(RE_Tag
),
1106 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1109 -- The previous assignment has to be done in any case
1111 Set_Assignment_OK
(Name
(Tag_Assign
));
1112 Insert_Action
(N
, Tag_Assign
);
1115 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1116 -- the object may be inherently limited, in which case there is no
1117 -- Adjust procedure, and the object is built in place. In Ada 95, the
1118 -- object can be limited but not inherently limited if this allocator
1119 -- came from a return statement (we're allocating the result on the
1120 -- secondary stack). In that case, the object will be moved, so we do
1121 -- want to Adjust. However, if it's a nonlimited build-in-place
1122 -- function call, Adjust is not wanted.
1124 if Needs_Finalization
(DesigT
)
1125 and then Needs_Finalization
(T
)
1126 and then not Aggr_In_Place
1127 and then not Is_Limited_View
(T
)
1128 and then not Alloc_For_BIP_Return
(N
)
1129 and then not Is_Build_In_Place_Function_Call
(Expression
(N
))
1131 -- An unchecked conversion is needed in the classwide case because
1132 -- the designated type can be an ancestor of the subtype mark of
1138 Unchecked_Convert_To
(T
,
1139 Make_Explicit_Dereference
(Loc
,
1140 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
1143 if Present
(Adj_Call
) then
1144 Insert_Action
(N
, Adj_Call
);
1148 -- Note: the accessibility check must be inserted after the call to
1149 -- [Deep_]Adjust to ensure proper completion of the assignment.
1151 Apply_Accessibility_Check
(Temp
);
1153 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1154 Analyze_And_Resolve
(N
, PtrT
);
1156 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1157 -- component containing the secondary dispatch table of the interface
1160 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1161 Displace_Allocator_Pointer
(N
);
1164 -- Always force the generation of a temporary for aggregates when
1165 -- generating C code, to simplify the work in the code generator.
1168 or else (Modify_Tree_For_C
and then Nkind
(Exp
) = N_Aggregate
)
1170 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1172 Make_Object_Declaration
(Loc
,
1173 Defining_Identifier
=> Temp
,
1174 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1176 Make_Allocator
(Loc
,
1177 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1179 -- Copy the Comes_From_Source flag for the allocator we just built,
1180 -- since logically this allocator is a replacement of the original
1181 -- allocator node. This is for proper handling of restriction
1182 -- No_Implicit_Heap_Allocations.
1184 Set_Comes_From_Source
1185 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1187 Set_No_Initialization
(Expression
(Temp_Decl
));
1188 Insert_Action
(N
, Temp_Decl
);
1190 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1191 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1193 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1194 Analyze_And_Resolve
(N
, PtrT
);
1196 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1197 Install_Null_Excluding_Check
(Exp
);
1199 elsif Is_Access_Type
(DesigT
)
1200 and then Nkind
(Exp
) = N_Allocator
1201 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1203 -- Apply constraint to designated subtype indication
1205 Apply_Constraint_Check
1206 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1208 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1210 -- Propagate constraint_error to enclosing allocator
1212 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1216 Build_Allocate_Deallocate_Proc
(N
, True);
1219 -- type A is access T1;
1220 -- X : A := new T2'(...);
1221 -- T1 and T2 can be different subtypes, and we might need to check
1222 -- both constraints. First check against the type of the qualified
1225 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1227 if Do_Range_Check
(Exp
) then
1228 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1231 -- A check is also needed in cases where the designated subtype is
1232 -- constrained and differs from the subtype given in the qualified
1233 -- expression. Note that the check on the qualified expression does
1234 -- not allow sliding, but this check does (a relaxation from Ada 83).
1236 if Is_Constrained
(DesigT
)
1237 and then not Subtypes_Statically_Match
(T
, DesigT
)
1239 Apply_Constraint_Check
1240 (Exp
, DesigT
, No_Sliding
=> False);
1242 if Do_Range_Check
(Exp
) then
1243 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1247 -- For an access to unconstrained packed array, GIGI needs to see an
1248 -- expression with a constrained subtype in order to compute the
1249 -- proper size for the allocator.
1251 if Is_Array_Type
(T
)
1252 and then not Is_Constrained
(T
)
1253 and then Is_Packed
(T
)
1256 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1257 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1260 Make_Subtype_Declaration
(Loc
,
1261 Defining_Identifier
=> ConstrT
,
1262 Subtype_Indication
=>
1263 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1264 Freeze_Itype
(ConstrT
, Exp
);
1265 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1269 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1270 -- to a build-in-place function, then access to the allocated object
1271 -- must be passed to the function.
1273 if Is_Build_In_Place_Function_Call
(Exp
) then
1274 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1279 when RE_Not_Available
=>
1281 end Expand_Allocator_Expression
;
1283 -----------------------------
1284 -- Expand_Array_Comparison --
1285 -----------------------------
1287 -- Expansion is only required in the case of array types. For the unpacked
1288 -- case, an appropriate runtime routine is called. For packed cases, and
1289 -- also in some other cases where a runtime routine cannot be called, the
1290 -- form of the expansion is:
1292 -- [body for greater_nn; boolean_expression]
1294 -- The body is built by Make_Array_Comparison_Op, and the form of the
1295 -- Boolean expression depends on the operator involved.
1297 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1298 Loc
: constant Source_Ptr
:= Sloc
(N
);
1299 Op1
: Node_Id
:= Left_Opnd
(N
);
1300 Op2
: Node_Id
:= Right_Opnd
(N
);
1301 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1302 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1305 Func_Body
: Node_Id
;
1306 Func_Name
: Entity_Id
;
1310 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1311 -- True for byte addressable target
1313 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1314 -- Returns True if the length of the given operand is known to be less
1315 -- than 4. Returns False if this length is known to be four or greater
1316 -- or is not known at compile time.
1318 ------------------------
1319 -- Length_Less_Than_4 --
1320 ------------------------
1322 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1323 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1326 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1327 return String_Literal_Length
(Otyp
) < 4;
1331 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1332 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1333 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1338 if Compile_Time_Known_Value
(Lo
) then
1339 Lov
:= Expr_Value
(Lo
);
1344 if Compile_Time_Known_Value
(Hi
) then
1345 Hiv
:= Expr_Value
(Hi
);
1350 return Hiv
< Lov
+ 3;
1353 end Length_Less_Than_4
;
1355 -- Start of processing for Expand_Array_Comparison
1358 -- Deal first with unpacked case, where we can call a runtime routine
1359 -- except that we avoid this for targets for which are not addressable
1362 if not Is_Bit_Packed_Array
(Typ1
)
1363 and then Byte_Addressable
1365 -- The call we generate is:
1367 -- Compare_Array_xn[_Unaligned]
1368 -- (left'address, right'address, left'length, right'length) <op> 0
1370 -- x = U for unsigned, S for signed
1371 -- n = 8,16,32,64 for component size
1372 -- Add _Unaligned if length < 4 and component size is 8.
1373 -- <op> is the standard comparison operator
1375 if Component_Size
(Typ1
) = 8 then
1376 if Length_Less_Than_4
(Op1
)
1378 Length_Less_Than_4
(Op2
)
1380 if Is_Unsigned_Type
(Ctyp
) then
1381 Comp
:= RE_Compare_Array_U8_Unaligned
;
1383 Comp
:= RE_Compare_Array_S8_Unaligned
;
1387 if Is_Unsigned_Type
(Ctyp
) then
1388 Comp
:= RE_Compare_Array_U8
;
1390 Comp
:= RE_Compare_Array_S8
;
1394 elsif Component_Size
(Typ1
) = 16 then
1395 if Is_Unsigned_Type
(Ctyp
) then
1396 Comp
:= RE_Compare_Array_U16
;
1398 Comp
:= RE_Compare_Array_S16
;
1401 elsif Component_Size
(Typ1
) = 32 then
1402 if Is_Unsigned_Type
(Ctyp
) then
1403 Comp
:= RE_Compare_Array_U32
;
1405 Comp
:= RE_Compare_Array_S32
;
1408 else pragma Assert
(Component_Size
(Typ1
) = 64);
1409 if Is_Unsigned_Type
(Ctyp
) then
1410 Comp
:= RE_Compare_Array_U64
;
1412 Comp
:= RE_Compare_Array_S64
;
1416 if RTE_Available
(Comp
) then
1418 -- Expand to a call only if the runtime function is available,
1419 -- otherwise fall back to inline code.
1421 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1422 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1425 Make_Function_Call
(Sloc
(Op1
),
1426 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1428 Parameter_Associations
=> New_List
(
1429 Make_Attribute_Reference
(Loc
,
1430 Prefix
=> Relocate_Node
(Op1
),
1431 Attribute_Name
=> Name_Address
),
1433 Make_Attribute_Reference
(Loc
,
1434 Prefix
=> Relocate_Node
(Op2
),
1435 Attribute_Name
=> Name_Address
),
1437 Make_Attribute_Reference
(Loc
,
1438 Prefix
=> Relocate_Node
(Op1
),
1439 Attribute_Name
=> Name_Length
),
1441 Make_Attribute_Reference
(Loc
,
1442 Prefix
=> Relocate_Node
(Op2
),
1443 Attribute_Name
=> Name_Length
))));
1446 Make_Integer_Literal
(Sloc
(Op2
),
1449 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1450 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1455 -- Cases where we cannot make runtime call
1457 -- For (a <= b) we convert to not (a > b)
1459 if Chars
(N
) = Name_Op_Le
then
1465 Right_Opnd
=> Op2
)));
1466 Analyze_And_Resolve
(N
, Standard_Boolean
);
1469 -- For < the Boolean expression is
1470 -- greater__nn (op2, op1)
1472 elsif Chars
(N
) = Name_Op_Lt
then
1473 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1477 Op1
:= Right_Opnd
(N
);
1478 Op2
:= Left_Opnd
(N
);
1480 -- For (a >= b) we convert to not (a < b)
1482 elsif Chars
(N
) = Name_Op_Ge
then
1488 Right_Opnd
=> Op2
)));
1489 Analyze_And_Resolve
(N
, Standard_Boolean
);
1492 -- For > the Boolean expression is
1493 -- greater__nn (op1, op2)
1496 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1497 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1500 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1502 Make_Function_Call
(Loc
,
1503 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1504 Parameter_Associations
=> New_List
(Op1
, Op2
));
1506 Insert_Action
(N
, Func_Body
);
1508 Analyze_And_Resolve
(N
, Standard_Boolean
);
1509 end Expand_Array_Comparison
;
1511 ---------------------------
1512 -- Expand_Array_Equality --
1513 ---------------------------
1515 -- Expand an equality function for multi-dimensional arrays. Here is an
1516 -- example of such a function for Nb_Dimension = 2
1518 -- function Enn (A : atyp; B : btyp) return boolean is
1520 -- if (A'length (1) = 0 or else A'length (2) = 0)
1522 -- (B'length (1) = 0 or else B'length (2) = 0)
1524 -- return True; -- RM 4.5.2(22)
1527 -- if A'length (1) /= B'length (1)
1529 -- A'length (2) /= B'length (2)
1531 -- return False; -- RM 4.5.2(23)
1535 -- A1 : Index_T1 := A'first (1);
1536 -- B1 : Index_T1 := B'first (1);
1540 -- A2 : Index_T2 := A'first (2);
1541 -- B2 : Index_T2 := B'first (2);
1544 -- if A (A1, A2) /= B (B1, B2) then
1548 -- exit when A2 = A'last (2);
1549 -- A2 := Index_T2'succ (A2);
1550 -- B2 := Index_T2'succ (B2);
1554 -- exit when A1 = A'last (1);
1555 -- A1 := Index_T1'succ (A1);
1556 -- B1 := Index_T1'succ (B1);
1563 -- Note on the formal types used (atyp and btyp). If either of the arrays
1564 -- is of a private type, we use the underlying type, and do an unchecked
1565 -- conversion of the actual. If either of the arrays has a bound depending
1566 -- on a discriminant, then we use the base type since otherwise we have an
1567 -- escaped discriminant in the function.
1569 -- If both arrays are constrained and have the same bounds, we can generate
1570 -- a loop with an explicit iteration scheme using a 'Range attribute over
1573 function Expand_Array_Equality
1578 Typ
: Entity_Id
) return Node_Id
1580 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1581 Decls
: constant List_Id
:= New_List
;
1582 Index_List1
: constant List_Id
:= New_List
;
1583 Index_List2
: constant List_Id
:= New_List
;
1585 First_Idx
: Node_Id
;
1587 Func_Name
: Entity_Id
;
1588 Func_Body
: Node_Id
;
1590 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1591 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1595 -- The parameter types to be used for the formals
1599 -- The LHS and RHS converted to the parameter types
1604 Num
: Int
) return Node_Id
;
1605 -- This builds the attribute reference Arr'Nam (Expr)
1607 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1608 -- Create one statement to compare corresponding components, designated
1609 -- by a full set of indexes.
1611 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1612 -- Given one of the arguments, computes the appropriate type to be used
1613 -- for that argument in the corresponding function formal
1615 function Handle_One_Dimension
1617 Index
: Node_Id
) return Node_Id
;
1618 -- This procedure returns the following code
1621 -- Bn : Index_T := B'First (N);
1625 -- exit when An = A'Last (N);
1626 -- An := Index_T'Succ (An)
1627 -- Bn := Index_T'Succ (Bn)
1631 -- If both indexes are constrained and identical, the procedure
1632 -- returns a simpler loop:
1634 -- for An in A'Range (N) loop
1638 -- N is the dimension for which we are generating a loop. Index is the
1639 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1640 -- xxx statement is either the loop or declare for the next dimension
1641 -- or if this is the last dimension the comparison of corresponding
1642 -- components of the arrays.
1644 -- The actual way the code works is to return the comparison of
1645 -- corresponding components for the N+1 call. That's neater.
1647 function Test_Empty_Arrays
return Node_Id
;
1648 -- This function constructs the test for both arrays being empty
1649 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1651 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1653 function Test_Lengths_Correspond
return Node_Id
;
1654 -- This function constructs the test for arrays having different lengths
1655 -- in at least one index position, in which case the resulting code is:
1657 -- A'length (1) /= B'length (1)
1659 -- A'length (2) /= B'length (2)
1670 Num
: Int
) return Node_Id
1674 Make_Attribute_Reference
(Loc
,
1675 Attribute_Name
=> Nam
,
1676 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1677 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1680 ------------------------
1681 -- Component_Equality --
1682 ------------------------
1684 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1689 -- if a(i1...) /= b(j1...) then return false; end if;
1692 Make_Indexed_Component
(Loc
,
1693 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1694 Expressions
=> Index_List1
);
1697 Make_Indexed_Component
(Loc
,
1698 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1699 Expressions
=> Index_List2
);
1701 Test
:= Expand_Composite_Equality
1702 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1704 -- If some (sub)component is an unchecked_union, the whole operation
1705 -- will raise program error.
1707 if Nkind
(Test
) = N_Raise_Program_Error
then
1709 -- This node is going to be inserted at a location where a
1710 -- statement is expected: clear its Etype so analysis will set
1711 -- it to the expected Standard_Void_Type.
1713 Set_Etype
(Test
, Empty
);
1718 Make_Implicit_If_Statement
(Nod
,
1719 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1720 Then_Statements
=> New_List
(
1721 Make_Simple_Return_Statement
(Loc
,
1722 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1724 end Component_Equality
;
1730 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1741 T
:= Underlying_Type
(T
);
1743 X
:= First_Index
(T
);
1744 while Present
(X
) loop
1745 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1747 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1760 --------------------------
1761 -- Handle_One_Dimension --
1762 ---------------------------
1764 function Handle_One_Dimension
1766 Index
: Node_Id
) return Node_Id
1768 Need_Separate_Indexes
: constant Boolean :=
1769 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1770 -- If the index types are identical, and we are working with
1771 -- constrained types, then we can use the same index for both
1774 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1777 Index_T
: Entity_Id
;
1782 if N
> Number_Dimensions
(Ltyp
) then
1783 return Component_Equality
(Ltyp
);
1786 -- Case where we generate a loop
1788 Index_T
:= Base_Type
(Etype
(Index
));
1790 if Need_Separate_Indexes
then
1791 Bn
:= Make_Temporary
(Loc
, 'B');
1796 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1797 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1799 Stm_List
:= New_List
(
1800 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1802 if Need_Separate_Indexes
then
1804 -- Generate guard for loop, followed by increments of indexes
1806 Append_To
(Stm_List
,
1807 Make_Exit_Statement
(Loc
,
1810 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1811 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1813 Append_To
(Stm_List
,
1814 Make_Assignment_Statement
(Loc
,
1815 Name
=> New_Occurrence_Of
(An
, Loc
),
1817 Make_Attribute_Reference
(Loc
,
1818 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1819 Attribute_Name
=> Name_Succ
,
1820 Expressions
=> New_List
(
1821 New_Occurrence_Of
(An
, Loc
)))));
1823 Append_To
(Stm_List
,
1824 Make_Assignment_Statement
(Loc
,
1825 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1827 Make_Attribute_Reference
(Loc
,
1828 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1829 Attribute_Name
=> Name_Succ
,
1830 Expressions
=> New_List
(
1831 New_Occurrence_Of
(Bn
, Loc
)))));
1834 -- If separate indexes, we need a declare block for An and Bn, and a
1835 -- loop without an iteration scheme.
1837 if Need_Separate_Indexes
then
1839 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1842 Make_Block_Statement
(Loc
,
1843 Declarations
=> New_List
(
1844 Make_Object_Declaration
(Loc
,
1845 Defining_Identifier
=> An
,
1846 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1847 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1849 Make_Object_Declaration
(Loc
,
1850 Defining_Identifier
=> Bn
,
1851 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1852 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1854 Handled_Statement_Sequence
=>
1855 Make_Handled_Sequence_Of_Statements
(Loc
,
1856 Statements
=> New_List
(Loop_Stm
)));
1858 -- If no separate indexes, return loop statement with explicit
1859 -- iteration scheme on its own.
1863 Make_Implicit_Loop_Statement
(Nod
,
1864 Statements
=> Stm_List
,
1866 Make_Iteration_Scheme
(Loc
,
1867 Loop_Parameter_Specification
=>
1868 Make_Loop_Parameter_Specification
(Loc
,
1869 Defining_Identifier
=> An
,
1870 Discrete_Subtype_Definition
=>
1871 Arr_Attr
(A
, Name_Range
, N
))));
1874 end Handle_One_Dimension
;
1876 -----------------------
1877 -- Test_Empty_Arrays --
1878 -----------------------
1880 function Test_Empty_Arrays
return Node_Id
is
1890 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1893 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1894 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1898 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1899 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1908 Left_Opnd
=> Relocate_Node
(Alist
),
1909 Right_Opnd
=> Atest
);
1913 Left_Opnd
=> Relocate_Node
(Blist
),
1914 Right_Opnd
=> Btest
);
1921 Right_Opnd
=> Blist
);
1922 end Test_Empty_Arrays
;
1924 -----------------------------
1925 -- Test_Lengths_Correspond --
1926 -----------------------------
1928 function Test_Lengths_Correspond
return Node_Id
is
1934 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1937 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1938 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
1945 Left_Opnd
=> Relocate_Node
(Result
),
1946 Right_Opnd
=> Rtest
);
1951 end Test_Lengths_Correspond
;
1953 -- Start of processing for Expand_Array_Equality
1956 Ltyp
:= Get_Arg_Type
(Lhs
);
1957 Rtyp
:= Get_Arg_Type
(Rhs
);
1959 -- For now, if the argument types are not the same, go to the base type,
1960 -- since the code assumes that the formals have the same type. This is
1961 -- fixable in future ???
1963 if Ltyp
/= Rtyp
then
1964 Ltyp
:= Base_Type
(Ltyp
);
1965 Rtyp
:= Base_Type
(Rtyp
);
1966 pragma Assert
(Ltyp
= Rtyp
);
1969 -- If the array type is distinct from the type of the arguments, it
1970 -- is the full view of a private type. Apply an unchecked conversion
1971 -- to ensure that analysis of the code below succeeds.
1974 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1976 New_Lhs
:= OK_Convert_To
(Ltyp
, Lhs
);
1982 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1984 New_Rhs
:= OK_Convert_To
(Rtyp
, Rhs
);
1989 First_Idx
:= First_Index
(Ltyp
);
1991 -- If optimization is enabled and the array boils down to a couple of
1992 -- consecutive elements, generate a simple conjunction of comparisons
1993 -- which should be easier to optimize by the code generator.
1995 if Optimization_Level
> 0
1996 and then Ltyp
= Rtyp
1997 and then Is_Constrained
(Ltyp
)
1998 and then Number_Dimensions
(Ltyp
) = 1
1999 and then Nkind
(First_Idx
) = N_Range
2000 and then Compile_Time_Known_Value
(Low_Bound
(First_Idx
))
2001 and then Compile_Time_Known_Value
(High_Bound
(First_Idx
))
2002 and then Expr_Value
(High_Bound
(First_Idx
)) =
2003 Expr_Value
(Low_Bound
(First_Idx
)) + 1
2006 Ctyp
: constant Entity_Id
:= Component_Type
(Ltyp
);
2008 TestL
, TestH
: Node_Id
;
2009 Index_List
: List_Id
;
2012 Index_List
:= New_List
(New_Copy_Tree
(Low_Bound
(First_Idx
)));
2015 Make_Indexed_Component
(Loc
,
2016 Prefix
=> New_Copy_Tree
(New_Lhs
),
2017 Expressions
=> Index_List
);
2020 Make_Indexed_Component
(Loc
,
2021 Prefix
=> New_Copy_Tree
(New_Rhs
),
2022 Expressions
=> Index_List
);
2024 TestL
:= Expand_Composite_Equality
(Nod
, Ctyp
, L
, R
, Bodies
);
2026 Index_List
:= New_List
(New_Copy_Tree
(High_Bound
(First_Idx
)));
2029 Make_Indexed_Component
(Loc
,
2031 Expressions
=> Index_List
);
2034 Make_Indexed_Component
(Loc
,
2036 Expressions
=> Index_List
);
2038 TestH
:= Expand_Composite_Equality
(Nod
, Ctyp
, L
, R
, Bodies
);
2041 Make_And_Then
(Loc
, Left_Opnd
=> TestL
, Right_Opnd
=> TestH
);
2045 -- Build list of formals for function
2047 Formals
:= New_List
(
2048 Make_Parameter_Specification
(Loc
,
2049 Defining_Identifier
=> A
,
2050 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
2052 Make_Parameter_Specification
(Loc
,
2053 Defining_Identifier
=> B
,
2054 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
2056 Func_Name
:= Make_Temporary
(Loc
, 'E');
2058 -- Build statement sequence for function
2061 Make_Subprogram_Body
(Loc
,
2063 Make_Function_Specification
(Loc
,
2064 Defining_Unit_Name
=> Func_Name
,
2065 Parameter_Specifications
=> Formals
,
2066 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2068 Declarations
=> Decls
,
2070 Handled_Statement_Sequence
=>
2071 Make_Handled_Sequence_Of_Statements
(Loc
,
2072 Statements
=> New_List
(
2074 Make_Implicit_If_Statement
(Nod
,
2075 Condition
=> Test_Empty_Arrays
,
2076 Then_Statements
=> New_List
(
2077 Make_Simple_Return_Statement
(Loc
,
2079 New_Occurrence_Of
(Standard_True
, Loc
)))),
2081 Make_Implicit_If_Statement
(Nod
,
2082 Condition
=> Test_Lengths_Correspond
,
2083 Then_Statements
=> New_List
(
2084 Make_Simple_Return_Statement
(Loc
,
2085 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
2087 Handle_One_Dimension
(1, First_Idx
),
2089 Make_Simple_Return_Statement
(Loc
,
2090 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2092 Set_Has_Completion
(Func_Name
, True);
2093 Set_Is_Inlined
(Func_Name
);
2095 Append_To
(Bodies
, Func_Body
);
2098 Make_Function_Call
(Loc
,
2099 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2100 Parameter_Associations
=> New_List
(New_Lhs
, New_Rhs
));
2101 end Expand_Array_Equality
;
2103 -----------------------------
2104 -- Expand_Boolean_Operator --
2105 -----------------------------
2107 -- Note that we first get the actual subtypes of the operands, since we
2108 -- always want to deal with types that have bounds.
2110 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2111 Typ
: constant Entity_Id
:= Etype
(N
);
2114 -- Special case of bit packed array where both operands are known to be
2115 -- properly aligned. In this case we use an efficient run time routine
2116 -- to carry out the operation (see System.Bit_Ops).
2118 if Is_Bit_Packed_Array
(Typ
)
2119 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2120 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2122 Expand_Packed_Boolean_Operator
(N
);
2126 -- For the normal non-packed case, the general expansion is to build
2127 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2128 -- and then inserting it into the tree. The original operator node is
2129 -- then rewritten as a call to this function. We also use this in the
2130 -- packed case if either operand is a possibly unaligned object.
2133 Loc
: constant Source_Ptr
:= Sloc
(N
);
2134 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2135 R
: Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2136 Func_Body
: Node_Id
;
2137 Func_Name
: Entity_Id
;
2140 Convert_To_Actual_Subtype
(L
);
2141 Convert_To_Actual_Subtype
(R
);
2142 Ensure_Defined
(Etype
(L
), N
);
2143 Ensure_Defined
(Etype
(R
), N
);
2144 Apply_Length_Check
(R
, Etype
(L
));
2146 if Nkind
(N
) = N_Op_Xor
then
2147 R
:= Duplicate_Subexpr
(R
);
2148 Silly_Boolean_Array_Xor_Test
(N
, R
, Etype
(L
));
2151 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2152 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2154 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2156 elsif Nkind
(Parent
(N
)) = N_Op_Not
2157 and then Nkind
(N
) = N_Op_And
2158 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2159 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2164 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2165 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2166 Insert_Action
(N
, Func_Body
);
2168 -- Now rewrite the expression with a call
2171 Make_Function_Call
(Loc
,
2172 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2173 Parameter_Associations
=>
2176 Make_Type_Conversion
2177 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2179 Analyze_And_Resolve
(N
, Typ
);
2182 end Expand_Boolean_Operator
;
2184 ------------------------------------------------
2185 -- Expand_Compare_Minimize_Eliminate_Overflow --
2186 ------------------------------------------------
2188 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2189 Loc
: constant Source_Ptr
:= Sloc
(N
);
2191 Result_Type
: constant Entity_Id
:= Etype
(N
);
2192 -- Capture result type (could be a derived boolean type)
2197 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2198 -- Entity for Long_Long_Integer'Base
2200 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2201 -- Current overflow checking mode
2204 procedure Set_False
;
2205 -- These procedures rewrite N with an occurrence of Standard_True or
2206 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2212 procedure Set_False
is
2214 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2215 Warn_On_Known_Condition
(N
);
2222 procedure Set_True
is
2224 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2225 Warn_On_Known_Condition
(N
);
2228 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2231 -- Nothing to do unless we have a comparison operator with operands
2232 -- that are signed integer types, and we are operating in either
2233 -- MINIMIZED or ELIMINATED overflow checking mode.
2235 if Nkind
(N
) not in N_Op_Compare
2236 or else Check
not in Minimized_Or_Eliminated
2237 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2242 -- OK, this is the case we are interested in. First step is to process
2243 -- our operands using the Minimize_Eliminate circuitry which applies
2244 -- this processing to the two operand subtrees.
2246 Minimize_Eliminate_Overflows
2247 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2248 Minimize_Eliminate_Overflows
2249 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2251 -- See if the range information decides the result of the comparison.
2252 -- We can only do this if we in fact have full range information (which
2253 -- won't be the case if either operand is bignum at this stage).
2255 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2256 case N_Op_Compare
(Nkind
(N
)) is
2258 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2260 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2267 elsif Lhi
< Rlo
then
2274 elsif Lhi
<= Rlo
then
2281 elsif Lhi
<= Rlo
then
2288 elsif Lhi
< Rlo
then
2293 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2295 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2300 -- All done if we did the rewrite
2302 if Nkind
(N
) not in N_Op_Compare
then
2307 -- Otherwise, time to do the comparison
2310 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2311 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2314 -- If the two operands have the same signed integer type we are
2315 -- all set, nothing more to do. This is the case where either
2316 -- both operands were unchanged, or we rewrote both of them to
2317 -- be Long_Long_Integer.
2319 -- Note: Entity for the comparison may be wrong, but it's not worth
2320 -- the effort to change it, since the back end does not use it.
2322 if Is_Signed_Integer_Type
(Ltype
)
2323 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2327 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2329 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2331 Left
: Node_Id
:= Left_Opnd
(N
);
2332 Right
: Node_Id
:= Right_Opnd
(N
);
2333 -- Bignum references for left and right operands
2336 if not Is_RTE
(Ltype
, RE_Bignum
) then
2337 Left
:= Convert_To_Bignum
(Left
);
2338 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2339 Right
:= Convert_To_Bignum
(Right
);
2342 -- We rewrite our node with:
2345 -- Bnn : Result_Type;
2347 -- M : Mark_Id := SS_Mark;
2349 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2357 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2358 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2362 case N_Op_Compare
(Nkind
(N
)) is
2363 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2364 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2365 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2366 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2367 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2368 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2371 -- Insert assignment to Bnn into the bignum block
2374 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2375 Make_Assignment_Statement
(Loc
,
2376 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2378 Make_Function_Call
(Loc
,
2380 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2381 Parameter_Associations
=> New_List
(Left
, Right
))));
2383 -- Now do the rewrite with expression actions
2386 Make_Expression_With_Actions
(Loc
,
2387 Actions
=> New_List
(
2388 Make_Object_Declaration
(Loc
,
2389 Defining_Identifier
=> Bnn
,
2390 Object_Definition
=>
2391 New_Occurrence_Of
(Result_Type
, Loc
)),
2393 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2394 Analyze_And_Resolve
(N
, Result_Type
);
2398 -- No bignums involved, but types are different, so we must have
2399 -- rewritten one of the operands as a Long_Long_Integer but not
2402 -- If left operand is Long_Long_Integer, convert right operand
2403 -- and we are done (with a comparison of two Long_Long_Integers).
2405 elsif Ltype
= LLIB
then
2406 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2407 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2410 -- If right operand is Long_Long_Integer, convert left operand
2411 -- and we are done (with a comparison of two Long_Long_Integers).
2413 -- This is the only remaining possibility
2415 else pragma Assert
(Rtype
= LLIB
);
2416 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2417 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2421 end Expand_Compare_Minimize_Eliminate_Overflow
;
2423 -------------------------------
2424 -- Expand_Composite_Equality --
2425 -------------------------------
2427 -- This function is only called for comparing internal fields of composite
2428 -- types when these fields are themselves composites. This is a special
2429 -- case because it is not possible to respect normal Ada visibility rules.
2431 function Expand_Composite_Equality
2436 Bodies
: List_Id
) return Node_Id
2438 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2439 Full_Type
: Entity_Id
;
2442 -- Start of processing for Expand_Composite_Equality
2445 if Is_Private_Type
(Typ
) then
2446 Full_Type
:= Underlying_Type
(Typ
);
2451 -- If the private type has no completion the context may be the
2452 -- expansion of a composite equality for a composite type with some
2453 -- still incomplete components. The expression will not be analyzed
2454 -- until the enclosing type is completed, at which point this will be
2455 -- properly expanded, unless there is a bona fide completion error.
2457 if No
(Full_Type
) then
2458 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2461 Full_Type
:= Base_Type
(Full_Type
);
2463 -- When the base type itself is private, use the full view to expand
2464 -- the composite equality.
2466 if Is_Private_Type
(Full_Type
) then
2467 Full_Type
:= Underlying_Type
(Full_Type
);
2470 -- Case of array types
2472 if Is_Array_Type
(Full_Type
) then
2474 -- If the operand is an elementary type other than a floating-point
2475 -- type, then we can simply use the built-in block bitwise equality,
2476 -- since the predefined equality operators always apply and bitwise
2477 -- equality is fine for all these cases.
2479 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2480 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2482 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2484 -- For composite component types, and floating-point types, use the
2485 -- expansion. This deals with tagged component types (where we use
2486 -- the applicable equality routine) and floating-point (where we
2487 -- need to worry about negative zeroes), and also the case of any
2488 -- composite type recursively containing such fields.
2492 Comp_Typ
: Entity_Id
;
2499 -- Do the comparison in the type (or its full view) and not in
2500 -- its unconstrained base type, because the latter operation is
2501 -- more complex and would also require an unchecked conversion.
2503 if Is_Private_Type
(Typ
) then
2504 Comp_Typ
:= Underlying_Type
(Typ
);
2509 -- Except for the case where the bounds of the type depend on a
2510 -- discriminant, or else we would run into scoping issues.
2512 Indx
:= First_Index
(Comp_Typ
);
2513 while Present
(Indx
) loop
2514 Ityp
:= Etype
(Indx
);
2516 Lo
:= Type_Low_Bound
(Ityp
);
2517 Hi
:= Type_High_Bound
(Ityp
);
2519 if (Nkind
(Lo
) = N_Identifier
2520 and then Ekind
(Entity
(Lo
)) = E_Discriminant
)
2522 (Nkind
(Hi
) = N_Identifier
2523 and then Ekind
(Entity
(Hi
)) = E_Discriminant
)
2525 Comp_Typ
:= Full_Type
;
2532 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Comp_Typ
);
2536 -- Case of tagged record types
2538 elsif Is_Tagged_Type
(Full_Type
) then
2539 Eq_Op
:= Find_Primitive_Eq
(Typ
);
2540 pragma Assert
(Present
(Eq_Op
));
2543 Make_Function_Call
(Loc
,
2544 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2545 Parameter_Associations
=>
2547 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2548 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2550 -- Case of untagged record types
2552 elsif Is_Record_Type
(Full_Type
) then
2553 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2555 if Present
(Eq_Op
) then
2556 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2558 -- Inherited equality from parent type. Convert the actuals to
2559 -- match signature of operation.
2562 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2566 Make_Function_Call
(Loc
,
2567 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2568 Parameter_Associations
=> New_List
(
2569 OK_Convert_To
(T
, Lhs
),
2570 OK_Convert_To
(T
, Rhs
)));
2574 -- Comparison between Unchecked_Union components
2576 if Is_Unchecked_Union
(Full_Type
) then
2578 Lhs_Type
: Node_Id
:= Full_Type
;
2579 Rhs_Type
: Node_Id
:= Full_Type
;
2580 Lhs_Discr_Val
: Node_Id
;
2581 Rhs_Discr_Val
: Node_Id
;
2586 if Nkind
(Lhs
) = N_Selected_Component
then
2587 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2592 if Nkind
(Rhs
) = N_Selected_Component
then
2593 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2596 -- Lhs of the composite equality
2598 if Is_Constrained
(Lhs_Type
) then
2600 -- Since the enclosing record type can never be an
2601 -- Unchecked_Union (this code is executed for records
2602 -- that do not have variants), we may reference its
2605 if Nkind
(Lhs
) = N_Selected_Component
2606 and then Has_Per_Object_Constraint
2607 (Entity
(Selector_Name
(Lhs
)))
2610 Make_Selected_Component
(Loc
,
2611 Prefix
=> Prefix
(Lhs
),
2614 (Get_Discriminant_Value
2615 (First_Discriminant
(Lhs_Type
),
2617 Stored_Constraint
(Lhs_Type
))));
2622 (Get_Discriminant_Value
2623 (First_Discriminant
(Lhs_Type
),
2625 Stored_Constraint
(Lhs_Type
)));
2629 -- It is not possible to infer the discriminant since
2630 -- the subtype is not constrained.
2633 Make_Raise_Program_Error
(Loc
,
2634 Reason
=> PE_Unchecked_Union_Restriction
);
2637 -- Rhs of the composite equality
2639 if Is_Constrained
(Rhs_Type
) then
2640 if Nkind
(Rhs
) = N_Selected_Component
2641 and then Has_Per_Object_Constraint
2642 (Entity
(Selector_Name
(Rhs
)))
2645 Make_Selected_Component
(Loc
,
2646 Prefix
=> Prefix
(Rhs
),
2649 (Get_Discriminant_Value
2650 (First_Discriminant
(Rhs_Type
),
2652 Stored_Constraint
(Rhs_Type
))));
2657 (Get_Discriminant_Value
2658 (First_Discriminant
(Rhs_Type
),
2660 Stored_Constraint
(Rhs_Type
)));
2665 Make_Raise_Program_Error
(Loc
,
2666 Reason
=> PE_Unchecked_Union_Restriction
);
2669 -- Call the TSS equality function with the inferred
2670 -- discriminant values.
2673 Make_Function_Call
(Loc
,
2674 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2675 Parameter_Associations
=> New_List
(
2682 -- All cases other than comparing Unchecked_Union types
2686 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2689 Make_Function_Call
(Loc
,
2691 New_Occurrence_Of
(Eq_Op
, Loc
),
2692 Parameter_Associations
=> New_List
(
2693 OK_Convert_To
(T
, Lhs
),
2694 OK_Convert_To
(T
, Rhs
)));
2699 -- Equality composes in Ada 2012 for untagged record types. It also
2700 -- composes for bounded strings, because they are part of the
2701 -- predefined environment. We could make it compose for bounded
2702 -- strings by making them tagged, or by making sure all subcomponents
2703 -- are set to the same value, even when not used. Instead, we have
2704 -- this special case in the compiler, because it's more efficient.
2706 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2708 -- If no TSS has been created for the type, check whether there is
2709 -- a primitive equality declared for it.
2712 Op
: constant Node_Id
:= Build_Eq_Call
(Typ
, Loc
, Lhs
, Rhs
);
2715 -- Use user-defined primitive if it exists, otherwise use
2716 -- predefined equality.
2718 if Present
(Op
) then
2721 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2726 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2729 -- Non-composite types (always use predefined equality)
2732 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2734 end Expand_Composite_Equality
;
2736 ------------------------
2737 -- Expand_Concatenate --
2738 ------------------------
2740 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2741 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2743 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2744 -- Result type of concatenation
2746 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2747 -- Component type. Elements of this component type can appear as one
2748 -- of the operands of concatenation as well as arrays.
2750 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2753 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2754 -- Index type. This is the base type of the index subtype, and is used
2755 -- for all computed bounds (which may be out of range of Istyp in the
2756 -- case of null ranges).
2759 -- This is the type we use to do arithmetic to compute the bounds and
2760 -- lengths of operands. The choice of this type is a little subtle and
2761 -- is discussed in a separate section at the start of the body code.
2763 Concatenation_Error
: exception;
2764 -- Raised if concatenation is sure to raise a CE
2766 Result_May_Be_Null
: Boolean := True;
2767 -- Reset to False if at least one operand is encountered which is known
2768 -- at compile time to be non-null. Used for handling the special case
2769 -- of setting the high bound to the last operand high bound for a null
2770 -- result, thus ensuring a proper high bound in the super-flat case.
2772 N
: constant Nat
:= List_Length
(Opnds
);
2773 -- Number of concatenation operands including possibly null operands
2776 -- Number of operands excluding any known to be null, except that the
2777 -- last operand is always retained, in case it provides the bounds for
2780 Opnd
: Node_Id
:= Empty
;
2781 -- Current operand being processed in the loop through operands. After
2782 -- this loop is complete, always contains the last operand (which is not
2783 -- the same as Operands (NN), since null operands are skipped).
2785 -- Arrays describing the operands, only the first NN entries of each
2786 -- array are set (NN < N when we exclude known null operands).
2788 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2789 -- True if length of corresponding operand known at compile time
2791 Operands
: array (1 .. N
) of Node_Id
;
2792 -- Set to the corresponding entry in the Opnds list (but note that null
2793 -- operands are excluded, so not all entries in the list are stored).
2795 Fixed_Length
: array (1 .. N
) of Uint
;
2796 -- Set to length of operand. Entries in this array are set only if the
2797 -- corresponding entry in Is_Fixed_Length is True.
2799 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2800 -- Set to lower bound of operand. Either an integer literal in the case
2801 -- where the bound is known at compile time, else actual lower bound.
2802 -- The operand low bound is of type Ityp.
2804 Var_Length
: array (1 .. N
) of Entity_Id
;
2805 -- Set to an entity of type Natural that contains the length of an
2806 -- operand whose length is not known at compile time. Entries in this
2807 -- array are set only if the corresponding entry in Is_Fixed_Length
2808 -- is False. The entity is of type Artyp.
2810 Aggr_Length
: array (0 .. N
) of Node_Id
;
2811 -- The J'th entry in an expression node that represents the total length
2812 -- of operands 1 through J. It is either an integer literal node, or a
2813 -- reference to a constant entity with the right value, so it is fine
2814 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth
2815 -- entry always is set to zero. The length is of type Artyp.
2817 Low_Bound
: Node_Id
;
2818 -- A tree node representing the low bound of the result (of type Ityp).
2819 -- This is either an integer literal node, or an identifier reference to
2820 -- a constant entity initialized to the appropriate value.
2822 Last_Opnd_Low_Bound
: Node_Id
:= Empty
;
2823 -- A tree node representing the low bound of the last operand. This
2824 -- need only be set if the result could be null. It is used for the
2825 -- special case of setting the right low bound for a null result.
2826 -- This is of type Ityp.
2828 Last_Opnd_High_Bound
: Node_Id
:= Empty
;
2829 -- A tree node representing the high bound of the last operand. This
2830 -- need only be set if the result could be null. It is used for the
2831 -- special case of setting the right high bound for a null result.
2832 -- This is of type Ityp.
2834 High_Bound
: Node_Id
:= Empty
;
2835 -- A tree node representing the high bound of the result (of type Ityp)
2838 -- Result of the concatenation (of type Ityp)
2840 Actions
: constant List_Id
:= New_List
;
2841 -- Collect actions to be inserted
2843 Known_Non_Null_Operand_Seen
: Boolean;
2844 -- Set True during generation of the assignments of operands into
2845 -- result once an operand known to be non-null has been seen.
2847 function Library_Level_Target
return Boolean;
2848 -- Return True if the concatenation is within the expression of the
2849 -- declaration of a library-level object.
2851 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2852 -- This function makes an N_Integer_Literal node that is returned in
2853 -- analyzed form with the type set to Artyp. Importantly this literal
2854 -- is not flagged as static, so that if we do computations with it that
2855 -- result in statically detected out of range conditions, we will not
2856 -- generate error messages but instead warning messages.
2858 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2859 -- Given a node of type Ityp, returns the corresponding value of type
2860 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2861 -- For enum types, the Pos of the value is returned.
2863 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2864 -- The inverse function (uses Val in the case of enumeration types)
2866 --------------------------
2867 -- Library_Level_Target --
2868 --------------------------
2870 function Library_Level_Target
return Boolean is
2871 P
: Node_Id
:= Parent
(Cnode
);
2874 while Present
(P
) loop
2875 if Nkind
(P
) = N_Object_Declaration
then
2876 return Is_Library_Level_Entity
(Defining_Identifier
(P
));
2878 -- Prevent the search from going too far
2880 elsif Is_Body_Or_Package_Declaration
(P
) then
2888 end Library_Level_Target
;
2890 ------------------------
2891 -- Make_Artyp_Literal --
2892 ------------------------
2894 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2895 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2897 Set_Etype
(Result
, Artyp
);
2898 Set_Analyzed
(Result
, True);
2899 Set_Is_Static_Expression
(Result
, False);
2901 end Make_Artyp_Literal
;
2907 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2909 if Ityp
= Base_Type
(Artyp
) then
2912 elsif Is_Enumeration_Type
(Ityp
) then
2914 Make_Attribute_Reference
(Loc
,
2915 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2916 Attribute_Name
=> Name_Pos
,
2917 Expressions
=> New_List
(X
));
2920 return Convert_To
(Artyp
, X
);
2928 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2930 if Is_Enumeration_Type
(Ityp
) then
2932 Make_Attribute_Reference
(Loc
,
2933 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2934 Attribute_Name
=> Name_Val
,
2935 Expressions
=> New_List
(X
));
2937 -- Case where we will do a type conversion
2940 if Ityp
= Base_Type
(Artyp
) then
2943 return Convert_To
(Ityp
, X
);
2948 -- Local Declarations
2950 Opnd_Typ
: Entity_Id
;
2957 -- Start of processing for Expand_Concatenate
2960 -- Choose an appropriate computational type
2962 -- We will be doing calculations of lengths and bounds in this routine
2963 -- and computing one from the other in some cases, e.g. getting the high
2964 -- bound by adding the length-1 to the low bound.
2966 -- We can't just use the index type, or even its base type for this
2967 -- purpose for two reasons. First it might be an enumeration type which
2968 -- is not suitable for computations of any kind, and second it may
2969 -- simply not have enough range. For example if the index type is
2970 -- -128..+127 then lengths can be up to 256, which is out of range of
2973 -- For enumeration types, we can simply use Standard_Integer, this is
2974 -- sufficient since the actual number of enumeration literals cannot
2975 -- possibly exceed the range of integer (remember we will be doing the
2976 -- arithmetic with POS values, not representation values).
2978 if Is_Enumeration_Type
(Ityp
) then
2979 Artyp
:= Standard_Integer
;
2981 -- If index type is Positive, we use the standard unsigned type, to give
2982 -- more room on the top of the range, obviating the need for an overflow
2983 -- check when creating the upper bound. This is needed to avoid junk
2984 -- overflow checks in the common case of String types.
2986 -- ??? Disabled for now
2988 -- elsif Istyp = Standard_Positive then
2989 -- Artyp := Standard_Unsigned;
2991 -- For modular types, we use a 32-bit modular type for types whose size
2992 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2993 -- identity type, and for larger unsigned types we use 64-bits.
2995 elsif Is_Modular_Integer_Type
(Ityp
) then
2996 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
2997 Artyp
:= Standard_Unsigned
;
2998 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
3001 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
3004 -- Similar treatment for signed types
3007 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
3008 Artyp
:= Standard_Integer
;
3009 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
3012 Artyp
:= Standard_Long_Long_Integer
;
3016 -- Supply dummy entry at start of length array
3018 Aggr_Length
(0) := Make_Artyp_Literal
(0);
3020 -- Go through operands setting up the above arrays
3024 Opnd
:= Remove_Head
(Opnds
);
3025 Opnd_Typ
:= Etype
(Opnd
);
3027 -- The parent got messed up when we put the operands in a list,
3028 -- so now put back the proper parent for the saved operand, that
3029 -- is to say the concatenation node, to make sure that each operand
3030 -- is seen as a subexpression, e.g. if actions must be inserted.
3032 Set_Parent
(Opnd
, Cnode
);
3034 -- Set will be True when we have setup one entry in the array
3038 -- Singleton element (or character literal) case
3040 if Base_Type
(Opnd_Typ
) = Ctyp
then
3042 Operands
(NN
) := Opnd
;
3043 Is_Fixed_Length
(NN
) := True;
3044 Fixed_Length
(NN
) := Uint_1
;
3045 Result_May_Be_Null
:= False;
3047 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3048 -- since we know that the result cannot be null).
3050 Opnd_Low_Bound
(NN
) :=
3051 Make_Attribute_Reference
(Loc
,
3052 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
3053 Attribute_Name
=> Name_First
);
3057 -- String literal case (can only occur for strings of course)
3059 elsif Nkind
(Opnd
) = N_String_Literal
then
3060 Len
:= String_Literal_Length
(Opnd_Typ
);
3063 Result_May_Be_Null
:= False;
3066 -- Capture last operand low and high bound if result could be null
3068 if J
= N
and then Result_May_Be_Null
then
3069 Last_Opnd_Low_Bound
:=
3070 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3072 Last_Opnd_High_Bound
:=
3073 Make_Op_Subtract
(Loc
,
3075 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3076 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3079 -- Skip null string literal
3081 if J
< N
and then Len
= 0 then
3086 Operands
(NN
) := Opnd
;
3087 Is_Fixed_Length
(NN
) := True;
3089 -- Set length and bounds
3091 Fixed_Length
(NN
) := Len
;
3093 Opnd_Low_Bound
(NN
) :=
3094 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3101 -- Check constrained case with known bounds
3103 if Is_Constrained
(Opnd_Typ
) then
3105 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3106 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3107 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3108 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3111 -- Fixed length constrained array type with known at compile
3112 -- time bounds is last case of fixed length operand.
3114 if Compile_Time_Known_Value
(Lo
)
3116 Compile_Time_Known_Value
(Hi
)
3119 Loval
: constant Uint
:= Expr_Value
(Lo
);
3120 Hival
: constant Uint
:= Expr_Value
(Hi
);
3121 Len
: constant Uint
:=
3122 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3126 Result_May_Be_Null
:= False;
3129 -- Capture last operand bounds if result could be null
3131 if J
= N
and then Result_May_Be_Null
then
3132 Last_Opnd_Low_Bound
:=
3134 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3136 Last_Opnd_High_Bound
:=
3138 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3141 -- Exclude null length case unless last operand
3143 if J
< N
and then Len
= 0 then
3148 Operands
(NN
) := Opnd
;
3149 Is_Fixed_Length
(NN
) := True;
3150 Fixed_Length
(NN
) := Len
;
3152 Opnd_Low_Bound
(NN
) :=
3154 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3161 -- All cases where the length is not known at compile time, or the
3162 -- special case of an operand which is known to be null but has a
3163 -- lower bound other than 1 or is other than a string type.
3168 -- Capture operand bounds
3170 Opnd_Low_Bound
(NN
) :=
3171 Make_Attribute_Reference
(Loc
,
3173 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3174 Attribute_Name
=> Name_First
);
3176 -- Capture last operand bounds if result could be null
3178 if J
= N
and Result_May_Be_Null
then
3179 Last_Opnd_Low_Bound
:=
3181 Make_Attribute_Reference
(Loc
,
3183 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3184 Attribute_Name
=> Name_First
));
3186 Last_Opnd_High_Bound
:=
3188 Make_Attribute_Reference
(Loc
,
3190 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3191 Attribute_Name
=> Name_Last
));
3194 -- Capture length of operand in entity
3196 Operands
(NN
) := Opnd
;
3197 Is_Fixed_Length
(NN
) := False;
3199 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3202 Make_Object_Declaration
(Loc
,
3203 Defining_Identifier
=> Var_Length
(NN
),
3204 Constant_Present
=> True,
3205 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3207 Make_Attribute_Reference
(Loc
,
3209 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3210 Attribute_Name
=> Name_Length
)));
3214 -- Set next entry in aggregate length array
3216 -- For first entry, make either integer literal for fixed length
3217 -- or a reference to the saved length for variable length.
3220 if Is_Fixed_Length
(1) then
3221 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3223 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
3226 -- If entry is fixed length and only fixed lengths so far, make
3227 -- appropriate new integer literal adding new length.
3229 elsif Is_Fixed_Length
(NN
)
3230 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3233 Make_Integer_Literal
(Loc
,
3234 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3236 -- All other cases, construct an addition node for the length and
3237 -- create an entity initialized to this length.
3240 Ent
:= Make_Temporary
(Loc
, 'L');
3242 if Is_Fixed_Length
(NN
) then
3243 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3245 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3249 Make_Object_Declaration
(Loc
,
3250 Defining_Identifier
=> Ent
,
3251 Constant_Present
=> True,
3252 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3255 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
- 1)),
3256 Right_Opnd
=> Clen
)));
3258 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3265 -- If we have only skipped null operands, return the last operand
3272 -- If we have only one non-null operand, return it and we are done.
3273 -- There is one case in which this cannot be done, and that is when
3274 -- the sole operand is of the element type, in which case it must be
3275 -- converted to an array, and the easiest way of doing that is to go
3276 -- through the normal general circuit.
3278 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3279 Result
:= Operands
(1);
3283 -- Cases where we have a real concatenation
3285 -- Next step is to find the low bound for the result array that we
3286 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3288 -- If the ultimate ancestor of the index subtype is a constrained array
3289 -- definition, then the lower bound is that of the index subtype as
3290 -- specified by (RM 4.5.3(6)).
3292 -- The right test here is to go to the root type, and then the ultimate
3293 -- ancestor is the first subtype of this root type.
3295 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3297 Make_Attribute_Reference
(Loc
,
3299 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3300 Attribute_Name
=> Name_First
);
3302 -- If the first operand in the list has known length we know that
3303 -- the lower bound of the result is the lower bound of this operand.
3305 elsif Is_Fixed_Length
(1) then
3306 Low_Bound
:= Opnd_Low_Bound
(1);
3308 -- OK, we don't know the lower bound, we have to build a horrible
3309 -- if expression node of the form
3311 -- if Cond1'Length /= 0 then
3314 -- if Opnd2'Length /= 0 then
3319 -- The nesting ends either when we hit an operand whose length is known
3320 -- at compile time, or on reaching the last operand, whose low bound we
3321 -- take unconditionally whether or not it is null. It's easiest to do
3322 -- this with a recursive procedure:
3326 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3327 -- Returns the lower bound determined by operands J .. NN
3329 ---------------------
3330 -- Get_Known_Bound --
3331 ---------------------
3333 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3335 if Is_Fixed_Length
(J
) or else J
= NN
then
3336 return New_Copy_Tree
(Opnd_Low_Bound
(J
));
3340 Make_If_Expression
(Loc
,
3341 Expressions
=> New_List
(
3345 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3347 Make_Integer_Literal
(Loc
, 0)),
3349 New_Copy_Tree
(Opnd_Low_Bound
(J
)),
3350 Get_Known_Bound
(J
+ 1)));
3352 end Get_Known_Bound
;
3355 Ent
:= Make_Temporary
(Loc
, 'L');
3358 Make_Object_Declaration
(Loc
,
3359 Defining_Identifier
=> Ent
,
3360 Constant_Present
=> True,
3361 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3362 Expression
=> Get_Known_Bound
(1)));
3364 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3368 -- Now we can safely compute the upper bound, normally
3369 -- Low_Bound + Length - 1.
3374 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3376 Make_Op_Subtract
(Loc
,
3377 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3378 Right_Opnd
=> Make_Artyp_Literal
(1))));
3380 -- Note that calculation of the high bound may cause overflow in some
3381 -- very weird cases, so in the general case we need an overflow check on
3382 -- the high bound. We can avoid this for the common case of string types
3383 -- and other types whose index is Positive, since we chose a wider range
3384 -- for the arithmetic type. If checks are suppressed we do not set the
3385 -- flag, and possibly superfluous warnings will be omitted.
3387 if Istyp
/= Standard_Positive
3388 and then not Overflow_Checks_Suppressed
(Istyp
)
3390 Activate_Overflow_Check
(High_Bound
);
3393 -- Handle the exceptional case where the result is null, in which case
3394 -- case the bounds come from the last operand (so that we get the proper
3395 -- bounds if the last operand is super-flat).
3397 if Result_May_Be_Null
then
3399 Make_If_Expression
(Loc
,
3400 Expressions
=> New_List
(
3402 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3403 Right_Opnd
=> Make_Artyp_Literal
(0)),
3404 Last_Opnd_Low_Bound
,
3408 Make_If_Expression
(Loc
,
3409 Expressions
=> New_List
(
3411 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3412 Right_Opnd
=> Make_Artyp_Literal
(0)),
3413 Last_Opnd_High_Bound
,
3417 -- Here is where we insert the saved up actions
3419 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3421 -- Now we construct an array object with appropriate bounds. We mark
3422 -- the target as internal to prevent useless initialization when
3423 -- Initialize_Scalars is enabled. Also since this is the actual result
3424 -- entity, we make sure we have debug information for the result.
3426 Ent
:= Make_Temporary
(Loc
, 'S');
3427 Set_Is_Internal
(Ent
);
3428 Set_Debug_Info_Needed
(Ent
);
3430 -- If the bound is statically known to be out of range, we do not want
3431 -- to abort, we want a warning and a runtime constraint error. Note that
3432 -- we have arranged that the result will not be treated as a static
3433 -- constant, so we won't get an illegality during this insertion.
3435 Insert_Action
(Cnode
,
3436 Make_Object_Declaration
(Loc
,
3437 Defining_Identifier
=> Ent
,
3438 Object_Definition
=>
3439 Make_Subtype_Indication
(Loc
,
3440 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3442 Make_Index_Or_Discriminant_Constraint
(Loc
,
3443 Constraints
=> New_List
(
3445 Low_Bound
=> Low_Bound
,
3446 High_Bound
=> High_Bound
))))),
3447 Suppress
=> All_Checks
);
3449 -- If the result of the concatenation appears as the initializing
3450 -- expression of an object declaration, we can just rename the
3451 -- result, rather than copying it.
3453 Set_OK_To_Rename
(Ent
);
3455 -- Catch the static out of range case now
3457 if Raises_Constraint_Error
(High_Bound
) then
3458 raise Concatenation_Error
;
3461 -- Now we will generate the assignments to do the actual concatenation
3463 -- There is one case in which we will not do this, namely when all the
3464 -- following conditions are met:
3466 -- The result type is Standard.String
3468 -- There are nine or fewer retained (non-null) operands
3470 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3471 -- and the debug flag gnatd.c is not set.
3473 -- The corresponding System.Concat_n.Str_Concat_n routine is
3474 -- available in the run time.
3476 -- If all these conditions are met then we generate a call to the
3477 -- relevant concatenation routine. The purpose of this is to avoid
3478 -- undesirable code bloat at -O0.
3480 -- If the concatenation is within the declaration of a library-level
3481 -- object, we call the built-in concatenation routines to prevent code
3482 -- bloat, regardless of the optimization level. This is space efficient
3483 -- and prevents linking problems when units are compiled with different
3484 -- optimization levels.
3486 if Atyp
= Standard_String
3487 and then NN
in 2 .. 9
3488 and then (((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3489 and then not Debug_Flag_Dot_C
)
3490 or else Library_Level_Target
)
3493 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3504 if RTE_Available
(RR
(NN
)) then
3506 Opnds
: constant List_Id
:=
3507 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3510 for J
in 1 .. NN
loop
3511 if Is_List_Member
(Operands
(J
)) then
3512 Remove
(Operands
(J
));
3515 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3517 Make_Aggregate
(Loc
,
3518 Component_Associations
=> New_List
(
3519 Make_Component_Association
(Loc
,
3520 Choices
=> New_List
(
3521 Make_Integer_Literal
(Loc
, 1)),
3522 Expression
=> Operands
(J
)))));
3525 Append_To
(Opnds
, Operands
(J
));
3529 Insert_Action
(Cnode
,
3530 Make_Procedure_Call_Statement
(Loc
,
3531 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3532 Parameter_Associations
=> Opnds
));
3534 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3541 -- Not special case so generate the assignments
3543 Known_Non_Null_Operand_Seen
:= False;
3545 for J
in 1 .. NN
loop
3547 Lo
: constant Node_Id
:=
3549 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3550 Right_Opnd
=> Aggr_Length
(J
- 1));
3552 Hi
: constant Node_Id
:=
3554 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3556 Make_Op_Subtract
(Loc
,
3557 Left_Opnd
=> Aggr_Length
(J
),
3558 Right_Opnd
=> Make_Artyp_Literal
(1)));
3561 -- Singleton case, simple assignment
3563 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3564 Known_Non_Null_Operand_Seen
:= True;
3565 Insert_Action
(Cnode
,
3566 Make_Assignment_Statement
(Loc
,
3568 Make_Indexed_Component
(Loc
,
3569 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3570 Expressions
=> New_List
(To_Ityp
(Lo
))),
3571 Expression
=> Operands
(J
)),
3572 Suppress
=> All_Checks
);
3574 -- Array case, slice assignment, skipped when argument is fixed
3575 -- length and known to be null.
3577 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3580 Make_Assignment_Statement
(Loc
,
3584 New_Occurrence_Of
(Ent
, Loc
),
3587 Low_Bound
=> To_Ityp
(Lo
),
3588 High_Bound
=> To_Ityp
(Hi
))),
3589 Expression
=> Operands
(J
));
3591 if Is_Fixed_Length
(J
) then
3592 Known_Non_Null_Operand_Seen
:= True;
3594 elsif not Known_Non_Null_Operand_Seen
then
3596 -- Here if operand length is not statically known and no
3597 -- operand known to be non-null has been processed yet.
3598 -- If operand length is 0, we do not need to perform the
3599 -- assignment, and we must avoid the evaluation of the
3600 -- high bound of the slice, since it may underflow if the
3601 -- low bound is Ityp'First.
3604 Make_Implicit_If_Statement
(Cnode
,
3608 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3609 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3610 Then_Statements
=> New_List
(Assign
));
3613 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3619 -- Finally we build the result, which is a reference to the array object
3621 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3624 Rewrite
(Cnode
, Result
);
3625 Analyze_And_Resolve
(Cnode
, Atyp
);
3628 when Concatenation_Error
=>
3630 -- Kill warning generated for the declaration of the static out of
3631 -- range high bound, and instead generate a Constraint_Error with
3632 -- an appropriate specific message.
3634 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3635 Apply_Compile_Time_Constraint_Error
3637 Msg
=> "concatenation result upper bound out of range??",
3638 Reason
=> CE_Range_Check_Failed
);
3639 end Expand_Concatenate
;
3641 ---------------------------------------------------
3642 -- Expand_Membership_Minimize_Eliminate_Overflow --
3643 ---------------------------------------------------
3645 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3646 pragma Assert
(Nkind
(N
) = N_In
);
3647 -- Despite the name, this routine applies only to N_In, not to
3648 -- N_Not_In. The latter is always rewritten as not (X in Y).
3650 Result_Type
: constant Entity_Id
:= Etype
(N
);
3651 -- Capture result type, may be a derived boolean type
3653 Loc
: constant Source_Ptr
:= Sloc
(N
);
3654 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3655 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3657 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3658 -- is thus tempting to capture these values, but due to the rewrites
3659 -- that occur as a result of overflow checking, these values change
3660 -- as we go along, and it is safe just to always use Etype explicitly.
3662 Restype
: constant Entity_Id
:= Etype
(N
);
3666 -- Bounds in Minimize calls, not used currently
3668 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3669 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3672 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3674 -- If right operand is a subtype name, and the subtype name has no
3675 -- predicate, then we can just replace the right operand with an
3676 -- explicit range T'First .. T'Last, and use the explicit range code.
3678 if Nkind
(Rop
) /= N_Range
3679 and then No
(Predicate_Function
(Etype
(Rop
)))
3682 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3687 Make_Attribute_Reference
(Loc
,
3688 Attribute_Name
=> Name_First
,
3689 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3691 Make_Attribute_Reference
(Loc
,
3692 Attribute_Name
=> Name_Last
,
3693 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3694 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3698 -- Here for the explicit range case. Note that the bounds of the range
3699 -- have not been processed for minimized or eliminated checks.
3701 if Nkind
(Rop
) = N_Range
then
3702 Minimize_Eliminate_Overflows
3703 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3704 Minimize_Eliminate_Overflows
3705 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3707 -- We have A in B .. C, treated as A >= B and then A <= C
3711 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3712 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3713 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3716 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3717 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3718 L
: constant Entity_Id
:=
3719 Make_Defining_Identifier
(Loc
, Name_uL
);
3720 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3721 Lbound
: constant Node_Id
:=
3722 Convert_To_Bignum
(Low_Bound
(Rop
));
3723 Hbound
: constant Node_Id
:=
3724 Convert_To_Bignum
(High_Bound
(Rop
));
3726 -- Now we rewrite the membership test node to look like
3729 -- Bnn : Result_Type;
3731 -- M : Mark_Id := SS_Mark;
3732 -- L : Bignum := Lopnd;
3734 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3742 -- Insert declaration of L into declarations of bignum block
3745 (Last
(Declarations
(Blk
)),
3746 Make_Object_Declaration
(Loc
,
3747 Defining_Identifier
=> L
,
3748 Object_Definition
=>
3749 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3750 Expression
=> Lopnd
));
3752 -- Insert assignment to Bnn into expressions of bignum block
3755 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3756 Make_Assignment_Statement
(Loc
,
3757 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3761 Make_Function_Call
(Loc
,
3763 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3764 Parameter_Associations
=> New_List
(
3765 New_Occurrence_Of
(L
, Loc
),
3769 Make_Function_Call
(Loc
,
3771 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3772 Parameter_Associations
=> New_List
(
3773 New_Occurrence_Of
(L
, Loc
),
3776 -- Now rewrite the node
3779 Make_Expression_With_Actions
(Loc
,
3780 Actions
=> New_List
(
3781 Make_Object_Declaration
(Loc
,
3782 Defining_Identifier
=> Bnn
,
3783 Object_Definition
=>
3784 New_Occurrence_Of
(Result_Type
, Loc
)),
3786 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3787 Analyze_And_Resolve
(N
, Result_Type
);
3791 -- Here if no bignums around
3794 -- Case where types are all the same
3796 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3798 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3802 -- If types are not all the same, it means that we have rewritten
3803 -- at least one of them to be of type Long_Long_Integer, and we
3804 -- will convert the other operands to Long_Long_Integer.
3807 Convert_To_And_Rewrite
(LLIB
, Lop
);
3808 Set_Analyzed
(Lop
, False);
3809 Analyze_And_Resolve
(Lop
, LLIB
);
3811 -- For the right operand, avoid unnecessary recursion into
3812 -- this routine, we know that overflow is not possible.
3814 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3815 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3816 Set_Analyzed
(Rop
, False);
3817 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3820 -- Now the three operands are of the same signed integer type,
3821 -- so we can use the normal expansion routine for membership,
3822 -- setting the flag to prevent recursion into this procedure.
3824 Set_No_Minimize_Eliminate
(N
);
3828 -- Right operand is a subtype name and the subtype has a predicate. We
3829 -- have to make sure the predicate is checked, and for that we need to
3830 -- use the standard N_In circuitry with appropriate types.
3833 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3835 -- If types are "right", just call Expand_N_In preventing recursion
3837 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3838 Set_No_Minimize_Eliminate
(N
);
3843 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3845 -- For X in T, we want to rewrite our node as
3848 -- Bnn : Result_Type;
3851 -- M : Mark_Id := SS_Mark;
3852 -- Lnn : Long_Long_Integer'Base
3858 -- if not Bignum_In_LLI_Range (Nnn) then
3861 -- Lnn := From_Bignum (Nnn);
3863 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3864 -- and then T'Base (Lnn) in T;
3873 -- A bit gruesome, but there doesn't seem to be a simpler way
3876 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3877 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3878 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3879 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3880 T
: constant Entity_Id
:= Etype
(Rop
);
3881 TB
: constant Entity_Id
:= Base_Type
(T
);
3885 -- Mark the last membership operation to prevent recursion
3889 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3890 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3891 Set_No_Minimize_Eliminate
(Nin
);
3893 -- Now decorate the block
3896 (Last
(Declarations
(Blk
)),
3897 Make_Object_Declaration
(Loc
,
3898 Defining_Identifier
=> Lnn
,
3899 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3902 (Last
(Declarations
(Blk
)),
3903 Make_Object_Declaration
(Loc
,
3904 Defining_Identifier
=> Nnn
,
3905 Object_Definition
=>
3906 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3909 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3911 Make_Assignment_Statement
(Loc
,
3912 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3913 Expression
=> Relocate_Node
(Lop
)),
3915 Make_Implicit_If_Statement
(N
,
3919 Make_Function_Call
(Loc
,
3922 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3923 Parameter_Associations
=> New_List
(
3924 New_Occurrence_Of
(Nnn
, Loc
)))),
3926 Then_Statements
=> New_List
(
3927 Make_Assignment_Statement
(Loc
,
3928 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3930 New_Occurrence_Of
(Standard_False
, Loc
))),
3932 Else_Statements
=> New_List
(
3933 Make_Assignment_Statement
(Loc
,
3934 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3936 Make_Function_Call
(Loc
,
3938 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3939 Parameter_Associations
=> New_List
(
3940 New_Occurrence_Of
(Nnn
, Loc
)))),
3942 Make_Assignment_Statement
(Loc
,
3943 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3948 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3953 Make_Attribute_Reference
(Loc
,
3954 Attribute_Name
=> Name_First
,
3956 New_Occurrence_Of
(TB
, Loc
))),
3960 Make_Attribute_Reference
(Loc
,
3961 Attribute_Name
=> Name_Last
,
3963 New_Occurrence_Of
(TB
, Loc
))))),
3965 Right_Opnd
=> Nin
))))));
3967 -- Now we can do the rewrite
3970 Make_Expression_With_Actions
(Loc
,
3971 Actions
=> New_List
(
3972 Make_Object_Declaration
(Loc
,
3973 Defining_Identifier
=> Bnn
,
3974 Object_Definition
=>
3975 New_Occurrence_Of
(Result_Type
, Loc
)),
3977 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3978 Analyze_And_Resolve
(N
, Result_Type
);
3982 -- Not bignum case, but types don't match (this means we rewrote the
3983 -- left operand to be Long_Long_Integer).
3986 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
3988 -- We rewrite the membership test as (where T is the type with
3989 -- the predicate, i.e. the type of the right operand)
3991 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3992 -- and then T'Base (Lop) in T
3995 T
: constant Entity_Id
:= Etype
(Rop
);
3996 TB
: constant Entity_Id
:= Base_Type
(T
);
4000 -- The last membership test is marked to prevent recursion
4004 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
4005 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4006 Set_No_Minimize_Eliminate
(Nin
);
4008 -- Now do the rewrite
4019 Make_Attribute_Reference
(Loc
,
4020 Attribute_Name
=> Name_First
,
4022 New_Occurrence_Of
(TB
, Loc
))),
4025 Make_Attribute_Reference
(Loc
,
4026 Attribute_Name
=> Name_Last
,
4028 New_Occurrence_Of
(TB
, Loc
))))),
4029 Right_Opnd
=> Nin
));
4030 Set_Analyzed
(N
, False);
4031 Analyze_And_Resolve
(N
, Restype
);
4035 end Expand_Membership_Minimize_Eliminate_Overflow
;
4037 ---------------------------------
4038 -- Expand_Nonbinary_Modular_Op --
4039 ---------------------------------
4041 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
) is
4042 Loc
: constant Source_Ptr
:= Sloc
(N
);
4043 Typ
: constant Entity_Id
:= Etype
(N
);
4045 procedure Expand_Modular_Addition
;
4046 -- Expand the modular addition, handling the special case of adding a
4049 procedure Expand_Modular_Op
;
4050 -- Compute the general rule: (lhs OP rhs) mod Modulus
4052 procedure Expand_Modular_Subtraction
;
4053 -- Expand the modular addition, handling the special case of subtracting
4056 -----------------------------
4057 -- Expand_Modular_Addition --
4058 -----------------------------
4060 procedure Expand_Modular_Addition
is
4062 -- If this is not the addition of a constant then compute it using
4063 -- the general rule: (lhs + rhs) mod Modulus
4065 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4068 -- If this is an addition of a constant, convert it to a subtraction
4069 -- plus a conditional expression since we can compute it faster than
4070 -- computing the modulus.
4072 -- modMinusRhs = Modulus - rhs
4073 -- if lhs < modMinusRhs then lhs + rhs
4074 -- else lhs - modMinusRhs
4078 Mod_Minus_Right
: constant Uint
:=
4079 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4081 Exprs
: constant List_Id
:= New_List
;
4082 Cond_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Lt
, Loc
);
4083 Then_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Add
, Loc
);
4084 Else_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Subtract
,
4087 -- To prevent spurious visibility issues, convert all
4088 -- operands to Standard.Unsigned.
4090 Set_Left_Opnd
(Cond_Expr
,
4091 Unchecked_Convert_To
(Standard_Unsigned
,
4092 New_Copy_Tree
(Left_Opnd
(N
))));
4093 Set_Right_Opnd
(Cond_Expr
,
4094 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4095 Append_To
(Exprs
, Cond_Expr
);
4097 Set_Left_Opnd
(Then_Expr
,
4098 Unchecked_Convert_To
(Standard_Unsigned
,
4099 New_Copy_Tree
(Left_Opnd
(N
))));
4100 Set_Right_Opnd
(Then_Expr
,
4101 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4102 Append_To
(Exprs
, Then_Expr
);
4104 Set_Left_Opnd
(Else_Expr
,
4105 Unchecked_Convert_To
(Standard_Unsigned
,
4106 New_Copy_Tree
(Left_Opnd
(N
))));
4107 Set_Right_Opnd
(Else_Expr
,
4108 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4109 Append_To
(Exprs
, Else_Expr
);
4112 Unchecked_Convert_To
(Typ
,
4113 Make_If_Expression
(Loc
, Expressions
=> Exprs
)));
4116 end Expand_Modular_Addition
;
4118 -----------------------
4119 -- Expand_Modular_Op --
4120 -----------------------
4122 procedure Expand_Modular_Op
is
4123 Op_Expr
: constant Node_Id
:= New_Op_Node
(Nkind
(N
), Loc
);
4124 Mod_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Mod
, Loc
);
4126 Target_Type
: Entity_Id
;
4129 -- Convert nonbinary modular type operands into integer values. Thus
4130 -- we avoid never-ending loops expanding them, and we also ensure
4131 -- the back end never receives nonbinary modular type expressions.
4133 if Nkind_In
(Nkind
(N
), N_Op_And
, N_Op_Or
, N_Op_Xor
) then
4134 Set_Left_Opnd
(Op_Expr
,
4135 Unchecked_Convert_To
(Standard_Unsigned
,
4136 New_Copy_Tree
(Left_Opnd
(N
))));
4137 Set_Right_Opnd
(Op_Expr
,
4138 Unchecked_Convert_To
(Standard_Unsigned
,
4139 New_Copy_Tree
(Right_Opnd
(N
))));
4140 Set_Left_Opnd
(Mod_Expr
,
4141 Unchecked_Convert_To
(Standard_Integer
, Op_Expr
));
4144 -- If the modulus of the type is larger than Integer'Last use a
4145 -- larger type for the operands, to prevent spurious constraint
4146 -- errors on large legal literals of the type.
4148 if Modulus
(Etype
(N
)) > UI_From_Int
(Int
(Integer'Last)) then
4149 Target_Type
:= Standard_Long_Integer
;
4151 Target_Type
:= Standard_Integer
;
4154 Set_Left_Opnd
(Op_Expr
,
4155 Unchecked_Convert_To
(Target_Type
,
4156 New_Copy_Tree
(Left_Opnd
(N
))));
4157 Set_Right_Opnd
(Op_Expr
,
4158 Unchecked_Convert_To
(Target_Type
,
4159 New_Copy_Tree
(Right_Opnd
(N
))));
4161 -- Link this node to the tree to analyze it
4163 -- If the parent node is an expression with actions we link it to
4164 -- N since otherwise Force_Evaluation cannot identify if this node
4165 -- comes from the Expression and rejects generating the temporary.
4167 if Nkind
(Parent
(N
)) = N_Expression_With_Actions
then
4168 Set_Parent
(Op_Expr
, N
);
4173 Set_Parent
(Op_Expr
, Parent
(N
));
4178 -- Force generating a temporary because in the expansion of this
4179 -- expression we may generate code that performs this computation
4182 Force_Evaluation
(Op_Expr
, Mode
=> Strict
);
4184 Set_Left_Opnd
(Mod_Expr
, Op_Expr
);
4187 Set_Right_Opnd
(Mod_Expr
,
4188 Make_Integer_Literal
(Loc
, Modulus
(Typ
)));
4191 Unchecked_Convert_To
(Typ
, Mod_Expr
));
4192 end Expand_Modular_Op
;
4194 --------------------------------
4195 -- Expand_Modular_Subtraction --
4196 --------------------------------
4198 procedure Expand_Modular_Subtraction
is
4200 -- If this is not the addition of a constant then compute it using
4201 -- the general rule: (lhs + rhs) mod Modulus
4203 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4206 -- If this is an addition of a constant, convert it to a subtraction
4207 -- plus a conditional expression since we can compute it faster than
4208 -- computing the modulus.
4210 -- modMinusRhs = Modulus - rhs
4211 -- if lhs < rhs then lhs + modMinusRhs
4216 Mod_Minus_Right
: constant Uint
:=
4217 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4219 Exprs
: constant List_Id
:= New_List
;
4220 Cond_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Lt
, Loc
);
4221 Then_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Add
, Loc
);
4222 Else_Expr
: constant Node_Id
:= New_Op_Node
(N_Op_Subtract
,
4225 Set_Left_Opnd
(Cond_Expr
,
4226 Unchecked_Convert_To
(Standard_Unsigned
,
4227 New_Copy_Tree
(Left_Opnd
(N
))));
4228 Set_Right_Opnd
(Cond_Expr
,
4229 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4230 Append_To
(Exprs
, Cond_Expr
);
4232 Set_Left_Opnd
(Then_Expr
,
4233 Unchecked_Convert_To
(Standard_Unsigned
,
4234 New_Copy_Tree
(Left_Opnd
(N
))));
4235 Set_Right_Opnd
(Then_Expr
,
4236 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4237 Append_To
(Exprs
, Then_Expr
);
4239 Set_Left_Opnd
(Else_Expr
,
4240 Unchecked_Convert_To
(Standard_Unsigned
,
4241 New_Copy_Tree
(Left_Opnd
(N
))));
4242 Set_Right_Opnd
(Else_Expr
,
4243 Unchecked_Convert_To
(Standard_Unsigned
,
4244 New_Copy_Tree
(Right_Opnd
(N
))));
4245 Append_To
(Exprs
, Else_Expr
);
4248 Unchecked_Convert_To
(Typ
,
4249 Make_If_Expression
(Loc
, Expressions
=> Exprs
)));
4252 end Expand_Modular_Subtraction
;
4254 -- Start of processing for Expand_Nonbinary_Modular_Op
4257 -- No action needed if front-end expansion is not required or if we
4258 -- have a binary modular operand.
4260 if not Expand_Nonbinary_Modular_Ops
4261 or else not Non_Binary_Modulus
(Typ
)
4268 Expand_Modular_Addition
;
4270 when N_Op_Subtract
=>
4271 Expand_Modular_Subtraction
;
4275 -- Expand -expr into (0 - expr)
4278 Make_Op_Subtract
(Loc
,
4279 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
4280 Right_Opnd
=> Right_Opnd
(N
)));
4281 Analyze_And_Resolve
(N
, Typ
);
4287 Analyze_And_Resolve
(N
, Typ
);
4288 end Expand_Nonbinary_Modular_Op
;
4290 ------------------------
4291 -- Expand_N_Allocator --
4292 ------------------------
4294 procedure Expand_N_Allocator
(N
: Node_Id
) is
4295 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4296 Loc
: constant Source_Ptr
:= Sloc
(N
);
4297 PtrT
: constant Entity_Id
:= Etype
(N
);
4299 procedure Rewrite_Coextension
(N
: Node_Id
);
4300 -- Static coextensions have the same lifetime as the entity they
4301 -- constrain. Such occurrences can be rewritten as aliased objects
4302 -- and their unrestricted access used instead of the coextension.
4304 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4305 -- Given a constrained array type E, returns a node representing the
4306 -- code to compute a close approximation of the size in storage elements
4307 -- for the given type; for indexes that are modular types we compute
4308 -- 'Last - First (instead of 'Length) because for large arrays computing
4309 -- 'Last -'First + 1 causes overflow. This is done without using the
4310 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4313 -------------------------
4314 -- Rewrite_Coextension --
4315 -------------------------
4317 procedure Rewrite_Coextension
(N
: Node_Id
) is
4318 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4319 Temp_Decl
: Node_Id
;
4323 -- Cnn : aliased Etyp;
4326 Make_Object_Declaration
(Loc
,
4327 Defining_Identifier
=> Temp_Id
,
4328 Aliased_Present
=> True,
4329 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4331 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4332 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4335 Insert_Action
(N
, Temp_Decl
);
4337 Make_Attribute_Reference
(Loc
,
4338 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4339 Attribute_Name
=> Name_Unrestricted_Access
));
4341 Analyze_And_Resolve
(N
, PtrT
);
4342 end Rewrite_Coextension
;
4344 ------------------------------
4345 -- Size_In_Storage_Elements --
4346 ------------------------------
4348 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4350 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4351 -- However, the reason for the existence of this function is
4352 -- to construct a test for sizes too large, which means near the
4353 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4354 -- is that we get overflows when sizes are greater than 2**31.
4356 -- So what we end up doing for array types is to use the expression:
4358 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4360 -- which avoids this problem. All this is a bit bogus, but it does
4361 -- mean we catch common cases of trying to allocate arrays that
4362 -- are too large, and which in the absence of a check results in
4363 -- undetected chaos ???
4365 -- Note in particular that this is a pessimistic estimate in the
4366 -- case of packed array types, where an array element might occupy
4367 -- just a fraction of a storage element???
4370 Idx
: Node_Id
:= First_Index
(E
);
4373 pragma Warnings
(Off
, Res
);
4376 for J
in 1 .. Number_Dimensions
(E
) loop
4378 if not Is_Modular_Integer_Type
(Etype
(Idx
)) then
4380 Make_Attribute_Reference
(Loc
,
4381 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4382 Attribute_Name
=> Name_Length
,
4383 Expressions
=> New_List
4384 (Make_Integer_Literal
(Loc
, J
)));
4386 -- For indexes that are modular types we cannot generate code
4387 -- to compute 'Length since for large arrays 'Last -'First + 1
4388 -- causes overflow; therefore we compute 'Last - 'First (which
4389 -- is not the exact number of components but it is valid for
4390 -- the purpose of this runtime check on 32-bit targets).
4394 Len_Minus_1_Expr
: Node_Id
;
4400 Make_Attribute_Reference
(Loc
,
4401 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4402 Attribute_Name
=> Name_Last
,
4404 New_List
(Make_Integer_Literal
(Loc
, J
))),
4405 Make_Attribute_Reference
(Loc
,
4406 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4407 Attribute_Name
=> Name_First
,
4409 New_List
(Make_Integer_Literal
(Loc
, J
))));
4412 Convert_To
(Standard_Unsigned
,
4413 Make_Op_Subtract
(Loc
,
4414 Make_Attribute_Reference
(Loc
,
4415 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4416 Attribute_Name
=> Name_Last
,
4419 (Make_Integer_Literal
(Loc
, J
))),
4420 Make_Attribute_Reference
(Loc
,
4421 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4422 Attribute_Name
=> Name_First
,
4425 (Make_Integer_Literal
(Loc
, J
)))));
4427 -- Handle superflat arrays, i.e. arrays with such bounds
4428 -- as 4 .. 2, to ensure that the result is correct.
4431 -- (if X'Last > X'First then X'Last - X'First else 0)
4434 Make_If_Expression
(Loc
,
4435 Expressions
=> New_List
(
4438 Make_Integer_Literal
(Loc
, Uint_0
)));
4447 Make_Op_Multiply
(Loc
,
4456 Make_Op_Multiply
(Loc
,
4459 Make_Attribute_Reference
(Loc
,
4460 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4461 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4463 end Size_In_Storage_Elements
;
4467 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4471 Rel_Typ
: Entity_Id
;
4474 -- Start of processing for Expand_N_Allocator
4477 -- Warn on the presence of an allocator of an anonymous access type when
4478 -- enabled, except when it's an object declaration at library level.
4480 if Warn_On_Anonymous_Allocators
4481 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
4482 and then not (Is_Library_Level_Entity
(PtrT
)
4483 and then Nkind
(Associated_Node_For_Itype
(PtrT
)) =
4484 N_Object_Declaration
)
4486 Error_Msg_N
("?use of an anonymous access type allocator", N
);
4489 -- RM E.2.3(22). We enforce that the expected type of an allocator
4490 -- shall not be a remote access-to-class-wide-limited-private type
4492 -- Why is this being done at expansion time, seems clearly wrong ???
4494 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4496 -- Processing for anonymous access-to-controlled types. These access
4497 -- types receive a special finalization master which appears in the
4498 -- declarations of the enclosing semantic unit. This expansion is done
4499 -- now to ensure that any additional types generated by this routine or
4500 -- Expand_Allocator_Expression inherit the proper type attributes.
4502 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4503 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4504 and then Needs_Finalization
(Dtyp
)
4506 -- Detect the allocation of an anonymous controlled object where the
4507 -- type of the context is named. For example:
4509 -- procedure Proc (Ptr : Named_Access_Typ);
4510 -- Proc (new Designated_Typ);
4512 -- Regardless of the anonymous-to-named access type conversion, the
4513 -- lifetime of the object must be associated with the named access
4514 -- type. Use the finalization-related attributes of this type.
4516 if Nkind_In
(Parent
(N
), N_Type_Conversion
,
4517 N_Unchecked_Type_Conversion
)
4518 and then Ekind_In
(Etype
(Parent
(N
)), E_Access_Subtype
,
4520 E_General_Access_Type
)
4522 Rel_Typ
:= Etype
(Parent
(N
));
4527 -- Anonymous access-to-controlled types allocate on the global pool.
4528 -- Note that this is a "root type only" attribute.
4530 if No
(Associated_Storage_Pool
(PtrT
)) then
4531 if Present
(Rel_Typ
) then
4532 Set_Associated_Storage_Pool
4533 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4535 Set_Associated_Storage_Pool
4536 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4540 -- The finalization master must be inserted and analyzed as part of
4541 -- the current semantic unit. Note that the master is updated when
4542 -- analysis changes current units. Note that this is a "root type
4545 if Present
(Rel_Typ
) then
4546 Set_Finalization_Master
4547 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4549 Build_Anonymous_Master
(Root_Type
(PtrT
));
4553 -- Set the storage pool and find the appropriate version of Allocate to
4554 -- call. Do not overwrite the storage pool if it is already set, which
4555 -- can happen for build-in-place function returns (see
4556 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4558 if No
(Storage_Pool
(N
)) then
4559 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4561 if Present
(Pool
) then
4562 Set_Storage_Pool
(N
, Pool
);
4564 if Is_RTE
(Pool
, RE_SS_Pool
) then
4565 Check_Restriction
(No_Secondary_Stack
, N
);
4566 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4568 -- In the case of an allocator for a simple storage pool, locate
4569 -- and save a reference to the pool type's Allocate routine.
4571 elsif Present
(Get_Rep_Pragma
4572 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4575 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4576 Alloc_Op
: Entity_Id
;
4578 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4579 while Present
(Alloc_Op
) loop
4580 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4581 and then Present
(First_Formal
(Alloc_Op
))
4582 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4584 Set_Procedure_To_Call
(N
, Alloc_Op
);
4587 Alloc_Op
:= Homonym
(Alloc_Op
);
4592 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4593 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4596 Set_Procedure_To_Call
(N
,
4597 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4602 -- Under certain circumstances we can replace an allocator by an access
4603 -- to statically allocated storage. The conditions, as noted in AARM
4604 -- 3.10 (10c) are as follows:
4606 -- Size and initial value is known at compile time
4607 -- Access type is access-to-constant
4609 -- The allocator is not part of a constraint on a record component,
4610 -- because in that case the inserted actions are delayed until the
4611 -- record declaration is fully analyzed, which is too late for the
4612 -- analysis of the rewritten allocator.
4614 if Is_Access_Constant
(PtrT
)
4615 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4616 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4617 and then Size_Known_At_Compile_Time
4618 (Etype
(Expression
(Expression
(N
))))
4619 and then not Is_Record_Type
(Current_Scope
)
4621 -- Here we can do the optimization. For the allocator
4625 -- We insert an object declaration
4627 -- Tnn : aliased x := y;
4629 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4630 -- marked as requiring static allocation.
4632 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4633 Desig
:= Subtype_Mark
(Expression
(N
));
4635 -- If context is constrained, use constrained subtype directly,
4636 -- so that the constant is not labelled as having a nominally
4637 -- unconstrained subtype.
4639 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4640 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4644 Make_Object_Declaration
(Loc
,
4645 Defining_Identifier
=> Temp
,
4646 Aliased_Present
=> True,
4647 Constant_Present
=> Is_Access_Constant
(PtrT
),
4648 Object_Definition
=> Desig
,
4649 Expression
=> Expression
(Expression
(N
))));
4652 Make_Attribute_Reference
(Loc
,
4653 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4654 Attribute_Name
=> Name_Unrestricted_Access
));
4656 Analyze_And_Resolve
(N
, PtrT
);
4658 -- We set the variable as statically allocated, since we don't want
4659 -- it going on the stack of the current procedure.
4661 Set_Is_Statically_Allocated
(Temp
);
4665 -- Same if the allocator is an access discriminant for a local object:
4666 -- instead of an allocator we create a local value and constrain the
4667 -- enclosing object with the corresponding access attribute.
4669 if Is_Static_Coextension
(N
) then
4670 Rewrite_Coextension
(N
);
4674 -- Check for size too large, we do this because the back end misses
4675 -- proper checks here and can generate rubbish allocation calls when
4676 -- we are near the limit. We only do this for the 32-bit address case
4677 -- since that is from a practical point of view where we see a problem.
4679 if System_Address_Size
= 32
4680 and then not Storage_Checks_Suppressed
(PtrT
)
4681 and then not Storage_Checks_Suppressed
(Dtyp
)
4682 and then not Storage_Checks_Suppressed
(Etyp
)
4684 -- The check we want to generate should look like
4686 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4687 -- raise Storage_Error;
4690 -- where 3.5 gigabytes is a constant large enough to accommodate any
4691 -- reasonable request for. But we can't do it this way because at
4692 -- least at the moment we don't compute this attribute right, and
4693 -- can silently give wrong results when the result gets large. Since
4694 -- this is all about large results, that's bad, so instead we only
4695 -- apply the check for constrained arrays, and manually compute the
4696 -- value of the attribute ???
4698 -- The check on No_Initialization is used here to prevent generating
4699 -- this runtime check twice when the allocator is locally replaced by
4700 -- the expander with another one.
4702 if Is_Array_Type
(Etyp
) and then not No_Initialization
(N
) then
4705 Ins_Nod
: Node_Id
:= N
;
4706 Siz_Typ
: Entity_Id
:= Etyp
;
4710 -- For unconstrained array types initialized with a qualified
4711 -- expression we use its type to perform this check
4713 if not Is_Constrained
(Etyp
)
4714 and then not No_Initialization
(N
)
4715 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4717 Expr
:= Expression
(Expression
(N
));
4718 Siz_Typ
:= Etype
(Expression
(Expression
(N
)));
4720 -- If the qualified expression has been moved to an internal
4721 -- temporary (to remove side effects) then we must insert
4722 -- the runtime check before its declaration to ensure that
4723 -- the check is performed before the execution of the code
4724 -- computing the qualified expression.
4726 if Nkind
(Expr
) = N_Identifier
4727 and then Is_Internal_Name
(Chars
(Expr
))
4729 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
4731 Ins_Nod
:= Parent
(Entity
(Expr
));
4737 if Is_Constrained
(Siz_Typ
)
4738 and then Ekind
(Siz_Typ
) /= E_String_Literal_Subtype
4740 -- For CCG targets, the largest array may have up to 2**31-1
4741 -- components (i.e. 2 gigabytes if each array component is
4742 -- one byte). This ensures that fat pointer fields do not
4743 -- overflow, since they are 32-bit integer types, and also
4744 -- ensures that 'Length can be computed at run time.
4746 if Modify_Tree_For_C
then
4749 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4750 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4751 Uint_2
** 31 - Uint_1
));
4753 -- For native targets the largest object is 3.5 gigabytes
4758 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4759 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4760 Uint_7
* (Uint_2
** 29)));
4763 Insert_Action
(Ins_Nod
,
4764 Make_Raise_Storage_Error
(Loc
,
4766 Reason
=> SE_Object_Too_Large
));
4768 if Entity
(Cond
) = Standard_True
then
4770 ("object too large: Storage_Error will be raised at "
4778 -- If no storage pool has been specified, or the storage pool
4779 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4780 -- No_Standard_Allocators_After_Elaboration is present, then generate
4781 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4783 if Nkind
(N
) = N_Allocator
4784 and then (No
(Storage_Pool
(N
))
4785 or else Is_RTE
(Storage_Pool
(N
), RE_Global_Pool_Object
))
4786 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4789 Make_Procedure_Call_Statement
(Loc
,
4791 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4794 -- Handle case of qualified expression (other than optimization above)
4795 -- First apply constraint checks, because the bounds or discriminants
4796 -- in the aggregate might not match the subtype mark in the allocator.
4798 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4800 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
4801 Typ
: constant Entity_Id
:= Etype
(Expression
(N
));
4804 Apply_Constraint_Check
(Exp
, Typ
);
4805 Apply_Predicate_Check
(Exp
, Typ
);
4808 Expand_Allocator_Expression
(N
);
4812 -- If the allocator is for a type which requires initialization, and
4813 -- there is no initial value (i.e. operand is a subtype indication
4814 -- rather than a qualified expression), then we must generate a call to
4815 -- the initialization routine using an expressions action node:
4817 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4819 -- Here ptr_T is the pointer type for the allocator, and T is the
4820 -- subtype of the allocator. A special case arises if the designated
4821 -- type of the access type is a task or contains tasks. In this case
4822 -- the call to Init (Temp.all ...) is replaced by code that ensures
4823 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4824 -- for details). In addition, if the type T is a task type, then the
4825 -- first argument to Init must be converted to the task record type.
4828 T
: constant Entity_Id
:= Etype
(Expression
(N
));
4834 Init_Arg1
: Node_Id
;
4835 Init_Call
: Node_Id
;
4836 Temp_Decl
: Node_Id
;
4837 Temp_Type
: Entity_Id
;
4840 if No_Initialization
(N
) then
4842 -- Even though this might be a simple allocation, create a custom
4843 -- Allocate if the context requires it.
4845 if Present
(Finalization_Master
(PtrT
)) then
4846 Build_Allocate_Deallocate_Proc
4848 Is_Allocate
=> True);
4851 -- Optimize the default allocation of an array object when pragma
4852 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4853 -- in-place initialization aggregate which may be convert into a fast
4854 -- memset by the backend.
4856 elsif Init_Or_Norm_Scalars
4857 and then Is_Array_Type
(T
)
4859 -- The array must lack atomic components because they are treated
4860 -- as non-static, and as a result the backend will not initialize
4861 -- the memory in one go.
4863 and then not Has_Atomic_Components
(T
)
4865 -- The array must not be packed because the invalid values in
4866 -- System.Scalar_Values are multiples of Storage_Unit.
4868 and then not Is_Packed
(T
)
4870 -- The array must have static non-empty ranges, otherwise the
4871 -- backend cannot initialize the memory in one go.
4873 and then Has_Static_Non_Empty_Array_Bounds
(T
)
4875 -- The optimization is only relevant for arrays of scalar types
4877 and then Is_Scalar_Type
(Component_Type
(T
))
4879 -- Similar to regular array initialization using a type init proc,
4880 -- predicate checks are not performed because the initialization
4881 -- values are intentionally invalid, and may violate the predicate.
4883 and then not Has_Predicates
(Component_Type
(T
))
4885 -- The component type must have a single initialization value
4887 and then Needs_Simple_Initialization
4888 (Typ
=> Component_Type
(T
),
4889 Consider_IS
=> True)
4892 Temp
:= Make_Temporary
(Loc
, 'P');
4895 -- Temp : Ptr_Typ := new ...;
4900 Make_Object_Declaration
(Loc
,
4901 Defining_Identifier
=> Temp
,
4902 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
4903 Expression
=> Relocate_Node
(N
)),
4904 Suppress
=> All_Checks
);
4907 -- Temp.all := (others => ...);
4912 Make_Assignment_Statement
(Loc
,
4914 Make_Explicit_Dereference
(Loc
,
4915 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
4920 Size
=> Esize
(Component_Type
(T
)))),
4921 Suppress
=> All_Checks
);
4923 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4924 Analyze_And_Resolve
(N
, PtrT
);
4926 -- Case of no initialization procedure present
4928 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4930 -- Case of simple initialization required
4932 if Needs_Simple_Initialization
(T
) then
4933 Check_Restriction
(No_Default_Initialization
, N
);
4934 Rewrite
(Expression
(N
),
4935 Make_Qualified_Expression
(Loc
,
4936 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4937 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4939 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4940 Analyze_And_Resolve
(Expression
(N
), T
);
4941 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4942 Expand_N_Allocator
(N
);
4944 -- No initialization required
4947 Build_Allocate_Deallocate_Proc
4949 Is_Allocate
=> True);
4952 -- Case of initialization procedure present, must be called
4954 -- NOTE: There is a *huge* amount of code duplication here from
4955 -- Build_Initialization_Call. We should probably refactor???
4958 Check_Restriction
(No_Default_Initialization
, N
);
4960 if not Restriction_Active
(No_Default_Initialization
) then
4961 Init
:= Base_Init_Proc
(T
);
4963 Temp
:= Make_Temporary
(Loc
, 'P');
4965 -- Construct argument list for the initialization routine call
4968 Make_Explicit_Dereference
(Loc
,
4970 New_Occurrence_Of
(Temp
, Loc
));
4972 Set_Assignment_OK
(Init_Arg1
);
4975 -- The initialization procedure expects a specific type. if the
4976 -- context is access to class wide, indicate that the object
4977 -- being allocated has the right specific type.
4979 if Is_Class_Wide_Type
(Dtyp
) then
4980 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4983 -- If designated type is a concurrent type or if it is private
4984 -- type whose definition is a concurrent type, the first
4985 -- argument in the Init routine has to be unchecked conversion
4986 -- to the corresponding record type. If the designated type is
4987 -- a derived type, also convert the argument to its root type.
4989 if Is_Concurrent_Type
(T
) then
4991 Unchecked_Convert_To
(
4992 Corresponding_Record_Type
(T
), Init_Arg1
);
4994 elsif Is_Private_Type
(T
)
4995 and then Present
(Full_View
(T
))
4996 and then Is_Concurrent_Type
(Full_View
(T
))
4999 Unchecked_Convert_To
5000 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
5002 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
5004 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
5007 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
5008 Set_Etype
(Init_Arg1
, Ftyp
);
5012 Args
:= New_List
(Init_Arg1
);
5014 -- For the task case, pass the Master_Id of the access type as
5015 -- the value of the _Master parameter, and _Chain as the value
5016 -- of the _Chain parameter (_Chain will be defined as part of
5017 -- the generated code for the allocator).
5019 -- In Ada 2005, the context may be a function that returns an
5020 -- anonymous access type. In that case the Master_Id has been
5021 -- created when expanding the function declaration.
5023 if Has_Task
(T
) then
5024 if No
(Master_Id
(Base_Type
(PtrT
))) then
5026 -- The designated type was an incomplete type, and the
5027 -- access type did not get expanded. Salvage it now.
5029 if not Restriction_Active
(No_Task_Hierarchy
) then
5030 if Present
(Parent
(Base_Type
(PtrT
))) then
5031 Expand_N_Full_Type_Declaration
5032 (Parent
(Base_Type
(PtrT
)));
5034 -- The only other possibility is an itype. For this
5035 -- case, the master must exist in the context. This is
5036 -- the case when the allocator initializes an access
5037 -- component in an init-proc.
5040 pragma Assert
(Is_Itype
(PtrT
));
5041 Build_Master_Renaming
(PtrT
, N
);
5046 -- If the context of the allocator is a declaration or an
5047 -- assignment, we can generate a meaningful image for it,
5048 -- even though subsequent assignments might remove the
5049 -- connection between task and entity. We build this image
5050 -- when the left-hand side is a simple variable, a simple
5051 -- indexed assignment or a simple selected component.
5053 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
5055 Nam
: constant Node_Id
:= Name
(Parent
(N
));
5058 if Is_Entity_Name
(Nam
) then
5060 Build_Task_Image_Decls
5063 (Entity
(Nam
), Sloc
(Nam
)), T
);
5065 elsif Nkind_In
(Nam
, N_Indexed_Component
,
5066 N_Selected_Component
)
5067 and then Is_Entity_Name
(Prefix
(Nam
))
5070 Build_Task_Image_Decls
5071 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
5073 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
5077 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
5079 Build_Task_Image_Decls
5080 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
5083 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
5086 if Restriction_Active
(No_Task_Hierarchy
) then
5088 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
5092 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
5095 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
5097 Decl
:= Last
(Decls
);
5099 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
5101 -- Has_Task is false, Decls not used
5107 -- Add discriminants if discriminated type
5110 Dis
: Boolean := False;
5111 Typ
: Entity_Id
:= Empty
;
5114 if Has_Discriminants
(T
) then
5118 -- Type may be a private type with no visible discriminants
5119 -- in which case check full view if in scope, or the
5120 -- underlying_full_view if dealing with a type whose full
5121 -- view may be derived from a private type whose own full
5122 -- view has discriminants.
5124 elsif Is_Private_Type
(T
) then
5125 if Present
(Full_View
(T
))
5126 and then Has_Discriminants
(Full_View
(T
))
5129 Typ
:= Full_View
(T
);
5131 elsif Present
(Underlying_Full_View
(T
))
5132 and then Has_Discriminants
(Underlying_Full_View
(T
))
5135 Typ
:= Underlying_Full_View
(T
);
5141 -- If the allocated object will be constrained by the
5142 -- default values for discriminants, then build a subtype
5143 -- with those defaults, and change the allocated subtype
5144 -- to that. Note that this happens in fewer cases in Ada
5147 if not Is_Constrained
(Typ
)
5148 and then Present
(Discriminant_Default_Value
5149 (First_Discriminant
(Typ
)))
5150 and then (Ada_Version
< Ada_2005
5152 Object_Type_Has_Constrained_Partial_View
5153 (Typ
, Current_Scope
))
5155 Typ
:= Build_Default_Subtype
(Typ
, N
);
5156 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
5159 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
5160 while Present
(Discr
) loop
5161 Nod
:= Node
(Discr
);
5162 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
5164 -- AI-416: when the discriminant constraint is an
5165 -- anonymous access type make sure an accessibility
5166 -- check is inserted if necessary (3.10.2(22.q/2))
5168 if Ada_Version
>= Ada_2005
5170 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
5172 Apply_Accessibility_Check
5173 (Nod
, Typ
, Insert_Node
=> Nod
);
5181 -- We set the allocator as analyzed so that when we analyze
5182 -- the if expression node, we do not get an unwanted recursive
5183 -- expansion of the allocator expression.
5185 Set_Analyzed
(N
, True);
5186 Nod
:= Relocate_Node
(N
);
5188 -- Here is the transformation:
5189 -- input: new Ctrl_Typ
5190 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5191 -- Ctrl_TypIP (Temp.all, ...);
5192 -- [Deep_]Initialize (Temp.all);
5194 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5195 -- is the subtype of the allocator.
5198 Make_Object_Declaration
(Loc
,
5199 Defining_Identifier
=> Temp
,
5200 Constant_Present
=> True,
5201 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
5204 Set_Assignment_OK
(Temp_Decl
);
5205 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
5207 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
5209 -- If the designated type is a task type or contains tasks,
5210 -- create block to activate created tasks, and insert
5211 -- declaration for Task_Image variable ahead of call.
5213 if Has_Task
(T
) then
5215 L
: constant List_Id
:= New_List
;
5218 Build_Task_Allocate_Block
(L
, Nod
, Args
);
5220 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
5221 Insert_Actions
(N
, L
);
5226 Make_Procedure_Call_Statement
(Loc
,
5227 Name
=> New_Occurrence_Of
(Init
, Loc
),
5228 Parameter_Associations
=> Args
));
5231 if Needs_Finalization
(T
) then
5234 -- [Deep_]Initialize (Init_Arg1);
5238 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
5241 -- Guard against a missing [Deep_]Initialize when the
5242 -- designated type was not properly frozen.
5244 if Present
(Init_Call
) then
5245 Insert_Action
(N
, Init_Call
);
5249 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5250 Analyze_And_Resolve
(N
, PtrT
);
5255 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5256 -- object that has been rewritten as a reference, we displace "this"
5257 -- to reference properly its secondary dispatch table.
5259 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
5260 Displace_Allocator_Pointer
(N
);
5264 when RE_Not_Available
=>
5266 end Expand_N_Allocator
;
5268 -----------------------
5269 -- Expand_N_And_Then --
5270 -----------------------
5272 procedure Expand_N_And_Then
(N
: Node_Id
)
5273 renames Expand_Short_Circuit_Operator
;
5275 ------------------------------
5276 -- Expand_N_Case_Expression --
5277 ------------------------------
5279 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
5280 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean;
5281 -- Return True if we can copy objects of this type when expanding a case
5288 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean is
5290 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5291 -- large objects, as long as they are constrained and not limited.
5294 Is_Elementary_Type
(Underlying_Type
(Typ
))
5296 (Minimize_Expression_With_Actions
5297 and then Is_Constrained
(Underlying_Type
(Typ
))
5298 and then not Is_Limited_Type
(Underlying_Type
(Typ
)));
5303 Loc
: constant Source_Ptr
:= Sloc
(N
);
5304 Par
: constant Node_Id
:= Parent
(N
);
5305 Typ
: constant Entity_Id
:= Etype
(N
);
5309 Case_Stmt
: Node_Id
;
5313 Target_Typ
: Entity_Id
;
5315 In_Predicate
: Boolean := False;
5316 -- Flag set when the case expression appears within a predicate
5318 Optimize_Return_Stmt
: Boolean := False;
5319 -- Flag set when the case expression can be optimized in the context of
5320 -- a simple return statement.
5322 -- Start of processing for Expand_N_Case_Expression
5325 -- Check for MINIMIZED/ELIMINATED overflow mode
5327 if Minimized_Eliminated_Overflow_Check
(N
) then
5328 Apply_Arithmetic_Overflow_Check
(N
);
5332 -- If the case expression is a predicate specification, and the type
5333 -- to which it applies has a static predicate aspect, do not expand,
5334 -- because it will be converted to the proper predicate form later.
5336 if Ekind_In
(Current_Scope
, E_Function
, E_Procedure
)
5337 and then Is_Predicate_Function
(Current_Scope
)
5339 In_Predicate
:= True;
5341 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
5347 -- When the type of the case expression is elementary, expand
5349 -- (case X is when A => AX, when B => BX ...)
5364 -- In all other cases expand into
5367 -- type Ptr_Typ is access all Typ;
5368 -- Target : Ptr_Typ;
5371 -- Target := AX'Unrestricted_Access;
5373 -- Target := BX'Unrestricted_Access;
5376 -- in Target.all end;
5378 -- This approach avoids extra copies of potentially large objects. It
5379 -- also allows handling of values of limited or unconstrained types.
5380 -- Note that we do the copy also for constrained, nonlimited types
5381 -- when minimizing expressions with actions (e.g. when generating C
5382 -- code) since it allows us to do the optimization below in more cases.
5384 -- Small optimization: when the case expression appears in the context
5385 -- of a simple return statement, expand into
5396 Make_Case_Statement
(Loc
,
5397 Expression
=> Expression
(N
),
5398 Alternatives
=> New_List
);
5400 -- Preserve the original context for which the case statement is being
5401 -- generated. This is needed by the finalization machinery to prevent
5402 -- the premature finalization of controlled objects found within the
5405 Set_From_Conditional_Expression
(Case_Stmt
);
5410 if Is_Copy_Type
(Typ
) then
5413 -- ??? Do not perform the optimization when the return statement is
5414 -- within a predicate function, as this causes spurious errors. Could
5415 -- this be a possible mismatch in handling this case somewhere else
5416 -- in semantic analysis?
5418 Optimize_Return_Stmt
:=
5419 Nkind
(Par
) = N_Simple_Return_Statement
and then not In_Predicate
;
5421 -- Otherwise create an access type to handle the general case using
5422 -- 'Unrestricted_Access.
5425 -- type Ptr_Typ is access all Typ;
5428 if Generate_C_Code
then
5430 -- We cannot ensure that correct C code will be generated if any
5431 -- temporary is created down the line (to e.g. handle checks or
5432 -- capture values) since we might end up with dangling references
5433 -- to local variables, so better be safe and reject the construct.
5436 ("case expression too complex, use case statement instead", N
);
5439 Target_Typ
:= Make_Temporary
(Loc
, 'P');
5442 Make_Full_Type_Declaration
(Loc
,
5443 Defining_Identifier
=> Target_Typ
,
5445 Make_Access_To_Object_Definition
(Loc
,
5446 All_Present
=> True,
5447 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5450 -- Create the declaration of the target which captures the value of the
5454 -- Target : [Ptr_]Typ;
5456 if not Optimize_Return_Stmt
then
5457 Target
:= Make_Temporary
(Loc
, 'T');
5460 Make_Object_Declaration
(Loc
,
5461 Defining_Identifier
=> Target
,
5462 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
5463 Set_No_Initialization
(Decl
);
5465 Append_To
(Acts
, Decl
);
5468 -- Process the alternatives
5470 Alt
:= First
(Alternatives
(N
));
5471 while Present
(Alt
) loop
5473 Alt_Expr
: Node_Id
:= Expression
(Alt
);
5474 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
5479 -- Take the unrestricted access of the expression value for non-
5480 -- scalar types. This approach avoids big copies and covers the
5481 -- limited and unconstrained cases.
5484 -- AX'Unrestricted_Access
5486 if not Is_Copy_Type
(Typ
) then
5488 Make_Attribute_Reference
(Alt_Loc
,
5489 Prefix
=> Relocate_Node
(Alt_Expr
),
5490 Attribute_Name
=> Name_Unrestricted_Access
);
5494 -- return AX['Unrestricted_Access];
5496 if Optimize_Return_Stmt
then
5498 Make_Simple_Return_Statement
(Alt_Loc
,
5499 Expression
=> Alt_Expr
));
5502 -- Target := AX['Unrestricted_Access];
5505 LHS
:= New_Occurrence_Of
(Target
, Loc
);
5506 Set_Assignment_OK
(LHS
);
5509 Make_Assignment_Statement
(Alt_Loc
,
5511 Expression
=> Alt_Expr
));
5514 -- Propagate declarations inserted in the node by Insert_Actions
5515 -- (for example, temporaries generated to remove side effects).
5516 -- These actions must remain attached to the alternative, given
5517 -- that they are generated by the corresponding expression.
5519 if Present
(Actions
(Alt
)) then
5520 Prepend_List
(Actions
(Alt
), Stmts
);
5523 -- Finalize any transient objects on exit from the alternative.
5524 -- This is done only in the return optimization case because
5525 -- otherwise the case expression is converted into an expression
5526 -- with actions which already contains this form of processing.
5528 if Optimize_Return_Stmt
then
5529 Process_If_Case_Statements
(N
, Stmts
);
5533 (Alternatives
(Case_Stmt
),
5534 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5535 Discrete_Choices
=> Discrete_Choices
(Alt
),
5536 Statements
=> Stmts
));
5542 -- Rewrite the parent return statement as a case statement
5544 if Optimize_Return_Stmt
then
5545 Rewrite
(Par
, Case_Stmt
);
5548 -- Otherwise convert the case expression into an expression with actions
5551 Append_To
(Acts
, Case_Stmt
);
5553 if Is_Copy_Type
(Typ
) then
5554 Expr
:= New_Occurrence_Of
(Target
, Loc
);
5558 Make_Explicit_Dereference
(Loc
,
5559 Prefix
=> New_Occurrence_Of
(Target
, Loc
));
5565 -- in Target[.all] end;
5568 Make_Expression_With_Actions
(Loc
,
5572 Analyze_And_Resolve
(N
, Typ
);
5574 end Expand_N_Case_Expression
;
5576 -----------------------------------
5577 -- Expand_N_Explicit_Dereference --
5578 -----------------------------------
5580 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5582 -- Insert explicit dereference call for the checked storage pool case
5584 Insert_Dereference_Action
(Prefix
(N
));
5586 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5587 -- we set the atomic sync flag.
5589 if Is_Atomic
(Etype
(N
))
5590 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5592 Activate_Atomic_Synchronization
(N
);
5594 end Expand_N_Explicit_Dereference
;
5596 --------------------------------------
5597 -- Expand_N_Expression_With_Actions --
5598 --------------------------------------
5600 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5601 Acts
: constant List_Id
:= Actions
(N
);
5603 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
5604 -- Force the evaluation of Boolean expression Expr
5606 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5607 -- Inspect and process a single action of an expression_with_actions for
5608 -- transient objects. If such objects are found, the routine generates
5609 -- code to clean them up when the context of the expression is evaluated
5612 ------------------------------
5613 -- Force_Boolean_Evaluation --
5614 ------------------------------
5616 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
5617 Loc
: constant Source_Ptr
:= Sloc
(N
);
5618 Flag_Decl
: Node_Id
;
5619 Flag_Id
: Entity_Id
;
5622 -- Relocate the expression to the actions list by capturing its value
5623 -- in a Boolean flag. Generate:
5624 -- Flag : constant Boolean := Expr;
5626 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5629 Make_Object_Declaration
(Loc
,
5630 Defining_Identifier
=> Flag_Id
,
5631 Constant_Present
=> True,
5632 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5633 Expression
=> Relocate_Node
(Expr
));
5635 Append
(Flag_Decl
, Acts
);
5636 Analyze
(Flag_Decl
);
5638 -- Replace the expression with a reference to the flag
5640 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
5641 Analyze
(Expression
(N
));
5642 end Force_Boolean_Evaluation
;
5644 --------------------
5645 -- Process_Action --
5646 --------------------
5648 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5650 if Nkind
(Act
) = N_Object_Declaration
5651 and then Is_Finalizable_Transient
(Act
, N
)
5653 Process_Transient_In_Expression
(Act
, N
, Acts
);
5656 -- Avoid processing temporary function results multiple times when
5657 -- dealing with nested expression_with_actions.
5659 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5662 -- Do not process temporary function results in loops. This is done
5663 -- by Expand_N_Loop_Statement and Build_Finalizer.
5665 elsif Nkind
(Act
) = N_Loop_Statement
then
5672 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5678 -- Start of processing for Expand_N_Expression_With_Actions
5681 -- Do not evaluate the expression when it denotes an entity because the
5682 -- expression_with_actions node will be replaced by the reference.
5684 if Is_Entity_Name
(Expression
(N
)) then
5687 -- Do not evaluate the expression when there are no actions because the
5688 -- expression_with_actions node will be replaced by the expression.
5690 elsif No
(Acts
) or else Is_Empty_List
(Acts
) then
5693 -- Force the evaluation of the expression by capturing its value in a
5694 -- temporary. This ensures that aliases of transient objects do not leak
5695 -- to the expression of the expression_with_actions node:
5698 -- Trans_Id : Ctrl_Typ := ...;
5699 -- Alias : ... := Trans_Id;
5700 -- in ... Alias ... end;
5702 -- In the example above, Trans_Id cannot be finalized at the end of the
5703 -- actions list because this may affect the alias and the final value of
5704 -- the expression_with_actions. Forcing the evaluation encapsulates the
5705 -- reference to the Alias within the actions list:
5708 -- Trans_Id : Ctrl_Typ := ...;
5709 -- Alias : ... := Trans_Id;
5710 -- Val : constant Boolean := ... Alias ...;
5711 -- <finalize Trans_Id>
5714 -- Once this transformation is performed, it is safe to finalize the
5715 -- transient object at the end of the actions list.
5717 -- Note that Force_Evaluation does not remove side effects in operators
5718 -- because it assumes that all operands are evaluated and side effect
5719 -- free. This is not the case when an operand depends implicitly on the
5720 -- transient object through the use of access types.
5722 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5723 Force_Boolean_Evaluation
(Expression
(N
));
5725 -- The expression of an expression_with_actions node may not necessarily
5726 -- be Boolean when the node appears in an if expression. In this case do
5727 -- the usual forced evaluation to encapsulate potential aliasing.
5730 Force_Evaluation
(Expression
(N
));
5733 -- Process all transient objects found within the actions of the EWA
5736 Act
:= First
(Acts
);
5737 while Present
(Act
) loop
5738 Process_Single_Action
(Act
);
5742 -- Deal with case where there are no actions. In this case we simply
5743 -- rewrite the node with its expression since we don't need the actions
5744 -- and the specification of this node does not allow a null action list.
5746 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5747 -- the expanded tree and relying on being able to retrieve the original
5748 -- tree in cases like this. This raises a whole lot of issues of whether
5749 -- we have problems elsewhere, which will be addressed in the future???
5751 if Is_Empty_List
(Acts
) then
5752 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5754 end Expand_N_Expression_With_Actions
;
5756 ----------------------------
5757 -- Expand_N_If_Expression --
5758 ----------------------------
5760 -- Deal with limited types and condition actions
5762 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5763 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5764 Loc
: constant Source_Ptr
:= Sloc
(N
);
5765 Thenx
: constant Node_Id
:= Next
(Cond
);
5766 Elsex
: constant Node_Id
:= Next
(Thenx
);
5767 Typ
: constant Entity_Id
:= Etype
(N
);
5776 -- Check for MINIMIZED/ELIMINATED overflow mode
5778 if Minimized_Eliminated_Overflow_Check
(N
) then
5779 Apply_Arithmetic_Overflow_Check
(N
);
5783 -- Fold at compile time if condition known. We have already folded
5784 -- static if expressions, but it is possible to fold any case in which
5785 -- the condition is known at compile time, even though the result is
5788 -- Note that we don't do the fold of such cases in Sem_Elab because
5789 -- it can cause infinite loops with the expander adding a conditional
5790 -- expression, and Sem_Elab circuitry removing it repeatedly.
5792 if Compile_Time_Known_Value
(Cond
) then
5794 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5795 -- Fold at compile time. Assumes condition known. Return True if
5796 -- folding occurred, meaning we're done.
5798 ----------------------
5799 -- Fold_Known_Value --
5800 ----------------------
5802 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5804 if Is_True
(Expr_Value
(Cond
)) then
5806 Actions
:= Then_Actions
(N
);
5809 Actions
:= Else_Actions
(N
);
5814 if Present
(Actions
) then
5816 -- To minimize the use of Expression_With_Actions, just skip
5817 -- the optimization as it is not critical for correctness.
5819 if Minimize_Expression_With_Actions
then
5824 Make_Expression_With_Actions
(Loc
,
5825 Expression
=> Relocate_Node
(Expr
),
5826 Actions
=> Actions
));
5827 Analyze_And_Resolve
(N
, Typ
);
5830 Rewrite
(N
, Relocate_Node
(Expr
));
5833 -- Note that the result is never static (legitimate cases of
5834 -- static if expressions were folded in Sem_Eval).
5836 Set_Is_Static_Expression
(N
, False);
5838 end Fold_Known_Value
;
5841 if Fold_Known_Value
(Cond
) then
5847 -- If the type is limited, and the back end does not handle limited
5848 -- types, then we expand as follows to avoid the possibility of
5849 -- improper copying.
5851 -- type Ptr is access all Typ;
5855 -- Cnn := then-expr'Unrestricted_Access;
5858 -- Cnn := else-expr'Unrestricted_Access;
5861 -- and replace the if expression by a reference to Cnn.all.
5863 -- This special case can be skipped if the back end handles limited
5864 -- types properly and ensures that no incorrect copies are made.
5866 if Is_By_Reference_Type
(Typ
)
5867 and then not Back_End_Handles_Limited_Types
5869 -- When the "then" or "else" expressions involve controlled function
5870 -- calls, generated temporaries are chained on the corresponding list
5871 -- of actions. These temporaries need to be finalized after the if
5872 -- expression is evaluated.
5874 Process_If_Case_Statements
(N
, Then_Actions
(N
));
5875 Process_If_Case_Statements
(N
, Else_Actions
(N
));
5878 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C', N
);
5879 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5883 -- type Ann is access all Typ;
5886 Make_Full_Type_Declaration
(Loc
,
5887 Defining_Identifier
=> Ptr_Typ
,
5889 Make_Access_To_Object_Definition
(Loc
,
5890 All_Present
=> True,
5891 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5897 Make_Object_Declaration
(Loc
,
5898 Defining_Identifier
=> Cnn
,
5899 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5903 -- Cnn := <Thenx>'Unrestricted_Access;
5905 -- Cnn := <Elsex>'Unrestricted_Access;
5909 Make_Implicit_If_Statement
(N
,
5910 Condition
=> Relocate_Node
(Cond
),
5911 Then_Statements
=> New_List
(
5912 Make_Assignment_Statement
(Sloc
(Thenx
),
5913 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5915 Make_Attribute_Reference
(Loc
,
5916 Prefix
=> Relocate_Node
(Thenx
),
5917 Attribute_Name
=> Name_Unrestricted_Access
))),
5919 Else_Statements
=> New_List
(
5920 Make_Assignment_Statement
(Sloc
(Elsex
),
5921 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5923 Make_Attribute_Reference
(Loc
,
5924 Prefix
=> Relocate_Node
(Elsex
),
5925 Attribute_Name
=> Name_Unrestricted_Access
))));
5927 -- Preserve the original context for which the if statement is
5928 -- being generated. This is needed by the finalization machinery
5929 -- to prevent the premature finalization of controlled objects
5930 -- found within the if statement.
5932 Set_From_Conditional_Expression
(New_If
);
5935 Make_Explicit_Dereference
(Loc
,
5936 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5939 -- If the result is an unconstrained array and the if expression is in a
5940 -- context other than the initializing expression of the declaration of
5941 -- an object, then we pull out the if expression as follows:
5943 -- Cnn : constant typ := if-expression
5945 -- and then replace the if expression with an occurrence of Cnn. This
5946 -- avoids the need in the back end to create on-the-fly variable length
5947 -- temporaries (which it cannot do!)
5949 -- Note that the test for being in an object declaration avoids doing an
5950 -- unnecessary expansion, and also avoids infinite recursion.
5952 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
)
5953 and then (Nkind
(Parent
(N
)) /= N_Object_Declaration
5954 or else Expression
(Parent
(N
)) /= N
)
5957 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5961 Make_Object_Declaration
(Loc
,
5962 Defining_Identifier
=> Cnn
,
5963 Constant_Present
=> True,
5964 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5965 Expression
=> Relocate_Node
(N
),
5966 Has_Init_Expression
=> True));
5968 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
5972 -- For other types, we only need to expand if there are other actions
5973 -- associated with either branch.
5975 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5977 -- We now wrap the actions into the appropriate expression
5979 if Minimize_Expression_With_Actions
5980 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
5981 or else Is_Constrained
(Underlying_Type
(Typ
)))
5983 -- If we can't use N_Expression_With_Actions nodes, then we insert
5984 -- the following sequence of actions (using Insert_Actions):
5989 -- Cnn := then-expr;
5995 -- and replace the if expression by a reference to Cnn
5998 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6002 Make_Object_Declaration
(Loc
,
6003 Defining_Identifier
=> Cnn
,
6004 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6007 Make_Implicit_If_Statement
(N
,
6008 Condition
=> Relocate_Node
(Cond
),
6010 Then_Statements
=> New_List
(
6011 Make_Assignment_Statement
(Sloc
(Thenx
),
6012 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6013 Expression
=> Relocate_Node
(Thenx
))),
6015 Else_Statements
=> New_List
(
6016 Make_Assignment_Statement
(Sloc
(Elsex
),
6017 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6018 Expression
=> Relocate_Node
(Elsex
))));
6020 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
6021 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
6023 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
6026 -- Regular path using Expression_With_Actions
6029 if Present
(Then_Actions
(N
)) then
6031 Make_Expression_With_Actions
(Sloc
(Thenx
),
6032 Actions
=> Then_Actions
(N
),
6033 Expression
=> Relocate_Node
(Thenx
)));
6035 Set_Then_Actions
(N
, No_List
);
6036 Analyze_And_Resolve
(Thenx
, Typ
);
6039 if Present
(Else_Actions
(N
)) then
6041 Make_Expression_With_Actions
(Sloc
(Elsex
),
6042 Actions
=> Else_Actions
(N
),
6043 Expression
=> Relocate_Node
(Elsex
)));
6045 Set_Else_Actions
(N
, No_List
);
6046 Analyze_And_Resolve
(Elsex
, Typ
);
6052 -- If no actions then no expansion needed, gigi will handle it using the
6053 -- same approach as a C conditional expression.
6059 -- Fall through here for either the limited expansion, or the case of
6060 -- inserting actions for nonlimited types. In both these cases, we must
6061 -- move the SLOC of the parent If statement to the newly created one and
6062 -- change it to the SLOC of the expression which, after expansion, will
6063 -- correspond to what is being evaluated.
6065 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
6066 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
6067 Set_Sloc
(Parent
(N
), Loc
);
6070 -- Make sure Then_Actions and Else_Actions are appropriately moved
6071 -- to the new if statement.
6073 if Present
(Then_Actions
(N
)) then
6075 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
6078 if Present
(Else_Actions
(N
)) then
6080 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
6083 Insert_Action
(N
, Decl
);
6084 Insert_Action
(N
, New_If
);
6086 Analyze_And_Resolve
(N
, Typ
);
6087 end Expand_N_If_Expression
;
6093 procedure Expand_N_In
(N
: Node_Id
) is
6094 Loc
: constant Source_Ptr
:= Sloc
(N
);
6095 Restyp
: constant Entity_Id
:= Etype
(N
);
6096 Lop
: constant Node_Id
:= Left_Opnd
(N
);
6097 Rop
: constant Node_Id
:= Right_Opnd
(N
);
6098 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
6100 procedure Substitute_Valid_Check
;
6101 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6102 -- test for the left operand being in range of its subtype.
6104 ----------------------------
6105 -- Substitute_Valid_Check --
6106 ----------------------------
6108 procedure Substitute_Valid_Check
is
6109 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
6110 -- Determine whether arbitrary node Nod denotes a source object that
6111 -- may safely act as prefix of attribute 'Valid.
6113 ----------------------------
6114 -- Is_OK_Object_Reference --
6115 ----------------------------
6117 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
6121 -- Inspect the original operand
6123 Obj_Ref
:= Original_Node
(Nod
);
6125 -- The object reference must be a source construct, otherwise the
6126 -- codefix suggestion may refer to nonexistent code from a user
6129 if Comes_From_Source
(Obj_Ref
) then
6131 -- Recover the actual object reference. There may be more cases
6135 if Nkind_In
(Obj_Ref
, N_Type_Conversion
,
6136 N_Unchecked_Type_Conversion
)
6138 Obj_Ref
:= Expression
(Obj_Ref
);
6144 return Is_Object_Reference
(Obj_Ref
);
6148 end Is_OK_Object_Reference
;
6150 -- Start of processing for Substitute_Valid_Check
6154 Make_Attribute_Reference
(Loc
,
6155 Prefix
=> Relocate_Node
(Lop
),
6156 Attribute_Name
=> Name_Valid
));
6158 Analyze_And_Resolve
(N
, Restyp
);
6160 -- Emit a warning when the left-hand operand of the membership test
6161 -- is a source object, otherwise the use of attribute 'Valid would be
6162 -- illegal. The warning is not given when overflow checking is either
6163 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6164 -- eliminated above.
6166 if Is_OK_Object_Reference
(Lop
)
6167 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
6170 ("??explicit membership test may be optimized away", N
);
6171 Error_Msg_N
-- CODEFIX
6172 ("\??use ''Valid attribute instead", N
);
6174 end Substitute_Valid_Check
;
6181 -- Start of processing for Expand_N_In
6184 -- If set membership case, expand with separate procedure
6186 if Present
(Alternatives
(N
)) then
6187 Expand_Set_Membership
(N
);
6191 -- Not set membership, proceed with expansion
6193 Ltyp
:= Etype
(Left_Opnd
(N
));
6194 Rtyp
:= Etype
(Right_Opnd
(N
));
6196 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6197 -- type, then expand with a separate procedure. Note the use of the
6198 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6200 if Overflow_Check_Mode
in Minimized_Or_Eliminated
6201 and then Is_Signed_Integer_Type
(Ltyp
)
6202 and then not No_Minimize_Eliminate
(N
)
6204 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
6208 -- Check case of explicit test for an expression in range of its
6209 -- subtype. This is suspicious usage and we replace it with a 'Valid
6210 -- test and give a warning for scalar types.
6212 if Is_Scalar_Type
(Ltyp
)
6214 -- Only relevant for source comparisons
6216 and then Comes_From_Source
(N
)
6218 -- In floating-point this is a standard way to check for finite values
6219 -- and using 'Valid would typically be a pessimization.
6221 and then not Is_Floating_Point_Type
(Ltyp
)
6223 -- Don't give the message unless right operand is a type entity and
6224 -- the type of the left operand matches this type. Note that this
6225 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6226 -- checks have changed the type of the left operand.
6228 and then Nkind
(Rop
) in N_Has_Entity
6229 and then Ltyp
= Entity
(Rop
)
6231 -- Skip this for predicated types, where such expressions are a
6232 -- reasonable way of testing if something meets the predicate.
6234 and then not Present
(Predicate_Function
(Ltyp
))
6236 Substitute_Valid_Check
;
6240 -- Do validity check on operands
6242 if Validity_Checks_On
and Validity_Check_Operands
then
6243 Ensure_Valid
(Left_Opnd
(N
));
6244 Validity_Check_Range
(Right_Opnd
(N
));
6247 -- Case of explicit range
6249 if Nkind
(Rop
) = N_Range
then
6251 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
6252 Hi
: constant Node_Id
:= High_Bound
(Rop
);
6254 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
6255 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
6257 Lcheck
: Compare_Result
;
6258 Ucheck
: Compare_Result
;
6260 Warn1
: constant Boolean :=
6261 Constant_Condition_Warnings
6262 and then Comes_From_Source
(N
)
6263 and then not In_Instance
;
6264 -- This must be true for any of the optimization warnings, we
6265 -- clearly want to give them only for source with the flag on. We
6266 -- also skip these warnings in an instance since it may be the
6267 -- case that different instantiations have different ranges.
6269 Warn2
: constant Boolean :=
6271 and then Nkind
(Original_Node
(Rop
)) = N_Range
6272 and then Is_Integer_Type
(Etype
(Lo
));
6273 -- For the case where only one bound warning is elided, we also
6274 -- insist on an explicit range and an integer type. The reason is
6275 -- that the use of enumeration ranges including an end point is
6276 -- common, as is the use of a subtype name, one of whose bounds is
6277 -- the same as the type of the expression.
6280 -- If test is explicit x'First .. x'Last, replace by valid check
6282 -- Could use some individual comments for this complex test ???
6284 if Is_Scalar_Type
(Ltyp
)
6286 -- And left operand is X'First where X matches left operand
6287 -- type (this eliminates cases of type mismatch, including
6288 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6289 -- type of the left operand.
6291 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
6292 and then Attribute_Name
(Lo_Orig
) = Name_First
6293 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
6294 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
6296 -- Same tests for right operand
6298 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
6299 and then Attribute_Name
(Hi_Orig
) = Name_Last
6300 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
6301 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
6303 -- Relevant only for source cases
6305 and then Comes_From_Source
(N
)
6307 Substitute_Valid_Check
;
6311 -- If bounds of type are known at compile time, and the end points
6312 -- are known at compile time and identical, this is another case
6313 -- for substituting a valid test. We only do this for discrete
6314 -- types, since it won't arise in practice for float types.
6316 if Comes_From_Source
(N
)
6317 and then Is_Discrete_Type
(Ltyp
)
6318 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
6319 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
6320 and then Compile_Time_Known_Value
(Lo
)
6321 and then Compile_Time_Known_Value
(Hi
)
6322 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
6323 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
6325 -- Kill warnings in instances, since they may be cases where we
6326 -- have a test in the generic that makes sense with some types
6327 -- and not with other types.
6329 -- Similarly, do not rewrite membership as a validity check if
6330 -- within the predicate function for the type.
6332 -- Finally, if the original bounds are type conversions, even
6333 -- if they have been folded into constants, there are different
6334 -- types involved and 'Valid is not appropriate.
6338 or else (Ekind
(Current_Scope
) = E_Function
6339 and then Is_Predicate_Function
(Current_Scope
))
6343 elsif Nkind
(Lo_Orig
) = N_Type_Conversion
6344 or else Nkind
(Hi_Orig
) = N_Type_Conversion
6349 Substitute_Valid_Check
;
6354 -- If we have an explicit range, do a bit of optimization based on
6355 -- range analysis (we may be able to kill one or both checks).
6357 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
6358 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
6360 -- If either check is known to fail, replace result by False since
6361 -- the other check does not matter. Preserve the static flag for
6362 -- legality checks, because we are constant-folding beyond RM 4.9.
6364 if Lcheck
= LT
or else Ucheck
= GT
then
6366 Error_Msg_N
("?c?range test optimized away", N
);
6367 Error_Msg_N
("\?c?value is known to be out of range", N
);
6370 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6371 Analyze_And_Resolve
(N
, Restyp
);
6372 Set_Is_Static_Expression
(N
, Static
);
6375 -- If both checks are known to succeed, replace result by True,
6376 -- since we know we are in range.
6378 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6380 Error_Msg_N
("?c?range test optimized away", N
);
6381 Error_Msg_N
("\?c?value is known to be in range", N
);
6384 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6385 Analyze_And_Resolve
(N
, Restyp
);
6386 Set_Is_Static_Expression
(N
, Static
);
6389 -- If lower bound check succeeds and upper bound check is not
6390 -- known to succeed or fail, then replace the range check with
6391 -- a comparison against the upper bound.
6393 elsif Lcheck
in Compare_GE
then
6394 if Warn2
and then not In_Instance
then
6395 Error_Msg_N
("??lower bound test optimized away", Lo
);
6396 Error_Msg_N
("\??value is known to be in range", Lo
);
6402 Right_Opnd
=> High_Bound
(Rop
)));
6403 Analyze_And_Resolve
(N
, Restyp
);
6406 -- If upper bound check succeeds and lower bound check is not
6407 -- known to succeed or fail, then replace the range check with
6408 -- a comparison against the lower bound.
6410 elsif Ucheck
in Compare_LE
then
6411 if Warn2
and then not In_Instance
then
6412 Error_Msg_N
("??upper bound test optimized away", Hi
);
6413 Error_Msg_N
("\??value is known to be in range", Hi
);
6419 Right_Opnd
=> Low_Bound
(Rop
)));
6420 Analyze_And_Resolve
(N
, Restyp
);
6424 -- We couldn't optimize away the range check, but there is one
6425 -- more issue. If we are checking constant conditionals, then we
6426 -- see if we can determine the outcome assuming everything is
6427 -- valid, and if so give an appropriate warning.
6429 if Warn1
and then not Assume_No_Invalid_Values
then
6430 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
6431 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
6433 -- Result is out of range for valid value
6435 if Lcheck
= LT
or else Ucheck
= GT
then
6437 ("?c?value can only be in range if it is invalid", N
);
6439 -- Result is in range for valid value
6441 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6443 ("?c?value can only be out of range if it is invalid", N
);
6445 -- Lower bound check succeeds if value is valid
6447 elsif Warn2
and then Lcheck
in Compare_GE
then
6449 ("?c?lower bound check only fails if it is invalid", Lo
);
6451 -- Upper bound check succeeds if value is valid
6453 elsif Warn2
and then Ucheck
in Compare_LE
then
6455 ("?c?upper bound check only fails for invalid values", Hi
);
6460 -- For all other cases of an explicit range, nothing to be done
6464 -- Here right operand is a subtype mark
6468 Typ
: Entity_Id
:= Etype
(Rop
);
6469 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
6470 Cond
: Node_Id
:= Empty
;
6472 Obj
: Node_Id
:= Lop
;
6473 SCIL_Node
: Node_Id
;
6476 Remove_Side_Effects
(Obj
);
6478 -- For tagged type, do tagged membership operation
6480 if Is_Tagged_Type
(Typ
) then
6482 -- No expansion will be performed for VM targets, as the VM
6483 -- back ends will handle the membership tests directly.
6485 if Tagged_Type_Expansion
then
6486 Tagged_Membership
(N
, SCIL_Node
, New_N
);
6488 Analyze_And_Resolve
(N
, Restyp
, Suppress
=> All_Checks
);
6490 -- Update decoration of relocated node referenced by the
6493 if Generate_SCIL
and then Present
(SCIL_Node
) then
6494 Set_SCIL_Node
(N
, SCIL_Node
);
6500 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6501 -- This reason we do this is that the bounds may have the wrong
6502 -- type if they come from the original type definition. Also this
6503 -- way we get all the processing above for an explicit range.
6505 -- Don't do this for predicated types, since in this case we
6506 -- want to check the predicate.
6508 elsif Is_Scalar_Type
(Typ
) then
6509 if No
(Predicate_Function
(Typ
)) then
6513 Make_Attribute_Reference
(Loc
,
6514 Attribute_Name
=> Name_First
,
6515 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
6518 Make_Attribute_Reference
(Loc
,
6519 Attribute_Name
=> Name_Last
,
6520 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
6521 Analyze_And_Resolve
(N
, Restyp
);
6526 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
6527 -- a membership test if the subtype mark denotes a constrained
6528 -- Unchecked_Union subtype and the expression lacks inferable
6531 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
6532 and then Is_Constrained
(Typ
)
6533 and then not Has_Inferable_Discriminants
(Lop
)
6536 Make_Raise_Program_Error
(Loc
,
6537 Reason
=> PE_Unchecked_Union_Restriction
));
6539 -- Prevent Gigi from generating incorrect code by rewriting the
6540 -- test as False. What is this undocumented thing about ???
6542 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6546 -- Here we have a non-scalar type
6549 Typ
:= Designated_Type
(Typ
);
6552 if not Is_Constrained
(Typ
) then
6553 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6554 Analyze_And_Resolve
(N
, Restyp
);
6556 -- For the constrained array case, we have to check the subscripts
6557 -- for an exact match if the lengths are non-zero (the lengths
6558 -- must match in any case).
6560 elsif Is_Array_Type
(Typ
) then
6561 Check_Subscripts
: declare
6562 function Build_Attribute_Reference
6565 Dim
: Nat
) return Node_Id
;
6566 -- Build attribute reference E'Nam (Dim)
6568 -------------------------------
6569 -- Build_Attribute_Reference --
6570 -------------------------------
6572 function Build_Attribute_Reference
6575 Dim
: Nat
) return Node_Id
6579 Make_Attribute_Reference
(Loc
,
6581 Attribute_Name
=> Nam
,
6582 Expressions
=> New_List
(
6583 Make_Integer_Literal
(Loc
, Dim
)));
6584 end Build_Attribute_Reference
;
6586 -- Start of processing for Check_Subscripts
6589 for J
in 1 .. Number_Dimensions
(Typ
) loop
6590 Evolve_And_Then
(Cond
,
6593 Build_Attribute_Reference
6594 (Duplicate_Subexpr_No_Checks
(Obj
),
6597 Build_Attribute_Reference
6598 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
6600 Evolve_And_Then
(Cond
,
6603 Build_Attribute_Reference
6604 (Duplicate_Subexpr_No_Checks
(Obj
),
6607 Build_Attribute_Reference
6608 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
6617 Right_Opnd
=> Make_Null
(Loc
)),
6618 Right_Opnd
=> Cond
);
6622 Analyze_And_Resolve
(N
, Restyp
);
6623 end Check_Subscripts
;
6625 -- These are the cases where constraint checks may be required,
6626 -- e.g. records with possible discriminants
6629 -- Expand the test into a series of discriminant comparisons.
6630 -- The expression that is built is the negation of the one that
6631 -- is used for checking discriminant constraints.
6633 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6635 if Has_Discriminants
(Typ
) then
6636 Cond
:= Make_Op_Not
(Loc
,
6637 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6640 Cond
:= Make_Or_Else
(Loc
,
6644 Right_Opnd
=> Make_Null
(Loc
)),
6645 Right_Opnd
=> Cond
);
6649 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6653 Analyze_And_Resolve
(N
, Restyp
);
6656 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6657 -- expression of an anonymous access type. This can involve an
6658 -- accessibility test and a tagged type membership test in the
6659 -- case of tagged designated types.
6661 if Ada_Version
>= Ada_2012
6663 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6666 Expr_Entity
: Entity_Id
:= Empty
;
6668 Param_Level
: Node_Id
;
6669 Type_Level
: Node_Id
;
6672 if Is_Entity_Name
(Lop
) then
6673 Expr_Entity
:= Param_Entity
(Lop
);
6675 if not Present
(Expr_Entity
) then
6676 Expr_Entity
:= Entity
(Lop
);
6680 -- If a conversion of the anonymous access value to the
6681 -- tested type would be illegal, then the result is False.
6683 if not Valid_Conversion
6684 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6686 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6687 Analyze_And_Resolve
(N
, Restyp
);
6689 -- Apply an accessibility check if the access object has an
6690 -- associated access level and when the level of the type is
6691 -- less deep than the level of the access parameter. This
6692 -- only occur for access parameters and stand-alone objects
6693 -- of an anonymous access type.
6696 if Present
(Expr_Entity
)
6699 (Effective_Extra_Accessibility
(Expr_Entity
))
6700 and then UI_Gt
(Object_Access_Level
(Lop
),
6701 Type_Access_Level
(Rtyp
))
6705 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
6708 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6710 -- Return True only if the accessibility level of the
6711 -- expression entity is not deeper than the level of
6712 -- the tested access type.
6716 Left_Opnd
=> Relocate_Node
(N
),
6717 Right_Opnd
=> Make_Op_Le
(Loc
,
6718 Left_Opnd
=> Param_Level
,
6719 Right_Opnd
=> Type_Level
)));
6721 Analyze_And_Resolve
(N
);
6724 -- If the designated type is tagged, do tagged membership
6727 -- *** NOTE: we have to check not null before doing the
6728 -- tagged membership test (but maybe that can be done
6729 -- inside Tagged_Membership?).
6731 if Is_Tagged_Type
(Typ
) then
6734 Left_Opnd
=> Relocate_Node
(N
),
6738 Right_Opnd
=> Make_Null
(Loc
))));
6740 -- No expansion will be performed for VM targets, as
6741 -- the VM back ends will handle the membership tests
6744 if Tagged_Type_Expansion
then
6746 -- Note that we have to pass Original_Node, because
6747 -- the membership test might already have been
6748 -- rewritten by earlier parts of membership test.
6751 (Original_Node
(N
), SCIL_Node
, New_N
);
6753 -- Update decoration of relocated node referenced
6754 -- by the SCIL node.
6756 if Generate_SCIL
and then Present
(SCIL_Node
) then
6757 Set_SCIL_Node
(New_N
, SCIL_Node
);
6762 Left_Opnd
=> Relocate_Node
(N
),
6763 Right_Opnd
=> New_N
));
6765 Analyze_And_Resolve
(N
, Restyp
);
6774 -- At this point, we have done the processing required for the basic
6775 -- membership test, but not yet dealt with the predicate.
6779 -- If a predicate is present, then we do the predicate test, but we
6780 -- most certainly want to omit this if we are within the predicate
6781 -- function itself, since otherwise we have an infinite recursion.
6782 -- The check should also not be emitted when testing against a range
6783 -- (the check is only done when the right operand is a subtype; see
6784 -- RM12-4.5.2 (28.1/3-30/3)).
6786 Predicate_Check
: declare
6787 function In_Range_Check
return Boolean;
6788 -- Within an expanded range check that may raise Constraint_Error do
6789 -- not generate a predicate check as well. It is redundant because
6790 -- the context will add an explicit predicate check, and it will
6791 -- raise the wrong exception if it fails.
6793 --------------------
6794 -- In_Range_Check --
6795 --------------------
6797 function In_Range_Check
return Boolean is
6801 while Present
(P
) loop
6802 if Nkind
(P
) = N_Raise_Constraint_Error
then
6805 elsif Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6806 or else Nkind
(P
) = N_Procedure_Call_Statement
6807 or else Nkind
(P
) in N_Declaration
6820 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6823 -- Start of processing for Predicate_Check
6827 and then Current_Scope
/= PFunc
6828 and then Nkind
(Rop
) /= N_Range
6830 if not In_Range_Check
then
6831 R_Op
:= Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True);
6833 R_Op
:= New_Occurrence_Of
(Standard_True
, Loc
);
6838 Left_Opnd
=> Relocate_Node
(N
),
6839 Right_Opnd
=> R_Op
));
6841 -- Analyze new expression, mark left operand as analyzed to
6842 -- avoid infinite recursion adding predicate calls. Similarly,
6843 -- suppress further range checks on the call.
6845 Set_Analyzed
(Left_Opnd
(N
));
6846 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6848 -- All done, skip attempt at compile time determination of result
6852 end Predicate_Check
;
6855 --------------------------------
6856 -- Expand_N_Indexed_Component --
6857 --------------------------------
6859 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6860 Loc
: constant Source_Ptr
:= Sloc
(N
);
6861 Typ
: constant Entity_Id
:= Etype
(N
);
6862 P
: constant Node_Id
:= Prefix
(N
);
6863 T
: constant Entity_Id
:= Etype
(P
);
6867 -- A special optimization, if we have an indexed component that is
6868 -- selecting from a slice, then we can eliminate the slice, since, for
6869 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6870 -- the range check required by the slice. The range check for the slice
6871 -- itself has already been generated. The range check for the
6872 -- subscripting operation is ensured by converting the subject to
6873 -- the subtype of the slice.
6875 -- This optimization not only generates better code, avoiding slice
6876 -- messing especially in the packed case, but more importantly bypasses
6877 -- some problems in handling this peculiar case, for example, the issue
6878 -- of dealing specially with object renamings.
6880 if Nkind
(P
) = N_Slice
6882 -- This optimization is disabled for CodePeer because it can transform
6883 -- an index-check constraint_error into a range-check constraint_error
6884 -- and CodePeer cares about that distinction.
6886 and then not CodePeer_Mode
6889 Make_Indexed_Component
(Loc
,
6890 Prefix
=> Prefix
(P
),
6891 Expressions
=> New_List
(
6893 (Etype
(First_Index
(Etype
(P
))),
6894 First
(Expressions
(N
))))));
6895 Analyze_And_Resolve
(N
, Typ
);
6899 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6900 -- function, then additional actuals must be passed.
6902 if Is_Build_In_Place_Function_Call
(P
) then
6903 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6905 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
6906 -- containing build-in-place function calls whose returned object covers
6909 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
6910 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
6913 -- If the prefix is an access type, then we unconditionally rewrite if
6914 -- as an explicit dereference. This simplifies processing for several
6915 -- cases, including packed array cases and certain cases in which checks
6916 -- must be generated. We used to try to do this only when it was
6917 -- necessary, but it cleans up the code to do it all the time.
6919 if Is_Access_Type
(T
) then
6920 Insert_Explicit_Dereference
(P
);
6921 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6922 Atp
:= Designated_Type
(T
);
6927 -- Generate index and validity checks
6929 Generate_Index_Checks
(N
);
6931 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6932 Apply_Subscript_Validity_Checks
(N
);
6935 -- If selecting from an array with atomic components, and atomic sync
6936 -- is not suppressed for this array type, set atomic sync flag.
6938 if (Has_Atomic_Components
(Atp
)
6939 and then not Atomic_Synchronization_Disabled
(Atp
))
6940 or else (Is_Atomic
(Typ
)
6941 and then not Atomic_Synchronization_Disabled
(Typ
))
6942 or else (Is_Entity_Name
(P
)
6943 and then Has_Atomic_Components
(Entity
(P
))
6944 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
6946 Activate_Atomic_Synchronization
(N
);
6949 -- All done if the prefix is not a packed array implemented specially
6951 if not (Is_Packed
(Etype
(Prefix
(N
)))
6952 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(N
)))))
6957 -- For packed arrays that are not bit-packed (i.e. the case of an array
6958 -- with one or more index types with a non-contiguous enumeration type),
6959 -- we can always use the normal packed element get circuit.
6961 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6962 Expand_Packed_Element_Reference
(N
);
6966 -- For a reference to a component of a bit packed array, we convert it
6967 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6968 -- want to do this for simple references, and not for:
6970 -- Left side of assignment, or prefix of left side of assignment, or
6971 -- prefix of the prefix, to handle packed arrays of packed arrays,
6972 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6974 -- Renaming objects in renaming associations
6975 -- This case is handled when a use of the renamed variable occurs
6977 -- Actual parameters for a subprogram call
6978 -- This case is handled in Exp_Ch6.Expand_Actuals
6980 -- The second expression in a 'Read attribute reference
6982 -- The prefix of an address or bit or size attribute reference
6984 -- The following circuit detects these exceptions. Note that we need to
6985 -- deal with implicit dereferences when climbing up the parent chain,
6986 -- with the additional difficulty that the type of parents may have yet
6987 -- to be resolved since prefixes are usually resolved first.
6990 Child
: Node_Id
:= N
;
6991 Parnt
: Node_Id
:= Parent
(N
);
6995 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6998 elsif Nkind
(Parnt
) = N_Object_Renaming_Declaration
then
7001 elsif Nkind
(Parnt
) in N_Subprogram_Call
7002 or else (Nkind
(Parnt
) = N_Parameter_Association
7003 and then Nkind
(Parent
(Parnt
)) in N_Subprogram_Call
)
7007 elsif Nkind
(Parnt
) = N_Attribute_Reference
7008 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
7011 and then Prefix
(Parnt
) = Child
7015 elsif Nkind
(Parnt
) = N_Assignment_Statement
7016 and then Name
(Parnt
) = Child
7020 -- If the expression is an index of an indexed component, it must
7021 -- be expanded regardless of context.
7023 elsif Nkind
(Parnt
) = N_Indexed_Component
7024 and then Child
/= Prefix
(Parnt
)
7026 Expand_Packed_Element_Reference
(N
);
7029 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
7030 and then Name
(Parent
(Parnt
)) = Parnt
7034 elsif Nkind
(Parnt
) = N_Attribute_Reference
7035 and then Attribute_Name
(Parnt
) = Name_Read
7036 and then Next
(First
(Expressions
(Parnt
))) = Child
7040 elsif Nkind
(Parnt
) = N_Indexed_Component
7041 and then Prefix
(Parnt
) = Child
7045 elsif Nkind
(Parnt
) = N_Selected_Component
7046 and then Prefix
(Parnt
) = Child
7047 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
7049 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
7053 -- If the parent is a dereference, either implicit or explicit,
7054 -- then the packed reference needs to be expanded.
7057 Expand_Packed_Element_Reference
(N
);
7061 -- Keep looking up tree for unchecked expression, or if we are the
7062 -- prefix of a possible assignment left side.
7065 Parnt
:= Parent
(Child
);
7068 end Expand_N_Indexed_Component
;
7070 ---------------------
7071 -- Expand_N_Not_In --
7072 ---------------------
7074 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7075 -- can be done. This avoids needing to duplicate this expansion code.
7077 procedure Expand_N_Not_In
(N
: Node_Id
) is
7078 Loc
: constant Source_Ptr
:= Sloc
(N
);
7079 Typ
: constant Entity_Id
:= Etype
(N
);
7080 Cfs
: constant Boolean := Comes_From_Source
(N
);
7087 Left_Opnd
=> Left_Opnd
(N
),
7088 Right_Opnd
=> Right_Opnd
(N
))));
7090 -- If this is a set membership, preserve list of alternatives
7092 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
7094 -- We want this to appear as coming from source if original does (see
7095 -- transformations in Expand_N_In).
7097 Set_Comes_From_Source
(N
, Cfs
);
7098 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
7100 -- Now analyze transformed node
7102 Analyze_And_Resolve
(N
, Typ
);
7103 end Expand_N_Not_In
;
7109 -- The only replacement required is for the case of a null of a type that
7110 -- is an access to protected subprogram, or a subtype thereof. We represent
7111 -- such access values as a record, and so we must replace the occurrence of
7112 -- null by the equivalent record (with a null address and a null pointer in
7113 -- it), so that the back end creates the proper value.
7115 procedure Expand_N_Null
(N
: Node_Id
) is
7116 Loc
: constant Source_Ptr
:= Sloc
(N
);
7117 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
7121 if Is_Access_Protected_Subprogram_Type
(Typ
) then
7123 Make_Aggregate
(Loc
,
7124 Expressions
=> New_List
(
7125 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
7129 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
7131 -- For subsequent semantic analysis, the node must retain its type.
7132 -- Gigi in any case replaces this type by the corresponding record
7133 -- type before processing the node.
7139 when RE_Not_Available
=>
7143 ---------------------
7144 -- Expand_N_Op_Abs --
7145 ---------------------
7147 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
7148 Loc
: constant Source_Ptr
:= Sloc
(N
);
7149 Expr
: constant Node_Id
:= Right_Opnd
(N
);
7152 Unary_Op_Validity_Checks
(N
);
7154 -- Check for MINIMIZED/ELIMINATED overflow mode
7156 if Minimized_Eliminated_Overflow_Check
(N
) then
7157 Apply_Arithmetic_Overflow_Check
(N
);
7161 -- Deal with software overflow checking
7163 if Is_Signed_Integer_Type
(Etype
(N
))
7164 and then Do_Overflow_Check
(N
)
7166 -- The only case to worry about is when the argument is equal to the
7167 -- largest negative number, so what we do is to insert the check:
7169 -- [constraint_error when Expr = typ'Base'First]
7171 -- with the usual Duplicate_Subexpr use coding for expr
7174 Make_Raise_Constraint_Error
(Loc
,
7177 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
7179 Make_Attribute_Reference
(Loc
,
7181 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
7182 Attribute_Name
=> Name_First
)),
7183 Reason
=> CE_Overflow_Check_Failed
));
7185 Set_Do_Overflow_Check
(N
, False);
7187 end Expand_N_Op_Abs
;
7189 ---------------------
7190 -- Expand_N_Op_Add --
7191 ---------------------
7193 procedure Expand_N_Op_Add
(N
: Node_Id
) is
7194 Typ
: constant Entity_Id
:= Etype
(N
);
7197 Binary_Op_Validity_Checks
(N
);
7199 -- Check for MINIMIZED/ELIMINATED overflow mode
7201 if Minimized_Eliminated_Overflow_Check
(N
) then
7202 Apply_Arithmetic_Overflow_Check
(N
);
7206 -- N + 0 = 0 + N = N for integer types
7208 if Is_Integer_Type
(Typ
) then
7209 if Compile_Time_Known_Value
(Right_Opnd
(N
))
7210 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
7212 Rewrite
(N
, Left_Opnd
(N
));
7215 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
7216 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
7218 Rewrite
(N
, Right_Opnd
(N
));
7223 -- Arithmetic overflow checks for signed integer/fixed point types
7225 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
7226 Apply_Arithmetic_Overflow_Check
(N
);
7230 -- Overflow checks for floating-point if -gnateF mode active
7232 Check_Float_Op_Overflow
(N
);
7234 Expand_Nonbinary_Modular_Op
(N
);
7235 end Expand_N_Op_Add
;
7237 ---------------------
7238 -- Expand_N_Op_And --
7239 ---------------------
7241 procedure Expand_N_Op_And
(N
: Node_Id
) is
7242 Typ
: constant Entity_Id
:= Etype
(N
);
7245 Binary_Op_Validity_Checks
(N
);
7247 if Is_Array_Type
(Etype
(N
)) then
7248 Expand_Boolean_Operator
(N
);
7250 elsif Is_Boolean_Type
(Etype
(N
)) then
7251 Adjust_Condition
(Left_Opnd
(N
));
7252 Adjust_Condition
(Right_Opnd
(N
));
7253 Set_Etype
(N
, Standard_Boolean
);
7254 Adjust_Result_Type
(N
, Typ
);
7256 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
7257 Expand_Intrinsic_Call
(N
, Entity
(N
));
7260 Expand_Nonbinary_Modular_Op
(N
);
7261 end Expand_N_Op_And
;
7263 ------------------------
7264 -- Expand_N_Op_Concat --
7265 ------------------------
7267 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
7269 -- List of operands to be concatenated
7272 -- Node which is to be replaced by the result of concatenating the nodes
7273 -- in the list Opnds.
7276 -- Ensure validity of both operands
7278 Binary_Op_Validity_Checks
(N
);
7280 -- If we are the left operand of a concatenation higher up the tree,
7281 -- then do nothing for now, since we want to deal with a series of
7282 -- concatenations as a unit.
7284 if Nkind
(Parent
(N
)) = N_Op_Concat
7285 and then N
= Left_Opnd
(Parent
(N
))
7290 -- We get here with a concatenation whose left operand may be a
7291 -- concatenation itself with a consistent type. We need to process
7292 -- these concatenation operands from left to right, which means
7293 -- from the deepest node in the tree to the highest node.
7296 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
7297 Cnode
:= Left_Opnd
(Cnode
);
7300 -- Now Cnode is the deepest concatenation, and its parents are the
7301 -- concatenation nodes above, so now we process bottom up, doing the
7304 -- The outer loop runs more than once if more than one concatenation
7305 -- type is involved.
7308 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
7309 Set_Parent
(Opnds
, N
);
7311 -- The inner loop gathers concatenation operands
7313 Inner
: while Cnode
/= N
7314 and then Base_Type
(Etype
(Cnode
)) =
7315 Base_Type
(Etype
(Parent
(Cnode
)))
7317 Cnode
:= Parent
(Cnode
);
7318 Append
(Right_Opnd
(Cnode
), Opnds
);
7321 -- Note: The following code is a temporary workaround for N731-034
7322 -- and N829-028 and will be kept until the general issue of internal
7323 -- symbol serialization is addressed. The workaround is kept under a
7324 -- debug switch to avoid permiating into the general case.
7326 -- Wrap the node to concatenate into an expression actions node to
7327 -- keep it nicely packaged. This is useful in the case of an assert
7328 -- pragma with a concatenation where we want to be able to delete
7329 -- the concatenation and all its expansion stuff.
7331 if Debug_Flag_Dot_H
then
7333 Cnod
: constant Node_Id
:= New_Copy_Tree
(Cnode
);
7334 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
7337 -- Note: use Rewrite rather than Replace here, so that for
7338 -- example Why_Not_Static can find the original concatenation
7342 Make_Expression_With_Actions
(Sloc
(Cnode
),
7343 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
7344 Expression
=> Cnod
));
7346 Expand_Concatenate
(Cnod
, Opnds
);
7347 Analyze_And_Resolve
(Cnode
, Typ
);
7353 Expand_Concatenate
(Cnode
, Opnds
);
7356 exit Outer
when Cnode
= N
;
7357 Cnode
:= Parent
(Cnode
);
7359 end Expand_N_Op_Concat
;
7361 ------------------------
7362 -- Expand_N_Op_Divide --
7363 ------------------------
7365 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
7366 Loc
: constant Source_Ptr
:= Sloc
(N
);
7367 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
7368 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
7369 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
7370 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
7371 Typ
: Entity_Id
:= Etype
(N
);
7372 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
7374 Compile_Time_Known_Value
(Ropnd
);
7378 Binary_Op_Validity_Checks
(N
);
7380 -- Check for MINIMIZED/ELIMINATED overflow mode
7382 if Minimized_Eliminated_Overflow_Check
(N
) then
7383 Apply_Arithmetic_Overflow_Check
(N
);
7387 -- Otherwise proceed with expansion of division
7390 Rval
:= Expr_Value
(Ropnd
);
7393 -- N / 1 = N for integer types
7395 if Rknow
and then Rval
= Uint_1
then
7400 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7401 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7402 -- operand is an unsigned integer, as required for this to work.
7404 if Nkind
(Ropnd
) = N_Op_Expon
7405 and then Is_Power_Of_2_For_Shift
(Ropnd
)
7407 -- We cannot do this transformation in configurable run time mode if we
7408 -- have 64-bit integers and long shifts are not available.
7410 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
7413 Make_Op_Shift_Right
(Loc
,
7416 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
7417 Analyze_And_Resolve
(N
, Typ
);
7421 -- Do required fixup of universal fixed operation
7423 if Typ
= Universal_Fixed
then
7424 Fixup_Universal_Fixed_Operation
(N
);
7428 -- Divisions with fixed-point results
7430 if Is_Fixed_Point_Type
(Typ
) then
7432 -- No special processing if Treat_Fixed_As_Integer is set, since
7433 -- from a semantic point of view such operations are simply integer
7434 -- operations and will be treated that way.
7436 if not Treat_Fixed_As_Integer
(N
) then
7437 if Is_Integer_Type
(Rtyp
) then
7438 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
7440 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
7444 -- Deal with divide-by-zero check if back end cannot handle them
7445 -- and the flag is set indicating that we need such a check. Note
7446 -- that we don't need to bother here with the case of mixed-mode
7447 -- (Right operand an integer type), since these will be rewritten
7448 -- with conversions to a divide with a fixed-point right operand.
7450 if Nkind
(N
) = N_Op_Divide
7451 and then Do_Division_Check
(N
)
7452 and then not Backend_Divide_Checks_On_Target
7453 and then not Is_Integer_Type
(Rtyp
)
7455 Set_Do_Division_Check
(N
, False);
7457 Make_Raise_Constraint_Error
(Loc
,
7460 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
7461 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
7462 Reason
=> CE_Divide_By_Zero
));
7465 -- Other cases of division of fixed-point operands. Again we exclude the
7466 -- case where Treat_Fixed_As_Integer is set.
7468 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
7469 and then not Treat_Fixed_As_Integer
(N
)
7471 if Is_Integer_Type
(Typ
) then
7472 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
7474 pragma Assert
(Is_Floating_Point_Type
(Typ
));
7475 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
7478 -- Mixed-mode operations can appear in a non-static universal context,
7479 -- in which case the integer argument must be converted explicitly.
7481 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
7483 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
7485 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
7487 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
7489 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
7491 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
7493 -- Non-fixed point cases, do integer zero divide and overflow checks
7495 elsif Is_Integer_Type
(Typ
) then
7496 Apply_Divide_Checks
(N
);
7499 -- Overflow checks for floating-point if -gnateF mode active
7501 Check_Float_Op_Overflow
(N
);
7503 Expand_Nonbinary_Modular_Op
(N
);
7504 end Expand_N_Op_Divide
;
7506 --------------------
7507 -- Expand_N_Op_Eq --
7508 --------------------
7510 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
7511 Loc
: constant Source_Ptr
:= Sloc
(N
);
7512 Typ
: constant Entity_Id
:= Etype
(N
);
7513 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
7514 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
7515 Bodies
: constant List_Id
:= New_List
;
7516 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
7518 procedure Build_Equality_Call
(Eq
: Entity_Id
);
7519 -- If a constructed equality exists for the type or for its parent,
7520 -- build and analyze call, adding conversions if the operation is
7523 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
;
7524 -- Find a primitive equality function within primitive operation list
7527 function Has_Unconstrained_UU_Component
(Typ
: Entity_Id
) return Boolean;
7528 -- Determines whether a type has a subcomponent of an unconstrained
7529 -- Unchecked_Union subtype. Typ is a record type.
7531 -------------------------
7532 -- Build_Equality_Call --
7533 -------------------------
7535 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
7536 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
7537 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
7538 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
7541 -- Adjust operands if necessary to comparison type
7543 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
7544 and then not Is_Class_Wide_Type
(A_Typ
)
7546 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
7547 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
7550 -- If we have an Unchecked_Union, we need to add the inferred
7551 -- discriminant values as actuals in the function call. At this
7552 -- point, the expansion has determined that both operands have
7553 -- inferable discriminants.
7555 if Is_Unchecked_Union
(Op_Type
) then
7557 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
7558 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
7560 Lhs_Discr_Vals
: Elist_Id
;
7561 -- List of inferred discriminant values for left operand.
7563 Rhs_Discr_Vals
: Elist_Id
;
7564 -- List of inferred discriminant values for right operand.
7569 Lhs_Discr_Vals
:= New_Elmt_List
;
7570 Rhs_Discr_Vals
:= New_Elmt_List
;
7572 -- Per-object constrained selected components require special
7573 -- attention. If the enclosing scope of the component is an
7574 -- Unchecked_Union, we cannot reference its discriminants
7575 -- directly. This is why we use the extra parameters of the
7576 -- equality function of the enclosing Unchecked_Union.
7578 -- type UU_Type (Discr : Integer := 0) is
7581 -- pragma Unchecked_Union (UU_Type);
7583 -- 1. Unchecked_Union enclosing record:
7585 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
7587 -- Comp : UU_Type (Discr);
7589 -- end Enclosing_UU_Type;
7590 -- pragma Unchecked_Union (Enclosing_UU_Type);
7592 -- Obj1 : Enclosing_UU_Type;
7593 -- Obj2 : Enclosing_UU_Type (1);
7595 -- [. . .] Obj1 = Obj2 [. . .]
7599 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
7601 -- A and B are the formal parameters of the equality function
7602 -- of Enclosing_UU_Type. The function always has two extra
7603 -- formals to capture the inferred discriminant values for
7604 -- each discriminant of the type.
7606 -- 2. Non-Unchecked_Union enclosing record:
7609 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
7612 -- Comp : UU_Type (Discr);
7614 -- end Enclosing_Non_UU_Type;
7616 -- Obj1 : Enclosing_Non_UU_Type;
7617 -- Obj2 : Enclosing_Non_UU_Type (1);
7619 -- ... Obj1 = Obj2 ...
7623 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
7624 -- obj1.discr, obj2.discr)) then
7626 -- In this case we can directly reference the discriminants of
7627 -- the enclosing record.
7629 -- Process left operand of equality
7631 if Nkind
(Lhs
) = N_Selected_Component
7633 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
7635 -- If enclosing record is an Unchecked_Union, use formals
7636 -- corresponding to each discriminant. The name of the
7637 -- formal is that of the discriminant, with added suffix,
7638 -- see Exp_Ch3.Build_Record_Equality for details.
7640 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Lhs
))))
7644 (Scope
(Entity
(Selector_Name
(Lhs
))));
7645 while Present
(Discr
) loop
7647 (Make_Identifier
(Loc
,
7648 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
7649 To
=> Lhs_Discr_Vals
);
7650 Next_Discriminant
(Discr
);
7653 -- If enclosing record is of a non-Unchecked_Union type, it
7654 -- is possible to reference its discriminants directly.
7657 Discr
:= First_Discriminant
(Lhs_Type
);
7658 while Present
(Discr
) loop
7660 (Make_Selected_Component
(Loc
,
7661 Prefix
=> Prefix
(Lhs
),
7664 (Get_Discriminant_Value
(Discr
,
7666 Stored_Constraint
(Lhs_Type
)))),
7667 To
=> Lhs_Discr_Vals
);
7668 Next_Discriminant
(Discr
);
7672 -- Otherwise operand is on object with a constrained type.
7673 -- Infer the discriminant values from the constraint.
7676 Discr
:= First_Discriminant
(Lhs_Type
);
7677 while Present
(Discr
) loop
7680 (Get_Discriminant_Value
(Discr
,
7682 Stored_Constraint
(Lhs_Type
))),
7683 To
=> Lhs_Discr_Vals
);
7684 Next_Discriminant
(Discr
);
7688 -- Similar processing for right operand of equality
7690 if Nkind
(Rhs
) = N_Selected_Component
7692 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
7694 if Is_Unchecked_Union
7695 (Scope
(Entity
(Selector_Name
(Rhs
))))
7699 (Scope
(Entity
(Selector_Name
(Rhs
))));
7700 while Present
(Discr
) loop
7702 (Make_Identifier
(Loc
,
7703 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
7704 To
=> Rhs_Discr_Vals
);
7705 Next_Discriminant
(Discr
);
7709 Discr
:= First_Discriminant
(Rhs_Type
);
7710 while Present
(Discr
) loop
7712 (Make_Selected_Component
(Loc
,
7713 Prefix
=> Prefix
(Rhs
),
7715 New_Copy
(Get_Discriminant_Value
7718 Stored_Constraint
(Rhs_Type
)))),
7719 To
=> Rhs_Discr_Vals
);
7720 Next_Discriminant
(Discr
);
7725 Discr
:= First_Discriminant
(Rhs_Type
);
7726 while Present
(Discr
) loop
7728 (New_Copy
(Get_Discriminant_Value
7731 Stored_Constraint
(Rhs_Type
))),
7732 To
=> Rhs_Discr_Vals
);
7733 Next_Discriminant
(Discr
);
7737 -- Now merge the list of discriminant values so that values
7738 -- of corresponding discriminants are adjacent.
7746 Params
:= New_List
(L_Exp
, R_Exp
);
7747 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
7748 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
7749 while Present
(L_Elmt
) loop
7750 Append_To
(Params
, Node
(L_Elmt
));
7751 Append_To
(Params
, Node
(R_Elmt
));
7757 Make_Function_Call
(Loc
,
7758 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7759 Parameter_Associations
=> Params
));
7763 -- Normal case, not an unchecked union
7767 Make_Function_Call
(Loc
,
7768 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7769 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7772 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7773 end Build_Equality_Call
;
7779 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
is
7780 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
;
7781 -- Find an equality in a possible alias chain starting from primitive
7784 function Is_Equality
(Id
: Entity_Id
) return Boolean;
7785 -- Determine whether arbitrary entity Id denotes an equality
7787 ---------------------------
7788 -- Find_Aliased_Equality --
7789 ---------------------------
7791 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
is
7795 -- Inspect each candidate in the alias chain, checking whether it
7796 -- denotes an equality.
7799 while Present
(Candid
) loop
7800 if Is_Equality
(Candid
) then
7804 Candid
:= Alias
(Candid
);
7808 end Find_Aliased_Equality
;
7814 function Is_Equality
(Id
: Entity_Id
) return Boolean is
7815 Formal_1
: Entity_Id
;
7816 Formal_2
: Entity_Id
;
7819 -- The equality function carries name "=", returns Boolean, and
7820 -- has exactly two formal parameters of an identical type.
7822 if Ekind
(Id
) = E_Function
7823 and then Chars
(Id
) = Name_Op_Eq
7824 and then Base_Type
(Etype
(Id
)) = Standard_Boolean
7826 Formal_1
:= First_Formal
(Id
);
7829 if Present
(Formal_1
) then
7830 Formal_2
:= Next_Formal
(Formal_1
);
7835 and then Present
(Formal_2
)
7836 and then Etype
(Formal_1
) = Etype
(Formal_2
)
7837 and then No
(Next_Formal
(Formal_2
));
7845 Eq_Prim
: Entity_Id
;
7846 Prim_Elmt
: Elmt_Id
;
7848 -- Start of processing for Find_Equality
7851 -- Assume that the tagged type lacks an equality
7855 -- Inspect the list of primitives looking for a suitable equality
7856 -- within a possible chain of aliases.
7858 Prim_Elmt
:= First_Elmt
(Prims
);
7859 while Present
(Prim_Elmt
) and then No
(Eq_Prim
) loop
7860 Eq_Prim
:= Find_Aliased_Equality
(Node
(Prim_Elmt
));
7862 Next_Elmt
(Prim_Elmt
);
7865 -- A tagged type should always have an equality
7867 pragma Assert
(Present
(Eq_Prim
));
7872 ------------------------------------
7873 -- Has_Unconstrained_UU_Component --
7874 ------------------------------------
7876 function Has_Unconstrained_UU_Component
7877 (Typ
: Entity_Id
) return Boolean
7879 Tdef
: constant Node_Id
:=
7880 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
7884 function Component_Is_Unconstrained_UU
7885 (Comp
: Node_Id
) return Boolean;
7886 -- Determines whether the subtype of the component is an
7887 -- unconstrained Unchecked_Union.
7889 function Variant_Is_Unconstrained_UU
7890 (Variant
: Node_Id
) return Boolean;
7891 -- Determines whether a component of the variant has an unconstrained
7892 -- Unchecked_Union subtype.
7894 -----------------------------------
7895 -- Component_Is_Unconstrained_UU --
7896 -----------------------------------
7898 function Component_Is_Unconstrained_UU
7899 (Comp
: Node_Id
) return Boolean
7902 if Nkind
(Comp
) /= N_Component_Declaration
then
7907 Sindic
: constant Node_Id
:=
7908 Subtype_Indication
(Component_Definition
(Comp
));
7911 -- Unconstrained nominal type. In the case of a constraint
7912 -- present, the node kind would have been N_Subtype_Indication.
7914 if Nkind
(Sindic
) = N_Identifier
then
7915 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
7920 end Component_Is_Unconstrained_UU
;
7922 ---------------------------------
7923 -- Variant_Is_Unconstrained_UU --
7924 ---------------------------------
7926 function Variant_Is_Unconstrained_UU
7927 (Variant
: Node_Id
) return Boolean
7929 Clist
: constant Node_Id
:= Component_List
(Variant
);
7932 if Is_Empty_List
(Component_Items
(Clist
)) then
7936 -- We only need to test one component
7939 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7942 while Present
(Comp
) loop
7943 if Component_Is_Unconstrained_UU
(Comp
) then
7951 -- None of the components withing the variant were of
7952 -- unconstrained Unchecked_Union type.
7955 end Variant_Is_Unconstrained_UU
;
7957 -- Start of processing for Has_Unconstrained_UU_Component
7960 if Null_Present
(Tdef
) then
7964 Clist
:= Component_List
(Tdef
);
7965 Vpart
:= Variant_Part
(Clist
);
7967 -- Inspect available components
7969 if Present
(Component_Items
(Clist
)) then
7971 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7974 while Present
(Comp
) loop
7976 -- One component is sufficient
7978 if Component_Is_Unconstrained_UU
(Comp
) then
7987 -- Inspect available components withing variants
7989 if Present
(Vpart
) then
7991 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7994 while Present
(Variant
) loop
7996 -- One component within a variant is sufficient
7998 if Variant_Is_Unconstrained_UU
(Variant
) then
8007 -- Neither the available components, nor the components inside the
8008 -- variant parts were of an unconstrained Unchecked_Union subtype.
8011 end Has_Unconstrained_UU_Component
;
8017 -- Start of processing for Expand_N_Op_Eq
8020 Binary_Op_Validity_Checks
(N
);
8022 -- Deal with private types
8026 if Ekind
(Typl
) = E_Private_Type
then
8027 Typl
:= Underlying_Type
(Typl
);
8029 elsif Ekind
(Typl
) = E_Private_Subtype
then
8030 Typl
:= Underlying_Type
(Base_Type
(Typl
));
8033 -- It may happen in error situations that the underlying type is not
8034 -- set. The error will be detected later, here we just defend the
8041 -- Now get the implementation base type (note that plain Base_Type here
8042 -- might lead us back to the private type, which is not what we want!)
8044 Typl
:= Implementation_Base_Type
(Typl
);
8046 -- Equality between variant records results in a call to a routine
8047 -- that has conditional tests of the discriminant value(s), and hence
8048 -- violates the No_Implicit_Conditionals restriction.
8050 if Has_Variant_Part
(Typl
) then
8055 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
8059 ("\comparison of variant records tests discriminants", N
);
8065 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8066 -- means we no longer have a comparison operation, we are all done.
8068 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8070 if Nkind
(N
) /= N_Op_Eq
then
8074 -- Boolean types (requiring handling of non-standard case)
8076 if Is_Boolean_Type
(Typl
) then
8077 Adjust_Condition
(Left_Opnd
(N
));
8078 Adjust_Condition
(Right_Opnd
(N
));
8079 Set_Etype
(N
, Standard_Boolean
);
8080 Adjust_Result_Type
(N
, Typ
);
8084 elsif Is_Array_Type
(Typl
) then
8086 -- If we are doing full validity checking, and it is possible for the
8087 -- array elements to be invalid then expand out array comparisons to
8088 -- make sure that we check the array elements.
8090 if Validity_Check_Operands
8091 and then not Is_Known_Valid
(Component_Type
(Typl
))
8094 Save_Force_Validity_Checks
: constant Boolean :=
8095 Force_Validity_Checks
;
8097 Force_Validity_Checks
:= True;
8099 Expand_Array_Equality
8101 Relocate_Node
(Lhs
),
8102 Relocate_Node
(Rhs
),
8105 Insert_Actions
(N
, Bodies
);
8106 Analyze_And_Resolve
(N
, Standard_Boolean
);
8107 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
8110 -- Packed case where both operands are known aligned
8112 elsif Is_Bit_Packed_Array
(Typl
)
8113 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8114 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8116 Expand_Packed_Eq
(N
);
8118 -- Where the component type is elementary we can use a block bit
8119 -- comparison (if supported on the target) exception in the case
8120 -- of floating-point (negative zero issues require element by
8121 -- element comparison), and atomic/VFA types (where we must be sure
8122 -- to load elements independently) and possibly unaligned arrays.
8124 elsif Is_Elementary_Type
(Component_Type
(Typl
))
8125 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
8126 and then not Is_Atomic_Or_VFA
(Component_Type
(Typl
))
8127 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8128 and then not Is_Possibly_Unaligned_Slice
(Lhs
)
8129 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8130 and then not Is_Possibly_Unaligned_Slice
(Rhs
)
8131 and then Support_Composite_Compare_On_Target
8135 -- For composite and floating-point cases, expand equality loop to
8136 -- make sure of using proper comparisons for tagged types, and
8137 -- correctly handling the floating-point case.
8141 Expand_Array_Equality
8143 Relocate_Node
(Lhs
),
8144 Relocate_Node
(Rhs
),
8147 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8148 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8153 elsif Is_Record_Type
(Typl
) then
8155 -- For tagged types, use the primitive "="
8157 if Is_Tagged_Type
(Typl
) then
8159 -- No need to do anything else compiling under restriction
8160 -- No_Dispatching_Calls. During the semantic analysis we
8161 -- already notified such violation.
8163 if Restriction_Active
(No_Dispatching_Calls
) then
8167 -- If this is an untagged private type completed with a derivation
8168 -- of an untagged private type whose full view is a tagged type,
8169 -- we use the primitive operations of the private type (since it
8170 -- does not have a full view, and also because its equality
8171 -- primitive may have been overridden in its untagged full view).
8173 if Inherits_From_Tagged_Full_View
(A_Typ
) then
8175 (Find_Equality
(Collect_Primitive_Operations
(A_Typ
)));
8177 -- Find the type's predefined equality or an overriding
8178 -- user-defined equality. The reason for not simply calling
8179 -- Find_Prim_Op here is that there may be a user-defined
8180 -- overloaded equality op that precedes the equality that we
8181 -- want, so we have to explicitly search (e.g., there could be
8182 -- an equality with two different parameter types).
8185 if Is_Class_Wide_Type
(Typl
) then
8186 Typl
:= Find_Specific_Type
(Typl
);
8190 (Find_Equality
(Primitive_Operations
(Typl
)));
8193 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8194 -- predefined equality operator for a type which has a subcomponent
8195 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
8197 elsif Has_Unconstrained_UU_Component
(Typl
) then
8199 Make_Raise_Program_Error
(Loc
,
8200 Reason
=> PE_Unchecked_Union_Restriction
));
8202 -- Prevent Gigi from generating incorrect code by rewriting the
8203 -- equality as a standard False. (is this documented somewhere???)
8206 New_Occurrence_Of
(Standard_False
, Loc
));
8208 elsif Is_Unchecked_Union
(Typl
) then
8210 -- If we can infer the discriminants of the operands, we make a
8211 -- call to the TSS equality function.
8213 if Has_Inferable_Discriminants
(Lhs
)
8215 Has_Inferable_Discriminants
(Rhs
)
8218 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8221 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
8222 -- the predefined equality operator for an Unchecked_Union type
8223 -- if either of the operands lack inferable discriminants.
8226 Make_Raise_Program_Error
(Loc
,
8227 Reason
=> PE_Unchecked_Union_Restriction
));
8229 -- Emit a warning on source equalities only, otherwise the
8230 -- message may appear out of place due to internal use. The
8231 -- warning is unconditional because it is required by the
8234 if Comes_From_Source
(N
) then
8236 ("Unchecked_Union discriminants cannot be determined??",
8239 ("\Program_Error will be raised for equality operation??",
8243 -- Prevent Gigi from generating incorrect code by rewriting
8244 -- the equality as a standard False (documented where???).
8247 New_Occurrence_Of
(Standard_False
, Loc
));
8250 -- If a type support function is present (for complex cases), use it
8252 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
8254 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8256 -- When comparing two Bounded_Strings, use the primitive equality of
8257 -- the root Super_String type.
8259 elsif Is_Bounded_String
(Typl
) then
8262 (Collect_Primitive_Operations
(Root_Type
(Typl
))));
8264 -- Otherwise expand the component by component equality. Note that
8265 -- we never use block-bit comparisons for records, because of the
8266 -- problems with gaps. The back end will often be able to recombine
8267 -- the separate comparisons that we generate here.
8270 Remove_Side_Effects
(Lhs
);
8271 Remove_Side_Effects
(Rhs
);
8273 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
8275 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8276 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8279 -- If unnesting, handle elementary types whose Equivalent_Types are
8280 -- records because there may be padding or undefined fields.
8282 elsif Unnest_Subprogram_Mode
8283 and then Ekind_In
(Typl
, E_Class_Wide_Type
,
8284 E_Class_Wide_Subtype
,
8285 E_Access_Subprogram_Type
,
8286 E_Access_Protected_Subprogram_Type
,
8287 E_Anonymous_Access_Protected_Subprogram_Type
,
8288 E_Access_Subprogram_Type
,
8290 and then Present
(Equivalent_Type
(Typl
))
8291 and then Is_Record_Type
(Equivalent_Type
(Typl
))
8293 Typl
:= Equivalent_Type
(Typl
);
8294 Remove_Side_Effects
(Lhs
);
8295 Remove_Side_Effects
(Rhs
);
8297 Expand_Record_Equality
(N
, Typl
,
8298 Unchecked_Convert_To
(Typl
, Lhs
),
8299 Unchecked_Convert_To
(Typl
, Rhs
),
8302 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8303 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8306 -- Test if result is known at compile time
8308 Rewrite_Comparison
(N
);
8310 -- Special optimization of length comparison
8312 Optimize_Length_Comparison
(N
);
8314 -- One more special case: if we have a comparison of X'Result = expr
8315 -- in floating-point, then if not already there, change expr to be
8316 -- f'Machine (expr) to eliminate surprise from extra precision.
8318 if Is_Floating_Point_Type
(Typl
)
8319 and then Nkind
(Original_Node
(Lhs
)) = N_Attribute_Reference
8320 and then Attribute_Name
(Original_Node
(Lhs
)) = Name_Result
8322 -- Stick in the Typ'Machine call if not already there
8324 if Nkind
(Rhs
) /= N_Attribute_Reference
8325 or else Attribute_Name
(Rhs
) /= Name_Machine
8328 Make_Attribute_Reference
(Loc
,
8329 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
8330 Attribute_Name
=> Name_Machine
,
8331 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
8332 Analyze_And_Resolve
(Rhs
, Typl
);
8337 -----------------------
8338 -- Expand_N_Op_Expon --
8339 -----------------------
8341 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
8342 Loc
: constant Source_Ptr
:= Sloc
(N
);
8343 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
8344 Typ
: constant Entity_Id
:= Etype
(N
);
8345 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
8349 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
8350 -- Given an expression Exp, if the root type is Float or Long_Float,
8351 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8352 -- extra precision. This is done to ensure that X**A = X**B when A is
8353 -- a static constant and B is a variable with the same value. For any
8354 -- other type, the node Exp is returned unchanged.
8360 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
8361 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
8364 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
8366 Make_Attribute_Reference
(Loc
,
8367 Attribute_Name
=> Name_Machine
,
8368 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
8369 Expressions
=> New_List
(Relocate_Node
(Exp
)));
8387 -- Start of processing for Expand_N_Op_Expon
8390 Binary_Op_Validity_Checks
(N
);
8392 -- CodePeer wants to see the unexpanded N_Op_Expon node
8394 if CodePeer_Mode
then
8398 -- Relocation of left and right operands must be done after performing
8399 -- the validity checks since the generation of validation checks may
8400 -- remove side effects.
8402 Base
:= Relocate_Node
(Left_Opnd
(N
));
8403 Bastyp
:= Etype
(Base
);
8404 Exp
:= Relocate_Node
(Right_Opnd
(N
));
8405 Exptyp
:= Etype
(Exp
);
8407 -- If either operand is of a private type, then we have the use of an
8408 -- intrinsic operator, and we get rid of the privateness, by using root
8409 -- types of underlying types for the actual operation. Otherwise the
8410 -- private types will cause trouble if we expand multiplications or
8411 -- shifts etc. We also do this transformation if the result type is
8412 -- different from the base type.
8414 if Is_Private_Type
(Etype
(Base
))
8415 or else Is_Private_Type
(Typ
)
8416 or else Is_Private_Type
(Exptyp
)
8417 or else Rtyp
/= Root_Type
(Bastyp
)
8420 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
8421 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
8424 Unchecked_Convert_To
(Typ
,
8426 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
8427 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
8428 Analyze_And_Resolve
(N
, Typ
);
8433 -- Check for MINIMIZED/ELIMINATED overflow mode
8435 if Minimized_Eliminated_Overflow_Check
(N
) then
8436 Apply_Arithmetic_Overflow_Check
(N
);
8440 -- Test for case of known right argument where we can replace the
8441 -- exponentiation by an equivalent expression using multiplication.
8443 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8444 -- configurable run-time mode, we may not have the exponentiation
8445 -- routine available, and we don't want the legality of the program
8446 -- to depend on how clever the compiler is in knowing values.
8448 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
8449 Expv
:= Expr_Value
(Exp
);
8451 -- We only fold small non-negative exponents. You might think we
8452 -- could fold small negative exponents for the real case, but we
8453 -- can't because we are required to raise Constraint_Error for
8454 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8455 -- See ACVC test C4A012B, and it is not worth generating the test.
8457 -- For small negative exponents, we return the reciprocal of
8458 -- the folding of the exponentiation for the opposite (positive)
8459 -- exponent, as required by Ada RM 4.5.6(11/3).
8461 if abs Expv
<= 4 then
8463 -- X ** 0 = 1 (or 1.0)
8467 -- Call Remove_Side_Effects to ensure that any side effects
8468 -- in the ignored left operand (in particular function calls
8469 -- to user defined functions) are properly executed.
8471 Remove_Side_Effects
(Base
);
8473 if Ekind
(Typ
) in Integer_Kind
then
8474 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
8476 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
8489 Make_Op_Multiply
(Loc
,
8490 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8491 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8493 -- X ** 3 = X * X * X
8498 Make_Op_Multiply
(Loc
,
8500 Make_Op_Multiply
(Loc
,
8501 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8502 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
8503 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8508 -- En : constant base'type := base * base;
8513 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
8516 Make_Expression_With_Actions
(Loc
,
8517 Actions
=> New_List
(
8518 Make_Object_Declaration
(Loc
,
8519 Defining_Identifier
=> Temp
,
8520 Constant_Present
=> True,
8521 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8524 Make_Op_Multiply
(Loc
,
8526 Duplicate_Subexpr
(Base
),
8528 Duplicate_Subexpr_No_Checks
(Base
))))),
8532 Make_Op_Multiply
(Loc
,
8533 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
8534 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
8536 -- X ** N = 1.0 / X ** (-N)
8541 (Expv
= -1 or Expv
= -2 or Expv
= -3 or Expv
= -4);
8544 Make_Op_Divide
(Loc
,
8546 Make_Float_Literal
(Loc
,
8548 Significand
=> Uint_1
,
8549 Exponent
=> Uint_0
),
8552 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8554 Make_Integer_Literal
(Loc
,
8559 Analyze_And_Resolve
(N
, Typ
);
8564 -- Deal with optimizing 2 ** expression to shift where possible
8566 -- Note: we used to check that Exptyp was an unsigned type. But that is
8567 -- an unnecessary check, since if Exp is negative, we have a run-time
8568 -- error that is either caught (so we get the right result) or we have
8569 -- suppressed the check, in which case the code is erroneous anyway.
8571 if Is_Integer_Type
(Rtyp
)
8573 -- The base value must be "safe compile-time known", and exactly 2
8575 and then Nkind
(Base
) = N_Integer_Literal
8576 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
8577 and then Expr_Value
(Base
) = Uint_2
8579 -- We only handle cases where the right type is a integer
8581 and then Is_Integer_Type
(Root_Type
(Exptyp
))
8582 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
8584 -- This transformation is not applicable for a modular type with a
8585 -- nonbinary modulus because we do not handle modular reduction in
8586 -- a correct manner if we attempt this transformation in this case.
8588 and then not Non_Binary_Modulus
(Typ
)
8590 -- Handle the cases where our parent is a division or multiplication
8591 -- specially. In these cases we can convert to using a shift at the
8592 -- parent level if we are not doing overflow checking, since it is
8593 -- too tricky to combine the overflow check at the parent level.
8596 and then Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
)
8599 P
: constant Node_Id
:= Parent
(N
);
8600 L
: constant Node_Id
:= Left_Opnd
(P
);
8601 R
: constant Node_Id
:= Right_Opnd
(P
);
8604 if (Nkind
(P
) = N_Op_Multiply
8606 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
8608 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
8609 and then not Do_Overflow_Check
(P
))
8612 (Nkind
(P
) = N_Op_Divide
8613 and then Is_Integer_Type
(Etype
(L
))
8614 and then Is_Unsigned_Type
(Etype
(L
))
8616 and then not Do_Overflow_Check
(P
))
8618 Set_Is_Power_Of_2_For_Shift
(N
);
8623 -- Here we just have 2 ** N on its own, so we can convert this to a
8624 -- shift node. We are prepared to deal with overflow here, and we
8625 -- also have to handle proper modular reduction for binary modular.
8634 -- Maximum shift count with no overflow
8637 -- Set True if we must test the shift count
8640 -- Node for test against TestS
8643 -- Compute maximum shift based on the underlying size. For a
8644 -- modular type this is one less than the size.
8646 if Is_Modular_Integer_Type
(Typ
) then
8648 -- For modular integer types, this is the size of the value
8649 -- being shifted minus one. Any larger values will cause
8650 -- modular reduction to a result of zero. Note that we do
8651 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
8652 -- of 6, since 2**7 should be reduced to zero).
8654 MaxS
:= RM_Size
(Rtyp
) - 1;
8656 -- For signed integer types, we use the size of the value
8657 -- being shifted minus 2. Larger values cause overflow.
8660 MaxS
:= Esize
(Rtyp
) - 2;
8663 -- Determine range to see if it can be larger than MaxS
8666 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
8667 TestS
:= (not OK
) or else Hi
> MaxS
;
8669 -- Signed integer case
8671 if Is_Signed_Integer_Type
(Typ
) then
8673 -- Generate overflow check if overflow is active. Note that
8674 -- we can simply ignore the possibility of overflow if the
8675 -- flag is not set (means that overflow cannot happen or
8676 -- that overflow checks are suppressed).
8678 if Ovflo
and TestS
then
8680 Make_Raise_Constraint_Error
(Loc
,
8683 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
8684 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
8685 Reason
=> CE_Overflow_Check_Failed
));
8688 -- Now rewrite node as Shift_Left (1, right-operand)
8691 Make_Op_Shift_Left
(Loc
,
8692 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8693 Right_Opnd
=> Right_Opnd
(N
)));
8695 -- Modular integer case
8697 else pragma Assert
(Is_Modular_Integer_Type
(Typ
));
8699 -- If shift count can be greater than MaxS, we need to wrap
8700 -- the shift in a test that will reduce the result value to
8701 -- zero if this shift count is exceeded.
8705 -- Note: build node for the comparison first, before we
8706 -- reuse the Right_Opnd, so that we have proper parents
8707 -- in place for the Duplicate_Subexpr call.
8711 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
8712 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
));
8715 Make_If_Expression
(Loc
,
8716 Expressions
=> New_List
(
8718 Make_Integer_Literal
(Loc
, Uint_0
),
8719 Make_Op_Shift_Left
(Loc
,
8720 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8721 Right_Opnd
=> Right_Opnd
(N
)))));
8723 -- If we know shift count cannot be greater than MaxS, then
8724 -- it is safe to just rewrite as a shift with no test.
8728 Make_Op_Shift_Left
(Loc
,
8729 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8730 Right_Opnd
=> Right_Opnd
(N
)));
8734 Analyze_And_Resolve
(N
, Typ
);
8740 -- Fall through if exponentiation must be done using a runtime routine
8742 -- First deal with modular case
8744 if Is_Modular_Integer_Type
(Rtyp
) then
8746 -- Nonbinary modular case, we call the special exponentiation
8747 -- routine for the nonbinary case, converting the argument to
8748 -- Long_Long_Integer and passing the modulus value. Then the
8749 -- result is converted back to the base type.
8751 if Non_Binary_Modulus
(Rtyp
) then
8754 Make_Function_Call
(Loc
,
8756 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
8757 Parameter_Associations
=> New_List
(
8758 Convert_To
(RTE
(RE_Unsigned
), Base
),
8759 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
8762 -- Binary modular case, in this case, we call one of two routines,
8763 -- either the unsigned integer case, or the unsigned long long
8764 -- integer case, with a final "and" operation to do the required mod.
8767 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
8768 Ent
:= RTE
(RE_Exp_Unsigned
);
8770 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
8777 Make_Function_Call
(Loc
,
8778 Name
=> New_Occurrence_Of
(Ent
, Loc
),
8779 Parameter_Associations
=> New_List
(
8780 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
8783 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
8787 -- Common exit point for modular type case
8789 Analyze_And_Resolve
(N
, Typ
);
8792 -- Signed integer cases, done using either Integer or Long_Long_Integer.
8793 -- It is not worth having routines for Short_[Short_]Integer, since for
8794 -- most machines it would not help, and it would generate more code that
8795 -- might need certification when a certified run time is required.
8797 -- In the integer cases, we have two routines, one for when overflow
8798 -- checks are required, and one when they are not required, since there
8799 -- is a real gain in omitting checks on many machines.
8801 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
8802 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
8804 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
8805 or else Rtyp
= Universal_Integer
8807 Etyp
:= Standard_Long_Long_Integer
;
8810 Rent
:= RE_Exp_Long_Long_Integer
;
8812 Rent
:= RE_Exn_Long_Long_Integer
;
8815 elsif Is_Signed_Integer_Type
(Rtyp
) then
8816 Etyp
:= Standard_Integer
;
8819 Rent
:= RE_Exp_Integer
;
8821 Rent
:= RE_Exn_Integer
;
8824 -- Floating-point cases. We do not need separate routines for the
8825 -- overflow case here, since in the case of floating-point, we generate
8826 -- infinities anyway as a rule (either that or we automatically trap
8827 -- overflow), and if there is an infinity generated and a range check
8828 -- is required, the check will fail anyway.
8830 -- Historical note: we used to convert everything to Long_Long_Float
8831 -- and call a single common routine, but this had the undesirable effect
8832 -- of giving different results for small static exponent values and the
8833 -- same dynamic values.
8836 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
8838 if Rtyp
= Standard_Float
then
8839 Etyp
:= Standard_Float
;
8840 Rent
:= RE_Exn_Float
;
8842 elsif Rtyp
= Standard_Long_Float
then
8843 Etyp
:= Standard_Long_Float
;
8844 Rent
:= RE_Exn_Long_Float
;
8847 Etyp
:= Standard_Long_Long_Float
;
8848 Rent
:= RE_Exn_Long_Long_Float
;
8852 -- Common processing for integer cases and floating-point cases.
8853 -- If we are in the right type, we can call runtime routine directly
8856 and then Rtyp
/= Universal_Integer
8857 and then Rtyp
/= Universal_Real
8861 Make_Function_Call
(Loc
,
8862 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8863 Parameter_Associations
=> New_List
(Base
, Exp
))));
8865 -- Otherwise we have to introduce conversions (conversions are also
8866 -- required in the universal cases, since the runtime routine is
8867 -- typed using one of the standard types).
8872 Make_Function_Call
(Loc
,
8873 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8874 Parameter_Associations
=> New_List
(
8875 Convert_To
(Etyp
, Base
),
8879 Analyze_And_Resolve
(N
, Typ
);
8883 when RE_Not_Available
=>
8885 end Expand_N_Op_Expon
;
8887 --------------------
8888 -- Expand_N_Op_Ge --
8889 --------------------
8891 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
8892 Typ
: constant Entity_Id
:= Etype
(N
);
8893 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8894 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8895 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8898 Binary_Op_Validity_Checks
(N
);
8900 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8901 -- means we no longer have a comparison operation, we are all done.
8903 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8905 if Nkind
(N
) /= N_Op_Ge
then
8911 if Is_Array_Type
(Typ1
) then
8912 Expand_Array_Comparison
(N
);
8916 -- Deal with boolean operands
8918 if Is_Boolean_Type
(Typ1
) then
8919 Adjust_Condition
(Op1
);
8920 Adjust_Condition
(Op2
);
8921 Set_Etype
(N
, Standard_Boolean
);
8922 Adjust_Result_Type
(N
, Typ
);
8925 Rewrite_Comparison
(N
);
8927 Optimize_Length_Comparison
(N
);
8930 --------------------
8931 -- Expand_N_Op_Gt --
8932 --------------------
8934 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
8935 Typ
: constant Entity_Id
:= Etype
(N
);
8936 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8937 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8938 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8941 Binary_Op_Validity_Checks
(N
);
8943 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8944 -- means we no longer have a comparison operation, we are all done.
8946 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8948 if Nkind
(N
) /= N_Op_Gt
then
8952 -- Deal with array type operands
8954 if Is_Array_Type
(Typ1
) then
8955 Expand_Array_Comparison
(N
);
8959 -- Deal with boolean type operands
8961 if Is_Boolean_Type
(Typ1
) then
8962 Adjust_Condition
(Op1
);
8963 Adjust_Condition
(Op2
);
8964 Set_Etype
(N
, Standard_Boolean
);
8965 Adjust_Result_Type
(N
, Typ
);
8968 Rewrite_Comparison
(N
);
8970 Optimize_Length_Comparison
(N
);
8973 --------------------
8974 -- Expand_N_Op_Le --
8975 --------------------
8977 procedure Expand_N_Op_Le
(N
: Node_Id
) is
8978 Typ
: constant Entity_Id
:= Etype
(N
);
8979 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8980 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8981 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8984 Binary_Op_Validity_Checks
(N
);
8986 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8987 -- means we no longer have a comparison operation, we are all done.
8989 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8991 if Nkind
(N
) /= N_Op_Le
then
8995 -- Deal with array type operands
8997 if Is_Array_Type
(Typ1
) then
8998 Expand_Array_Comparison
(N
);
9002 -- Deal with Boolean type operands
9004 if Is_Boolean_Type
(Typ1
) then
9005 Adjust_Condition
(Op1
);
9006 Adjust_Condition
(Op2
);
9007 Set_Etype
(N
, Standard_Boolean
);
9008 Adjust_Result_Type
(N
, Typ
);
9011 Rewrite_Comparison
(N
);
9013 Optimize_Length_Comparison
(N
);
9016 --------------------
9017 -- Expand_N_Op_Lt --
9018 --------------------
9020 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
9021 Typ
: constant Entity_Id
:= Etype
(N
);
9022 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9023 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9024 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9027 Binary_Op_Validity_Checks
(N
);
9029 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9030 -- means we no longer have a comparison operation, we are all done.
9032 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9034 if Nkind
(N
) /= N_Op_Lt
then
9038 -- Deal with array type operands
9040 if Is_Array_Type
(Typ1
) then
9041 Expand_Array_Comparison
(N
);
9045 -- Deal with Boolean type operands
9047 if Is_Boolean_Type
(Typ1
) then
9048 Adjust_Condition
(Op1
);
9049 Adjust_Condition
(Op2
);
9050 Set_Etype
(N
, Standard_Boolean
);
9051 Adjust_Result_Type
(N
, Typ
);
9054 Rewrite_Comparison
(N
);
9056 Optimize_Length_Comparison
(N
);
9059 -----------------------
9060 -- Expand_N_Op_Minus --
9061 -----------------------
9063 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
9064 Loc
: constant Source_Ptr
:= Sloc
(N
);
9065 Typ
: constant Entity_Id
:= Etype
(N
);
9068 Unary_Op_Validity_Checks
(N
);
9070 -- Check for MINIMIZED/ELIMINATED overflow mode
9072 if Minimized_Eliminated_Overflow_Check
(N
) then
9073 Apply_Arithmetic_Overflow_Check
(N
);
9077 if not Backend_Overflow_Checks_On_Target
9078 and then Is_Signed_Integer_Type
(Etype
(N
))
9079 and then Do_Overflow_Check
(N
)
9081 -- Software overflow checking expands -expr into (0 - expr)
9084 Make_Op_Subtract
(Loc
,
9085 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
9086 Right_Opnd
=> Right_Opnd
(N
)));
9088 Analyze_And_Resolve
(N
, Typ
);
9091 Expand_Nonbinary_Modular_Op
(N
);
9092 end Expand_N_Op_Minus
;
9094 ---------------------
9095 -- Expand_N_Op_Mod --
9096 ---------------------
9098 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
9099 Loc
: constant Source_Ptr
:= Sloc
(N
);
9100 Typ
: constant Entity_Id
:= Etype
(N
);
9101 DDC
: constant Boolean := Do_Division_Check
(N
);
9114 pragma Warnings
(Off
, Lhi
);
9117 Binary_Op_Validity_Checks
(N
);
9119 -- Check for MINIMIZED/ELIMINATED overflow mode
9121 if Minimized_Eliminated_Overflow_Check
(N
) then
9122 Apply_Arithmetic_Overflow_Check
(N
);
9126 if Is_Integer_Type
(Etype
(N
)) then
9127 Apply_Divide_Checks
(N
);
9129 -- All done if we don't have a MOD any more, which can happen as a
9130 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9132 if Nkind
(N
) /= N_Op_Mod
then
9137 -- Proceed with expansion of mod operator
9139 Left
:= Left_Opnd
(N
);
9140 Right
:= Right_Opnd
(N
);
9142 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
9143 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
9145 -- Convert mod to rem if operands are both known to be non-negative, or
9146 -- both known to be non-positive (these are the cases in which rem and
9147 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9148 -- likely that this will improve the quality of code, (the operation now
9149 -- corresponds to the hardware remainder), and it does not seem likely
9150 -- that it could be harmful. It also avoids some cases of the elaborate
9151 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9154 and then ((Llo
>= 0 and then Rlo
>= 0)
9156 (Lhi
<= 0 and then Rhi
<= 0))
9159 Make_Op_Rem
(Sloc
(N
),
9160 Left_Opnd
=> Left_Opnd
(N
),
9161 Right_Opnd
=> Right_Opnd
(N
)));
9163 -- Instead of reanalyzing the node we do the analysis manually. This
9164 -- avoids anomalies when the replacement is done in an instance and
9165 -- is epsilon more efficient.
9167 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
9169 Set_Do_Division_Check
(N
, DDC
);
9170 Expand_N_Op_Rem
(N
);
9174 -- Otherwise, normal mod processing
9177 -- Apply optimization x mod 1 = 0. We don't really need that with
9178 -- gcc, but it is useful with other back ends and is certainly
9181 if Is_Integer_Type
(Etype
(N
))
9182 and then Compile_Time_Known_Value
(Right
)
9183 and then Expr_Value
(Right
) = Uint_1
9185 -- Call Remove_Side_Effects to ensure that any side effects in
9186 -- the ignored left operand (in particular function calls to
9187 -- user defined functions) are properly executed.
9189 Remove_Side_Effects
(Left
);
9191 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9192 Analyze_And_Resolve
(N
, Typ
);
9196 -- If we still have a mod operator and we are in Modify_Tree_For_C
9197 -- mode, and we have a signed integer type, then here is where we do
9198 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9199 -- for the special handling of the annoying case of largest negative
9200 -- number mod minus one.
9202 if Nkind
(N
) = N_Op_Mod
9203 and then Is_Signed_Integer_Type
(Typ
)
9204 and then Modify_Tree_For_C
9206 -- In the general case, we expand A mod B as
9208 -- Tnn : constant typ := A rem B;
9210 -- (if (A >= 0) = (B >= 0) then Tnn
9211 -- elsif Tnn = 0 then 0
9214 -- The comparison can be written simply as A >= 0 if we know that
9215 -- B >= 0 which is a very common case.
9217 -- An important optimization is when B is known at compile time
9218 -- to be 2**K for some constant. In this case we can simply AND
9219 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9220 -- and that works for both the positive and negative cases.
9223 P2
: constant Nat
:= Power_Of_Two
(Right
);
9228 Unchecked_Convert_To
(Typ
,
9231 Unchecked_Convert_To
9232 (Corresponding_Unsigned_Type
(Typ
), Left
),
9234 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
9235 Analyze_And_Resolve
(N
, Typ
);
9240 -- Here for the full rewrite
9243 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
9249 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9250 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
9252 if not LOK
or else Rlo
< 0 then
9258 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
9259 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
9263 Make_Object_Declaration
(Loc
,
9264 Defining_Identifier
=> Tnn
,
9265 Constant_Present
=> True,
9266 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9270 Right_Opnd
=> Right
)));
9273 Make_If_Expression
(Loc
,
9274 Expressions
=> New_List
(
9276 New_Occurrence_Of
(Tnn
, Loc
),
9277 Make_If_Expression
(Loc
,
9279 Expressions
=> New_List
(
9281 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9282 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9283 Make_Integer_Literal
(Loc
, 0),
9285 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9287 Duplicate_Subexpr_No_Checks
(Right
)))))));
9289 Analyze_And_Resolve
(N
, Typ
);
9294 -- Deal with annoying case of largest negative number mod minus one.
9295 -- Gigi may not handle this case correctly, because on some targets,
9296 -- the mod value is computed using a divide instruction which gives
9297 -- an overflow trap for this case.
9299 -- It would be a bit more efficient to figure out which targets
9300 -- this is really needed for, but in practice it is reasonable
9301 -- to do the following special check in all cases, since it means
9302 -- we get a clearer message, and also the overhead is minimal given
9303 -- that division is expensive in any case.
9305 -- In fact the check is quite easy, if the right operand is -1, then
9306 -- the mod value is always 0, and we can just ignore the left operand
9307 -- completely in this case.
9309 -- This only applies if we still have a mod operator. Skip if we
9310 -- have already rewritten this (e.g. in the case of eliminated
9311 -- overflow checks which have driven us into bignum mode).
9313 if Nkind
(N
) = N_Op_Mod
then
9315 -- The operand type may be private (e.g. in the expansion of an
9316 -- intrinsic operation) so we must use the underlying type to get
9317 -- the bounds, and convert the literals explicitly.
9321 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
9323 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
9324 and then ((not LOK
) or else (Llo
= LLB
))
9327 Make_If_Expression
(Loc
,
9328 Expressions
=> New_List
(
9330 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9332 Unchecked_Convert_To
(Typ
,
9333 Make_Integer_Literal
(Loc
, -1))),
9334 Unchecked_Convert_To
(Typ
,
9335 Make_Integer_Literal
(Loc
, Uint_0
)),
9336 Relocate_Node
(N
))));
9338 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9339 Analyze_And_Resolve
(N
, Typ
);
9343 end Expand_N_Op_Mod
;
9345 --------------------------
9346 -- Expand_N_Op_Multiply --
9347 --------------------------
9349 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
9350 Loc
: constant Source_Ptr
:= Sloc
(N
);
9351 Lop
: constant Node_Id
:= Left_Opnd
(N
);
9352 Rop
: constant Node_Id
:= Right_Opnd
(N
);
9354 Lp2
: constant Boolean :=
9355 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
9356 Rp2
: constant Boolean :=
9357 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
9359 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
9360 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
9361 Typ
: Entity_Id
:= Etype
(N
);
9364 Binary_Op_Validity_Checks
(N
);
9366 -- Check for MINIMIZED/ELIMINATED overflow mode
9368 if Minimized_Eliminated_Overflow_Check
(N
) then
9369 Apply_Arithmetic_Overflow_Check
(N
);
9373 -- Special optimizations for integer types
9375 if Is_Integer_Type
(Typ
) then
9377 -- N * 0 = 0 for integer types
9379 if Compile_Time_Known_Value
(Rop
)
9380 and then Expr_Value
(Rop
) = Uint_0
9382 -- Call Remove_Side_Effects to ensure that any side effects in
9383 -- the ignored left operand (in particular function calls to
9384 -- user defined functions) are properly executed.
9386 Remove_Side_Effects
(Lop
);
9388 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9389 Analyze_And_Resolve
(N
, Typ
);
9393 -- Similar handling for 0 * N = 0
9395 if Compile_Time_Known_Value
(Lop
)
9396 and then Expr_Value
(Lop
) = Uint_0
9398 Remove_Side_Effects
(Rop
);
9399 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9400 Analyze_And_Resolve
(N
, Typ
);
9404 -- N * 1 = 1 * N = N for integer types
9406 -- This optimisation is not done if we are going to
9407 -- rewrite the product 1 * 2 ** N to a shift.
9409 if Compile_Time_Known_Value
(Rop
)
9410 and then Expr_Value
(Rop
) = Uint_1
9416 elsif Compile_Time_Known_Value
(Lop
)
9417 and then Expr_Value
(Lop
) = Uint_1
9425 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9426 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9427 -- operand is an integer, as required for this to work.
9432 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9436 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
9439 Left_Opnd
=> Right_Opnd
(Lop
),
9440 Right_Opnd
=> Right_Opnd
(Rop
))));
9441 Analyze_And_Resolve
(N
, Typ
);
9445 -- If the result is modular, perform the reduction of the result
9448 if Is_Modular_Integer_Type
(Typ
)
9449 and then not Non_Binary_Modulus
(Typ
)
9454 Make_Op_Shift_Left
(Loc
,
9457 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
9459 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9463 Make_Op_Shift_Left
(Loc
,
9466 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
9469 Analyze_And_Resolve
(N
, Typ
);
9473 -- Same processing for the operands the other way round
9476 if Is_Modular_Integer_Type
(Typ
)
9477 and then not Non_Binary_Modulus
(Typ
)
9482 Make_Op_Shift_Left
(Loc
,
9485 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
9487 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9491 Make_Op_Shift_Left
(Loc
,
9494 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
9497 Analyze_And_Resolve
(N
, Typ
);
9501 -- Do required fixup of universal fixed operation
9503 if Typ
= Universal_Fixed
then
9504 Fixup_Universal_Fixed_Operation
(N
);
9508 -- Multiplications with fixed-point results
9510 if Is_Fixed_Point_Type
(Typ
) then
9512 -- No special processing if Treat_Fixed_As_Integer is set, since from
9513 -- a semantic point of view such operations are simply integer
9514 -- operations and will be treated that way.
9516 if not Treat_Fixed_As_Integer
(N
) then
9518 -- Case of fixed * integer => fixed
9520 if Is_Integer_Type
(Rtyp
) then
9521 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
9523 -- Case of integer * fixed => fixed
9525 elsif Is_Integer_Type
(Ltyp
) then
9526 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
9528 -- Case of fixed * fixed => fixed
9531 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
9535 -- Other cases of multiplication of fixed-point operands. Again we
9536 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
9538 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
9539 and then not Treat_Fixed_As_Integer
(N
)
9541 if Is_Integer_Type
(Typ
) then
9542 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
9544 pragma Assert
(Is_Floating_Point_Type
(Typ
));
9545 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
9548 -- Mixed-mode operations can appear in a non-static universal context,
9549 -- in which case the integer argument must be converted explicitly.
9551 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
9552 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
9553 Analyze_And_Resolve
(Rop
, Universal_Real
);
9555 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
9556 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
9557 Analyze_And_Resolve
(Lop
, Universal_Real
);
9559 -- Non-fixed point cases, check software overflow checking required
9561 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
9562 Apply_Arithmetic_Overflow_Check
(N
);
9565 -- Overflow checks for floating-point if -gnateF mode active
9567 Check_Float_Op_Overflow
(N
);
9569 Expand_Nonbinary_Modular_Op
(N
);
9570 end Expand_N_Op_Multiply
;
9572 --------------------
9573 -- Expand_N_Op_Ne --
9574 --------------------
9576 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
9577 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
9580 -- Case of elementary type with standard operator. But if
9581 -- unnesting, handle elementary types whose Equivalent_Types are
9582 -- records because there may be padding or undefined fields.
9584 if Is_Elementary_Type
(Typ
)
9585 and then Sloc
(Entity
(N
)) = Standard_Location
9586 and then not (Ekind_In
(Typ
, E_Class_Wide_Type
,
9587 E_Class_Wide_Subtype
,
9588 E_Access_Subprogram_Type
,
9589 E_Access_Protected_Subprogram_Type
,
9590 E_Anonymous_Access_Protected_Subprogram_Type
,
9591 E_Access_Subprogram_Type
,
9593 and then Present
(Equivalent_Type
(Typ
))
9594 and then Is_Record_Type
(Equivalent_Type
(Typ
)))
9596 Binary_Op_Validity_Checks
(N
);
9598 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9599 -- means we no longer have a /= operation, we are all done.
9601 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9603 if Nkind
(N
) /= N_Op_Ne
then
9607 -- Boolean types (requiring handling of non-standard case)
9609 if Is_Boolean_Type
(Typ
) then
9610 Adjust_Condition
(Left_Opnd
(N
));
9611 Adjust_Condition
(Right_Opnd
(N
));
9612 Set_Etype
(N
, Standard_Boolean
);
9613 Adjust_Result_Type
(N
, Typ
);
9616 Rewrite_Comparison
(N
);
9618 -- For all cases other than elementary types, we rewrite node as the
9619 -- negation of an equality operation, and reanalyze. The equality to be
9620 -- used is defined in the same scope and has the same signature. This
9621 -- signature must be set explicitly since in an instance it may not have
9622 -- the same visibility as in the generic unit. This avoids duplicating
9623 -- or factoring the complex code for record/array equality tests etc.
9625 -- This case is also used for the minimal expansion performed in
9630 Loc
: constant Source_Ptr
:= Sloc
(N
);
9632 Ne
: constant Entity_Id
:= Entity
(N
);
9635 Binary_Op_Validity_Checks
(N
);
9641 Left_Opnd
=> Left_Opnd
(N
),
9642 Right_Opnd
=> Right_Opnd
(N
)));
9644 -- The level of parentheses is useless in GNATprove mode, and
9645 -- bumping its level here leads to wrong columns being used in
9646 -- check messages, hence skip it in this mode.
9648 if not GNATprove_Mode
then
9649 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
9652 if Scope
(Ne
) /= Standard_Standard
then
9653 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
9656 -- For navigation purposes, we want to treat the inequality as an
9657 -- implicit reference to the corresponding equality. Preserve the
9658 -- Comes_From_ source flag to generate proper Xref entries.
9660 Preserve_Comes_From_Source
(Neg
, N
);
9661 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
9663 Analyze_And_Resolve
(N
, Standard_Boolean
);
9667 -- No need for optimization in GNATprove mode, where we would rather see
9668 -- the original source expression.
9670 if not GNATprove_Mode
then
9671 Optimize_Length_Comparison
(N
);
9675 ---------------------
9676 -- Expand_N_Op_Not --
9677 ---------------------
9679 -- If the argument is other than a Boolean array type, there is no special
9680 -- expansion required, except for dealing with validity checks, and non-
9681 -- standard boolean representations.
9683 -- For the packed array case, we call the special routine in Exp_Pakd,
9684 -- except that if the component size is greater than one, we use the
9685 -- standard routine generating a gruesome loop (it is so peculiar to have
9686 -- packed arrays with non-standard Boolean representations anyway, so it
9687 -- does not matter that we do not handle this case efficiently).
9689 -- For the unpacked array case (and for the special packed case where we
9690 -- have non standard Booleans, as discussed above), we generate and insert
9691 -- into the tree the following function definition:
9693 -- function Nnnn (A : arr) is
9696 -- for J in a'range loop
9697 -- B (J) := not A (J);
9702 -- Here arr is the actual subtype of the parameter (and hence always
9703 -- constrained). Then we replace the not with a call to this function.
9705 procedure Expand_N_Op_Not
(N
: Node_Id
) is
9706 Loc
: constant Source_Ptr
:= Sloc
(N
);
9707 Typ
: constant Entity_Id
:= Etype
(N
);
9716 Func_Name
: Entity_Id
;
9717 Loop_Statement
: Node_Id
;
9720 Unary_Op_Validity_Checks
(N
);
9722 -- For boolean operand, deal with non-standard booleans
9724 if Is_Boolean_Type
(Typ
) then
9725 Adjust_Condition
(Right_Opnd
(N
));
9726 Set_Etype
(N
, Standard_Boolean
);
9727 Adjust_Result_Type
(N
, Typ
);
9731 -- Only array types need any other processing
9733 if not Is_Array_Type
(Typ
) then
9737 -- Case of array operand. If bit packed with a component size of 1,
9738 -- handle it in Exp_Pakd if the operand is known to be aligned.
9740 if Is_Bit_Packed_Array
(Typ
)
9741 and then Component_Size
(Typ
) = 1
9742 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
9744 Expand_Packed_Not
(N
);
9748 -- Case of array operand which is not bit-packed. If the context is
9749 -- a safe assignment, call in-place operation, If context is a larger
9750 -- boolean expression in the context of a safe assignment, expansion is
9751 -- done by enclosing operation.
9753 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
9754 Convert_To_Actual_Subtype
(Opnd
);
9755 Arr
:= Etype
(Opnd
);
9756 Ensure_Defined
(Arr
, N
);
9757 Silly_Boolean_Array_Not_Test
(N
, Arr
);
9759 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9760 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
9761 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9764 -- Special case the negation of a binary operation
9766 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
9767 and then Safe_In_Place_Array_Op
9768 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
9770 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9774 elsif Nkind
(Parent
(N
)) in N_Binary_Op
9775 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9778 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
9779 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
9780 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
9783 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
9785 -- (not A) op (not B) can be reduced to a single call
9787 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
9790 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
9793 -- A xor (not B) can also be special-cased
9795 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
9802 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
9803 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
9804 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
9807 Make_Indexed_Component
(Loc
,
9808 Prefix
=> New_Occurrence_Of
(A
, Loc
),
9809 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9812 Make_Indexed_Component
(Loc
,
9813 Prefix
=> New_Occurrence_Of
(B
, Loc
),
9814 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9817 Make_Implicit_Loop_Statement
(N
,
9818 Identifier
=> Empty
,
9821 Make_Iteration_Scheme
(Loc
,
9822 Loop_Parameter_Specification
=>
9823 Make_Loop_Parameter_Specification
(Loc
,
9824 Defining_Identifier
=> J
,
9825 Discrete_Subtype_Definition
=>
9826 Make_Attribute_Reference
(Loc
,
9827 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
9828 Attribute_Name
=> Name_Range
))),
9830 Statements
=> New_List
(
9831 Make_Assignment_Statement
(Loc
,
9833 Expression
=> Make_Op_Not
(Loc
, A_J
))));
9835 Func_Name
:= Make_Temporary
(Loc
, 'N');
9836 Set_Is_Inlined
(Func_Name
);
9839 Make_Subprogram_Body
(Loc
,
9841 Make_Function_Specification
(Loc
,
9842 Defining_Unit_Name
=> Func_Name
,
9843 Parameter_Specifications
=> New_List
(
9844 Make_Parameter_Specification
(Loc
,
9845 Defining_Identifier
=> A
,
9846 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9847 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9849 Declarations
=> New_List
(
9850 Make_Object_Declaration
(Loc
,
9851 Defining_Identifier
=> B
,
9852 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
9854 Handled_Statement_Sequence
=>
9855 Make_Handled_Sequence_Of_Statements
(Loc
,
9856 Statements
=> New_List
(
9858 Make_Simple_Return_Statement
(Loc
,
9859 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
9862 Make_Function_Call
(Loc
,
9863 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
9864 Parameter_Associations
=> New_List
(Opnd
)));
9866 Analyze_And_Resolve
(N
, Typ
);
9867 end Expand_N_Op_Not
;
9869 --------------------
9870 -- Expand_N_Op_Or --
9871 --------------------
9873 procedure Expand_N_Op_Or
(N
: Node_Id
) is
9874 Typ
: constant Entity_Id
:= Etype
(N
);
9877 Binary_Op_Validity_Checks
(N
);
9879 if Is_Array_Type
(Etype
(N
)) then
9880 Expand_Boolean_Operator
(N
);
9882 elsif Is_Boolean_Type
(Etype
(N
)) then
9883 Adjust_Condition
(Left_Opnd
(N
));
9884 Adjust_Condition
(Right_Opnd
(N
));
9885 Set_Etype
(N
, Standard_Boolean
);
9886 Adjust_Result_Type
(N
, Typ
);
9888 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9889 Expand_Intrinsic_Call
(N
, Entity
(N
));
9892 Expand_Nonbinary_Modular_Op
(N
);
9895 ----------------------
9896 -- Expand_N_Op_Plus --
9897 ----------------------
9899 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
9901 Unary_Op_Validity_Checks
(N
);
9903 -- Check for MINIMIZED/ELIMINATED overflow mode
9905 if Minimized_Eliminated_Overflow_Check
(N
) then
9906 Apply_Arithmetic_Overflow_Check
(N
);
9909 end Expand_N_Op_Plus
;
9911 ---------------------
9912 -- Expand_N_Op_Rem --
9913 ---------------------
9915 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
9916 Loc
: constant Source_Ptr
:= Sloc
(N
);
9917 Typ
: constant Entity_Id
:= Etype
(N
);
9928 -- Set if corresponding operand can be negative
9930 pragma Unreferenced
(Hi
);
9933 Binary_Op_Validity_Checks
(N
);
9935 -- Check for MINIMIZED/ELIMINATED overflow mode
9937 if Minimized_Eliminated_Overflow_Check
(N
) then
9938 Apply_Arithmetic_Overflow_Check
(N
);
9942 if Is_Integer_Type
(Etype
(N
)) then
9943 Apply_Divide_Checks
(N
);
9945 -- All done if we don't have a REM any more, which can happen as a
9946 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9948 if Nkind
(N
) /= N_Op_Rem
then
9953 -- Proceed with expansion of REM
9955 Left
:= Left_Opnd
(N
);
9956 Right
:= Right_Opnd
(N
);
9958 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9959 -- but it is useful with other back ends, and is certainly harmless.
9961 if Is_Integer_Type
(Etype
(N
))
9962 and then Compile_Time_Known_Value
(Right
)
9963 and then Expr_Value
(Right
) = Uint_1
9965 -- Call Remove_Side_Effects to ensure that any side effects in the
9966 -- ignored left operand (in particular function calls to user defined
9967 -- functions) are properly executed.
9969 Remove_Side_Effects
(Left
);
9971 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9972 Analyze_And_Resolve
(N
, Typ
);
9976 -- Deal with annoying case of largest negative number remainder minus
9977 -- one. Gigi may not handle this case correctly, because on some
9978 -- targets, the mod value is computed using a divide instruction
9979 -- which gives an overflow trap for this case.
9981 -- It would be a bit more efficient to figure out which targets this
9982 -- is really needed for, but in practice it is reasonable to do the
9983 -- following special check in all cases, since it means we get a clearer
9984 -- message, and also the overhead is minimal given that division is
9985 -- expensive in any case.
9987 -- In fact the check is quite easy, if the right operand is -1, then
9988 -- the remainder is always 0, and we can just ignore the left operand
9989 -- completely in this case.
9991 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9992 Lneg
:= (not OK
) or else Lo
< 0;
9994 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9995 Rneg
:= (not OK
) or else Lo
< 0;
9997 -- We won't mess with trying to find out if the left operand can really
9998 -- be the largest negative number (that's a pain in the case of private
9999 -- types and this is really marginal). We will just assume that we need
10000 -- the test if the left operand can be negative at all.
10002 if Lneg
and Rneg
then
10004 Make_If_Expression
(Loc
,
10005 Expressions
=> New_List
(
10007 Left_Opnd
=> Duplicate_Subexpr
(Right
),
10009 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
10011 Unchecked_Convert_To
(Typ
,
10012 Make_Integer_Literal
(Loc
, Uint_0
)),
10014 Relocate_Node
(N
))));
10016 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
10017 Analyze_And_Resolve
(N
, Typ
);
10019 end Expand_N_Op_Rem
;
10021 -----------------------------
10022 -- Expand_N_Op_Rotate_Left --
10023 -----------------------------
10025 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
10027 Binary_Op_Validity_Checks
(N
);
10029 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10030 -- so we rewrite in terms of logical shifts
10032 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10034 -- where Bits is the shift count mod Esize (the mod operation here
10035 -- deals with ludicrous large shift counts, which are apparently OK).
10037 -- What about nonbinary modulus ???
10040 Loc
: constant Source_Ptr
:= Sloc
(N
);
10041 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10042 Typ
: constant Entity_Id
:= Etype
(N
);
10045 if Modify_Tree_For_C
then
10046 Rewrite
(Right_Opnd
(N
),
10048 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10049 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10051 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10056 Make_Op_Shift_Left
(Loc
,
10057 Left_Opnd
=> Left_Opnd
(N
),
10058 Right_Opnd
=> Right_Opnd
(N
)),
10061 Make_Op_Shift_Right
(Loc
,
10062 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10064 Make_Op_Subtract
(Loc
,
10065 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10067 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10069 Analyze_And_Resolve
(N
, Typ
);
10072 end Expand_N_Op_Rotate_Left
;
10074 ------------------------------
10075 -- Expand_N_Op_Rotate_Right --
10076 ------------------------------
10078 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
10080 Binary_Op_Validity_Checks
(N
);
10082 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10083 -- so we rewrite in terms of logical shifts
10085 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10087 -- where Bits is the shift count mod Esize (the mod operation here
10088 -- deals with ludicrous large shift counts, which are apparently OK).
10090 -- What about nonbinary modulus ???
10093 Loc
: constant Source_Ptr
:= Sloc
(N
);
10094 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10095 Typ
: constant Entity_Id
:= Etype
(N
);
10098 Rewrite
(Right_Opnd
(N
),
10100 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10101 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10103 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10105 if Modify_Tree_For_C
then
10109 Make_Op_Shift_Right
(Loc
,
10110 Left_Opnd
=> Left_Opnd
(N
),
10111 Right_Opnd
=> Right_Opnd
(N
)),
10114 Make_Op_Shift_Left
(Loc
,
10115 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10117 Make_Op_Subtract
(Loc
,
10118 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10120 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10122 Analyze_And_Resolve
(N
, Typ
);
10125 end Expand_N_Op_Rotate_Right
;
10127 ----------------------------
10128 -- Expand_N_Op_Shift_Left --
10129 ----------------------------
10131 -- Note: nothing in this routine depends on left as opposed to right shifts
10132 -- so we share the routine for expanding shift right operations.
10134 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
10136 Binary_Op_Validity_Checks
(N
);
10138 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10139 -- operand is not greater than the word size (since that would not
10140 -- be defined properly by the corresponding C shift operator).
10142 if Modify_Tree_For_C
then
10144 Right
: constant Node_Id
:= Right_Opnd
(N
);
10145 Loc
: constant Source_Ptr
:= Sloc
(Right
);
10146 Typ
: constant Entity_Id
:= Etype
(N
);
10147 Siz
: constant Uint
:= Esize
(Typ
);
10154 if Compile_Time_Known_Value
(Right
) then
10155 if Expr_Value
(Right
) >= Siz
then
10156 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10157 Analyze_And_Resolve
(N
, Typ
);
10160 -- Not compile time known, find range
10163 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10165 -- Nothing to do if known to be OK range, otherwise expand
10167 if not OK
or else Hi
>= Siz
then
10169 -- Prevent recursion on copy of shift node
10171 Orig
:= Relocate_Node
(N
);
10172 Set_Analyzed
(Orig
);
10174 -- Now do the rewrite
10177 Make_If_Expression
(Loc
,
10178 Expressions
=> New_List
(
10180 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
10181 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
10182 Make_Integer_Literal
(Loc
, 0),
10184 Analyze_And_Resolve
(N
, Typ
);
10189 end Expand_N_Op_Shift_Left
;
10191 -----------------------------
10192 -- Expand_N_Op_Shift_Right --
10193 -----------------------------
10195 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
10197 -- Share shift left circuit
10199 Expand_N_Op_Shift_Left
(N
);
10200 end Expand_N_Op_Shift_Right
;
10202 ----------------------------------------
10203 -- Expand_N_Op_Shift_Right_Arithmetic --
10204 ----------------------------------------
10206 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
10208 Binary_Op_Validity_Checks
(N
);
10210 -- If we are in Modify_Tree_For_C mode, there is no shift right
10211 -- arithmetic in C, so we rewrite in terms of logical shifts.
10213 -- Shift_Right (Num, Bits) or
10215 -- then not (Shift_Right (Mask, bits))
10218 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10220 -- Note: in almost all C compilers it would work to just shift a
10221 -- signed integer right, but it's undefined and we cannot rely on it.
10223 -- Note: the above works fine for shift counts greater than or equal
10224 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10225 -- generates all 1'bits.
10227 -- What about nonbinary modulus ???
10230 Loc
: constant Source_Ptr
:= Sloc
(N
);
10231 Typ
: constant Entity_Id
:= Etype
(N
);
10232 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
10233 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
10234 Left
: constant Node_Id
:= Left_Opnd
(N
);
10235 Right
: constant Node_Id
:= Right_Opnd
(N
);
10239 if Modify_Tree_For_C
then
10241 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10242 -- compile time as a single constant.
10244 if Compile_Time_Known_Value
(Right
) then
10246 Val
: constant Uint
:= Expr_Value
(Right
);
10249 if Val
>= Esize
(Typ
) then
10250 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
10254 Make_Integer_Literal
(Loc
,
10255 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
10263 Make_Op_Shift_Right
(Loc
,
10264 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
10265 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
10268 -- Now do the rewrite
10273 Make_Op_Shift_Right
(Loc
,
10275 Right_Opnd
=> Right
),
10277 Make_If_Expression
(Loc
,
10278 Expressions
=> New_List
(
10280 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
10281 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
10283 Make_Integer_Literal
(Loc
, 0)))));
10284 Analyze_And_Resolve
(N
, Typ
);
10287 end Expand_N_Op_Shift_Right_Arithmetic
;
10289 --------------------------
10290 -- Expand_N_Op_Subtract --
10291 --------------------------
10293 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
10294 Typ
: constant Entity_Id
:= Etype
(N
);
10297 Binary_Op_Validity_Checks
(N
);
10299 -- Check for MINIMIZED/ELIMINATED overflow mode
10301 if Minimized_Eliminated_Overflow_Check
(N
) then
10302 Apply_Arithmetic_Overflow_Check
(N
);
10306 -- N - 0 = N for integer types
10308 if Is_Integer_Type
(Typ
)
10309 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
10310 and then Expr_Value
(Right_Opnd
(N
)) = 0
10312 Rewrite
(N
, Left_Opnd
(N
));
10316 -- Arithmetic overflow checks for signed integer/fixed point types
10318 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
10319 Apply_Arithmetic_Overflow_Check
(N
);
10322 -- Overflow checks for floating-point if -gnateF mode active
10324 Check_Float_Op_Overflow
(N
);
10326 Expand_Nonbinary_Modular_Op
(N
);
10327 end Expand_N_Op_Subtract
;
10329 ---------------------
10330 -- Expand_N_Op_Xor --
10331 ---------------------
10333 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
10334 Typ
: constant Entity_Id
:= Etype
(N
);
10337 Binary_Op_Validity_Checks
(N
);
10339 if Is_Array_Type
(Etype
(N
)) then
10340 Expand_Boolean_Operator
(N
);
10342 elsif Is_Boolean_Type
(Etype
(N
)) then
10343 Adjust_Condition
(Left_Opnd
(N
));
10344 Adjust_Condition
(Right_Opnd
(N
));
10345 Set_Etype
(N
, Standard_Boolean
);
10346 Adjust_Result_Type
(N
, Typ
);
10348 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10349 Expand_Intrinsic_Call
(N
, Entity
(N
));
10352 Expand_Nonbinary_Modular_Op
(N
);
10353 end Expand_N_Op_Xor
;
10355 ----------------------
10356 -- Expand_N_Or_Else --
10357 ----------------------
10359 procedure Expand_N_Or_Else
(N
: Node_Id
)
10360 renames Expand_Short_Circuit_Operator
;
10362 -----------------------------------
10363 -- Expand_N_Qualified_Expression --
10364 -----------------------------------
10366 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
10367 Operand
: constant Node_Id
:= Expression
(N
);
10368 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
10371 -- Do validity check if validity checking operands
10373 if Validity_Checks_On
and Validity_Check_Operands
then
10374 Ensure_Valid
(Operand
);
10377 -- Apply possible constraint check
10379 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
10381 if Do_Range_Check
(Operand
) then
10382 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
10384 end Expand_N_Qualified_Expression
;
10386 ------------------------------------
10387 -- Expand_N_Quantified_Expression --
10388 ------------------------------------
10392 -- for all X in range => Cond
10397 -- for X in range loop
10398 -- if not Cond then
10404 -- Similarly, an existentially quantified expression:
10406 -- for some X in range => Cond
10411 -- for X in range loop
10418 -- In both cases, the iteration may be over a container in which case it is
10419 -- given by an iterator specification, not a loop parameter specification.
10421 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
10422 Actions
: constant List_Id
:= New_List
;
10423 For_All
: constant Boolean := All_Present
(N
);
10424 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
10425 Loc
: constant Source_Ptr
:= Sloc
(N
);
10426 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
10434 -- Ensure that the bound variable is properly frozen. We must do
10435 -- this before expansion because the expression is about to be
10436 -- converted into a loop, and resulting freeze nodes may end up
10437 -- in the wrong place in the tree.
10439 if Present
(Iter_Spec
) then
10440 Var
:= Defining_Identifier
(Iter_Spec
);
10442 Var
:= Defining_Identifier
(Loop_Spec
);
10446 P
: Node_Id
:= Parent
(N
);
10448 while Nkind
(P
) in N_Subexpr
loop
10452 Freeze_Before
(P
, Etype
(Var
));
10455 -- Create the declaration of the flag which tracks the status of the
10456 -- quantified expression. Generate:
10458 -- Flag : Boolean := (True | False);
10460 Flag
:= Make_Temporary
(Loc
, 'T', N
);
10462 Append_To
(Actions
,
10463 Make_Object_Declaration
(Loc
,
10464 Defining_Identifier
=> Flag
,
10465 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
10467 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
10469 -- Construct the circuitry which tracks the status of the quantified
10470 -- expression. Generate:
10472 -- if [not] Cond then
10473 -- Flag := (False | True);
10477 Cond
:= Relocate_Node
(Condition
(N
));
10480 Cond
:= Make_Op_Not
(Loc
, Cond
);
10483 Stmts
:= New_List
(
10484 Make_Implicit_If_Statement
(N
,
10486 Then_Statements
=> New_List
(
10487 Make_Assignment_Statement
(Loc
,
10488 Name
=> New_Occurrence_Of
(Flag
, Loc
),
10490 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
10491 Make_Exit_Statement
(Loc
))));
10493 -- Build the loop equivalent of the quantified expression
10495 if Present
(Iter_Spec
) then
10497 Make_Iteration_Scheme
(Loc
,
10498 Iterator_Specification
=> Iter_Spec
);
10501 Make_Iteration_Scheme
(Loc
,
10502 Loop_Parameter_Specification
=> Loop_Spec
);
10505 Append_To
(Actions
,
10506 Make_Loop_Statement
(Loc
,
10507 Iteration_Scheme
=> Scheme
,
10508 Statements
=> Stmts
,
10509 End_Label
=> Empty
));
10511 -- Transform the quantified expression
10514 Make_Expression_With_Actions
(Loc
,
10515 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
10516 Actions
=> Actions
));
10517 Analyze_And_Resolve
(N
, Standard_Boolean
);
10518 end Expand_N_Quantified_Expression
;
10520 ---------------------------------
10521 -- Expand_N_Selected_Component --
10522 ---------------------------------
10524 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
10525 Loc
: constant Source_Ptr
:= Sloc
(N
);
10526 Par
: constant Node_Id
:= Parent
(N
);
10527 P
: constant Node_Id
:= Prefix
(N
);
10528 S
: constant Node_Id
:= Selector_Name
(N
);
10529 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
10535 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
10536 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10537 -- unless the context of an assignment can provide size information.
10538 -- Don't we have a general routine that does this???
10540 function Is_Subtype_Declaration
return Boolean;
10541 -- The replacement of a discriminant reference by its value is required
10542 -- if this is part of the initialization of an temporary generated by a
10543 -- change of representation. This shows up as the construction of a
10544 -- discriminant constraint for a subtype declared at the same point as
10545 -- the entity in the prefix of the selected component. We recognize this
10546 -- case when the context of the reference is:
10547 -- subtype ST is T(Obj.D);
10548 -- where the entity for Obj comes from source, and ST has the same sloc.
10550 -----------------------
10551 -- In_Left_Hand_Side --
10552 -----------------------
10554 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
10556 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
10557 and then Comp
= Name
(Parent
(Comp
)))
10558 or else (Present
(Parent
(Comp
))
10559 and then Nkind
(Parent
(Comp
)) in N_Subexpr
10560 and then In_Left_Hand_Side
(Parent
(Comp
)));
10561 end In_Left_Hand_Side
;
10563 -----------------------------
10564 -- Is_Subtype_Declaration --
10565 -----------------------------
10567 function Is_Subtype_Declaration
return Boolean is
10568 Par
: constant Node_Id
:= Parent
(N
);
10571 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
10572 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
10573 and then Comes_From_Source
(Entity
(Prefix
(N
)))
10574 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
10575 end Is_Subtype_Declaration
;
10577 -- Start of processing for Expand_N_Selected_Component
10580 -- Insert explicit dereference if required
10582 if Is_Access_Type
(Ptyp
) then
10584 -- First set prefix type to proper access type, in case it currently
10585 -- has a private (non-access) view of this type.
10587 Set_Etype
(P
, Ptyp
);
10589 Insert_Explicit_Dereference
(P
);
10590 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
10595 -- Deal with discriminant check required
10597 if Do_Discriminant_Check
(N
) then
10598 if Present
(Discriminant_Checking_Func
10599 (Original_Record_Component
(Entity
(S
))))
10601 -- Present the discriminant checking function to the backend, so
10602 -- that it can inline the call to the function.
10605 (Discriminant_Checking_Func
10606 (Original_Record_Component
(Entity
(S
))),
10609 -- Now reset the flag and generate the call
10611 Set_Do_Discriminant_Check
(N
, False);
10612 Generate_Discriminant_Check
(N
);
10614 -- In the case of Unchecked_Union, no discriminant checking is
10615 -- actually performed.
10618 Set_Do_Discriminant_Check
(N
, False);
10622 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10623 -- function, then additional actuals must be passed.
10625 if Is_Build_In_Place_Function_Call
(P
) then
10626 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
10628 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10629 -- containing build-in-place function calls whose returned object covers
10630 -- interface types.
10632 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
10633 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
10636 -- Gigi cannot handle unchecked conversions that are the prefix of a
10637 -- selected component with discriminants. This must be checked during
10638 -- expansion, because during analysis the type of the selector is not
10639 -- known at the point the prefix is analyzed. If the conversion is the
10640 -- target of an assignment, then we cannot force the evaluation.
10642 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
10643 and then Has_Discriminants
(Etype
(N
))
10644 and then not In_Left_Hand_Side
(N
)
10646 Force_Evaluation
(Prefix
(N
));
10649 -- Remaining processing applies only if selector is a discriminant
10651 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
10653 -- If the selector is a discriminant of a constrained record type,
10654 -- we may be able to rewrite the expression with the actual value
10655 -- of the discriminant, a useful optimization in some cases.
10657 if Is_Record_Type
(Ptyp
)
10658 and then Has_Discriminants
(Ptyp
)
10659 and then Is_Constrained
(Ptyp
)
10661 -- Do this optimization for discrete types only, and not for
10662 -- access types (access discriminants get us into trouble).
10664 if not Is_Discrete_Type
(Etype
(N
)) then
10667 -- Don't do this on the left-hand side of an assignment statement.
10668 -- Normally one would think that references like this would not
10669 -- occur, but they do in generated code, and mean that we really
10670 -- do want to assign the discriminant.
10672 elsif Nkind
(Par
) = N_Assignment_Statement
10673 and then Name
(Par
) = N
10677 -- Don't do this optimization for the prefix of an attribute or
10678 -- the name of an object renaming declaration since these are
10679 -- contexts where we do not want the value anyway.
10681 elsif (Nkind
(Par
) = N_Attribute_Reference
10682 and then Prefix
(Par
) = N
)
10683 or else Is_Renamed_Object
(N
)
10687 -- Don't do this optimization if we are within the code for a
10688 -- discriminant check, since the whole point of such a check may
10689 -- be to verify the condition on which the code below depends.
10691 elsif Is_In_Discriminant_Check
(N
) then
10694 -- Green light to see if we can do the optimization. There is
10695 -- still one condition that inhibits the optimization below but
10696 -- now is the time to check the particular discriminant.
10699 -- Loop through discriminants to find the matching discriminant
10700 -- constraint to see if we can copy it.
10702 Disc
:= First_Discriminant
(Ptyp
);
10703 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
10704 Discr_Loop
: while Present
(Dcon
) loop
10705 Dval
:= Node
(Dcon
);
10707 -- Check if this is the matching discriminant and if the
10708 -- discriminant value is simple enough to make sense to
10709 -- copy. We don't want to copy complex expressions, and
10710 -- indeed to do so can cause trouble (before we put in
10711 -- this guard, a discriminant expression containing an
10712 -- AND THEN was copied, causing problems for coverage
10713 -- analysis tools).
10715 -- However, if the reference is part of the initialization
10716 -- code generated for an object declaration, we must use
10717 -- the discriminant value from the subtype constraint,
10718 -- because the selected component may be a reference to the
10719 -- object being initialized, whose discriminant is not yet
10720 -- set. This only happens in complex cases involving changes
10721 -- or representation.
10723 if Disc
= Entity
(Selector_Name
(N
))
10724 and then (Is_Entity_Name
(Dval
)
10725 or else Compile_Time_Known_Value
(Dval
)
10726 or else Is_Subtype_Declaration
)
10728 -- Here we have the matching discriminant. Check for
10729 -- the case of a discriminant of a component that is
10730 -- constrained by an outer discriminant, which cannot
10731 -- be optimized away.
10733 if Denotes_Discriminant
10734 (Dval
, Check_Concurrent
=> True)
10738 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
10740 Denotes_Discriminant
10741 (Selector_Name
(Original_Node
(Dval
)), True)
10745 -- Do not retrieve value if constraint is not static. It
10746 -- is generally not useful, and the constraint may be a
10747 -- rewritten outer discriminant in which case it is in
10750 elsif Is_Entity_Name
(Dval
)
10752 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
10753 and then Present
(Expression
(Parent
(Entity
(Dval
))))
10755 Is_OK_Static_Expression
10756 (Expression
(Parent
(Entity
(Dval
))))
10760 -- In the context of a case statement, the expression may
10761 -- have the base type of the discriminant, and we need to
10762 -- preserve the constraint to avoid spurious errors on
10765 elsif Nkind
(Parent
(N
)) = N_Case_Statement
10766 and then Etype
(Dval
) /= Etype
(Disc
)
10769 Make_Qualified_Expression
(Loc
,
10771 New_Occurrence_Of
(Etype
(Disc
), Loc
),
10773 New_Copy_Tree
(Dval
)));
10774 Analyze_And_Resolve
(N
, Etype
(Disc
));
10776 -- In case that comes out as a static expression,
10777 -- reset it (a selected component is never static).
10779 Set_Is_Static_Expression
(N
, False);
10782 -- Otherwise we can just copy the constraint, but the
10783 -- result is certainly not static. In some cases the
10784 -- discriminant constraint has been analyzed in the
10785 -- context of the original subtype indication, but for
10786 -- itypes the constraint might not have been analyzed
10787 -- yet, and this must be done now.
10790 Rewrite
(N
, New_Copy_Tree
(Dval
));
10791 Analyze_And_Resolve
(N
);
10792 Set_Is_Static_Expression
(N
, False);
10798 Next_Discriminant
(Disc
);
10799 end loop Discr_Loop
;
10801 -- Note: the above loop should always find a matching
10802 -- discriminant, but if it does not, we just missed an
10803 -- optimization due to some glitch (perhaps a previous
10804 -- error), so ignore.
10809 -- The only remaining processing is in the case of a discriminant of
10810 -- a concurrent object, where we rewrite the prefix to denote the
10811 -- corresponding record type. If the type is derived and has renamed
10812 -- discriminants, use corresponding discriminant, which is the one
10813 -- that appears in the corresponding record.
10815 if not Is_Concurrent_Type
(Ptyp
) then
10819 Disc
:= Entity
(Selector_Name
(N
));
10821 if Is_Derived_Type
(Ptyp
)
10822 and then Present
(Corresponding_Discriminant
(Disc
))
10824 Disc
:= Corresponding_Discriminant
(Disc
);
10828 Make_Selected_Component
(Loc
,
10830 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
10831 New_Copy_Tree
(P
)),
10832 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
10834 Rewrite
(N
, New_N
);
10838 -- Set Atomic_Sync_Required if necessary for atomic component
10840 if Nkind
(N
) = N_Selected_Component
then
10842 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
10846 -- If component is atomic, but type is not, setting depends on
10847 -- disable/enable state for the component.
10849 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
10850 Set
:= not Atomic_Synchronization_Disabled
(E
);
10852 -- If component is not atomic, but its type is atomic, setting
10853 -- depends on disable/enable state for the type.
10855 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
10856 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
10858 -- If both component and type are atomic, we disable if either
10859 -- component or its type have sync disabled.
10861 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
10862 Set
:= (not Atomic_Synchronization_Disabled
(E
))
10864 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
10870 -- Set flag if required
10873 Activate_Atomic_Synchronization
(N
);
10877 end Expand_N_Selected_Component
;
10879 --------------------
10880 -- Expand_N_Slice --
10881 --------------------
10883 procedure Expand_N_Slice
(N
: Node_Id
) is
10884 Loc
: constant Source_Ptr
:= Sloc
(N
);
10885 Typ
: constant Entity_Id
:= Etype
(N
);
10887 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
10888 -- Check whether the argument is an actual for a procedure call, in
10889 -- which case the expansion of a bit-packed slice is deferred until the
10890 -- call itself is expanded. The reason this is required is that we might
10891 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10892 -- that copy out would be missed if we created a temporary here in
10893 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10894 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10895 -- is harmless to defer expansion in the IN case, since the call
10896 -- processing will still generate the appropriate copy in operation,
10897 -- which will take care of the slice.
10899 procedure Make_Temporary_For_Slice
;
10900 -- Create a named variable for the value of the slice, in cases where
10901 -- the back end cannot handle it properly, e.g. when packed types or
10902 -- unaligned slices are involved.
10904 -------------------------
10905 -- Is_Procedure_Actual --
10906 -------------------------
10908 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
10909 Par
: Node_Id
:= Parent
(N
);
10913 -- If our parent is a procedure call we can return
10915 if Nkind
(Par
) = N_Procedure_Call_Statement
then
10918 -- If our parent is a type conversion, keep climbing the tree,
10919 -- since a type conversion can be a procedure actual. Also keep
10920 -- climbing if parameter association or a qualified expression,
10921 -- since these are additional cases that do can appear on
10922 -- procedure actuals.
10924 elsif Nkind_In
(Par
, N_Type_Conversion
,
10925 N_Parameter_Association
,
10926 N_Qualified_Expression
)
10928 Par
:= Parent
(Par
);
10930 -- Any other case is not what we are looking for
10936 end Is_Procedure_Actual
;
10938 ------------------------------
10939 -- Make_Temporary_For_Slice --
10940 ------------------------------
10942 procedure Make_Temporary_For_Slice
is
10943 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
10948 Make_Object_Declaration
(Loc
,
10949 Defining_Identifier
=> Ent
,
10950 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10952 Set_No_Initialization
(Decl
);
10954 Insert_Actions
(N
, New_List
(
10956 Make_Assignment_Statement
(Loc
,
10957 Name
=> New_Occurrence_Of
(Ent
, Loc
),
10958 Expression
=> Relocate_Node
(N
))));
10960 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
10961 Analyze_And_Resolve
(N
, Typ
);
10962 end Make_Temporary_For_Slice
;
10966 Pref
: constant Node_Id
:= Prefix
(N
);
10967 Pref_Typ
: Entity_Id
:= Etype
(Pref
);
10969 -- Start of processing for Expand_N_Slice
10972 -- Special handling for access types
10974 if Is_Access_Type
(Pref_Typ
) then
10975 Pref_Typ
:= Designated_Type
(Pref_Typ
);
10978 Make_Explicit_Dereference
(Sloc
(N
),
10979 Prefix
=> Relocate_Node
(Pref
)));
10981 Analyze_And_Resolve
(Pref
, Pref_Typ
);
10984 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10985 -- function, then additional actuals must be passed.
10987 if Is_Build_In_Place_Function_Call
(Pref
) then
10988 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
10990 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10991 -- containing build-in-place function calls whose returned object covers
10992 -- interface types.
10994 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
10995 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
10998 -- The remaining case to be handled is packed slices. We can leave
10999 -- packed slices as they are in the following situations:
11001 -- 1. Right or left side of an assignment (we can handle this
11002 -- situation correctly in the assignment statement expansion).
11004 -- 2. Prefix of indexed component (the slide is optimized away in this
11005 -- case, see the start of Expand_N_Slice.)
11007 -- 3. Object renaming declaration, since we want the name of the
11008 -- slice, not the value.
11010 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11011 -- be required, and this is handled in the expansion of call
11014 -- 5. Prefix of an address attribute (this is an error which is caught
11015 -- elsewhere, and the expansion would interfere with generating the
11018 if not Is_Packed
(Typ
) then
11020 -- Apply transformation for actuals of a function call, where
11021 -- Expand_Actuals is not used.
11023 if Nkind
(Parent
(N
)) = N_Function_Call
11024 and then Is_Possibly_Unaligned_Slice
(N
)
11026 Make_Temporary_For_Slice
;
11029 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
11030 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
11031 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
11035 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
11036 or else Is_Renamed_Object
(N
)
11037 or else Is_Procedure_Actual
(N
)
11041 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
11042 and then Attribute_Name
(Parent
(N
)) = Name_Address
11047 Make_Temporary_For_Slice
;
11049 end Expand_N_Slice
;
11051 ------------------------------
11052 -- Expand_N_Type_Conversion --
11053 ------------------------------
11055 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
11056 Loc
: constant Source_Ptr
:= Sloc
(N
);
11057 Operand
: constant Node_Id
:= Expression
(N
);
11058 Operand_Acc
: Node_Id
:= Operand
;
11059 Target_Type
: Entity_Id
:= Etype
(N
);
11060 Operand_Type
: Entity_Id
:= Etype
(Operand
);
11062 procedure Discrete_Range_Check
;
11063 -- Handles generation of range check for discrete target value
11065 procedure Handle_Changed_Representation
;
11066 -- This is called in the case of record and array type conversions to
11067 -- see if there is a change of representation to be handled. Change of
11068 -- representation is actually handled at the assignment statement level,
11069 -- and what this procedure does is rewrite node N conversion as an
11070 -- assignment to temporary. If there is no change of representation,
11071 -- then the conversion node is unchanged.
11073 procedure Raise_Accessibility_Error
;
11074 -- Called when we know that an accessibility check will fail. Rewrites
11075 -- node N to an appropriate raise statement and outputs warning msgs.
11076 -- The Etype of the raise node is set to Target_Type. Note that in this
11077 -- case the rest of the processing should be skipped (i.e. the call to
11078 -- this procedure will be followed by "goto Done").
11080 procedure Real_Range_Check
;
11081 -- Handles generation of range check for real target value
11083 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
11084 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11085 -- evaluates to True.
11087 --------------------------
11088 -- Discrete_Range_Check --
11089 --------------------------
11091 -- Case of conversions to a discrete type. We let Generate_Range_Check
11092 -- do the heavy lifting, after converting a fixed-point operand to an
11093 -- appropriate integer type.
11095 procedure Discrete_Range_Check
is
11100 -- Nothing to do if conversion was rewritten
11102 if Nkind
(N
) /= N_Type_Conversion
then
11106 Expr
:= Expression
(N
);
11108 -- Nothing to do if range checks suppressed
11110 if Range_Checks_Suppressed
(Target_Type
) then
11114 -- Nothing to do if expression is an entity on which checks have been
11117 if Is_Entity_Name
(Expr
)
11118 and then Range_Checks_Suppressed
(Entity
(Expr
))
11123 -- Before we do a range check, we have to deal with treating
11124 -- a fixed-point operand as an integer. The way we do this
11125 -- is simply to do an unchecked conversion to an appropriate
11126 -- integer type large enough to hold the result.
11128 if Is_Fixed_Point_Type
(Etype
(Expr
)) then
11129 if Esize
(Base_Type
(Etype
(Expr
))) > Esize
(Standard_Integer
) then
11130 Ityp
:= Standard_Long_Long_Integer
;
11132 Ityp
:= Standard_Integer
;
11135 Set_Do_Range_Check
(Expr
, False);
11136 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11139 -- Reset overflow flag, since the range check will include
11140 -- dealing with possible overflow, and generate the check.
11142 Set_Do_Overflow_Check
(N
, False);
11144 Generate_Range_Check
(Expr
, Target_Type
, CE_Range_Check_Failed
);
11145 end Discrete_Range_Check
;
11147 -----------------------------------
11148 -- Handle_Changed_Representation --
11149 -----------------------------------
11151 procedure Handle_Changed_Representation
is
11159 -- Nothing else to do if no change of representation
11161 if Same_Representation
(Operand_Type
, Target_Type
) then
11164 -- The real change of representation work is done by the assignment
11165 -- statement processing. So if this type conversion is appearing as
11166 -- the expression of an assignment statement, nothing needs to be
11167 -- done to the conversion.
11169 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
11172 -- Otherwise we need to generate a temporary variable, and do the
11173 -- change of representation assignment into that temporary variable.
11174 -- The conversion is then replaced by a reference to this variable.
11179 -- If type is unconstrained we have to add a constraint, copied
11180 -- from the actual value of the left-hand side.
11182 if not Is_Constrained
(Target_Type
) then
11183 if Has_Discriminants
(Operand_Type
) then
11185 -- A change of representation can only apply to untagged
11186 -- types. We need to build the constraint that applies to
11187 -- the target type, using the constraints of the operand.
11188 -- The analysis is complicated if there are both inherited
11189 -- discriminants and constrained discriminants.
11190 -- We iterate over the discriminants of the target, and
11191 -- find the discriminant of the same name:
11193 -- a) If there is a corresponding discriminant in the object
11194 -- then the value is a selected component of the operand.
11196 -- b) Otherwise the value of a constrained discriminant is
11197 -- found in the stored constraint of the operand.
11200 Stored
: constant Elist_Id
:=
11201 Stored_Constraint
(Operand_Type
);
11205 Disc_O
: Entity_Id
;
11206 -- Discriminant of the operand type. Its value in the
11207 -- object is captured in a selected component.
11209 Disc_S
: Entity_Id
;
11210 -- Stored discriminant of the operand. If present, it
11211 -- corresponds to a constrained discriminant of the
11214 Disc_T
: Entity_Id
;
11215 -- Discriminant of the target type
11218 Disc_T
:= First_Discriminant
(Target_Type
);
11219 Disc_O
:= First_Discriminant
(Operand_Type
);
11220 Disc_S
:= First_Stored_Discriminant
(Operand_Type
);
11222 if Present
(Stored
) then
11223 Elmt
:= First_Elmt
(Stored
);
11225 Elmt
:= No_Elmt
; -- init to avoid warning
11229 while Present
(Disc_T
) loop
11230 if Present
(Disc_O
)
11231 and then Chars
(Disc_T
) = Chars
(Disc_O
)
11234 Make_Selected_Component
(Loc
,
11236 Duplicate_Subexpr_Move_Checks
(Operand
),
11238 Make_Identifier
(Loc
, Chars
(Disc_O
))));
11239 Next_Discriminant
(Disc_O
);
11241 elsif Present
(Disc_S
) then
11242 Append_To
(Cons
, New_Copy_Tree
(Node
(Elmt
)));
11246 Next_Discriminant
(Disc_T
);
11250 elsif Is_Array_Type
(Operand_Type
) then
11251 N_Ix
:= First_Index
(Target_Type
);
11254 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
11256 -- We convert the bounds explicitly. We use an unchecked
11257 -- conversion because bounds checks are done elsewhere.
11262 Unchecked_Convert_To
(Etype
(N_Ix
),
11263 Make_Attribute_Reference
(Loc
,
11265 Duplicate_Subexpr_No_Checks
11266 (Operand
, Name_Req
=> True),
11267 Attribute_Name
=> Name_First
,
11268 Expressions
=> New_List
(
11269 Make_Integer_Literal
(Loc
, J
)))),
11272 Unchecked_Convert_To
(Etype
(N_Ix
),
11273 Make_Attribute_Reference
(Loc
,
11275 Duplicate_Subexpr_No_Checks
11276 (Operand
, Name_Req
=> True),
11277 Attribute_Name
=> Name_Last
,
11278 Expressions
=> New_List
(
11279 Make_Integer_Literal
(Loc
, J
))))));
11286 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
11288 if Present
(Cons
) then
11290 Make_Subtype_Indication
(Loc
,
11291 Subtype_Mark
=> Odef
,
11293 Make_Index_Or_Discriminant_Constraint
(Loc
,
11294 Constraints
=> Cons
));
11297 Temp
:= Make_Temporary
(Loc
, 'C');
11299 Make_Object_Declaration
(Loc
,
11300 Defining_Identifier
=> Temp
,
11301 Object_Definition
=> Odef
);
11303 Set_No_Initialization
(Decl
, True);
11305 -- Insert required actions. It is essential to suppress checks
11306 -- since we have suppressed default initialization, which means
11307 -- that the variable we create may have no discriminants.
11312 Make_Assignment_Statement
(Loc
,
11313 Name
=> New_Occurrence_Of
(Temp
, Loc
),
11314 Expression
=> Relocate_Node
(N
))),
11315 Suppress
=> All_Checks
);
11317 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
11320 end Handle_Changed_Representation
;
11322 -------------------------------
11323 -- Raise_Accessibility_Error --
11324 -------------------------------
11326 procedure Raise_Accessibility_Error
is
11328 Error_Msg_Warn
:= SPARK_Mode
/= On
;
11330 Make_Raise_Program_Error
(Sloc
(N
),
11331 Reason
=> PE_Accessibility_Check_Failed
));
11332 Set_Etype
(N
, Target_Type
);
11334 Error_Msg_N
("<<accessibility check failure", N
);
11335 Error_Msg_NE
("\<<& [", N
, Standard_Program_Error
);
11336 end Raise_Accessibility_Error
;
11338 ----------------------
11339 -- Real_Range_Check --
11340 ----------------------
11342 -- Case of conversions to floating-point or fixed-point. If range checks
11343 -- are enabled and the target type has a range constraint, we convert:
11349 -- Tnn : typ'Base := typ'Base (x);
11350 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11353 -- This is necessary when there is a conversion of integer to float or
11354 -- to fixed-point to ensure that the correct checks are made. It is not
11355 -- necessary for the float-to-float case where it is enough to just set
11356 -- the Do_Range_Check flag on the expression.
11358 procedure Real_Range_Check
is
11359 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
11360 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
11361 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
11372 -- Nothing to do if conversion was rewritten
11374 if Nkind
(N
) /= N_Type_Conversion
then
11378 Expr
:= Expression
(N
);
11380 -- Clear the flag once for all
11382 Set_Do_Range_Check
(Expr
, False);
11384 -- Nothing to do if range checks suppressed, or target has the same
11385 -- range as the base type (or is the base type).
11387 if Range_Checks_Suppressed
(Target_Type
)
11388 or else (Lo
= Type_Low_Bound
(Btyp
)
11390 Hi
= Type_High_Bound
(Btyp
))
11395 -- Nothing to do if expression is an entity on which checks have been
11398 if Is_Entity_Name
(Expr
)
11399 and then Range_Checks_Suppressed
(Entity
(Expr
))
11404 -- Nothing to do if expression was rewritten into a float-to-float
11405 -- conversion, since this kind of conversion is handled elsewhere.
11407 if Is_Floating_Point_Type
(Etype
(Expr
))
11408 and then Is_Floating_Point_Type
(Target_Type
)
11413 -- Nothing to do if bounds are all static and we can tell that the
11414 -- expression is within the bounds of the target. Note that if the
11415 -- operand is of an unconstrained floating-point type, then we do
11416 -- not trust it to be in range (might be infinite)
11419 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Expr
));
11420 S_Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Expr
));
11423 if (not Is_Floating_Point_Type
(Etype
(Expr
))
11424 or else Is_Constrained
(Etype
(Expr
)))
11425 and then Compile_Time_Known_Value
(S_Lo
)
11426 and then Compile_Time_Known_Value
(S_Hi
)
11427 and then Compile_Time_Known_Value
(Hi
)
11428 and then Compile_Time_Known_Value
(Lo
)
11431 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
11432 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
11437 if Is_Real_Type
(Etype
(Expr
)) then
11438 S_Lov
:= Expr_Value_R
(S_Lo
);
11439 S_Hiv
:= Expr_Value_R
(S_Hi
);
11441 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
11442 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
11446 and then S_Lov
>= D_Lov
11447 and then S_Hiv
<= D_Hiv
11455 -- Otherwise rewrite the conversion as described above
11457 Conv
:= Convert_To
(Btyp
, Expr
);
11459 -- If a conversion is necessary, then copy the specific flags from
11460 -- the original one and also move the Do_Overflow_Check flag since
11461 -- this new conversion is to the base type.
11463 if Nkind
(Conv
) = N_Type_Conversion
then
11464 Set_Conversion_OK
(Conv
, Conversion_OK
(N
));
11465 Set_Float_Truncate
(Conv
, Float_Truncate
(N
));
11466 Set_Rounded_Result
(Conv
, Rounded_Result
(N
));
11468 if Do_Overflow_Check
(N
) then
11469 Set_Do_Overflow_Check
(Conv
);
11470 Set_Do_Overflow_Check
(N
, False);
11474 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
11476 -- For a conversion from Float to Fixed where the bounds of the
11477 -- fixed-point type are static, we can obtain a more accurate
11478 -- fixed-point value by converting the result of the floating-
11479 -- point expression to an appropriate integer type, and then
11480 -- performing an unchecked conversion to the target fixed-point
11481 -- type. The range check can then use the corresponding integer
11482 -- value of the bounds instead of requiring further conversions.
11483 -- This preserves the identity:
11485 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11487 -- which used to fail when Fix_Val was a bound of the type and
11488 -- the 'Small was not a representable number.
11489 -- This transformation requires an integer type large enough to
11490 -- accommodate a fixed-point value. This will not be the case
11491 -- in systems where Duration is larger than Long_Integer.
11493 if Is_Ordinary_Fixed_Point_Type
(Target_Type
)
11494 and then Is_Floating_Point_Type
(Etype
(Expr
))
11495 and then RM_Size
(Btyp
) <= RM_Size
(Standard_Long_Integer
)
11496 and then Nkind
(Lo
) = N_Real_Literal
11497 and then Nkind
(Hi
) = N_Real_Literal
11500 Expr_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Conv
);
11501 Int_Type
: Entity_Id
;
11504 -- Find an integer type of the appropriate size to perform an
11505 -- unchecked conversion to the target fixed-point type.
11507 if RM_Size
(Btyp
) > RM_Size
(Standard_Integer
) then
11508 Int_Type
:= Standard_Long_Integer
;
11510 elsif RM_Size
(Btyp
) > RM_Size
(Standard_Short_Integer
) then
11511 Int_Type
:= Standard_Integer
;
11514 Int_Type
:= Standard_Short_Integer
;
11517 -- Generate a temporary with the integer value. Required in the
11518 -- CCG compiler to ensure that run-time checks reference this
11519 -- integer expression (instead of the resulting fixed-point
11520 -- value because fixed-point values are handled by means of
11521 -- unsigned integer types).
11524 Make_Object_Declaration
(Loc
,
11525 Defining_Identifier
=> Expr_Id
,
11526 Object_Definition
=> New_Occurrence_Of
(Int_Type
, Loc
),
11527 Constant_Present
=> True,
11529 Convert_To
(Int_Type
, Expression
(Conv
))));
11531 -- Create integer objects for range checking of result.
11534 Unchecked_Convert_To
11535 (Int_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11538 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Lo
));
11541 Unchecked_Convert_To
11542 (Int_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11545 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Hi
));
11547 -- Rewrite conversion as an integer conversion of the
11548 -- original floating-point expression, followed by an
11549 -- unchecked conversion to the target fixed-point type.
11552 Make_Unchecked_Type_Conversion
(Loc
,
11553 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
11554 Expression
=> New_Occurrence_Of
(Expr_Id
, Loc
));
11557 -- All other conversions
11560 Lo_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11562 Make_Attribute_Reference
(Loc
,
11563 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11564 Attribute_Name
=> Name_First
);
11566 Hi_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11568 Make_Attribute_Reference
(Loc
,
11569 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11570 Attribute_Name
=> Name_Last
);
11573 -- Build code for range checking. Note that checks are suppressed
11574 -- here since we don't want a recursive range check popping up.
11576 Insert_Actions
(N
, New_List
(
11577 Make_Object_Declaration
(Loc
,
11578 Defining_Identifier
=> Tnn
,
11579 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
11580 Constant_Present
=> True,
11581 Expression
=> Conv
),
11583 Make_Raise_Constraint_Error
(Loc
,
11588 Left_Opnd
=> Lo_Arg
,
11589 Right_Opnd
=> Lo_Val
),
11593 Left_Opnd
=> Hi_Arg
,
11594 Right_Opnd
=> Hi_Val
)),
11595 Reason
=> CE_Range_Check_Failed
)),
11596 Suppress
=> All_Checks
);
11598 Rewrite
(Expr
, New_Occurrence_Of
(Tnn
, Loc
));
11599 end Real_Range_Check
;
11601 -----------------------------
11602 -- Has_Extra_Accessibility --
11603 -----------------------------
11605 -- Returns true for a formal of an anonymous access type or for an Ada
11606 -- 2012-style stand-alone object of an anonymous access type.
11608 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
11610 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
11611 return Present
(Effective_Extra_Accessibility
(Id
));
11615 end Has_Extra_Accessibility
;
11617 -- Start of processing for Expand_N_Type_Conversion
11620 -- First remove check marks put by the semantic analysis on the type
11621 -- conversion between array types. We need these checks, and they will
11622 -- be generated by this expansion routine, but we do not depend on these
11623 -- flags being set, and since we do intend to expand the checks in the
11624 -- front end, we don't want them on the tree passed to the back end.
11626 if Is_Array_Type
(Target_Type
) then
11627 if Is_Constrained
(Target_Type
) then
11628 Set_Do_Length_Check
(N
, False);
11630 Set_Do_Range_Check
(Operand
, False);
11634 -- Nothing at all to do if conversion is to the identical type so remove
11635 -- the conversion completely, it is useless, except that it may carry
11636 -- an Assignment_OK attribute, which must be propagated to the operand.
11638 if Operand_Type
= Target_Type
then
11639 if Assignment_OK
(N
) then
11640 Set_Assignment_OK
(Operand
);
11643 Rewrite
(N
, Relocate_Node
(Operand
));
11647 -- Nothing to do if this is the second argument of read. This is a
11648 -- "backwards" conversion that will be handled by the specialized code
11649 -- in attribute processing.
11651 if Nkind
(Parent
(N
)) = N_Attribute_Reference
11652 and then Attribute_Name
(Parent
(N
)) = Name_Read
11653 and then Next
(First
(Expressions
(Parent
(N
)))) = N
11658 -- Check for case of converting to a type that has an invariant
11659 -- associated with it. This requires an invariant check. We insert
11662 -- invariant_check (typ (expr))
11664 -- in the code, after removing side effects from the expression.
11665 -- This is clearer than replacing the conversion into an expression
11666 -- with actions, because the context may impose additional actions
11667 -- (tag checks, membership tests, etc.) that conflict with this
11668 -- rewriting (used previously).
11670 -- Note: the Comes_From_Source check, and then the resetting of this
11671 -- flag prevents what would otherwise be an infinite recursion.
11673 if Has_Invariants
(Target_Type
)
11674 and then Present
(Invariant_Procedure
(Target_Type
))
11675 and then Comes_From_Source
(N
)
11677 Set_Comes_From_Source
(N
, False);
11678 Remove_Side_Effects
(N
);
11679 Insert_Action
(N
, Make_Invariant_Call
(Duplicate_Subexpr
(N
)));
11683 -- Here if we may need to expand conversion
11685 -- If the operand of the type conversion is an arithmetic operation on
11686 -- signed integers, and the based type of the signed integer type in
11687 -- question is smaller than Standard.Integer, we promote both of the
11688 -- operands to type Integer.
11690 -- For example, if we have
11692 -- target-type (opnd1 + opnd2)
11694 -- and opnd1 and opnd2 are of type short integer, then we rewrite
11697 -- target-type (integer(opnd1) + integer(opnd2))
11699 -- We do this because we are always allowed to compute in a larger type
11700 -- if we do the right thing with the result, and in this case we are
11701 -- going to do a conversion which will do an appropriate check to make
11702 -- sure that things are in range of the target type in any case. This
11703 -- avoids some unnecessary intermediate overflows.
11705 -- We might consider a similar transformation in the case where the
11706 -- target is a real type or a 64-bit integer type, and the operand
11707 -- is an arithmetic operation using a 32-bit integer type. However,
11708 -- we do not bother with this case, because it could cause significant
11709 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
11710 -- much cheaper, but we don't want different behavior on 32-bit and
11711 -- 64-bit machines. Note that the exclusion of the 64-bit case also
11712 -- handles the configurable run-time cases where 64-bit arithmetic
11713 -- may simply be unavailable.
11715 -- Note: this circuit is partially redundant with respect to the circuit
11716 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
11717 -- the processing here. Also we still need the Checks circuit, since we
11718 -- have to be sure not to generate junk overflow checks in the first
11719 -- place, since it would be trick to remove them here.
11721 if Integer_Promotion_Possible
(N
) then
11723 -- All conditions met, go ahead with transformation
11731 Make_Type_Conversion
(Loc
,
11732 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11733 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
11735 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
11736 Set_Right_Opnd
(Opnd
, R
);
11738 if Nkind
(Operand
) in N_Binary_Op
then
11740 Make_Type_Conversion
(Loc
,
11741 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
11742 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
11744 Set_Left_Opnd
(Opnd
, L
);
11748 Make_Type_Conversion
(Loc
,
11749 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
11750 Expression
=> Opnd
));
11752 Analyze_And_Resolve
(N
, Target_Type
);
11757 -- Do validity check if validity checking operands
11759 if Validity_Checks_On
and Validity_Check_Operands
then
11760 Ensure_Valid
(Operand
);
11763 -- Special case of converting from non-standard boolean type
11765 if Is_Boolean_Type
(Operand_Type
)
11766 and then (Nonzero_Is_True
(Operand_Type
))
11768 Adjust_Condition
(Operand
);
11769 Set_Etype
(Operand
, Standard_Boolean
);
11770 Operand_Type
:= Standard_Boolean
;
11773 -- Case of converting to an access type
11775 if Is_Access_Type
(Target_Type
) then
11776 -- In terms of accessibility rules, an anonymous access discriminant
11777 -- is not considered separate from its parent object.
11779 if Nkind
(Operand
) = N_Selected_Component
11780 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
11781 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
11783 Operand_Acc
:= Original_Node
(Prefix
(Operand
));
11786 -- If this type conversion was internally generated by the front end
11787 -- to displace the pointer to the object to reference an interface
11788 -- type and the original node was an Unrestricted_Access attribute,
11789 -- then skip applying accessibility checks (because, according to the
11790 -- GNAT Reference Manual, this attribute is similar to 'Access except
11791 -- that all accessibility and aliased view checks are omitted).
11793 if not Comes_From_Source
(N
)
11794 and then Is_Interface
(Designated_Type
(Target_Type
))
11795 and then Nkind
(Original_Node
(N
)) = N_Attribute_Reference
11796 and then Attribute_Name
(Original_Node
(N
)) =
11797 Name_Unrestricted_Access
11801 -- Apply an accessibility check when the conversion operand is an
11802 -- access parameter (or a renaming thereof), unless conversion was
11803 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
11804 -- or for the actual of a class-wide interface parameter. Note that
11805 -- other checks may still need to be applied below (such as tagged
11808 elsif Is_Entity_Name
(Operand_Acc
)
11809 and then Has_Extra_Accessibility
(Entity
(Operand_Acc
))
11810 and then Ekind
(Etype
(Operand_Acc
)) = E_Anonymous_Access_Type
11811 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
11812 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
11814 if not Comes_From_Source
(N
)
11815 and then Nkind_In
(Parent
(N
), N_Function_Call
,
11816 N_Parameter_Association
,
11817 N_Procedure_Call_Statement
)
11818 and then Is_Interface
(Designated_Type
(Target_Type
))
11819 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
11824 Apply_Accessibility_Check
11825 (Operand_Acc
, Target_Type
, Insert_Node
=> Operand
);
11828 -- If the level of the operand type is statically deeper than the
11829 -- level of the target type, then force Program_Error. Note that this
11830 -- can only occur for cases where the attribute is within the body of
11831 -- an instantiation, otherwise the conversion will already have been
11832 -- rejected as illegal.
11834 -- Note: warnings are issued by the analyzer for the instance cases
11836 elsif In_Instance_Body
11838 -- The case where the target type is an anonymous access type of
11839 -- a discriminant is excluded, because the level of such a type
11840 -- depends on the context and currently the level returned for such
11841 -- types is zero, resulting in warnings about about check failures
11842 -- in certain legal cases involving class-wide interfaces as the
11843 -- designated type (some cases, such as return statements, are
11844 -- checked at run time, but not clear if these are handled right
11845 -- in general, see 3.10.2(12/2-12.5/3) ???).
11848 not (Ekind
(Target_Type
) = E_Anonymous_Access_Type
11849 and then Present
(Associated_Node_For_Itype
(Target_Type
))
11850 and then Nkind
(Associated_Node_For_Itype
(Target_Type
)) =
11851 N_Discriminant_Specification
)
11853 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
11855 Raise_Accessibility_Error
;
11858 -- When the operand is a selected access discriminant the check needs
11859 -- to be made against the level of the object denoted by the prefix
11860 -- of the selected name. Force Program_Error for this case as well
11861 -- (this accessibility violation can only happen if within the body
11862 -- of an instantiation).
11864 elsif In_Instance_Body
11865 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
11866 and then Nkind
(Operand
) = N_Selected_Component
11867 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
11868 and then Object_Access_Level
(Operand
) >
11869 Type_Access_Level
(Target_Type
)
11871 Raise_Accessibility_Error
;
11876 -- Case of conversions of tagged types and access to tagged types
11878 -- When needed, that is to say when the expression is class-wide, Add
11879 -- runtime a tag check for (strict) downward conversion by using the
11880 -- membership test, generating:
11882 -- [constraint_error when Operand not in Target_Type'Class]
11884 -- or in the access type case
11886 -- [constraint_error
11887 -- when Operand /= null
11888 -- and then Operand.all not in
11889 -- Designated_Type (Target_Type)'Class]
11891 if (Is_Access_Type
(Target_Type
)
11892 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
11893 or else Is_Tagged_Type
(Target_Type
)
11895 -- Do not do any expansion in the access type case if the parent is a
11896 -- renaming, since this is an error situation which will be caught by
11897 -- Sem_Ch8, and the expansion can interfere with this error check.
11899 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
11903 -- Otherwise, proceed with processing tagged conversion
11905 Tagged_Conversion
: declare
11906 Actual_Op_Typ
: Entity_Id
;
11907 Actual_Targ_Typ
: Entity_Id
;
11908 Make_Conversion
: Boolean := False;
11909 Root_Op_Typ
: Entity_Id
;
11911 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
11912 -- Create a membership check to test whether Operand is a member
11913 -- of Targ_Typ. If the original Target_Type is an access, include
11914 -- a test for null value. The check is inserted at N.
11916 --------------------
11917 -- Make_Tag_Check --
11918 --------------------
11920 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
11925 -- [Constraint_Error
11926 -- when Operand /= null
11927 -- and then Operand.all not in Targ_Typ]
11929 if Is_Access_Type
(Target_Type
) then
11931 Make_And_Then
(Loc
,
11934 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
11935 Right_Opnd
=> Make_Null
(Loc
)),
11940 Make_Explicit_Dereference
(Loc
,
11941 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
11942 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
11945 -- [Constraint_Error when Operand not in Targ_Typ]
11950 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
11951 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
11955 Make_Raise_Constraint_Error
(Loc
,
11957 Reason
=> CE_Tag_Check_Failed
),
11958 Suppress
=> All_Checks
);
11959 end Make_Tag_Check
;
11961 -- Start of processing for Tagged_Conversion
11964 -- Handle entities from the limited view
11966 if Is_Access_Type
(Operand_Type
) then
11968 Available_View
(Designated_Type
(Operand_Type
));
11970 Actual_Op_Typ
:= Operand_Type
;
11973 if Is_Access_Type
(Target_Type
) then
11975 Available_View
(Designated_Type
(Target_Type
));
11977 Actual_Targ_Typ
:= Target_Type
;
11980 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
11982 -- Ada 2005 (AI-251): Handle interface type conversion
11984 if Is_Interface
(Actual_Op_Typ
)
11986 Is_Interface
(Actual_Targ_Typ
)
11988 Expand_Interface_Conversion
(N
);
11992 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
11994 -- Create a runtime tag check for a downward class-wide type
11997 if Is_Class_Wide_Type
(Actual_Op_Typ
)
11998 and then Actual_Op_Typ
/= Actual_Targ_Typ
11999 and then Root_Op_Typ
/= Actual_Targ_Typ
12000 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
12001 Use_Full_View
=> True)
12003 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
12004 Make_Conversion
:= True;
12007 -- AI05-0073: If the result subtype of the function is defined
12008 -- by an access_definition designating a specific tagged type
12009 -- T, a check is made that the result value is null or the tag
12010 -- of the object designated by the result value identifies T.
12011 -- Constraint_Error is raised if this check fails.
12013 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
12016 Func_Typ
: Entity_Id
;
12019 -- Climb scope stack looking for the enclosing function
12021 Func
:= Current_Scope
;
12022 while Present
(Func
)
12023 and then Ekind
(Func
) /= E_Function
12025 Func
:= Scope
(Func
);
12028 -- The function's return subtype must be defined using
12029 -- an access definition.
12031 if Nkind
(Result_Definition
(Parent
(Func
))) =
12032 N_Access_Definition
12034 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
12036 -- The return subtype denotes a specific tagged type,
12037 -- in other words, a non class-wide type.
12039 if Is_Tagged_Type
(Func_Typ
)
12040 and then not Is_Class_Wide_Type
(Func_Typ
)
12042 Make_Tag_Check
(Actual_Targ_Typ
);
12043 Make_Conversion
:= True;
12049 -- We have generated a tag check for either a class-wide type
12050 -- conversion or for AI05-0073.
12052 if Make_Conversion
then
12057 Make_Unchecked_Type_Conversion
(Loc
,
12058 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
12059 Expression
=> Relocate_Node
(Expression
(N
)));
12061 Analyze_And_Resolve
(N
, Target_Type
);
12065 end Tagged_Conversion
;
12067 -- Case of other access type conversions
12069 elsif Is_Access_Type
(Target_Type
) then
12070 Apply_Constraint_Check
(Operand
, Target_Type
);
12072 -- Case of conversions from a fixed-point type
12074 -- These conversions require special expansion and processing, found in
12075 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12076 -- since from a semantic point of view, these are simple integer
12077 -- conversions, which do not need further processing.
12079 elsif Is_Fixed_Point_Type
(Operand_Type
)
12080 and then not Conversion_OK
(N
)
12082 -- We should never see universal fixed at this case, since the
12083 -- expansion of the constituent divide or multiply should have
12084 -- eliminated the explicit mention of universal fixed.
12086 pragma Assert
(Operand_Type
/= Universal_Fixed
);
12088 -- Check for special case of the conversion to universal real that
12089 -- occurs as a result of the use of a round attribute. In this case,
12090 -- the real type for the conversion is taken from the target type of
12091 -- the Round attribute and the result must be marked as rounded.
12093 if Target_Type
= Universal_Real
12094 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
12095 and then Attribute_Name
(Parent
(N
)) = Name_Round
12097 Set_Rounded_Result
(N
);
12098 Set_Etype
(N
, Etype
(Parent
(N
)));
12099 Target_Type
:= Etype
(N
);
12102 if Is_Fixed_Point_Type
(Target_Type
) then
12103 Expand_Convert_Fixed_To_Fixed
(N
);
12106 elsif Is_Integer_Type
(Target_Type
) then
12107 Expand_Convert_Fixed_To_Integer
(N
);
12108 Discrete_Range_Check
;
12111 pragma Assert
(Is_Floating_Point_Type
(Target_Type
));
12112 Expand_Convert_Fixed_To_Float
(N
);
12116 -- Case of conversions to a fixed-point type
12118 -- These conversions require special expansion and processing, found in
12119 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12120 -- since from a semantic point of view, these are simple integer
12121 -- conversions, which do not need further processing.
12123 elsif Is_Fixed_Point_Type
(Target_Type
)
12124 and then not Conversion_OK
(N
)
12126 if Is_Integer_Type
(Operand_Type
) then
12127 Expand_Convert_Integer_To_Fixed
(N
);
12130 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
12131 Expand_Convert_Float_To_Fixed
(N
);
12135 -- Case of array conversions
12137 -- Expansion of array conversions, add required length/range checks but
12138 -- only do this if there is no change of representation. For handling of
12139 -- this case, see Handle_Changed_Representation.
12141 elsif Is_Array_Type
(Target_Type
) then
12142 if Is_Constrained
(Target_Type
) then
12143 Apply_Length_Check
(Operand
, Target_Type
);
12145 Apply_Range_Check
(Operand
, Target_Type
);
12148 Handle_Changed_Representation
;
12150 -- Case of conversions of discriminated types
12152 -- Add required discriminant checks if target is constrained. Again this
12153 -- change is skipped if we have a change of representation.
12155 elsif Has_Discriminants
(Target_Type
)
12156 and then Is_Constrained
(Target_Type
)
12158 Apply_Discriminant_Check
(Operand
, Target_Type
);
12159 Handle_Changed_Representation
;
12161 -- Case of all other record conversions. The only processing required
12162 -- is to check for a change of representation requiring the special
12163 -- assignment processing.
12165 elsif Is_Record_Type
(Target_Type
) then
12167 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12168 -- a derived Unchecked_Union type to an unconstrained type that is
12169 -- not Unchecked_Union if the operand lacks inferable discriminants.
12171 if Is_Derived_Type
(Operand_Type
)
12172 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
12173 and then not Is_Constrained
(Target_Type
)
12174 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
12175 and then not Has_Inferable_Discriminants
(Operand
)
12177 -- To prevent Gigi from generating illegal code, we generate a
12178 -- Program_Error node, but we give it the target type of the
12179 -- conversion (is this requirement documented somewhere ???)
12182 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
12183 Reason
=> PE_Unchecked_Union_Restriction
);
12186 Set_Etype
(PE
, Target_Type
);
12191 Handle_Changed_Representation
;
12194 -- Case of conversions of enumeration types
12196 elsif Is_Enumeration_Type
(Target_Type
) then
12198 -- Special processing is required if there is a change of
12199 -- representation (from enumeration representation clauses).
12201 if not Same_Representation
(Target_Type
, Operand_Type
) then
12203 -- Convert: x(y) to x'val (ytyp'val (y))
12206 Make_Attribute_Reference
(Loc
,
12207 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
12208 Attribute_Name
=> Name_Val
,
12209 Expressions
=> New_List
(
12210 Make_Attribute_Reference
(Loc
,
12211 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
12212 Attribute_Name
=> Name_Pos
,
12213 Expressions
=> New_List
(Operand
)))));
12215 Analyze_And_Resolve
(N
, Target_Type
);
12219 -- At this stage, either the conversion node has been transformed into
12220 -- some other equivalent expression, or left as a conversion that can be
12221 -- handled by Gigi, in the following cases:
12223 -- Conversions with no change of representation or type
12225 -- Numeric conversions involving integer, floating- and fixed-point
12226 -- values. Fixed-point values are allowed only if Conversion_OK is
12227 -- set, i.e. if the fixed-point values are to be treated as integers.
12229 -- No other conversions should be passed to Gigi
12231 -- Check: are these rules stated in sinfo??? if so, why restate here???
12233 -- The only remaining step is to generate a range check if we still have
12234 -- a type conversion at this stage and Do_Range_Check is set. Note that
12235 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12236 -- conversions here, because the float-to-integer case is entirely dealt
12237 -- with by Apply_Float_Conversion_Check.
12239 if Nkind
(N
) = N_Type_Conversion
12240 and then Do_Range_Check
(Expression
(N
))
12242 -- Float-to-float conversions
12244 if Is_Floating_Point_Type
(Target_Type
)
12245 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
12247 -- Reset overflow flag, since the range check will include
12248 -- dealing with possible overflow, and generate the check.
12250 Set_Do_Overflow_Check
(N
, False);
12252 Generate_Range_Check
12253 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
12255 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12256 -- conversions when Conversion_OK is set.
12258 elsif Is_Discrete_Type
(Target_Type
)
12259 and then (Is_Discrete_Type
(Etype
(Expression
(N
)))
12260 or else (Is_Fixed_Point_Type
(Etype
(Expression
(N
)))
12261 and then Conversion_OK
(N
)))
12263 -- If Address is either a source type or target type,
12264 -- suppress range check to avoid typing anomalies when
12265 -- it is a visible integer type.
12267 if Is_Descendant_Of_Address
(Etype
(Expression
(N
)))
12268 or else Is_Descendant_Of_Address
(Target_Type
)
12270 Set_Do_Range_Check
(Expression
(N
), False);
12272 Discrete_Range_Check
;
12275 -- Conversions to floating- or fixed-point when Conversion_OK is set
12277 elsif Is_Floating_Point_Type
(Target_Type
)
12278 or else (Is_Fixed_Point_Type
(Target_Type
)
12279 and then Conversion_OK
(N
))
12285 -- Here at end of processing
12288 -- Apply predicate check if required. Note that we can't just call
12289 -- Apply_Predicate_Check here, because the type looks right after
12290 -- the conversion and it would omit the check. The Comes_From_Source
12291 -- guard is necessary to prevent infinite recursions when we generate
12292 -- internal conversions for the purpose of checking predicates.
12294 if Present
(Predicate_Function
(Target_Type
))
12295 and then not Predicates_Ignored
(Target_Type
)
12296 and then Target_Type
/= Operand_Type
12297 and then Comes_From_Source
(N
)
12300 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
12303 -- Avoid infinite recursion on the subsequent expansion of
12304 -- of the copy of the original type conversion. When needed,
12305 -- a range check has already been applied to the expression.
12307 Set_Comes_From_Source
(New_Expr
, False);
12309 Make_Predicate_Check
(Target_Type
, New_Expr
),
12310 Suppress
=> Range_Check
);
12313 end Expand_N_Type_Conversion
;
12315 -----------------------------------
12316 -- Expand_N_Unchecked_Expression --
12317 -----------------------------------
12319 -- Remove the unchecked expression node from the tree. Its job was simply
12320 -- to make sure that its constituent expression was handled with checks
12321 -- off, and now that that is done, we can remove it from the tree, and
12322 -- indeed must, since Gigi does not expect to see these nodes.
12324 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
12325 Exp
: constant Node_Id
:= Expression
(N
);
12327 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
12329 end Expand_N_Unchecked_Expression
;
12331 ----------------------------------------
12332 -- Expand_N_Unchecked_Type_Conversion --
12333 ----------------------------------------
12335 -- If this cannot be handled by Gigi and we haven't already made a
12336 -- temporary for it, do it now.
12338 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
12339 Target_Type
: constant Entity_Id
:= Etype
(N
);
12340 Operand
: constant Node_Id
:= Expression
(N
);
12341 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12344 -- Nothing at all to do if conversion is to the identical type so remove
12345 -- the conversion completely, it is useless, except that it may carry
12346 -- an Assignment_OK indication which must be propagated to the operand.
12348 if Operand_Type
= Target_Type
then
12350 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
12352 if Assignment_OK
(N
) then
12353 Set_Assignment_OK
(Operand
);
12356 Rewrite
(N
, Relocate_Node
(Operand
));
12360 -- If we have a conversion of a compile time known value to a target
12361 -- type and the value is in range of the target type, then we can simply
12362 -- replace the construct by an integer literal of the correct type. We
12363 -- only apply this to integer types being converted. Possibly it may
12364 -- apply in other cases, but it is too much trouble to worry about.
12366 -- Note that we do not do this transformation if the Kill_Range_Check
12367 -- flag is set, since then the value may be outside the expected range.
12368 -- This happens in the Normalize_Scalars case.
12370 -- We also skip this if either the target or operand type is biased
12371 -- because in this case, the unchecked conversion is supposed to
12372 -- preserve the bit pattern, not the integer value.
12374 if Is_Integer_Type
(Target_Type
)
12375 and then not Has_Biased_Representation
(Target_Type
)
12376 and then Is_Integer_Type
(Operand_Type
)
12377 and then not Has_Biased_Representation
(Operand_Type
)
12378 and then Compile_Time_Known_Value
(Operand
)
12379 and then not Kill_Range_Check
(N
)
12382 Val
: constant Uint
:= Expr_Value
(Operand
);
12385 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
12387 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
12389 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
12391 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
12393 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
12395 -- If Address is the target type, just set the type to avoid a
12396 -- spurious type error on the literal when Address is a visible
12399 if Is_Descendant_Of_Address
(Target_Type
) then
12400 Set_Etype
(N
, Target_Type
);
12402 Analyze_And_Resolve
(N
, Target_Type
);
12410 -- Nothing to do if conversion is safe
12412 if Safe_Unchecked_Type_Conversion
(N
) then
12416 -- Otherwise force evaluation unless Assignment_OK flag is set (this
12417 -- flag indicates ??? More comments needed here)
12419 if Assignment_OK
(N
) then
12422 Force_Evaluation
(N
);
12424 end Expand_N_Unchecked_Type_Conversion
;
12426 ----------------------------
12427 -- Expand_Record_Equality --
12428 ----------------------------
12430 -- For non-variant records, Equality is expanded when needed into:
12432 -- and then Lhs.Discr1 = Rhs.Discr1
12434 -- and then Lhs.Discrn = Rhs.Discrn
12435 -- and then Lhs.Cmp1 = Rhs.Cmp1
12437 -- and then Lhs.Cmpn = Rhs.Cmpn
12439 -- The expression is folded by the back end for adjacent fields. This
12440 -- function is called for tagged record in only one occasion: for imple-
12441 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12442 -- otherwise the primitive "=" is used directly.
12444 function Expand_Record_Equality
12449 Bodies
: List_Id
) return Node_Id
12451 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12456 First_Time
: Boolean := True;
12458 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
12459 -- Return the next discriminant or component to compare, starting with
12460 -- C, skipping inherited components.
12462 ------------------------
12463 -- Element_To_Compare --
12464 ------------------------
12466 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
12472 -- Exit loop when the next element to be compared is found, or
12473 -- there is no more such element.
12475 exit when No
(Comp
);
12477 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
12480 -- Skip inherited components
12482 -- Note: for a tagged type, we always generate the "=" primitive
12483 -- for the base type (not on the first subtype), so the test for
12484 -- Comp /= Original_Record_Component (Comp) is True for
12485 -- inherited components only.
12487 (Is_Tagged_Type
(Typ
)
12488 and then Comp
/= Original_Record_Component
(Comp
))
12492 or else Chars
(Comp
) = Name_uTag
12494 -- Skip interface elements (secondary tags???)
12496 or else Is_Interface
(Etype
(Comp
)));
12498 Next_Entity
(Comp
);
12502 end Element_To_Compare
;
12504 -- Start of processing for Expand_Record_Equality
12507 -- Generates the following code: (assuming that Typ has one Discr and
12508 -- component C2 is also a record)
12510 -- Lhs.Discr1 = Rhs.Discr1
12511 -- and then Lhs.C1 = Rhs.C1
12512 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12514 -- and then Lhs.Cmpn = Rhs.Cmpn
12516 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
12517 C
:= Element_To_Compare
(First_Entity
(Typ
));
12518 while Present
(C
) loop
12529 New_Lhs
:= New_Copy_Tree
(Lhs
);
12530 New_Rhs
:= New_Copy_Tree
(Rhs
);
12534 Expand_Composite_Equality
(Nod
, Etype
(C
),
12536 Make_Selected_Component
(Loc
,
12538 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12540 Make_Selected_Component
(Loc
,
12542 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12545 -- If some (sub)component is an unchecked_union, the whole
12546 -- operation will raise program error.
12548 if Nkind
(Check
) = N_Raise_Program_Error
then
12550 Set_Etype
(Result
, Standard_Boolean
);
12556 -- Generate logical "and" for CodePeer to simplify the
12557 -- generated code and analysis.
12559 elsif CodePeer_Mode
then
12562 Left_Opnd
=> Result
,
12563 Right_Opnd
=> Check
);
12567 Make_And_Then
(Loc
,
12568 Left_Opnd
=> Result
,
12569 Right_Opnd
=> Check
);
12574 First_Time
:= False;
12575 C
:= Element_To_Compare
(Next_Entity
(C
));
12579 end Expand_Record_Equality
;
12581 ---------------------------
12582 -- Expand_Set_Membership --
12583 ---------------------------
12585 procedure Expand_Set_Membership
(N
: Node_Id
) is
12586 Lop
: constant Node_Id
:= Left_Opnd
(N
);
12590 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
12591 -- If the alternative is a subtype mark, create a simple membership
12592 -- test. Otherwise create an equality test for it.
12598 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
12600 L
: constant Node_Id
:= New_Copy_Tree
(Lop
);
12601 R
: constant Node_Id
:= Relocate_Node
(Alt
);
12604 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
12605 or else Nkind
(Alt
) = N_Range
12608 Make_In
(Sloc
(Alt
),
12613 Make_Op_Eq
(Sloc
(Alt
),
12621 -- Start of processing for Expand_Set_Membership
12624 Remove_Side_Effects
(Lop
);
12626 Alt
:= Last
(Alternatives
(N
));
12627 Res
:= Make_Cond
(Alt
);
12630 while Present
(Alt
) loop
12632 Make_Or_Else
(Sloc
(Alt
),
12633 Left_Opnd
=> Make_Cond
(Alt
),
12634 Right_Opnd
=> Res
);
12639 Analyze_And_Resolve
(N
, Standard_Boolean
);
12640 end Expand_Set_Membership
;
12642 -----------------------------------
12643 -- Expand_Short_Circuit_Operator --
12644 -----------------------------------
12646 -- Deal with special expansion if actions are present for the right operand
12647 -- and deal with optimizing case of arguments being True or False. We also
12648 -- deal with the special case of non-standard boolean values.
12650 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
12651 Loc
: constant Source_Ptr
:= Sloc
(N
);
12652 Typ
: constant Entity_Id
:= Etype
(N
);
12653 Left
: constant Node_Id
:= Left_Opnd
(N
);
12654 Right
: constant Node_Id
:= Right_Opnd
(N
);
12655 LocR
: constant Source_Ptr
:= Sloc
(Right
);
12658 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
12659 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
12660 -- If Left = Shortcut_Value then Right need not be evaluated
12662 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
12663 -- For Opnd a boolean expression, return a Boolean expression equivalent
12664 -- to Opnd /= Shortcut_Value.
12666 function Useful
(Actions
: List_Id
) return Boolean;
12667 -- Return True if Actions is not empty and contains useful nodes to
12670 --------------------
12671 -- Make_Test_Expr --
12672 --------------------
12674 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
12676 if Shortcut_Value
then
12677 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
12681 end Make_Test_Expr
;
12687 function Useful
(Actions
: List_Id
) return Boolean is
12690 if Present
(Actions
) then
12691 L
:= First
(Actions
);
12693 -- For now "useful" means not N_Variable_Reference_Marker.
12694 -- Consider stripping other nodes in the future.
12696 while Present
(L
) loop
12697 if Nkind
(L
) /= N_Variable_Reference_Marker
then
12710 Op_Var
: Entity_Id
;
12711 -- Entity for a temporary variable holding the value of the operator,
12712 -- used for expansion in the case where actions are present.
12714 -- Start of processing for Expand_Short_Circuit_Operator
12717 -- Deal with non-standard booleans
12719 if Is_Boolean_Type
(Typ
) then
12720 Adjust_Condition
(Left
);
12721 Adjust_Condition
(Right
);
12722 Set_Etype
(N
, Standard_Boolean
);
12725 -- Check for cases where left argument is known to be True or False
12727 if Compile_Time_Known_Value
(Left
) then
12729 -- Mark SCO for left condition as compile time known
12731 if Generate_SCO
and then Comes_From_Source
(Left
) then
12732 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
12735 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
12736 -- Any actions associated with Right will be executed unconditionally
12737 -- and can thus be inserted into the tree unconditionally.
12739 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
12740 if Present
(Actions
(N
)) then
12741 Insert_Actions
(N
, Actions
(N
));
12744 Rewrite
(N
, Right
);
12746 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
12747 -- In this case we can forget the actions associated with Right,
12748 -- since they will never be executed.
12751 Kill_Dead_Code
(Right
);
12752 Kill_Dead_Code
(Actions
(N
));
12753 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
12756 Adjust_Result_Type
(N
, Typ
);
12760 -- If Actions are present for the right operand, we have to do some
12761 -- special processing. We can't just let these actions filter back into
12762 -- code preceding the short circuit (which is what would have happened
12763 -- if we had not trapped them in the short-circuit form), since they
12764 -- must only be executed if the right operand of the short circuit is
12765 -- executed and not otherwise.
12767 if Useful
(Actions
(N
)) then
12768 Actlist
:= Actions
(N
);
12770 -- The old approach is to expand:
12772 -- left AND THEN right
12776 -- C : Boolean := False;
12784 -- and finally rewrite the operator into a reference to C. Similarly
12785 -- for left OR ELSE right, with negated values. Note that this
12786 -- rewrite causes some difficulties for coverage analysis because
12787 -- of the introduction of the new variable C, which obscures the
12788 -- structure of the test.
12790 -- We use this "old approach" if Minimize_Expression_With_Actions
12793 if Minimize_Expression_With_Actions
then
12794 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
12797 Make_Object_Declaration
(Loc
,
12798 Defining_Identifier
=> Op_Var
,
12799 Object_Definition
=>
12800 New_Occurrence_Of
(Standard_Boolean
, Loc
),
12802 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
12804 Append_To
(Actlist
,
12805 Make_Implicit_If_Statement
(Right
,
12806 Condition
=> Make_Test_Expr
(Right
),
12807 Then_Statements
=> New_List
(
12808 Make_Assignment_Statement
(LocR
,
12809 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
12812 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
12815 Make_Implicit_If_Statement
(Left
,
12816 Condition
=> Make_Test_Expr
(Left
),
12817 Then_Statements
=> Actlist
));
12819 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
12820 Analyze_And_Resolve
(N
, Standard_Boolean
);
12822 -- The new approach (the default) is to use an
12823 -- Expression_With_Actions node for the right operand of the
12824 -- short-circuit form. Note that this solves the traceability
12825 -- problems for coverage analysis.
12829 Make_Expression_With_Actions
(LocR
,
12830 Expression
=> Relocate_Node
(Right
),
12831 Actions
=> Actlist
));
12833 Set_Actions
(N
, No_List
);
12834 Analyze_And_Resolve
(Right
, Standard_Boolean
);
12837 Adjust_Result_Type
(N
, Typ
);
12841 -- No actions present, check for cases of right argument True/False
12843 if Compile_Time_Known_Value
(Right
) then
12845 -- Mark SCO for left condition as compile time known
12847 if Generate_SCO
and then Comes_From_Source
(Right
) then
12848 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
12851 -- Change (Left and then True), (Left or else False) to Left. Note
12852 -- that we know there are no actions associated with the right
12853 -- operand, since we just checked for this case above.
12855 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
12858 -- Change (Left and then False), (Left or else True) to Right,
12859 -- making sure to preserve any side effects associated with the Left
12863 Remove_Side_Effects
(Left
);
12864 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
12868 Adjust_Result_Type
(N
, Typ
);
12869 end Expand_Short_Circuit_Operator
;
12871 ------------------------------------
12872 -- Fixup_Universal_Fixed_Operation --
12873 -------------------------------------
12875 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
12876 Conv
: constant Node_Id
:= Parent
(N
);
12879 -- We must have a type conversion immediately above us
12881 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
12883 -- Normally the type conversion gives our target type. The exception
12884 -- occurs in the case of the Round attribute, where the conversion
12885 -- will be to universal real, and our real type comes from the Round
12886 -- attribute (as well as an indication that we must round the result)
12888 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
12889 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
12891 Set_Etype
(N
, Base_Type
(Etype
(Parent
(Conv
))));
12892 Set_Rounded_Result
(N
);
12894 -- Normal case where type comes from conversion above us
12897 Set_Etype
(N
, Base_Type
(Etype
(Conv
)));
12899 end Fixup_Universal_Fixed_Operation
;
12901 ---------------------------------
12902 -- Has_Inferable_Discriminants --
12903 ---------------------------------
12905 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
12907 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
12908 -- Determines whether the left-most prefix of a selected component is a
12909 -- formal parameter in a subprogram. Assumes N is a selected component.
12911 --------------------------------
12912 -- Prefix_Is_Formal_Parameter --
12913 --------------------------------
12915 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
12916 Sel_Comp
: Node_Id
;
12919 -- Move to the left-most prefix by climbing up the tree
12922 while Present
(Parent
(Sel_Comp
))
12923 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
12925 Sel_Comp
:= Parent
(Sel_Comp
);
12928 return Is_Formal
(Entity
(Prefix
(Sel_Comp
)));
12929 end Prefix_Is_Formal_Parameter
;
12931 -- Start of processing for Has_Inferable_Discriminants
12934 -- For selected components, the subtype of the selector must be a
12935 -- constrained Unchecked_Union. If the component is subject to a
12936 -- per-object constraint, then the enclosing object must have inferable
12939 if Nkind
(N
) = N_Selected_Component
then
12940 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
12942 -- A small hack. If we have a per-object constrained selected
12943 -- component of a formal parameter, return True since we do not
12944 -- know the actual parameter association yet.
12946 if Prefix_Is_Formal_Parameter
(N
) then
12949 -- Otherwise, check the enclosing object and the selector
12952 return Has_Inferable_Discriminants
(Prefix
(N
))
12953 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
12956 -- The call to Has_Inferable_Discriminants will determine whether
12957 -- the selector has a constrained Unchecked_Union nominal type.
12960 return Has_Inferable_Discriminants
(Selector_Name
(N
));
12963 -- A qualified expression has inferable discriminants if its subtype
12964 -- mark is a constrained Unchecked_Union subtype.
12966 elsif Nkind
(N
) = N_Qualified_Expression
then
12967 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
12968 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
12970 -- For all other names, it is sufficient to have a constrained
12971 -- Unchecked_Union nominal subtype.
12974 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
12975 and then Is_Constrained
(Etype
(N
));
12977 end Has_Inferable_Discriminants
;
12979 -------------------------------
12980 -- Insert_Dereference_Action --
12981 -------------------------------
12983 procedure Insert_Dereference_Action
(N
: Node_Id
) is
12984 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
12985 -- Return true if type of P is derived from Checked_Pool;
12987 -----------------------------
12988 -- Is_Checked_Storage_Pool --
12989 -----------------------------
12991 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
13000 while T
/= Etype
(T
) loop
13001 if Is_RTE
(T
, RE_Checked_Pool
) then
13009 end Is_Checked_Storage_Pool
;
13013 Context
: constant Node_Id
:= Parent
(N
);
13014 Ptr_Typ
: constant Entity_Id
:= Etype
(N
);
13015 Desig_Typ
: constant Entity_Id
:=
13016 Available_View
(Designated_Type
(Ptr_Typ
));
13017 Loc
: constant Source_Ptr
:= Sloc
(N
);
13018 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
13024 Size_Bits
: Node_Id
;
13027 -- Start of processing for Insert_Dereference_Action
13030 pragma Assert
(Nkind
(Context
) = N_Explicit_Dereference
);
13032 -- Do not re-expand a dereference which has already been processed by
13035 if Has_Dereference_Action
(Context
) then
13038 -- Do not perform this type of expansion for internally-generated
13041 elsif not Comes_From_Source
(Original_Node
(Context
)) then
13044 -- A dereference action is only applicable to objects which have been
13045 -- allocated on a checked pool.
13047 elsif not Is_Checked_Storage_Pool
(Pool
) then
13051 -- Extract the address of the dereferenced object. Generate:
13053 -- Addr : System.Address := <N>'Pool_Address;
13055 Addr
:= Make_Temporary
(Loc
, 'P');
13058 Make_Object_Declaration
(Loc
,
13059 Defining_Identifier
=> Addr
,
13060 Object_Definition
=>
13061 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
13063 Make_Attribute_Reference
(Loc
,
13064 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
13065 Attribute_Name
=> Name_Pool_Address
)));
13067 -- Calculate the size of the dereferenced object. Generate:
13069 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13072 Make_Explicit_Dereference
(Loc
,
13073 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13074 Set_Has_Dereference_Action
(Deref
);
13077 Make_Attribute_Reference
(Loc
,
13079 Attribute_Name
=> Name_Size
);
13081 -- Special case of an unconstrained array: need to add descriptor size
13083 if Is_Array_Type
(Desig_Typ
)
13084 and then not Is_Constrained
(First_Subtype
(Desig_Typ
))
13089 Make_Attribute_Reference
(Loc
,
13091 New_Occurrence_Of
(First_Subtype
(Desig_Typ
), Loc
),
13092 Attribute_Name
=> Name_Descriptor_Size
),
13093 Right_Opnd
=> Size_Bits
);
13096 Size
:= Make_Temporary
(Loc
, 'S');
13098 Make_Object_Declaration
(Loc
,
13099 Defining_Identifier
=> Size
,
13100 Object_Definition
=>
13101 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13103 Make_Op_Divide
(Loc
,
13104 Left_Opnd
=> Size_Bits
,
13105 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
13107 -- Calculate the alignment of the dereferenced object. Generate:
13108 -- Alig : constant Storage_Count := <N>.all'Alignment;
13111 Make_Explicit_Dereference
(Loc
,
13112 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13113 Set_Has_Dereference_Action
(Deref
);
13115 Alig
:= Make_Temporary
(Loc
, 'A');
13117 Make_Object_Declaration
(Loc
,
13118 Defining_Identifier
=> Alig
,
13119 Object_Definition
=>
13120 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13122 Make_Attribute_Reference
(Loc
,
13124 Attribute_Name
=> Name_Alignment
)));
13126 -- A dereference of a controlled object requires special processing. The
13127 -- finalization machinery requests additional space from the underlying
13128 -- pool to allocate and hide two pointers. As a result, a checked pool
13129 -- may mark the wrong memory as valid. Since checked pools do not have
13130 -- knowledge of hidden pointers, we have to bring the two pointers back
13131 -- in view in order to restore the original state of the object.
13133 -- The address manipulation is not performed for access types that are
13134 -- subject to pragma No_Heap_Finalization because the two pointers do
13135 -- not exist in the first place.
13137 if No_Heap_Finalization
(Ptr_Typ
) then
13140 elsif Needs_Finalization
(Desig_Typ
) then
13142 -- Adjust the address and size of the dereferenced object. Generate:
13143 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13146 Make_Procedure_Call_Statement
(Loc
,
13148 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
13149 Parameter_Associations
=> New_List
(
13150 New_Occurrence_Of
(Addr
, Loc
),
13151 New_Occurrence_Of
(Size
, Loc
),
13152 New_Occurrence_Of
(Alig
, Loc
)));
13154 -- Class-wide types complicate things because we cannot determine
13155 -- statically whether the actual object is truly controlled. We must
13156 -- generate a runtime check to detect this property. Generate:
13158 -- if Needs_Finalization (<N>.all'Tag) then
13162 if Is_Class_Wide_Type
(Desig_Typ
) then
13164 Make_Explicit_Dereference
(Loc
,
13165 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13166 Set_Has_Dereference_Action
(Deref
);
13169 Make_Implicit_If_Statement
(N
,
13171 Make_Function_Call
(Loc
,
13173 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
13174 Parameter_Associations
=> New_List
(
13175 Make_Attribute_Reference
(Loc
,
13177 Attribute_Name
=> Name_Tag
))),
13178 Then_Statements
=> New_List
(Stmt
));
13181 Insert_Action
(N
, Stmt
);
13185 -- Dereference (Pool, Addr, Size, Alig);
13188 Make_Procedure_Call_Statement
(Loc
,
13191 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
13192 Parameter_Associations
=> New_List
(
13193 New_Occurrence_Of
(Pool
, Loc
),
13194 New_Occurrence_Of
(Addr
, Loc
),
13195 New_Occurrence_Of
(Size
, Loc
),
13196 New_Occurrence_Of
(Alig
, Loc
))));
13198 -- Mark the explicit dereference as processed to avoid potential
13199 -- infinite expansion.
13201 Set_Has_Dereference_Action
(Context
);
13204 when RE_Not_Available
=>
13206 end Insert_Dereference_Action
;
13208 --------------------------------
13209 -- Integer_Promotion_Possible --
13210 --------------------------------
13212 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
13213 Operand
: constant Node_Id
:= Expression
(N
);
13214 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
13215 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
13218 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
13222 -- We only do the transformation for source constructs. We assume
13223 -- that the expander knows what it is doing when it generates code.
13225 Comes_From_Source
(N
)
13227 -- If the operand type is Short_Integer or Short_Short_Integer,
13228 -- then we will promote to Integer, which is available on all
13229 -- targets, and is sufficient to ensure no intermediate overflow.
13230 -- Furthermore it is likely to be as efficient or more efficient
13231 -- than using the smaller type for the computation so we do this
13232 -- unconditionally.
13235 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
13237 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
13239 -- Test for interesting operation, which includes addition,
13240 -- division, exponentiation, multiplication, subtraction, absolute
13241 -- value and unary negation. Unary "+" is omitted since it is a
13242 -- no-op and thus can't overflow.
13244 and then Nkind_In
(Operand
, N_Op_Abs
,
13251 end Integer_Promotion_Possible
;
13253 ------------------------------
13254 -- Make_Array_Comparison_Op --
13255 ------------------------------
13257 -- This is a hand-coded expansion of the following generic function:
13260 -- type elem is (<>);
13261 -- type index is (<>);
13262 -- type a is array (index range <>) of elem;
13264 -- function Gnnn (X : a; Y: a) return boolean is
13265 -- J : index := Y'first;
13268 -- if X'length = 0 then
13271 -- elsif Y'length = 0 then
13275 -- for I in X'range loop
13276 -- if X (I) = Y (J) then
13277 -- if J = Y'last then
13280 -- J := index'succ (J);
13284 -- return X (I) > Y (J);
13288 -- return X'length > Y'length;
13292 -- Note that since we are essentially doing this expansion by hand, we
13293 -- do not need to generate an actual or formal generic part, just the
13294 -- instantiated function itself.
13296 -- Perhaps we could have the actual generic available in the run-time,
13297 -- obtained by rtsfind, and actually expand a real instantiation ???
13299 function Make_Array_Comparison_Op
13301 Nod
: Node_Id
) return Node_Id
13303 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
13305 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
13306 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
13307 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
13308 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13310 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
13312 Loop_Statement
: Node_Id
;
13313 Loop_Body
: Node_Id
;
13315 Inner_If
: Node_Id
;
13316 Final_Expr
: Node_Id
;
13317 Func_Body
: Node_Id
;
13318 Func_Name
: Entity_Id
;
13324 -- if J = Y'last then
13327 -- J := index'succ (J);
13331 Make_Implicit_If_Statement
(Nod
,
13334 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
13336 Make_Attribute_Reference
(Loc
,
13337 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13338 Attribute_Name
=> Name_Last
)),
13340 Then_Statements
=> New_List
(
13341 Make_Exit_Statement
(Loc
)),
13345 Make_Assignment_Statement
(Loc
,
13346 Name
=> New_Occurrence_Of
(J
, Loc
),
13348 Make_Attribute_Reference
(Loc
,
13349 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
13350 Attribute_Name
=> Name_Succ
,
13351 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
13353 -- if X (I) = Y (J) then
13356 -- return X (I) > Y (J);
13360 Make_Implicit_If_Statement
(Nod
,
13364 Make_Indexed_Component
(Loc
,
13365 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13366 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13369 Make_Indexed_Component
(Loc
,
13370 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13371 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
13373 Then_Statements
=> New_List
(Inner_If
),
13375 Else_Statements
=> New_List
(
13376 Make_Simple_Return_Statement
(Loc
,
13380 Make_Indexed_Component
(Loc
,
13381 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13382 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13385 Make_Indexed_Component
(Loc
,
13386 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13387 Expressions
=> New_List
(
13388 New_Occurrence_Of
(J
, Loc
)))))));
13390 -- for I in X'range loop
13395 Make_Implicit_Loop_Statement
(Nod
,
13396 Identifier
=> Empty
,
13398 Iteration_Scheme
=>
13399 Make_Iteration_Scheme
(Loc
,
13400 Loop_Parameter_Specification
=>
13401 Make_Loop_Parameter_Specification
(Loc
,
13402 Defining_Identifier
=> I
,
13403 Discrete_Subtype_Definition
=>
13404 Make_Attribute_Reference
(Loc
,
13405 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13406 Attribute_Name
=> Name_Range
))),
13408 Statements
=> New_List
(Loop_Body
));
13410 -- if X'length = 0 then
13412 -- elsif Y'length = 0 then
13415 -- for ... loop ... end loop;
13416 -- return X'length > Y'length;
13420 Make_Attribute_Reference
(Loc
,
13421 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13422 Attribute_Name
=> Name_Length
);
13425 Make_Attribute_Reference
(Loc
,
13426 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13427 Attribute_Name
=> Name_Length
);
13431 Left_Opnd
=> Length1
,
13432 Right_Opnd
=> Length2
);
13435 Make_Implicit_If_Statement
(Nod
,
13439 Make_Attribute_Reference
(Loc
,
13440 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13441 Attribute_Name
=> Name_Length
),
13443 Make_Integer_Literal
(Loc
, 0)),
13447 Make_Simple_Return_Statement
(Loc
,
13448 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
13450 Elsif_Parts
=> New_List
(
13451 Make_Elsif_Part
(Loc
,
13455 Make_Attribute_Reference
(Loc
,
13456 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13457 Attribute_Name
=> Name_Length
),
13459 Make_Integer_Literal
(Loc
, 0)),
13463 Make_Simple_Return_Statement
(Loc
,
13464 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
13466 Else_Statements
=> New_List
(
13468 Make_Simple_Return_Statement
(Loc
,
13469 Expression
=> Final_Expr
)));
13473 Formals
:= New_List
(
13474 Make_Parameter_Specification
(Loc
,
13475 Defining_Identifier
=> X
,
13476 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13478 Make_Parameter_Specification
(Loc
,
13479 Defining_Identifier
=> Y
,
13480 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13482 -- function Gnnn (...) return boolean is
13483 -- J : index := Y'first;
13488 Func_Name
:= Make_Temporary
(Loc
, 'G');
13491 Make_Subprogram_Body
(Loc
,
13493 Make_Function_Specification
(Loc
,
13494 Defining_Unit_Name
=> Func_Name
,
13495 Parameter_Specifications
=> Formals
,
13496 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
13498 Declarations
=> New_List
(
13499 Make_Object_Declaration
(Loc
,
13500 Defining_Identifier
=> J
,
13501 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
13503 Make_Attribute_Reference
(Loc
,
13504 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13505 Attribute_Name
=> Name_First
))),
13507 Handled_Statement_Sequence
=>
13508 Make_Handled_Sequence_Of_Statements
(Loc
,
13509 Statements
=> New_List
(If_Stat
)));
13512 end Make_Array_Comparison_Op
;
13514 ---------------------------
13515 -- Make_Boolean_Array_Op --
13516 ---------------------------
13518 -- For logical operations on boolean arrays, expand in line the following,
13519 -- replacing 'and' with 'or' or 'xor' where needed:
13521 -- function Annn (A : typ; B: typ) return typ is
13524 -- for J in A'range loop
13525 -- C (J) := A (J) op B (J);
13530 -- Here typ is the boolean array type
13532 function Make_Boolean_Array_Op
13534 N
: Node_Id
) return Node_Id
13536 Loc
: constant Source_Ptr
:= Sloc
(N
);
13538 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
13539 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
13540 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
13541 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13549 Func_Name
: Entity_Id
;
13550 Func_Body
: Node_Id
;
13551 Loop_Statement
: Node_Id
;
13555 Make_Indexed_Component
(Loc
,
13556 Prefix
=> New_Occurrence_Of
(A
, Loc
),
13557 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13560 Make_Indexed_Component
(Loc
,
13561 Prefix
=> New_Occurrence_Of
(B
, Loc
),
13562 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13565 Make_Indexed_Component
(Loc
,
13566 Prefix
=> New_Occurrence_Of
(C
, Loc
),
13567 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13569 if Nkind
(N
) = N_Op_And
then
13573 Right_Opnd
=> B_J
);
13575 elsif Nkind
(N
) = N_Op_Or
then
13579 Right_Opnd
=> B_J
);
13585 Right_Opnd
=> B_J
);
13589 Make_Implicit_Loop_Statement
(N
,
13590 Identifier
=> Empty
,
13592 Iteration_Scheme
=>
13593 Make_Iteration_Scheme
(Loc
,
13594 Loop_Parameter_Specification
=>
13595 Make_Loop_Parameter_Specification
(Loc
,
13596 Defining_Identifier
=> J
,
13597 Discrete_Subtype_Definition
=>
13598 Make_Attribute_Reference
(Loc
,
13599 Prefix
=> New_Occurrence_Of
(A
, Loc
),
13600 Attribute_Name
=> Name_Range
))),
13602 Statements
=> New_List
(
13603 Make_Assignment_Statement
(Loc
,
13605 Expression
=> Op
)));
13607 Formals
:= New_List
(
13608 Make_Parameter_Specification
(Loc
,
13609 Defining_Identifier
=> A
,
13610 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13612 Make_Parameter_Specification
(Loc
,
13613 Defining_Identifier
=> B
,
13614 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13616 Func_Name
:= Make_Temporary
(Loc
, 'A');
13617 Set_Is_Inlined
(Func_Name
);
13620 Make_Subprogram_Body
(Loc
,
13622 Make_Function_Specification
(Loc
,
13623 Defining_Unit_Name
=> Func_Name
,
13624 Parameter_Specifications
=> Formals
,
13625 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
13627 Declarations
=> New_List
(
13628 Make_Object_Declaration
(Loc
,
13629 Defining_Identifier
=> C
,
13630 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
13632 Handled_Statement_Sequence
=>
13633 Make_Handled_Sequence_Of_Statements
(Loc
,
13634 Statements
=> New_List
(
13636 Make_Simple_Return_Statement
(Loc
,
13637 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
13640 end Make_Boolean_Array_Op
;
13642 -----------------------------------------
13643 -- Minimized_Eliminated_Overflow_Check --
13644 -----------------------------------------
13646 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
13649 Is_Signed_Integer_Type
(Etype
(N
))
13650 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
13651 end Minimized_Eliminated_Overflow_Check
;
13653 --------------------------------
13654 -- Optimize_Length_Comparison --
13655 --------------------------------
13657 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
13658 Loc
: constant Source_Ptr
:= Sloc
(N
);
13659 Typ
: constant Entity_Id
:= Etype
(N
);
13664 -- First and Last attribute reference nodes, which end up as left and
13665 -- right operands of the optimized result.
13668 -- True for comparison operand of zero
13671 -- Comparison operand, set only if Is_Zero is false
13673 Ent
: Entity_Id
:= Empty
;
13674 -- Entity whose length is being compared
13676 Index
: Node_Id
:= Empty
;
13677 -- Integer_Literal node for length attribute expression, or Empty
13678 -- if there is no such expression present.
13681 -- Type of array index to which 'Length is applied
13683 Op
: Node_Kind
:= Nkind
(N
);
13684 -- Kind of comparison operator, gets flipped if operands backwards
13686 function Is_Optimizable
(N
: Node_Id
) return Boolean;
13687 -- Tests N to see if it is an optimizable comparison value (defined as
13688 -- constant zero or one, or something else where the value is known to
13689 -- be positive and in the range of 32-bits, and where the corresponding
13690 -- Length value is also known to be 32-bits. If result is true, sets
13691 -- Is_Zero, Ityp, and Comp accordingly.
13693 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
13694 -- Tests if N is a length attribute applied to a simple entity. If so,
13695 -- returns True, and sets Ent to the entity, and Index to the integer
13696 -- literal provided as an attribute expression, or to Empty if none.
13697 -- Also returns True if the expression is a generated type conversion
13698 -- whose expression is of the desired form. This latter case arises
13699 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
13700 -- to check for being in range, which is not needed in this context.
13701 -- Returns False if neither condition holds.
13703 function Prepare_64
(N
: Node_Id
) return Node_Id
;
13704 -- Given a discrete expression, returns a Long_Long_Integer typed
13705 -- expression representing the underlying value of the expression.
13706 -- This is done with an unchecked conversion to the result type. We
13707 -- use unchecked conversion to handle the enumeration type case.
13709 ----------------------
13710 -- Is_Entity_Length --
13711 ----------------------
13713 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
13715 if Nkind
(N
) = N_Attribute_Reference
13716 and then Attribute_Name
(N
) = Name_Length
13717 and then Is_Entity_Name
(Prefix
(N
))
13719 Ent
:= Entity
(Prefix
(N
));
13721 if Present
(Expressions
(N
)) then
13722 Index
:= First
(Expressions
(N
));
13729 elsif Nkind
(N
) = N_Type_Conversion
13730 and then not Comes_From_Source
(N
)
13732 return Is_Entity_Length
(Expression
(N
));
13737 end Is_Entity_Length
;
13739 --------------------
13740 -- Is_Optimizable --
13741 --------------------
13743 function Is_Optimizable
(N
: Node_Id
) return Boolean is
13751 if Compile_Time_Known_Value
(N
) then
13752 Val
:= Expr_Value
(N
);
13754 if Val
= Uint_0
then
13759 elsif Val
= Uint_1
then
13766 -- Here we have to make sure of being within 32-bits
13768 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
13771 or else Lo
< Uint_1
13772 or else Hi
> UI_From_Int
(Int
'Last)
13777 -- Comparison value was within range, so now we must check the index
13778 -- value to make sure it is also within 32-bits.
13780 Indx
:= First_Index
(Etype
(Ent
));
13782 if Present
(Index
) then
13783 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
13788 Ityp
:= Etype
(Indx
);
13790 if Esize
(Ityp
) > 32 then
13797 end Is_Optimizable
;
13803 function Prepare_64
(N
: Node_Id
) return Node_Id
is
13805 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
13808 -- Start of processing for Optimize_Length_Comparison
13811 -- Nothing to do if not a comparison
13813 if Op
not in N_Op_Compare
then
13817 -- Nothing to do if special -gnatd.P debug flag set.
13819 if Debug_Flag_Dot_PP
then
13823 -- Ent'Length op 0/1
13825 if Is_Entity_Length
(Left_Opnd
(N
))
13826 and then Is_Optimizable
(Right_Opnd
(N
))
13830 -- 0/1 op Ent'Length
13832 elsif Is_Entity_Length
(Right_Opnd
(N
))
13833 and then Is_Optimizable
(Left_Opnd
(N
))
13835 -- Flip comparison to opposite sense
13838 when N_Op_Lt
=> Op
:= N_Op_Gt
;
13839 when N_Op_Le
=> Op
:= N_Op_Ge
;
13840 when N_Op_Gt
=> Op
:= N_Op_Lt
;
13841 when N_Op_Ge
=> Op
:= N_Op_Le
;
13842 when others => null;
13845 -- Else optimization not possible
13851 -- Fall through if we will do the optimization
13853 -- Cases to handle:
13855 -- X'Length = 0 => X'First > X'Last
13856 -- X'Length = 1 => X'First = X'Last
13857 -- X'Length = n => X'First + (n - 1) = X'Last
13859 -- X'Length /= 0 => X'First <= X'Last
13860 -- X'Length /= 1 => X'First /= X'Last
13861 -- X'Length /= n => X'First + (n - 1) /= X'Last
13863 -- X'Length >= 0 => always true, warn
13864 -- X'Length >= 1 => X'First <= X'Last
13865 -- X'Length >= n => X'First + (n - 1) <= X'Last
13867 -- X'Length > 0 => X'First <= X'Last
13868 -- X'Length > 1 => X'First < X'Last
13869 -- X'Length > n => X'First + (n - 1) < X'Last
13871 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
13872 -- X'Length <= 1 => X'First >= X'Last
13873 -- X'Length <= n => X'First + (n - 1) >= X'Last
13875 -- X'Length < 0 => always false (warn)
13876 -- X'Length < 1 => X'First > X'Last
13877 -- X'Length < n => X'First + (n - 1) > X'Last
13879 -- Note: for the cases of n (not constant 0,1), we require that the
13880 -- corresponding index type be integer or shorter (i.e. not 64-bit),
13881 -- and the same for the comparison value. Then we do the comparison
13882 -- using 64-bit arithmetic (actually long long integer), so that we
13883 -- cannot have overflow intefering with the result.
13885 -- First deal with warning cases
13894 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
13895 Analyze_And_Resolve
(N
, Typ
);
13896 Warn_On_Known_Condition
(N
);
13903 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
13904 Analyze_And_Resolve
(N
, Typ
);
13905 Warn_On_Known_Condition
(N
);
13909 if Constant_Condition_Warnings
13910 and then Comes_From_Source
(Original_Node
(N
))
13912 Error_Msg_N
("could replace by ""'=""?c?", N
);
13922 -- Build the First reference we will use
13925 Make_Attribute_Reference
(Loc
,
13926 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
13927 Attribute_Name
=> Name_First
);
13929 if Present
(Index
) then
13930 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
13933 -- If general value case, then do the addition of (n - 1), and
13934 -- also add the needed conversions to type Long_Long_Integer.
13936 if Present
(Comp
) then
13939 Left_Opnd
=> Prepare_64
(Left
),
13941 Make_Op_Subtract
(Loc
,
13942 Left_Opnd
=> Prepare_64
(Comp
),
13943 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
13946 -- Build the Last reference we will use
13949 Make_Attribute_Reference
(Loc
,
13950 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
13951 Attribute_Name
=> Name_Last
);
13953 if Present
(Index
) then
13954 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
13957 -- If general operand, convert Last reference to Long_Long_Integer
13959 if Present
(Comp
) then
13960 Right
:= Prepare_64
(Right
);
13963 -- Check for cases to optimize
13965 -- X'Length = 0 => X'First > X'Last
13966 -- X'Length < 1 => X'First > X'Last
13967 -- X'Length < n => X'First + (n - 1) > X'Last
13969 if (Is_Zero
and then Op
= N_Op_Eq
)
13970 or else (not Is_Zero
and then Op
= N_Op_Lt
)
13975 Right_Opnd
=> Right
);
13977 -- X'Length = 1 => X'First = X'Last
13978 -- X'Length = n => X'First + (n - 1) = X'Last
13980 elsif not Is_Zero
and then Op
= N_Op_Eq
then
13984 Right_Opnd
=> Right
);
13986 -- X'Length /= 0 => X'First <= X'Last
13987 -- X'Length > 0 => X'First <= X'Last
13989 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
13993 Right_Opnd
=> Right
);
13995 -- X'Length /= 1 => X'First /= X'Last
13996 -- X'Length /= n => X'First + (n - 1) /= X'Last
13998 elsif not Is_Zero
and then Op
= N_Op_Ne
then
14002 Right_Opnd
=> Right
);
14004 -- X'Length >= 1 => X'First <= X'Last
14005 -- X'Length >= n => X'First + (n - 1) <= X'Last
14007 elsif not Is_Zero
and then Op
= N_Op_Ge
then
14011 Right_Opnd
=> Right
);
14013 -- X'Length > 1 => X'First < X'Last
14014 -- X'Length > n => X'First + (n = 1) < X'Last
14016 elsif not Is_Zero
and then Op
= N_Op_Gt
then
14020 Right_Opnd
=> Right
);
14022 -- X'Length <= 1 => X'First >= X'Last
14023 -- X'Length <= n => X'First + (n - 1) >= X'Last
14025 elsif not Is_Zero
and then Op
= N_Op_Le
then
14029 Right_Opnd
=> Right
);
14031 -- Should not happen at this stage
14034 raise Program_Error
;
14037 -- Rewrite and finish up
14039 Rewrite
(N
, Result
);
14040 Analyze_And_Resolve
(N
, Typ
);
14042 end Optimize_Length_Comparison
;
14044 --------------------------------
14045 -- Process_If_Case_Statements --
14046 --------------------------------
14048 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
) is
14052 Decl
:= First
(Stmts
);
14053 while Present
(Decl
) loop
14054 if Nkind
(Decl
) = N_Object_Declaration
14055 and then Is_Finalizable_Transient
(Decl
, N
)
14057 Process_Transient_In_Expression
(Decl
, N
, Stmts
);
14062 end Process_If_Case_Statements
;
14064 -------------------------------------
14065 -- Process_Transient_In_Expression --
14066 -------------------------------------
14068 procedure Process_Transient_In_Expression
14069 (Obj_Decl
: Node_Id
;
14073 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
14074 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Obj_Decl
);
14076 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Expr
);
14077 -- The node on which to insert the hook as an action. This is usually
14078 -- the innermost enclosing non-transient construct.
14080 Fin_Call
: Node_Id
;
14081 Hook_Assign
: Node_Id
;
14082 Hook_Clear
: Node_Id
;
14083 Hook_Decl
: Node_Id
;
14084 Hook_Insert
: Node_Id
;
14085 Ptr_Decl
: Node_Id
;
14087 Fin_Context
: Node_Id
;
14088 -- The node after which to insert the finalization actions of the
14089 -- transient object.
14092 pragma Assert
(Nkind_In
(Expr
, N_Case_Expression
,
14093 N_Expression_With_Actions
,
14096 -- When the context is a Boolean evaluation, all three nodes capture the
14097 -- result of their computation in a local temporary:
14100 -- Trans_Id : Ctrl_Typ := ...;
14101 -- Result : constant Boolean := ... Trans_Id ...;
14102 -- <finalize Trans_Id>
14105 -- As a result, the finalization of any transient objects can safely
14106 -- take place after the result capture.
14108 -- ??? could this be extended to elementary types?
14110 if Is_Boolean_Type
(Etype
(Expr
)) then
14111 Fin_Context
:= Last
(Stmts
);
14113 -- Otherwise the immediate context may not be safe enough to carry
14114 -- out transient object finalization due to aliasing and nesting of
14115 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14116 -- enclosing non-transient construct.
14119 Fin_Context
:= Hook_Context
;
14122 -- Mark the transient object as successfully processed to avoid double
14125 Set_Is_Finalized_Transient
(Obj_Id
);
14127 -- Construct all the pieces necessary to hook and finalize a transient
14130 Build_Transient_Object_Statements
14131 (Obj_Decl
=> Obj_Decl
,
14132 Fin_Call
=> Fin_Call
,
14133 Hook_Assign
=> Hook_Assign
,
14134 Hook_Clear
=> Hook_Clear
,
14135 Hook_Decl
=> Hook_Decl
,
14136 Ptr_Decl
=> Ptr_Decl
,
14137 Finalize_Obj
=> False);
14139 -- Add the access type which provides a reference to the transient
14140 -- object. Generate:
14142 -- type Ptr_Typ is access all Desig_Typ;
14144 Insert_Action
(Hook_Context
, Ptr_Decl
);
14146 -- Add the temporary which acts as a hook to the transient object.
14149 -- Hook : Ptr_Id := null;
14151 Insert_Action
(Hook_Context
, Hook_Decl
);
14153 -- When the transient object is initialized by an aggregate, the hook
14154 -- must capture the object after the last aggregate assignment takes
14155 -- place. Only then is the object considered initialized. Generate:
14157 -- Hook := Ptr_Typ (Obj_Id);
14159 -- Hook := Obj_Id'Unrestricted_Access;
14161 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
14162 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
14164 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
14166 -- Otherwise the hook seizes the related object immediately
14169 Hook_Insert
:= Obj_Decl
;
14172 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
14174 -- When the node is part of a return statement, there is no need to
14175 -- insert a finalization call, as the general finalization mechanism
14176 -- (see Build_Finalizer) would take care of the transient object on
14177 -- subprogram exit. Note that it would also be impossible to insert the
14178 -- finalization code after the return statement as this will render it
14181 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
14184 -- Finalize the hook after the context has been evaluated. Generate:
14186 -- if Hook /= null then
14187 -- [Deep_]Finalize (Hook.all);
14192 Insert_Action_After
(Fin_Context
,
14193 Make_Implicit_If_Statement
(Obj_Decl
,
14197 New_Occurrence_Of
(Defining_Entity
(Hook_Decl
), Loc
),
14198 Right_Opnd
=> Make_Null
(Loc
)),
14200 Then_Statements
=> New_List
(
14204 end Process_Transient_In_Expression
;
14206 ------------------------
14207 -- Rewrite_Comparison --
14208 ------------------------
14210 procedure Rewrite_Comparison
(N
: Node_Id
) is
14211 Typ
: constant Entity_Id
:= Etype
(N
);
14213 False_Result
: Boolean;
14214 True_Result
: Boolean;
14217 if Nkind
(N
) = N_Type_Conversion
then
14218 Rewrite_Comparison
(Expression
(N
));
14221 elsif Nkind
(N
) not in N_Op_Compare
then
14225 -- Determine the potential outcome of the comparison assuming that the
14226 -- operands are valid and emit a warning when the comparison evaluates
14227 -- to True or False only in the presence of invalid values.
14229 Warn_On_Constant_Valid_Condition
(N
);
14231 -- Determine the potential outcome of the comparison assuming that the
14232 -- operands are not valid.
14236 Assume_Valid
=> False,
14237 True_Result
=> True_Result
,
14238 False_Result
=> False_Result
);
14240 -- The outcome is a decisive False or True, rewrite the operator
14242 if False_Result
or True_Result
then
14245 New_Occurrence_Of
(Boolean_Literals
(True_Result
), Sloc
(N
))));
14247 Analyze_And_Resolve
(N
, Typ
);
14248 Warn_On_Known_Condition
(N
);
14250 end Rewrite_Comparison
;
14252 ----------------------------
14253 -- Safe_In_Place_Array_Op --
14254 ----------------------------
14256 function Safe_In_Place_Array_Op
14259 Op2
: Node_Id
) return Boolean
14261 Target
: Entity_Id
;
14263 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
14264 -- Operand is safe if it cannot overlap part of the target of the
14265 -- operation. If the operand and the target are identical, the operand
14266 -- is safe. The operand can be empty in the case of negation.
14268 function Is_Unaliased
(N
: Node_Id
) return Boolean;
14269 -- Check that N is a stand-alone entity
14275 function Is_Unaliased
(N
: Node_Id
) return Boolean is
14279 and then No
(Address_Clause
(Entity
(N
)))
14280 and then No
(Renamed_Object
(Entity
(N
)));
14283 ---------------------
14284 -- Is_Safe_Operand --
14285 ---------------------
14287 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
14292 elsif Is_Entity_Name
(Op
) then
14293 return Is_Unaliased
(Op
);
14295 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
14296 return Is_Unaliased
(Prefix
(Op
));
14298 elsif Nkind
(Op
) = N_Slice
then
14300 Is_Unaliased
(Prefix
(Op
))
14301 and then Entity
(Prefix
(Op
)) /= Target
;
14303 elsif Nkind
(Op
) = N_Op_Not
then
14304 return Is_Safe_Operand
(Right_Opnd
(Op
));
14309 end Is_Safe_Operand
;
14311 -- Start of processing for Safe_In_Place_Array_Op
14314 -- Skip this processing if the component size is different from system
14315 -- storage unit (since at least for NOT this would cause problems).
14317 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
14320 -- Cannot do in place stuff if non-standard Boolean representation
14322 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
14325 elsif not Is_Unaliased
(Lhs
) then
14329 Target
:= Entity
(Lhs
);
14330 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
14332 end Safe_In_Place_Array_Op
;
14334 -----------------------
14335 -- Tagged_Membership --
14336 -----------------------
14338 -- There are two different cases to consider depending on whether the right
14339 -- operand is a class-wide type or not. If not we just compare the actual
14340 -- tag of the left expr to the target type tag:
14342 -- Left_Expr.Tag = Right_Type'Tag;
14344 -- If it is a class-wide type we use the RT function CW_Membership which is
14345 -- usually implemented by looking in the ancestor tables contained in the
14346 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
14348 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
14349 -- function IW_Membership which is usually implemented by looking in the
14350 -- table of abstract interface types plus the ancestor table contained in
14351 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
14353 procedure Tagged_Membership
14355 SCIL_Node
: out Node_Id
;
14356 Result
: out Node_Id
)
14358 Left
: constant Node_Id
:= Left_Opnd
(N
);
14359 Right
: constant Node_Id
:= Right_Opnd
(N
);
14360 Loc
: constant Source_Ptr
:= Sloc
(N
);
14362 Full_R_Typ
: Entity_Id
;
14363 Left_Type
: Entity_Id
;
14364 New_Node
: Node_Id
;
14365 Right_Type
: Entity_Id
;
14369 SCIL_Node
:= Empty
;
14371 -- Handle entities from the limited view
14373 Left_Type
:= Available_View
(Etype
(Left
));
14374 Right_Type
:= Available_View
(Etype
(Right
));
14376 -- In the case where the type is an access type, the test is applied
14377 -- using the designated types (needed in Ada 2012 for implicit anonymous
14378 -- access conversions, for AI05-0149).
14380 if Is_Access_Type
(Right_Type
) then
14381 Left_Type
:= Designated_Type
(Left_Type
);
14382 Right_Type
:= Designated_Type
(Right_Type
);
14385 if Is_Class_Wide_Type
(Left_Type
) then
14386 Left_Type
:= Root_Type
(Left_Type
);
14389 if Is_Class_Wide_Type
(Right_Type
) then
14390 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
14392 Full_R_Typ
:= Underlying_Type
(Right_Type
);
14396 Make_Selected_Component
(Loc
,
14397 Prefix
=> Relocate_Node
(Left
),
14399 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
14401 if Is_Class_Wide_Type
(Right_Type
) or else Is_Interface
(Left_Type
) then
14403 -- No need to issue a run-time check if we statically know that the
14404 -- result of this membership test is always true. For example,
14405 -- considering the following declarations:
14407 -- type Iface is interface;
14408 -- type T is tagged null record;
14409 -- type DT is new T and Iface with null record;
14414 -- These membership tests are always true:
14417 -- Obj2 in T'Class;
14418 -- Obj2 in Iface'Class;
14420 -- We do not need to handle cases where the membership is illegal.
14423 -- Obj1 in DT'Class; -- Compile time error
14424 -- Obj1 in Iface'Class; -- Compile time error
14426 if not Is_Interface
(Left_Type
)
14427 and then not Is_Class_Wide_Type
(Left_Type
)
14428 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
14429 Use_Full_View
=> True)
14430 or else (Is_Interface
(Etype
(Right_Type
))
14431 and then Interface_Present_In_Ancestor
14433 Iface
=> Etype
(Right_Type
))))
14435 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
14439 -- Ada 2005 (AI-251): Class-wide applied to interfaces
14441 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
14443 -- Support to: "Iface_CW_Typ in Typ'Class"
14445 or else Is_Interface
(Left_Type
)
14447 -- Issue error if IW_Membership operation not available in a
14448 -- configurable run time setting.
14450 if not RTE_Available
(RE_IW_Membership
) then
14452 ("dynamic membership test on interface types", N
);
14458 Make_Function_Call
(Loc
,
14459 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
14460 Parameter_Associations
=> New_List
(
14461 Make_Attribute_Reference
(Loc
,
14463 Attribute_Name
=> Name_Address
),
14464 New_Occurrence_Of
(
14465 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
14468 -- Ada 95: Normal case
14471 Build_CW_Membership
(Loc
,
14472 Obj_Tag_Node
=> Obj_Tag
,
14474 New_Occurrence_Of
(
14475 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
14477 New_Node
=> New_Node
);
14479 -- Generate the SCIL node for this class-wide membership test.
14480 -- Done here because the previous call to Build_CW_Membership
14481 -- relocates Obj_Tag.
14483 if Generate_SCIL
then
14484 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
14485 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
14486 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
14489 Result
:= New_Node
;
14492 -- Right_Type is not a class-wide type
14495 -- No need to check the tag of the object if Right_Typ is abstract
14497 if Is_Abstract_Type
(Right_Type
) then
14498 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
14503 Left_Opnd
=> Obj_Tag
,
14506 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
14509 end Tagged_Membership
;
14511 ------------------------------
14512 -- Unary_Op_Validity_Checks --
14513 ------------------------------
14515 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
14517 if Validity_Checks_On
and Validity_Check_Operands
then
14518 Ensure_Valid
(Right_Opnd
(N
));
14520 end Unary_Op_Validity_Checks
;