1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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
;
48 with Namet
; use Namet
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
52 with Par_SCO
; use Par_SCO
;
53 with Restrict
; use Restrict
;
54 with Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
57 with Sem_Aux
; use Sem_Aux
;
58 with Sem_Cat
; use Sem_Cat
;
59 with Sem_Ch3
; use Sem_Ch3
;
60 with Sem_Ch8
; use Sem_Ch8
;
61 with Sem_Ch13
; use Sem_Ch13
;
62 with Sem_Eval
; use Sem_Eval
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Type
; use Sem_Type
;
65 with Sem_Util
; use Sem_Util
;
66 with Sem_Warn
; use Sem_Warn
;
67 with Sinfo
; use Sinfo
;
68 with Snames
; use Snames
;
69 with Stand
; use Stand
;
70 with SCIL_LL
; use SCIL_LL
;
71 with Targparm
; use Targparm
;
72 with Tbuild
; use Tbuild
;
73 with Ttypes
; use Ttypes
;
74 with Uintp
; use Uintp
;
75 with Urealp
; use Urealp
;
76 with Validsw
; use Validsw
;
78 package body Exp_Ch4
is
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
85 pragma Inline
(Binary_Op_Validity_Checks
);
86 -- Performs validity checks for a binary operator
88 procedure Build_Boolean_Array_Proc_Call
92 -- If a boolean array assignment can be done in place, build call to
93 -- corresponding library procedure.
95 function Current_Anonymous_Master
return Entity_Id
;
96 -- Return the entity of the heterogeneous finalization master belonging to
97 -- the current unit (either function, package or procedure). This master
98 -- services all anonymous access-to-controlled types. If the current unit
99 -- does not have such master, create one.
101 procedure Displace_Allocator_Pointer
(N
: Node_Id
);
102 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
103 -- Expand_Allocator_Expression. Allocating class-wide interface objects
104 -- this routine displaces the pointer to the allocated object to reference
105 -- the component referencing the corresponding secondary dispatch table.
107 procedure Expand_Allocator_Expression
(N
: Node_Id
);
108 -- Subsidiary to Expand_N_Allocator, for the case when the expression
109 -- is a qualified expression or an aggregate.
111 procedure Expand_Array_Comparison
(N
: Node_Id
);
112 -- This routine handles expansion of the comparison operators (N_Op_Lt,
113 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
114 -- code for these operators is similar, differing only in the details of
115 -- the actual comparison call that is made. Special processing (call a
118 function Expand_Array_Equality
123 Typ
: Entity_Id
) return Node_Id
;
124 -- Expand an array equality into a call to a function implementing this
125 -- equality, and a call to it. Loc is the location for the generated nodes.
126 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
127 -- on which to attach bodies of local functions that are created in the
128 -- process. It is the responsibility of the caller to insert those bodies
129 -- at the right place. Nod provides the Sloc value for the generated code.
130 -- Normally the types used for the generated equality routine are taken
131 -- from Lhs and Rhs. However, in some situations of generated code, the
132 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
133 -- the type to be used for the formal parameters.
135 procedure Expand_Boolean_Operator
(N
: Node_Id
);
136 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
137 -- case of array type arguments.
139 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
);
140 -- Common expansion processing for short-circuit boolean operators
142 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
);
143 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
144 -- where we allow comparison of "out of range" values.
146 function Expand_Composite_Equality
151 Bodies
: List_Id
) return Node_Id
;
152 -- Local recursive function used to expand equality for nested composite
153 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
154 -- to attach bodies of local functions that are created in the process. It
155 -- is the responsibility of the caller to insert those bodies at the right
156 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
157 -- the left and right sides for the comparison, and Typ is the type of the
158 -- objects to compare.
160 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
161 -- Routine to expand concatenation of a sequence of two or more operands
162 -- (in the list Operands) and replace node Cnode with the result of the
163 -- concatenation. The operands can be of any appropriate type, and can
164 -- include both arrays and singleton elements.
166 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
);
167 -- N is an N_In membership test mode, with the overflow check mode set to
168 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
169 -- integer type. This is a case where top level processing is required to
170 -- handle overflow checks in subtrees.
172 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
173 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
174 -- fixed. We do not have such a type at runtime, so the purpose of this
175 -- routine is to find the real type by looking up the tree. We also
176 -- determine if the operation must be rounded.
178 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
179 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
180 -- discriminants if it has a constrained nominal type, unless the object
181 -- is a component of an enclosing Unchecked_Union object that is subject
182 -- to a per-object constraint and the enclosing object lacks inferable
185 -- An expression of an Unchecked_Union type has inferable discriminants
186 -- if it is either a name of an object with inferable discriminants or a
187 -- qualified expression whose subtype mark denotes a constrained subtype.
189 procedure Insert_Dereference_Action
(N
: Node_Id
);
190 -- N is an expression whose type is an access. When the type of the
191 -- associated storage pool is derived from Checked_Pool, generate a
192 -- call to the 'Dereference' primitive operation.
194 function Make_Array_Comparison_Op
196 Nod
: Node_Id
) return Node_Id
;
197 -- Comparisons between arrays are expanded in line. This function produces
198 -- the body of the implementation of (a > b), where a and b are one-
199 -- dimensional arrays of some discrete type. The original node is then
200 -- expanded into the appropriate call to this function. Nod provides the
201 -- Sloc value for the generated code.
203 function Make_Boolean_Array_Op
205 N
: Node_Id
) return Node_Id
;
206 -- Boolean operations on boolean arrays are expanded in line. This function
207 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
208 -- b). It is used only the normal case and not the packed case. The type
209 -- involved, Typ, is the Boolean array type, and the logical operations in
210 -- the body are simple boolean operations. Note that Typ is always a
211 -- constrained type (the caller has ensured this by using
212 -- Convert_To_Actual_Subtype if necessary).
214 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean;
215 -- For signed arithmetic operations when the current overflow mode is
216 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
217 -- as the first thing we do. We then return. We count on the recursive
218 -- apparatus for overflow checks to call us back with an equivalent
219 -- operation that is in CHECKED mode, avoiding a recursive entry into this
220 -- routine, and that is when we will proceed with the expansion of the
221 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
222 -- these optimizations without first making this check, since there may be
223 -- operands further down the tree that are relying on the recursive calls
224 -- triggered by the top level nodes to properly process overflow checking
225 -- and remaining expansion on these nodes. Note that this call back may be
226 -- skipped if the operation is done in Bignum mode but that's fine, since
227 -- the Bignum call takes care of everything.
229 procedure Optimize_Length_Comparison
(N
: Node_Id
);
230 -- Given an expression, if it is of the form X'Length op N (or the other
231 -- way round), where N is known at compile time to be 0 or 1, and X is a
232 -- simple entity, and op is a comparison operator, optimizes it into a
233 -- comparison of First and Last.
235 procedure Process_Transient_Object
238 -- Subsidiary routine to the expansion of expression_with_actions and if
239 -- expressions. Generate all the necessary code to finalize a transient
240 -- controlled object when the enclosing context is elaborated or evaluated.
241 -- Decl denotes the declaration of the transient controlled object which is
242 -- usually the result of a controlled function call. Rel_Node denotes the
243 -- context, either an expression_with_actions or an if expression.
245 procedure Rewrite_Comparison
(N
: Node_Id
);
246 -- If N is the node for a comparison whose outcome can be determined at
247 -- compile time, then the node N can be rewritten with True or False. If
248 -- the outcome cannot be determined at compile time, the call has no
249 -- effect. If N is a type conversion, then this processing is applied to
250 -- its expression. If N is neither comparison nor a type conversion, the
251 -- call has no effect.
253 procedure Tagged_Membership
255 SCIL_Node
: out Node_Id
;
256 Result
: out Node_Id
);
257 -- Construct the expression corresponding to the tagged membership test.
258 -- Deals with a second operand being (or not) a class-wide type.
260 function Safe_In_Place_Array_Op
263 Op2
: Node_Id
) return Boolean;
264 -- In the context of an assignment, where the right-hand side is a boolean
265 -- operation on arrays, check whether operation can be performed in place.
267 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
268 pragma Inline
(Unary_Op_Validity_Checks
);
269 -- Performs validity checks for a unary operator
271 -------------------------------
272 -- Binary_Op_Validity_Checks --
273 -------------------------------
275 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
277 if Validity_Checks_On
and Validity_Check_Operands
then
278 Ensure_Valid
(Left_Opnd
(N
));
279 Ensure_Valid
(Right_Opnd
(N
));
281 end Binary_Op_Validity_Checks
;
283 ------------------------------------
284 -- Build_Boolean_Array_Proc_Call --
285 ------------------------------------
287 procedure Build_Boolean_Array_Proc_Call
292 Loc
: constant Source_Ptr
:= Sloc
(N
);
293 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
294 Target
: constant Node_Id
:=
295 Make_Attribute_Reference
(Loc
,
297 Attribute_Name
=> Name_Address
);
299 Arg1
: Node_Id
:= Op1
;
300 Arg2
: Node_Id
:= Op2
;
302 Proc_Name
: Entity_Id
;
305 if Kind
= N_Op_Not
then
306 if Nkind
(Op1
) in N_Binary_Op
then
308 -- Use negated version of the binary operators
310 if Nkind
(Op1
) = N_Op_And
then
311 Proc_Name
:= RTE
(RE_Vector_Nand
);
313 elsif Nkind
(Op1
) = N_Op_Or
then
314 Proc_Name
:= RTE
(RE_Vector_Nor
);
316 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
317 Proc_Name
:= RTE
(RE_Vector_Xor
);
321 Make_Procedure_Call_Statement
(Loc
,
322 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
324 Parameter_Associations
=> New_List
(
326 Make_Attribute_Reference
(Loc
,
327 Prefix
=> Left_Opnd
(Op1
),
328 Attribute_Name
=> Name_Address
),
330 Make_Attribute_Reference
(Loc
,
331 Prefix
=> Right_Opnd
(Op1
),
332 Attribute_Name
=> Name_Address
),
334 Make_Attribute_Reference
(Loc
,
335 Prefix
=> Left_Opnd
(Op1
),
336 Attribute_Name
=> Name_Length
)));
339 Proc_Name
:= RTE
(RE_Vector_Not
);
342 Make_Procedure_Call_Statement
(Loc
,
343 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
344 Parameter_Associations
=> New_List
(
347 Make_Attribute_Reference
(Loc
,
349 Attribute_Name
=> Name_Address
),
351 Make_Attribute_Reference
(Loc
,
353 Attribute_Name
=> Name_Length
)));
357 -- We use the following equivalences:
359 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
360 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
361 -- (not X) xor (not Y) = X xor Y
362 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
364 if Nkind
(Op1
) = N_Op_Not
then
365 Arg1
:= Right_Opnd
(Op1
);
366 Arg2
:= Right_Opnd
(Op2
);
368 if Kind
= N_Op_And
then
369 Proc_Name
:= RTE
(RE_Vector_Nor
);
370 elsif Kind
= N_Op_Or
then
371 Proc_Name
:= RTE
(RE_Vector_Nand
);
373 Proc_Name
:= RTE
(RE_Vector_Xor
);
377 if Kind
= N_Op_And
then
378 Proc_Name
:= RTE
(RE_Vector_And
);
379 elsif Kind
= N_Op_Or
then
380 Proc_Name
:= RTE
(RE_Vector_Or
);
381 elsif Nkind
(Op2
) = N_Op_Not
then
382 Proc_Name
:= RTE
(RE_Vector_Nxor
);
383 Arg2
:= Right_Opnd
(Op2
);
385 Proc_Name
:= RTE
(RE_Vector_Xor
);
390 Make_Procedure_Call_Statement
(Loc
,
391 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
392 Parameter_Associations
=> New_List
(
394 Make_Attribute_Reference
(Loc
,
396 Attribute_Name
=> Name_Address
),
397 Make_Attribute_Reference
(Loc
,
399 Attribute_Name
=> Name_Address
),
400 Make_Attribute_Reference
(Loc
,
402 Attribute_Name
=> Name_Length
)));
405 Rewrite
(N
, Call_Node
);
409 when RE_Not_Available
=>
411 end Build_Boolean_Array_Proc_Call
;
413 ------------------------------
414 -- Current_Anonymous_Master --
415 ------------------------------
417 function Current_Anonymous_Master
return Entity_Id
is
418 function Create_Anonymous_Master
419 (Unit_Id
: Entity_Id
;
420 Unit_Decl
: Node_Id
) return Entity_Id
;
421 -- Create a new anonymous master for a compilation unit denoted by its
422 -- entity Unit_Id and declaration Unit_Decl. The declaration of the new
423 -- master along with any specialized initialization is inserted at the
424 -- top of the unit's declarations (see body for special cases). Return
425 -- the entity of the anonymous master.
427 -----------------------------
428 -- Create_Anonymous_Master --
429 -----------------------------
431 function Create_Anonymous_Master
432 (Unit_Id
: Entity_Id
;
433 Unit_Decl
: Node_Id
) return Entity_Id
435 Insert_Nod
: Node_Id
:= Empty
;
436 -- The point of insertion into the declarative list of the unit. All
437 -- nodes are inserted before Insert_Nod.
439 procedure Insert_And_Analyze
(Decls
: List_Id
; N
: Node_Id
);
440 -- Insert arbitrary node N in declarative list Decls and analyze it
442 ------------------------
443 -- Insert_And_Analyze --
444 ------------------------
446 procedure Insert_And_Analyze
(Decls
: List_Id
; N
: Node_Id
) is
448 -- The declarative list is already populated, the nodes are
449 -- inserted at the top of the list, preserving their order.
451 if Present
(Insert_Nod
) then
452 Insert_Before
(Insert_Nod
, N
);
454 -- Otherwise append to the declarations to preserve order
457 Append_To
(Decls
, N
);
461 end Insert_And_Analyze
;
465 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
466 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Unit_Decl
);
472 -- Start of processing for Create_Anonymous_Master
475 -- Find the declarative list of the unit
477 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
478 Unit_Spec
:= Specification
(Unit_Decl
);
479 Decls
:= Visible_Declarations
(Unit_Spec
);
482 Decls
:= New_List
(Make_Null_Statement
(Loc
));
483 Set_Visible_Declarations
(Unit_Spec
, Decls
);
486 -- Package or subprogram body
488 -- ??? A subprogram declaration that acts as a compilation unit may
489 -- contain a formal parameter of an anonymous access-to-controlled
490 -- type initialized by an allocator.
492 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
494 -- There is no suitable place to create the anonymous master as the
495 -- subprogram is not in a declarative list.
498 Decls
:= Declarations
(Unit_Decl
);
501 Decls
:= New_List
(Make_Null_Statement
(Loc
));
502 Set_Declarations
(Unit_Decl
, Decls
);
506 -- The anonymous master and all initialization actions are inserted
507 -- before the first declaration (if any).
509 Insert_Nod
:= First
(Decls
);
511 -- Since the anonymous master and all its initialization actions are
512 -- inserted at top level, use the scope of the unit when analyzing.
514 Push_Scope
(Spec_Id
);
516 -- Step 1: Anonymous master creation
518 -- Use a unique prefix in case the same unit requires two anonymous
519 -- masters, one for the spec (S) and one for the body (B).
521 if Ekind_In
(Unit_Id
, E_Function
, E_Package
, E_Procedure
) then
528 Make_Defining_Identifier
(Loc
,
530 (Related_Id
=> Chars
(Unit_Id
),
534 Set_Anonymous_Master
(Unit_Id
, FM_Id
);
537 -- <FM_Id> : Finalization_Master;
539 Insert_And_Analyze
(Decls
,
540 Make_Object_Declaration
(Loc
,
541 Defining_Identifier
=> FM_Id
,
543 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
545 -- Step 2: Initialization actions
547 -- Do not set the base pool and mode of operation on .NET/JVM since
548 -- those targets do not support pools and all VM masters defaulted to
551 if VM_Target
= No_VM
then
555 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
557 Insert_And_Analyze
(Decls
,
558 Make_Procedure_Call_Statement
(Loc
,
560 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
561 Parameter_Associations
=> New_List
(
562 New_Occurrence_Of
(FM_Id
, Loc
),
563 Make_Attribute_Reference
(Loc
,
565 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
566 Attribute_Name
=> Name_Unrestricted_Access
))));
569 -- Set_Is_Heterogeneous (<FM_Id>);
571 Insert_And_Analyze
(Decls
,
572 Make_Procedure_Call_Statement
(Loc
,
574 New_Occurrence_Of
(RTE
(RE_Set_Is_Heterogeneous
), Loc
),
575 Parameter_Associations
=> New_List
(
576 New_Occurrence_Of
(FM_Id
, Loc
))));
581 end Create_Anonymous_Master
;
583 -- Local declarations
588 -- Start of processing for Current_Anonymous_Master
591 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
592 Unit_Id
:= Defining_Entity
(Unit_Decl
);
594 -- The compilation unit is a package instantiation. In this case the
595 -- anonymous master is associated with the package spec as both the
596 -- spec and body appear at the same level.
598 if Nkind
(Unit_Decl
) = N_Package_Body
599 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
601 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
602 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
605 if Present
(Anonymous_Master
(Unit_Id
)) then
606 return Anonymous_Master
(Unit_Id
);
608 -- Create a new anonymous master when allocating an object of anonymous
609 -- access-to-controlled type for the first time.
612 return Create_Anonymous_Master
(Unit_Id
, Unit_Decl
);
614 end Current_Anonymous_Master
;
616 --------------------------------
617 -- Displace_Allocator_Pointer --
618 --------------------------------
620 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
621 Loc
: constant Source_Ptr
:= Sloc
(N
);
622 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
628 -- Do nothing in case of VM targets: the virtual machine will handle
629 -- interfaces directly.
631 if not Tagged_Type_Expansion
then
635 pragma Assert
(Nkind
(N
) = N_Identifier
636 and then Nkind
(Orig_Node
) = N_Allocator
);
638 PtrT
:= Etype
(Orig_Node
);
639 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
640 Etyp
:= Etype
(Expression
(Orig_Node
));
642 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
644 -- If the type of the allocator expression is not an interface type
645 -- we can generate code to reference the record component containing
646 -- the pointer to the secondary dispatch table.
648 if not Is_Interface
(Etyp
) then
650 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
653 -- 1) Get access to the allocated object
656 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
660 -- 2) Add the conversion to displace the pointer to reference
661 -- the secondary dispatch table.
663 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
664 Analyze_And_Resolve
(N
, Dtyp
);
666 -- 3) The 'access to the secondary dispatch table will be used
667 -- as the value returned by the allocator.
670 Make_Attribute_Reference
(Loc
,
671 Prefix
=> Relocate_Node
(N
),
672 Attribute_Name
=> Name_Access
));
673 Set_Etype
(N
, Saved_Typ
);
677 -- If the type of the allocator expression is an interface type we
678 -- generate a run-time call to displace "this" to reference the
679 -- component containing the pointer to the secondary dispatch table
680 -- or else raise Constraint_Error if the actual object does not
681 -- implement the target interface. This case corresponds to the
682 -- following example:
684 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
686 -- return new Iface_2'Class'(Obj);
691 Unchecked_Convert_To
(PtrT
,
692 Make_Function_Call
(Loc
,
693 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
694 Parameter_Associations
=> New_List
(
695 Unchecked_Convert_To
(RTE
(RE_Address
),
701 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
703 Analyze_And_Resolve
(N
, PtrT
);
706 end Displace_Allocator_Pointer
;
708 ---------------------------------
709 -- Expand_Allocator_Expression --
710 ---------------------------------
712 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
713 Loc
: constant Source_Ptr
:= Sloc
(N
);
714 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
715 PtrT
: constant Entity_Id
:= Etype
(N
);
716 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
718 procedure Apply_Accessibility_Check
720 Built_In_Place
: Boolean := False);
721 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
722 -- type, generate an accessibility check to verify that the level of the
723 -- type of the created object is not deeper than the level of the access
724 -- type. If the type of the qualified expression is class-wide, then
725 -- always generate the check (except in the case where it is known to be
726 -- unnecessary, see comment below). Otherwise, only generate the check
727 -- if the level of the qualified expression type is statically deeper
728 -- than the access type.
730 -- Although the static accessibility will generally have been performed
731 -- as a legality check, it won't have been done in cases where the
732 -- allocator appears in generic body, so a run-time check is needed in
733 -- general. One special case is when the access type is declared in the
734 -- same scope as the class-wide allocator, in which case the check can
735 -- never fail, so it need not be generated.
737 -- As an open issue, there seem to be cases where the static level
738 -- associated with the class-wide object's underlying type is not
739 -- sufficient to perform the proper accessibility check, such as for
740 -- allocators in nested subprograms or accept statements initialized by
741 -- class-wide formals when the actual originates outside at a deeper
742 -- static level. The nested subprogram case might require passing
743 -- accessibility levels along with class-wide parameters, and the task
744 -- case seems to be an actual gap in the language rules that needs to
745 -- be fixed by the ARG. ???
747 -------------------------------
748 -- Apply_Accessibility_Check --
749 -------------------------------
751 procedure Apply_Accessibility_Check
753 Built_In_Place
: Boolean := False)
755 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
763 if Ada_Version
>= Ada_2005
764 and then Is_Class_Wide_Type
(DesigT
)
765 and then (Tagged_Type_Expansion
or else VM_Target
/= No_VM
)
766 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
768 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
770 (Is_Class_Wide_Type
(Etype
(Exp
))
771 and then Scope
(PtrT
) /= Current_Scope
))
773 -- If the allocator was built in place, Ref is already a reference
774 -- to the access object initialized to the result of the allocator
775 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
776 -- Remove_Side_Effects for cases where the build-in-place call may
777 -- still be the prefix of the reference (to avoid generating
778 -- duplicate calls). Otherwise, it is the entity associated with
779 -- the object containing the address of the allocated object.
781 if Built_In_Place
then
782 Remove_Side_Effects
(Ref
);
783 Obj_Ref
:= New_Copy_Tree
(Ref
);
785 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
788 -- For access to interface types we must generate code to displace
789 -- the pointer to the base of the object since the subsequent code
790 -- references components located in the TSD of the object (which
791 -- is associated with the primary dispatch table --see a-tags.ads)
792 -- and also generates code invoking Free, which requires also a
793 -- reference to the base of the unallocated object.
795 if Is_Interface
(DesigT
) and then Tagged_Type_Expansion
then
797 Unchecked_Convert_To
(Etype
(Obj_Ref
),
798 Make_Function_Call
(Loc
,
800 New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
801 Parameter_Associations
=> New_List
(
802 Unchecked_Convert_To
(RTE
(RE_Address
),
803 New_Copy_Tree
(Obj_Ref
)))));
806 -- Step 1: Create the object clean up code
810 -- Deallocate the object if the accessibility check fails. This
811 -- is done only on targets or profiles that support deallocation.
815 if RTE_Available
(RE_Free
) then
816 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
817 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
819 Append_To
(Stmts
, Free_Stmt
);
821 -- The target or profile cannot deallocate objects
827 -- Finalize the object if applicable. Generate:
829 -- [Deep_]Finalize (Obj_Ref.all);
831 if Needs_Finalization
(DesigT
) then
835 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
838 -- When the target or profile supports deallocation, wrap the
839 -- finalization call in a block to ensure proper deallocation
840 -- even if finalization fails. Generate:
850 if Present
(Free_Stmt
) then
852 Make_Block_Statement
(Loc
,
853 Handled_Statement_Sequence
=>
854 Make_Handled_Sequence_Of_Statements
(Loc
,
855 Statements
=> New_List
(Fin_Call
),
857 Exception_Handlers
=> New_List
(
858 Make_Exception_Handler
(Loc
,
859 Exception_Choices
=> New_List
(
860 Make_Others_Choice
(Loc
)),
861 Statements
=> New_List
(
862 New_Copy_Tree
(Free_Stmt
),
863 Make_Raise_Statement
(Loc
))))));
866 Prepend_To
(Stmts
, Fin_Call
);
869 -- Signal the accessibility failure through a Program_Error
872 Make_Raise_Program_Error
(Loc
,
873 Condition
=> New_Occurrence_Of
(Standard_True
, Loc
),
874 Reason
=> PE_Accessibility_Check_Failed
));
876 -- Step 2: Create the accessibility comparison
882 Make_Attribute_Reference
(Loc
,
884 Attribute_Name
=> Name_Tag
);
886 -- For tagged types, determine the accessibility level by looking
887 -- at the type specific data of the dispatch table. Generate:
889 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
891 if Tagged_Type_Expansion
then
892 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
894 -- Use a runtime call to determine the accessibility level when
895 -- compiling on virtual machine targets. Generate:
897 -- Get_Access_Level (Ref'Tag)
901 Make_Function_Call
(Loc
,
903 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
904 Parameter_Associations
=> New_List
(Obj_Ref
));
911 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
913 -- Due to the complexity and side effects of the check, utilize an
914 -- if statement instead of the regular Program_Error circuitry.
917 Make_Implicit_If_Statement
(N
,
919 Then_Statements
=> Stmts
));
921 end Apply_Accessibility_Check
;
925 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
926 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
927 T
: constant Entity_Id
:= Entity
(Indic
);
929 Tag_Assign
: Node_Id
;
933 TagT
: Entity_Id
:= Empty
;
934 -- Type used as source for tag assignment
936 TagR
: Node_Id
:= Empty
;
937 -- Target reference for tag assignment
939 -- Start of processing for Expand_Allocator_Expression
942 -- Handle call to C++ constructor
944 if Is_CPP_Constructor_Call
(Exp
) then
945 Make_CPP_Constructor_Call_In_Allocator
947 Function_Call
=> Exp
);
951 -- In the case of an Ada 2012 allocator whose initial value comes from a
952 -- function call, pass "the accessibility level determined by the point
953 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
954 -- Expand_Call but it couldn't be done there (because the Etype of the
955 -- allocator wasn't set then) so we generate the parameter here. See
956 -- the Boolean variable Defer in (a block within) Expand_Call.
958 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
963 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
964 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
966 Subp
:= Entity
(Name
(Exp
));
969 Subp
:= Ultimate_Alias
(Subp
);
971 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
972 Add_Extra_Actual_To_Call
973 (Subprogram_Call
=> Exp
,
974 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
975 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
980 -- Case of tagged type or type requiring finalization
982 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
984 -- Ada 2005 (AI-318-02): If the initialization expression is a call
985 -- to a build-in-place function, then access to the allocated object
986 -- must be passed to the function. Currently we limit such functions
987 -- to those with constrained limited result subtypes, but eventually
988 -- we plan to expand the allowed forms of functions that are treated
989 -- as build-in-place.
991 if Ada_Version
>= Ada_2005
992 and then Is_Build_In_Place_Function_Call
(Exp
)
994 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
995 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
999 -- Actions inserted before:
1000 -- Temp : constant ptr_T := new T'(Expression);
1001 -- Temp._tag = T'tag; -- when not class-wide
1002 -- [Deep_]Adjust (Temp.all);
1004 -- We analyze by hand the new internal allocator to avoid any
1005 -- recursion and inappropriate call to Initialize.
1007 -- We don't want to remove side effects when the expression must be
1008 -- built in place. In the case of a build-in-place function call,
1009 -- that could lead to a duplication of the call, which was already
1010 -- substituted for the allocator.
1012 if not Aggr_In_Place
then
1013 Remove_Side_Effects
(Exp
);
1016 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1018 -- For a class wide allocation generate the following code:
1020 -- type Equiv_Record is record ... end record;
1021 -- implicit subtype CW is <Class_Wide_Subytpe>;
1022 -- temp : PtrT := new CW'(CW!(expr));
1024 if Is_Class_Wide_Type
(T
) then
1025 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
1027 -- Ada 2005 (AI-251): If the expression is a class-wide interface
1028 -- object we generate code to move up "this" to reference the
1029 -- base of the object before allocating the new object.
1031 -- Note that Exp'Address is recursively expanded into a call
1032 -- to Base_Address (Exp.Tag)
1034 if Is_Class_Wide_Type
(Etype
(Exp
))
1035 and then Is_Interface
(Etype
(Exp
))
1036 and then Tagged_Type_Expansion
1040 Unchecked_Convert_To
(Entity
(Indic
),
1041 Make_Explicit_Dereference
(Loc
,
1042 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
1043 Make_Attribute_Reference
(Loc
,
1045 Attribute_Name
=> Name_Address
)))));
1049 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
1052 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
1055 -- Processing for allocators returning non-interface types
1057 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1058 if Aggr_In_Place
then
1060 Make_Object_Declaration
(Loc
,
1061 Defining_Identifier
=> Temp
,
1062 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1064 Make_Allocator
(Loc
,
1066 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1068 -- Copy the Comes_From_Source flag for the allocator we just
1069 -- built, since logically this allocator is a replacement of
1070 -- the original allocator node. This is for proper handling of
1071 -- restriction No_Implicit_Heap_Allocations.
1073 Set_Comes_From_Source
1074 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1076 Set_No_Initialization
(Expression
(Temp_Decl
));
1077 Insert_Action
(N
, Temp_Decl
);
1079 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1080 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1082 -- Attach the object to the associated finalization master.
1083 -- This is done manually on .NET/JVM since those compilers do
1084 -- no support pools and can't benefit from internally generated
1085 -- Allocate / Deallocate procedures.
1087 if VM_Target
/= No_VM
1088 and then Is_Controlled
(DesigT
)
1089 and then Present
(Finalization_Master
(PtrT
))
1093 (Obj_Ref
=> New_Occurrence_Of
(Temp
, Loc
),
1098 Node
:= Relocate_Node
(N
);
1099 Set_Analyzed
(Node
);
1102 Make_Object_Declaration
(Loc
,
1103 Defining_Identifier
=> Temp
,
1104 Constant_Present
=> True,
1105 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1106 Expression
=> Node
);
1108 Insert_Action
(N
, Temp_Decl
);
1109 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1111 -- Attach the object to the associated finalization master.
1112 -- This is done manually on .NET/JVM since those compilers do
1113 -- no support pools and can't benefit from internally generated
1114 -- Allocate / Deallocate procedures.
1116 if VM_Target
/= No_VM
1117 and then Is_Controlled
(DesigT
)
1118 and then Present
(Finalization_Master
(PtrT
))
1122 (Obj_Ref
=> New_Occurrence_Of
(Temp
, Loc
),
1127 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1128 -- interface type. In this case we use the type of the qualified
1129 -- expression to allocate the object.
1133 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1138 Make_Full_Type_Declaration
(Loc
,
1139 Defining_Identifier
=> Def_Id
,
1141 Make_Access_To_Object_Definition
(Loc
,
1142 All_Present
=> True,
1143 Null_Exclusion_Present
=> False,
1145 Is_Access_Constant
(Etype
(N
)),
1146 Subtype_Indication
=>
1147 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1149 Insert_Action
(N
, New_Decl
);
1151 -- Inherit the allocation-related attributes from the original
1154 Set_Finalization_Master
1155 (Def_Id
, Finalization_Master
(PtrT
));
1157 Set_Associated_Storage_Pool
1158 (Def_Id
, Associated_Storage_Pool
(PtrT
));
1160 -- Declare the object using the previous type declaration
1162 if Aggr_In_Place
then
1164 Make_Object_Declaration
(Loc
,
1165 Defining_Identifier
=> Temp
,
1166 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1168 Make_Allocator
(Loc
,
1169 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1171 -- Copy the Comes_From_Source flag for the allocator we just
1172 -- built, since logically this allocator is a replacement of
1173 -- the original allocator node. This is for proper handling
1174 -- of restriction No_Implicit_Heap_Allocations.
1176 Set_Comes_From_Source
1177 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1179 Set_No_Initialization
(Expression
(Temp_Decl
));
1180 Insert_Action
(N
, Temp_Decl
);
1182 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1183 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1186 Node
:= Relocate_Node
(N
);
1187 Set_Analyzed
(Node
);
1190 Make_Object_Declaration
(Loc
,
1191 Defining_Identifier
=> Temp
,
1192 Constant_Present
=> True,
1193 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1194 Expression
=> Node
);
1196 Insert_Action
(N
, Temp_Decl
);
1197 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1200 -- Generate an additional object containing the address of the
1201 -- returned object. The type of this second object declaration
1202 -- is the correct type required for the common processing that
1203 -- is still performed by this subprogram. The displacement of
1204 -- this pointer to reference the component associated with the
1205 -- interface type will be done at the end of common processing.
1208 Make_Object_Declaration
(Loc
,
1209 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
1210 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1212 Unchecked_Convert_To
(PtrT
,
1213 New_Occurrence_Of
(Temp
, Loc
)));
1215 Insert_Action
(N
, New_Decl
);
1217 Temp_Decl
:= New_Decl
;
1218 Temp
:= Defining_Identifier
(New_Decl
);
1222 Apply_Accessibility_Check
(Temp
);
1224 -- Generate the tag assignment
1226 -- Suppress the tag assignment when VM_Target because VM tags are
1227 -- represented implicitly in objects.
1229 if not Tagged_Type_Expansion
then
1232 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1233 -- interface objects because in this case the tag does not change.
1235 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1236 pragma Assert
(Is_Class_Wide_Type
1237 (Directly_Designated_Type
(Etype
(N
))));
1240 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1242 TagR
:= New_Occurrence_Of
(Temp
, Loc
);
1244 elsif Is_Private_Type
(T
)
1245 and then Is_Tagged_Type
(Underlying_Type
(T
))
1247 TagT
:= Underlying_Type
(T
);
1249 Unchecked_Convert_To
(Underlying_Type
(T
),
1250 Make_Explicit_Dereference
(Loc
,
1251 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
1254 if Present
(TagT
) then
1256 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1260 Make_Assignment_Statement
(Loc
,
1262 Make_Selected_Component
(Loc
,
1266 (First_Tag_Component
(Full_T
), Loc
)),
1269 Unchecked_Convert_To
(RTE
(RE_Tag
),
1272 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1275 -- The previous assignment has to be done in any case
1277 Set_Assignment_OK
(Name
(Tag_Assign
));
1278 Insert_Action
(N
, Tag_Assign
);
1281 if Needs_Finalization
(DesigT
) and then Needs_Finalization
(T
) then
1283 -- Generate an Adjust call if the object will be moved. In Ada
1284 -- 2005, the object may be inherently limited, in which case
1285 -- there is no Adjust procedure, and the object is built in
1286 -- place. In Ada 95, the object can be limited but not
1287 -- inherently limited if this allocator came from a return
1288 -- statement (we're allocating the result on the secondary
1289 -- stack). In that case, the object will be moved, so we _do_
1292 if not Aggr_In_Place
1293 and then not Is_Limited_View
(T
)
1297 -- An unchecked conversion is needed in the classwide case
1298 -- because the designated type can be an ancestor of the
1299 -- subtype mark of the allocator.
1303 Unchecked_Convert_To
(T
,
1304 Make_Explicit_Dereference
(Loc
,
1305 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
1310 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1311 Analyze_And_Resolve
(N
, PtrT
);
1313 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1314 -- component containing the secondary dispatch table of the interface
1317 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1318 Displace_Allocator_Pointer
(N
);
1321 elsif Aggr_In_Place
then
1322 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1324 Make_Object_Declaration
(Loc
,
1325 Defining_Identifier
=> Temp
,
1326 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1328 Make_Allocator
(Loc
,
1329 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1331 -- Copy the Comes_From_Source flag for the allocator we just built,
1332 -- since logically this allocator is a replacement of the original
1333 -- allocator node. This is for proper handling of restriction
1334 -- No_Implicit_Heap_Allocations.
1336 Set_Comes_From_Source
1337 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1339 Set_No_Initialization
(Expression
(Temp_Decl
));
1340 Insert_Action
(N
, Temp_Decl
);
1342 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1343 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1345 -- Attach the object to the associated finalization master. Thisis
1346 -- done manually on .NET/JVM since those compilers do no support
1347 -- pools and cannot benefit from internally generated Allocate and
1348 -- Deallocate procedures.
1350 if VM_Target
/= No_VM
1351 and then Is_Controlled
(DesigT
)
1352 and then Present
(Finalization_Master
(PtrT
))
1356 (Obj_Ref
=> New_Occurrence_Of
(Temp
, Loc
),
1360 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1361 Analyze_And_Resolve
(N
, PtrT
);
1363 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1364 Install_Null_Excluding_Check
(Exp
);
1366 elsif Is_Access_Type
(DesigT
)
1367 and then Nkind
(Exp
) = N_Allocator
1368 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1370 -- Apply constraint to designated subtype indication
1372 Apply_Constraint_Check
1373 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1375 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1377 -- Propagate constraint_error to enclosing allocator
1379 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1383 Build_Allocate_Deallocate_Proc
(N
, True);
1386 -- type A is access T1;
1387 -- X : A := new T2'(...);
1388 -- T1 and T2 can be different subtypes, and we might need to check
1389 -- both constraints. First check against the type of the qualified
1392 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1394 if Do_Range_Check
(Exp
) then
1395 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1398 -- A check is also needed in cases where the designated subtype is
1399 -- constrained and differs from the subtype given in the qualified
1400 -- expression. Note that the check on the qualified expression does
1401 -- not allow sliding, but this check does (a relaxation from Ada 83).
1403 if Is_Constrained
(DesigT
)
1404 and then not Subtypes_Statically_Match
(T
, DesigT
)
1406 Apply_Constraint_Check
1407 (Exp
, DesigT
, No_Sliding
=> False);
1409 if Do_Range_Check
(Exp
) then
1410 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1414 -- For an access to unconstrained packed array, GIGI needs to see an
1415 -- expression with a constrained subtype in order to compute the
1416 -- proper size for the allocator.
1418 if Is_Array_Type
(T
)
1419 and then not Is_Constrained
(T
)
1420 and then Is_Packed
(T
)
1423 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1424 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1427 Make_Subtype_Declaration
(Loc
,
1428 Defining_Identifier
=> ConstrT
,
1429 Subtype_Indication
=>
1430 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1431 Freeze_Itype
(ConstrT
, Exp
);
1432 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1436 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1437 -- to a build-in-place function, then access to the allocated object
1438 -- must be passed to the function. Currently we limit such functions
1439 -- to those with constrained limited result subtypes, but eventually
1440 -- we plan to expand the allowed forms of functions that are treated
1441 -- as build-in-place.
1443 if Ada_Version
>= Ada_2005
1444 and then Is_Build_In_Place_Function_Call
(Exp
)
1446 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1451 when RE_Not_Available
=>
1453 end Expand_Allocator_Expression
;
1455 -----------------------------
1456 -- Expand_Array_Comparison --
1457 -----------------------------
1459 -- Expansion is only required in the case of array types. For the unpacked
1460 -- case, an appropriate runtime routine is called. For packed cases, and
1461 -- also in some other cases where a runtime routine cannot be called, the
1462 -- form of the expansion is:
1464 -- [body for greater_nn; boolean_expression]
1466 -- The body is built by Make_Array_Comparison_Op, and the form of the
1467 -- Boolean expression depends on the operator involved.
1469 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1470 Loc
: constant Source_Ptr
:= Sloc
(N
);
1471 Op1
: Node_Id
:= Left_Opnd
(N
);
1472 Op2
: Node_Id
:= Right_Opnd
(N
);
1473 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1474 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1477 Func_Body
: Node_Id
;
1478 Func_Name
: Entity_Id
;
1482 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1483 -- True for byte addressable target
1485 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1486 -- Returns True if the length of the given operand is known to be less
1487 -- than 4. Returns False if this length is known to be four or greater
1488 -- or is not known at compile time.
1490 ------------------------
1491 -- Length_Less_Than_4 --
1492 ------------------------
1494 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1495 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1498 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1499 return String_Literal_Length
(Otyp
) < 4;
1503 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1504 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1505 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1510 if Compile_Time_Known_Value
(Lo
) then
1511 Lov
:= Expr_Value
(Lo
);
1516 if Compile_Time_Known_Value
(Hi
) then
1517 Hiv
:= Expr_Value
(Hi
);
1522 return Hiv
< Lov
+ 3;
1525 end Length_Less_Than_4
;
1527 -- Start of processing for Expand_Array_Comparison
1530 -- Deal first with unpacked case, where we can call a runtime routine
1531 -- except that we avoid this for targets for which are not addressable
1532 -- by bytes, and for the JVM/CIL, since they do not support direct
1533 -- addressing of array components.
1535 if not Is_Bit_Packed_Array
(Typ1
)
1536 and then Byte_Addressable
1537 and then VM_Target
= No_VM
1539 -- The call we generate is:
1541 -- Compare_Array_xn[_Unaligned]
1542 -- (left'address, right'address, left'length, right'length) <op> 0
1544 -- x = U for unsigned, S for signed
1545 -- n = 8,16,32,64 for component size
1546 -- Add _Unaligned if length < 4 and component size is 8.
1547 -- <op> is the standard comparison operator
1549 if Component_Size
(Typ1
) = 8 then
1550 if Length_Less_Than_4
(Op1
)
1552 Length_Less_Than_4
(Op2
)
1554 if Is_Unsigned_Type
(Ctyp
) then
1555 Comp
:= RE_Compare_Array_U8_Unaligned
;
1557 Comp
:= RE_Compare_Array_S8_Unaligned
;
1561 if Is_Unsigned_Type
(Ctyp
) then
1562 Comp
:= RE_Compare_Array_U8
;
1564 Comp
:= RE_Compare_Array_S8
;
1568 elsif Component_Size
(Typ1
) = 16 then
1569 if Is_Unsigned_Type
(Ctyp
) then
1570 Comp
:= RE_Compare_Array_U16
;
1572 Comp
:= RE_Compare_Array_S16
;
1575 elsif Component_Size
(Typ1
) = 32 then
1576 if Is_Unsigned_Type
(Ctyp
) then
1577 Comp
:= RE_Compare_Array_U32
;
1579 Comp
:= RE_Compare_Array_S32
;
1582 else pragma Assert
(Component_Size
(Typ1
) = 64);
1583 if Is_Unsigned_Type
(Ctyp
) then
1584 Comp
:= RE_Compare_Array_U64
;
1586 Comp
:= RE_Compare_Array_S64
;
1590 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1591 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1594 Make_Function_Call
(Sloc
(Op1
),
1595 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1597 Parameter_Associations
=> New_List
(
1598 Make_Attribute_Reference
(Loc
,
1599 Prefix
=> Relocate_Node
(Op1
),
1600 Attribute_Name
=> Name_Address
),
1602 Make_Attribute_Reference
(Loc
,
1603 Prefix
=> Relocate_Node
(Op2
),
1604 Attribute_Name
=> Name_Address
),
1606 Make_Attribute_Reference
(Loc
,
1607 Prefix
=> Relocate_Node
(Op1
),
1608 Attribute_Name
=> Name_Length
),
1610 Make_Attribute_Reference
(Loc
,
1611 Prefix
=> Relocate_Node
(Op2
),
1612 Attribute_Name
=> Name_Length
))));
1615 Make_Integer_Literal
(Sloc
(Op2
),
1618 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1619 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1623 -- Cases where we cannot make runtime call
1625 -- For (a <= b) we convert to not (a > b)
1627 if Chars
(N
) = Name_Op_Le
then
1633 Right_Opnd
=> Op2
)));
1634 Analyze_And_Resolve
(N
, Standard_Boolean
);
1637 -- For < the Boolean expression is
1638 -- greater__nn (op2, op1)
1640 elsif Chars
(N
) = Name_Op_Lt
then
1641 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1645 Op1
:= Right_Opnd
(N
);
1646 Op2
:= Left_Opnd
(N
);
1648 -- For (a >= b) we convert to not (a < b)
1650 elsif Chars
(N
) = Name_Op_Ge
then
1656 Right_Opnd
=> Op2
)));
1657 Analyze_And_Resolve
(N
, Standard_Boolean
);
1660 -- For > the Boolean expression is
1661 -- greater__nn (op1, op2)
1664 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1665 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1668 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1670 Make_Function_Call
(Loc
,
1671 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1672 Parameter_Associations
=> New_List
(Op1
, Op2
));
1674 Insert_Action
(N
, Func_Body
);
1676 Analyze_And_Resolve
(N
, Standard_Boolean
);
1679 when RE_Not_Available
=>
1681 end Expand_Array_Comparison
;
1683 ---------------------------
1684 -- Expand_Array_Equality --
1685 ---------------------------
1687 -- Expand an equality function for multi-dimensional arrays. Here is an
1688 -- example of such a function for Nb_Dimension = 2
1690 -- function Enn (A : atyp; B : btyp) return boolean is
1692 -- if (A'length (1) = 0 or else A'length (2) = 0)
1694 -- (B'length (1) = 0 or else B'length (2) = 0)
1696 -- return True; -- RM 4.5.2(22)
1699 -- if A'length (1) /= B'length (1)
1701 -- A'length (2) /= B'length (2)
1703 -- return False; -- RM 4.5.2(23)
1707 -- A1 : Index_T1 := A'first (1);
1708 -- B1 : Index_T1 := B'first (1);
1712 -- A2 : Index_T2 := A'first (2);
1713 -- B2 : Index_T2 := B'first (2);
1716 -- if A (A1, A2) /= B (B1, B2) then
1720 -- exit when A2 = A'last (2);
1721 -- A2 := Index_T2'succ (A2);
1722 -- B2 := Index_T2'succ (B2);
1726 -- exit when A1 = A'last (1);
1727 -- A1 := Index_T1'succ (A1);
1728 -- B1 := Index_T1'succ (B1);
1735 -- Note on the formal types used (atyp and btyp). If either of the arrays
1736 -- is of a private type, we use the underlying type, and do an unchecked
1737 -- conversion of the actual. If either of the arrays has a bound depending
1738 -- on a discriminant, then we use the base type since otherwise we have an
1739 -- escaped discriminant in the function.
1741 -- If both arrays are constrained and have the same bounds, we can generate
1742 -- a loop with an explicit iteration scheme using a 'Range attribute over
1745 function Expand_Array_Equality
1750 Typ
: Entity_Id
) return Node_Id
1752 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1753 Decls
: constant List_Id
:= New_List
;
1754 Index_List1
: constant List_Id
:= New_List
;
1755 Index_List2
: constant List_Id
:= New_List
;
1759 Func_Name
: Entity_Id
;
1760 Func_Body
: Node_Id
;
1762 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1763 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1767 -- The parameter types to be used for the formals
1772 Num
: Int
) return Node_Id
;
1773 -- This builds the attribute reference Arr'Nam (Expr)
1775 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1776 -- Create one statement to compare corresponding components, designated
1777 -- by a full set of indexes.
1779 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1780 -- Given one of the arguments, computes the appropriate type to be used
1781 -- for that argument in the corresponding function formal
1783 function Handle_One_Dimension
1785 Index
: Node_Id
) return Node_Id
;
1786 -- This procedure returns the following code
1789 -- Bn : Index_T := B'First (N);
1793 -- exit when An = A'Last (N);
1794 -- An := Index_T'Succ (An)
1795 -- Bn := Index_T'Succ (Bn)
1799 -- If both indexes are constrained and identical, the procedure
1800 -- returns a simpler loop:
1802 -- for An in A'Range (N) loop
1806 -- N is the dimension for which we are generating a loop. Index is the
1807 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1808 -- xxx statement is either the loop or declare for the next dimension
1809 -- or if this is the last dimension the comparison of corresponding
1810 -- components of the arrays.
1812 -- The actual way the code works is to return the comparison of
1813 -- corresponding components for the N+1 call. That's neater.
1815 function Test_Empty_Arrays
return Node_Id
;
1816 -- This function constructs the test for both arrays being empty
1817 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1819 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1821 function Test_Lengths_Correspond
return Node_Id
;
1822 -- This function constructs the test for arrays having different lengths
1823 -- in at least one index position, in which case the resulting code is:
1825 -- A'length (1) /= B'length (1)
1827 -- A'length (2) /= B'length (2)
1838 Num
: Int
) return Node_Id
1842 Make_Attribute_Reference
(Loc
,
1843 Attribute_Name
=> Nam
,
1844 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1845 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1848 ------------------------
1849 -- Component_Equality --
1850 ------------------------
1852 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1857 -- if a(i1...) /= b(j1...) then return false; end if;
1860 Make_Indexed_Component
(Loc
,
1861 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1862 Expressions
=> Index_List1
);
1865 Make_Indexed_Component
(Loc
,
1866 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1867 Expressions
=> Index_List2
);
1869 Test
:= Expand_Composite_Equality
1870 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1872 -- If some (sub)component is an unchecked_union, the whole operation
1873 -- will raise program error.
1875 if Nkind
(Test
) = N_Raise_Program_Error
then
1877 -- This node is going to be inserted at a location where a
1878 -- statement is expected: clear its Etype so analysis will set
1879 -- it to the expected Standard_Void_Type.
1881 Set_Etype
(Test
, Empty
);
1886 Make_Implicit_If_Statement
(Nod
,
1887 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1888 Then_Statements
=> New_List
(
1889 Make_Simple_Return_Statement
(Loc
,
1890 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1892 end Component_Equality
;
1898 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1909 T
:= Underlying_Type
(T
);
1911 X
:= First_Index
(T
);
1912 while Present
(X
) loop
1913 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1915 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1928 --------------------------
1929 -- Handle_One_Dimension --
1930 ---------------------------
1932 function Handle_One_Dimension
1934 Index
: Node_Id
) return Node_Id
1936 Need_Separate_Indexes
: constant Boolean :=
1937 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1938 -- If the index types are identical, and we are working with
1939 -- constrained types, then we can use the same index for both
1942 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1945 Index_T
: Entity_Id
;
1950 if N
> Number_Dimensions
(Ltyp
) then
1951 return Component_Equality
(Ltyp
);
1954 -- Case where we generate a loop
1956 Index_T
:= Base_Type
(Etype
(Index
));
1958 if Need_Separate_Indexes
then
1959 Bn
:= Make_Temporary
(Loc
, 'B');
1964 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1965 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1967 Stm_List
:= New_List
(
1968 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1970 if Need_Separate_Indexes
then
1972 -- Generate guard for loop, followed by increments of indexes
1974 Append_To
(Stm_List
,
1975 Make_Exit_Statement
(Loc
,
1978 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1979 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1981 Append_To
(Stm_List
,
1982 Make_Assignment_Statement
(Loc
,
1983 Name
=> New_Occurrence_Of
(An
, Loc
),
1985 Make_Attribute_Reference
(Loc
,
1986 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1987 Attribute_Name
=> Name_Succ
,
1988 Expressions
=> New_List
(
1989 New_Occurrence_Of
(An
, Loc
)))));
1991 Append_To
(Stm_List
,
1992 Make_Assignment_Statement
(Loc
,
1993 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1995 Make_Attribute_Reference
(Loc
,
1996 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1997 Attribute_Name
=> Name_Succ
,
1998 Expressions
=> New_List
(
1999 New_Occurrence_Of
(Bn
, Loc
)))));
2002 -- If separate indexes, we need a declare block for An and Bn, and a
2003 -- loop without an iteration scheme.
2005 if Need_Separate_Indexes
then
2007 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
2010 Make_Block_Statement
(Loc
,
2011 Declarations
=> New_List
(
2012 Make_Object_Declaration
(Loc
,
2013 Defining_Identifier
=> An
,
2014 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
2015 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
2017 Make_Object_Declaration
(Loc
,
2018 Defining_Identifier
=> Bn
,
2019 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
2020 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
2022 Handled_Statement_Sequence
=>
2023 Make_Handled_Sequence_Of_Statements
(Loc
,
2024 Statements
=> New_List
(Loop_Stm
)));
2026 -- If no separate indexes, return loop statement with explicit
2027 -- iteration scheme on its own
2031 Make_Implicit_Loop_Statement
(Nod
,
2032 Statements
=> Stm_List
,
2034 Make_Iteration_Scheme
(Loc
,
2035 Loop_Parameter_Specification
=>
2036 Make_Loop_Parameter_Specification
(Loc
,
2037 Defining_Identifier
=> An
,
2038 Discrete_Subtype_Definition
=>
2039 Arr_Attr
(A
, Name_Range
, N
))));
2042 end Handle_One_Dimension
;
2044 -----------------------
2045 -- Test_Empty_Arrays --
2046 -----------------------
2048 function Test_Empty_Arrays
return Node_Id
is
2058 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2061 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2062 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2066 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
2067 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2076 Left_Opnd
=> Relocate_Node
(Alist
),
2077 Right_Opnd
=> Atest
);
2081 Left_Opnd
=> Relocate_Node
(Blist
),
2082 Right_Opnd
=> Btest
);
2089 Right_Opnd
=> Blist
);
2090 end Test_Empty_Arrays
;
2092 -----------------------------
2093 -- Test_Lengths_Correspond --
2094 -----------------------------
2096 function Test_Lengths_Correspond
return Node_Id
is
2102 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2105 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2106 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
2113 Left_Opnd
=> Relocate_Node
(Result
),
2114 Right_Opnd
=> Rtest
);
2119 end Test_Lengths_Correspond
;
2121 -- Start of processing for Expand_Array_Equality
2124 Ltyp
:= Get_Arg_Type
(Lhs
);
2125 Rtyp
:= Get_Arg_Type
(Rhs
);
2127 -- For now, if the argument types are not the same, go to the base type,
2128 -- since the code assumes that the formals have the same type. This is
2129 -- fixable in future ???
2131 if Ltyp
/= Rtyp
then
2132 Ltyp
:= Base_Type
(Ltyp
);
2133 Rtyp
:= Base_Type
(Rtyp
);
2134 pragma Assert
(Ltyp
= Rtyp
);
2137 -- Build list of formals for function
2139 Formals
:= New_List
(
2140 Make_Parameter_Specification
(Loc
,
2141 Defining_Identifier
=> A
,
2142 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
2144 Make_Parameter_Specification
(Loc
,
2145 Defining_Identifier
=> B
,
2146 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
2148 Func_Name
:= Make_Temporary
(Loc
, 'E');
2150 -- Build statement sequence for function
2153 Make_Subprogram_Body
(Loc
,
2155 Make_Function_Specification
(Loc
,
2156 Defining_Unit_Name
=> Func_Name
,
2157 Parameter_Specifications
=> Formals
,
2158 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2160 Declarations
=> Decls
,
2162 Handled_Statement_Sequence
=>
2163 Make_Handled_Sequence_Of_Statements
(Loc
,
2164 Statements
=> New_List
(
2166 Make_Implicit_If_Statement
(Nod
,
2167 Condition
=> Test_Empty_Arrays
,
2168 Then_Statements
=> New_List
(
2169 Make_Simple_Return_Statement
(Loc
,
2171 New_Occurrence_Of
(Standard_True
, Loc
)))),
2173 Make_Implicit_If_Statement
(Nod
,
2174 Condition
=> Test_Lengths_Correspond
,
2175 Then_Statements
=> New_List
(
2176 Make_Simple_Return_Statement
(Loc
,
2177 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
2179 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
2181 Make_Simple_Return_Statement
(Loc
,
2182 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2184 Set_Has_Completion
(Func_Name
, True);
2185 Set_Is_Inlined
(Func_Name
);
2187 -- If the array type is distinct from the type of the arguments, it
2188 -- is the full view of a private type. Apply an unchecked conversion
2189 -- to insure that analysis of the call succeeds.
2199 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
2201 L
:= OK_Convert_To
(Ltyp
, Lhs
);
2205 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
2207 R
:= OK_Convert_To
(Rtyp
, Rhs
);
2210 Actuals
:= New_List
(L
, R
);
2213 Append_To
(Bodies
, Func_Body
);
2216 Make_Function_Call
(Loc
,
2217 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2218 Parameter_Associations
=> Actuals
);
2219 end Expand_Array_Equality
;
2221 -----------------------------
2222 -- Expand_Boolean_Operator --
2223 -----------------------------
2225 -- Note that we first get the actual subtypes of the operands, since we
2226 -- always want to deal with types that have bounds.
2228 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2229 Typ
: constant Entity_Id
:= Etype
(N
);
2232 -- Special case of bit packed array where both operands are known to be
2233 -- properly aligned. In this case we use an efficient run time routine
2234 -- to carry out the operation (see System.Bit_Ops).
2236 if Is_Bit_Packed_Array
(Typ
)
2237 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2238 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2240 Expand_Packed_Boolean_Operator
(N
);
2244 -- For the normal non-packed case, the general expansion is to build
2245 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2246 -- and then inserting it into the tree. The original operator node is
2247 -- then rewritten as a call to this function. We also use this in the
2248 -- packed case if either operand is a possibly unaligned object.
2251 Loc
: constant Source_Ptr
:= Sloc
(N
);
2252 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2253 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2254 Func_Body
: Node_Id
;
2255 Func_Name
: Entity_Id
;
2258 Convert_To_Actual_Subtype
(L
);
2259 Convert_To_Actual_Subtype
(R
);
2260 Ensure_Defined
(Etype
(L
), N
);
2261 Ensure_Defined
(Etype
(R
), N
);
2262 Apply_Length_Check
(R
, Etype
(L
));
2264 if Nkind
(N
) = N_Op_Xor
then
2265 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2268 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2269 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2271 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2273 elsif Nkind
(Parent
(N
)) = N_Op_Not
2274 and then Nkind
(N
) = N_Op_And
2275 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2276 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2281 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2282 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2283 Insert_Action
(N
, Func_Body
);
2285 -- Now rewrite the expression with a call
2288 Make_Function_Call
(Loc
,
2289 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2290 Parameter_Associations
=>
2293 Make_Type_Conversion
2294 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2296 Analyze_And_Resolve
(N
, Typ
);
2299 end Expand_Boolean_Operator
;
2301 ------------------------------------------------
2302 -- Expand_Compare_Minimize_Eliminate_Overflow --
2303 ------------------------------------------------
2305 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2306 Loc
: constant Source_Ptr
:= Sloc
(N
);
2308 Result_Type
: constant Entity_Id
:= Etype
(N
);
2309 -- Capture result type (could be a derived boolean type)
2314 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2315 -- Entity for Long_Long_Integer'Base
2317 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2318 -- Current overflow checking mode
2321 procedure Set_False
;
2322 -- These procedures rewrite N with an occurrence of Standard_True or
2323 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2329 procedure Set_False
is
2331 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2332 Warn_On_Known_Condition
(N
);
2339 procedure Set_True
is
2341 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2342 Warn_On_Known_Condition
(N
);
2345 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2348 -- Nothing to do unless we have a comparison operator with operands
2349 -- that are signed integer types, and we are operating in either
2350 -- MINIMIZED or ELIMINATED overflow checking mode.
2352 if Nkind
(N
) not in N_Op_Compare
2353 or else Check
not in Minimized_Or_Eliminated
2354 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2359 -- OK, this is the case we are interested in. First step is to process
2360 -- our operands using the Minimize_Eliminate circuitry which applies
2361 -- this processing to the two operand subtrees.
2363 Minimize_Eliminate_Overflows
2364 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2365 Minimize_Eliminate_Overflows
2366 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2368 -- See if the range information decides the result of the comparison.
2369 -- We can only do this if we in fact have full range information (which
2370 -- won't be the case if either operand is bignum at this stage).
2372 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2373 case N_Op_Compare
(Nkind
(N
)) is
2375 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2377 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2384 elsif Lhi
< Rlo
then
2391 elsif Lhi
<= Rlo
then
2398 elsif Lhi
<= Rlo
then
2405 elsif Lhi
< Rlo
then
2410 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2412 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2417 -- All done if we did the rewrite
2419 if Nkind
(N
) not in N_Op_Compare
then
2424 -- Otherwise, time to do the comparison
2427 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2428 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2431 -- If the two operands have the same signed integer type we are
2432 -- all set, nothing more to do. This is the case where either
2433 -- both operands were unchanged, or we rewrote both of them to
2434 -- be Long_Long_Integer.
2436 -- Note: Entity for the comparison may be wrong, but it's not worth
2437 -- the effort to change it, since the back end does not use it.
2439 if Is_Signed_Integer_Type
(Ltype
)
2440 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2444 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2446 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2448 Left
: Node_Id
:= Left_Opnd
(N
);
2449 Right
: Node_Id
:= Right_Opnd
(N
);
2450 -- Bignum references for left and right operands
2453 if not Is_RTE
(Ltype
, RE_Bignum
) then
2454 Left
:= Convert_To_Bignum
(Left
);
2455 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2456 Right
:= Convert_To_Bignum
(Right
);
2459 -- We rewrite our node with:
2462 -- Bnn : Result_Type;
2464 -- M : Mark_Id := SS_Mark;
2466 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2474 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2475 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2479 case N_Op_Compare
(Nkind
(N
)) is
2480 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2481 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2482 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2483 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2484 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2485 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2488 -- Insert assignment to Bnn into the bignum block
2491 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2492 Make_Assignment_Statement
(Loc
,
2493 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2495 Make_Function_Call
(Loc
,
2497 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2498 Parameter_Associations
=> New_List
(Left
, Right
))));
2500 -- Now do the rewrite with expression actions
2503 Make_Expression_With_Actions
(Loc
,
2504 Actions
=> New_List
(
2505 Make_Object_Declaration
(Loc
,
2506 Defining_Identifier
=> Bnn
,
2507 Object_Definition
=>
2508 New_Occurrence_Of
(Result_Type
, Loc
)),
2510 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2511 Analyze_And_Resolve
(N
, Result_Type
);
2515 -- No bignums involved, but types are different, so we must have
2516 -- rewritten one of the operands as a Long_Long_Integer but not
2519 -- If left operand is Long_Long_Integer, convert right operand
2520 -- and we are done (with a comparison of two Long_Long_Integers).
2522 elsif Ltype
= LLIB
then
2523 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2524 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2527 -- If right operand is Long_Long_Integer, convert left operand
2528 -- and we are done (with a comparison of two Long_Long_Integers).
2530 -- This is the only remaining possibility
2532 else pragma Assert
(Rtype
= LLIB
);
2533 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2534 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2538 end Expand_Compare_Minimize_Eliminate_Overflow
;
2540 -------------------------------
2541 -- Expand_Composite_Equality --
2542 -------------------------------
2544 -- This function is only called for comparing internal fields of composite
2545 -- types when these fields are themselves composites. This is a special
2546 -- case because it is not possible to respect normal Ada visibility rules.
2548 function Expand_Composite_Equality
2553 Bodies
: List_Id
) return Node_Id
2555 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2556 Full_Type
: Entity_Id
;
2560 function Find_Primitive_Eq
return Node_Id
;
2561 -- AI05-0123: Locate primitive equality for type if it exists, and
2562 -- build the corresponding call. If operation is abstract, replace
2563 -- call with an explicit raise. Return Empty if there is no primitive.
2565 -----------------------
2566 -- Find_Primitive_Eq --
2567 -----------------------
2569 function Find_Primitive_Eq
return Node_Id
is
2574 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2575 while Present
(Prim_E
) loop
2576 Prim
:= Node
(Prim_E
);
2578 -- Locate primitive equality with the right signature
2580 if Chars
(Prim
) = Name_Op_Eq
2581 and then Etype
(First_Formal
(Prim
)) =
2582 Etype
(Next_Formal
(First_Formal
(Prim
)))
2583 and then Etype
(Prim
) = Standard_Boolean
2585 if Is_Abstract_Subprogram
(Prim
) then
2587 Make_Raise_Program_Error
(Loc
,
2588 Reason
=> PE_Explicit_Raise
);
2592 Make_Function_Call
(Loc
,
2593 Name
=> New_Occurrence_Of
(Prim
, Loc
),
2594 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2601 -- If not found, predefined operation will be used
2604 end Find_Primitive_Eq
;
2606 -- Start of processing for Expand_Composite_Equality
2609 if Is_Private_Type
(Typ
) then
2610 Full_Type
:= Underlying_Type
(Typ
);
2615 -- If the private type has no completion the context may be the
2616 -- expansion of a composite equality for a composite type with some
2617 -- still incomplete components. The expression will not be analyzed
2618 -- until the enclosing type is completed, at which point this will be
2619 -- properly expanded, unless there is a bona fide completion error.
2621 if No
(Full_Type
) then
2622 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2625 Full_Type
:= Base_Type
(Full_Type
);
2627 -- When the base type itself is private, use the full view to expand
2628 -- the composite equality.
2630 if Is_Private_Type
(Full_Type
) then
2631 Full_Type
:= Underlying_Type
(Full_Type
);
2634 -- Case of array types
2636 if Is_Array_Type
(Full_Type
) then
2638 -- If the operand is an elementary type other than a floating-point
2639 -- type, then we can simply use the built-in block bitwise equality,
2640 -- since the predefined equality operators always apply and bitwise
2641 -- equality is fine for all these cases.
2643 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2644 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2646 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2648 -- For composite component types, and floating-point types, use the
2649 -- expansion. This deals with tagged component types (where we use
2650 -- the applicable equality routine) and floating-point, (where we
2651 -- need to worry about negative zeroes), and also the case of any
2652 -- composite type recursively containing such fields.
2655 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2658 -- Case of tagged record types
2660 elsif Is_Tagged_Type
(Full_Type
) then
2662 -- Call the primitive operation "=" of this type
2664 if Is_Class_Wide_Type
(Full_Type
) then
2665 Full_Type
:= Root_Type
(Full_Type
);
2668 -- If this is derived from an untagged private type completed with a
2669 -- tagged type, it does not have a full view, so we use the primitive
2670 -- operations of the private type. This check should no longer be
2671 -- necessary when these types receive their full views ???
2673 if Is_Private_Type
(Typ
)
2674 and then not Is_Tagged_Type
(Typ
)
2675 and then not Is_Controlled
(Typ
)
2676 and then Is_Derived_Type
(Typ
)
2677 and then No
(Full_View
(Typ
))
2679 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2681 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2685 Eq_Op
:= Node
(Prim
);
2686 exit when Chars
(Eq_Op
) = Name_Op_Eq
2687 and then Etype
(First_Formal
(Eq_Op
)) =
2688 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2689 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2691 pragma Assert
(Present
(Prim
));
2694 Eq_Op
:= Node
(Prim
);
2697 Make_Function_Call
(Loc
,
2698 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2699 Parameter_Associations
=>
2701 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2702 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2704 -- Case of untagged record types
2706 elsif Is_Record_Type
(Full_Type
) then
2707 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2709 if Present
(Eq_Op
) then
2710 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2712 -- Inherited equality from parent type. Convert the actuals to
2713 -- match signature of operation.
2716 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2720 Make_Function_Call
(Loc
,
2721 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2722 Parameter_Associations
=> New_List
(
2723 OK_Convert_To
(T
, Lhs
),
2724 OK_Convert_To
(T
, Rhs
)));
2728 -- Comparison between Unchecked_Union components
2730 if Is_Unchecked_Union
(Full_Type
) then
2732 Lhs_Type
: Node_Id
:= Full_Type
;
2733 Rhs_Type
: Node_Id
:= Full_Type
;
2734 Lhs_Discr_Val
: Node_Id
;
2735 Rhs_Discr_Val
: Node_Id
;
2740 if Nkind
(Lhs
) = N_Selected_Component
then
2741 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2746 if Nkind
(Rhs
) = N_Selected_Component
then
2747 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2750 -- Lhs of the composite equality
2752 if Is_Constrained
(Lhs_Type
) then
2754 -- Since the enclosing record type can never be an
2755 -- Unchecked_Union (this code is executed for records
2756 -- that do not have variants), we may reference its
2759 if Nkind
(Lhs
) = N_Selected_Component
2760 and then Has_Per_Object_Constraint
2761 (Entity
(Selector_Name
(Lhs
)))
2764 Make_Selected_Component
(Loc
,
2765 Prefix
=> Prefix
(Lhs
),
2768 (Get_Discriminant_Value
2769 (First_Discriminant
(Lhs_Type
),
2771 Stored_Constraint
(Lhs_Type
))));
2776 (Get_Discriminant_Value
2777 (First_Discriminant
(Lhs_Type
),
2779 Stored_Constraint
(Lhs_Type
)));
2783 -- It is not possible to infer the discriminant since
2784 -- the subtype is not constrained.
2787 Make_Raise_Program_Error
(Loc
,
2788 Reason
=> PE_Unchecked_Union_Restriction
);
2791 -- Rhs of the composite equality
2793 if Is_Constrained
(Rhs_Type
) then
2794 if Nkind
(Rhs
) = N_Selected_Component
2795 and then Has_Per_Object_Constraint
2796 (Entity
(Selector_Name
(Rhs
)))
2799 Make_Selected_Component
(Loc
,
2800 Prefix
=> Prefix
(Rhs
),
2803 (Get_Discriminant_Value
2804 (First_Discriminant
(Rhs_Type
),
2806 Stored_Constraint
(Rhs_Type
))));
2811 (Get_Discriminant_Value
2812 (First_Discriminant
(Rhs_Type
),
2814 Stored_Constraint
(Rhs_Type
)));
2819 Make_Raise_Program_Error
(Loc
,
2820 Reason
=> PE_Unchecked_Union_Restriction
);
2823 -- Call the TSS equality function with the inferred
2824 -- discriminant values.
2827 Make_Function_Call
(Loc
,
2828 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2829 Parameter_Associations
=> New_List
(
2836 -- All cases other than comparing Unchecked_Union types
2840 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2843 Make_Function_Call
(Loc
,
2845 New_Occurrence_Of
(Eq_Op
, Loc
),
2846 Parameter_Associations
=> New_List
(
2847 OK_Convert_To
(T
, Lhs
),
2848 OK_Convert_To
(T
, Rhs
)));
2853 -- Equality composes in Ada 2012 for untagged record types. It also
2854 -- composes for bounded strings, because they are part of the
2855 -- predefined environment. We could make it compose for bounded
2856 -- strings by making them tagged, or by making sure all subcomponents
2857 -- are set to the same value, even when not used. Instead, we have
2858 -- this special case in the compiler, because it's more efficient.
2860 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2862 -- If no TSS has been created for the type, check whether there is
2863 -- a primitive equality declared for it.
2866 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2869 -- Use user-defined primitive if it exists, otherwise use
2870 -- predefined equality.
2872 if Present
(Op
) then
2875 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2880 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2883 -- Non-composite types (always use predefined equality)
2886 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2888 end Expand_Composite_Equality
;
2890 ------------------------
2891 -- Expand_Concatenate --
2892 ------------------------
2894 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2895 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2897 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2898 -- Result type of concatenation
2900 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2901 -- Component type. Elements of this component type can appear as one
2902 -- of the operands of concatenation as well as arrays.
2904 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2907 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2908 -- Index type. This is the base type of the index subtype, and is used
2909 -- for all computed bounds (which may be out of range of Istyp in the
2910 -- case of null ranges).
2913 -- This is the type we use to do arithmetic to compute the bounds and
2914 -- lengths of operands. The choice of this type is a little subtle and
2915 -- is discussed in a separate section at the start of the body code.
2917 Concatenation_Error
: exception;
2918 -- Raised if concatenation is sure to raise a CE
2920 Result_May_Be_Null
: Boolean := True;
2921 -- Reset to False if at least one operand is encountered which is known
2922 -- at compile time to be non-null. Used for handling the special case
2923 -- of setting the high bound to the last operand high bound for a null
2924 -- result, thus ensuring a proper high bound in the super-flat case.
2926 N
: constant Nat
:= List_Length
(Opnds
);
2927 -- Number of concatenation operands including possibly null operands
2930 -- Number of operands excluding any known to be null, except that the
2931 -- last operand is always retained, in case it provides the bounds for
2935 -- Current operand being processed in the loop through operands. After
2936 -- this loop is complete, always contains the last operand (which is not
2937 -- the same as Operands (NN), since null operands are skipped).
2939 -- Arrays describing the operands, only the first NN entries of each
2940 -- array are set (NN < N when we exclude known null operands).
2942 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2943 -- True if length of corresponding operand known at compile time
2945 Operands
: array (1 .. N
) of Node_Id
;
2946 -- Set to the corresponding entry in the Opnds list (but note that null
2947 -- operands are excluded, so not all entries in the list are stored).
2949 Fixed_Length
: array (1 .. N
) of Uint
;
2950 -- Set to length of operand. Entries in this array are set only if the
2951 -- corresponding entry in Is_Fixed_Length is True.
2953 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2954 -- Set to lower bound of operand. Either an integer literal in the case
2955 -- where the bound is known at compile time, else actual lower bound.
2956 -- The operand low bound is of type Ityp.
2958 Var_Length
: array (1 .. N
) of Entity_Id
;
2959 -- Set to an entity of type Natural that contains the length of an
2960 -- operand whose length is not known at compile time. Entries in this
2961 -- array are set only if the corresponding entry in Is_Fixed_Length
2962 -- is False. The entity is of type Artyp.
2964 Aggr_Length
: array (0 .. N
) of Node_Id
;
2965 -- The J'th entry in an expression node that represents the total length
2966 -- of operands 1 through J. It is either an integer literal node, or a
2967 -- reference to a constant entity with the right value, so it is fine
2968 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2969 -- entry always is set to zero. The length is of type Artyp.
2971 Low_Bound
: Node_Id
;
2972 -- A tree node representing the low bound of the result (of type Ityp).
2973 -- This is either an integer literal node, or an identifier reference to
2974 -- a constant entity initialized to the appropriate value.
2976 Last_Opnd_Low_Bound
: Node_Id
;
2977 -- A tree node representing the low bound of the last operand. This
2978 -- need only be set if the result could be null. It is used for the
2979 -- special case of setting the right low bound for a null result.
2980 -- This is of type Ityp.
2982 Last_Opnd_High_Bound
: Node_Id
;
2983 -- A tree node representing the high bound of the last operand. This
2984 -- need only be set if the result could be null. It is used for the
2985 -- special case of setting the right high bound for a null result.
2986 -- This is of type Ityp.
2988 High_Bound
: Node_Id
;
2989 -- A tree node representing the high bound of the result (of type Ityp)
2992 -- Result of the concatenation (of type Ityp)
2994 Actions
: constant List_Id
:= New_List
;
2995 -- Collect actions to be inserted
2997 Known_Non_Null_Operand_Seen
: Boolean;
2998 -- Set True during generation of the assignments of operands into
2999 -- result once an operand known to be non-null has been seen.
3001 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
3002 -- This function makes an N_Integer_Literal node that is returned in
3003 -- analyzed form with the type set to Artyp. Importantly this literal
3004 -- is not flagged as static, so that if we do computations with it that
3005 -- result in statically detected out of range conditions, we will not
3006 -- generate error messages but instead warning messages.
3008 function To_Artyp
(X
: Node_Id
) return Node_Id
;
3009 -- Given a node of type Ityp, returns the corresponding value of type
3010 -- Artyp. For non-enumeration types, this is a plain integer conversion.
3011 -- For enum types, the Pos of the value is returned.
3013 function To_Ityp
(X
: Node_Id
) return Node_Id
;
3014 -- The inverse function (uses Val in the case of enumeration types)
3016 ------------------------
3017 -- Make_Artyp_Literal --
3018 ------------------------
3020 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
3021 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
3023 Set_Etype
(Result
, Artyp
);
3024 Set_Analyzed
(Result
, True);
3025 Set_Is_Static_Expression
(Result
, False);
3027 end Make_Artyp_Literal
;
3033 function To_Artyp
(X
: Node_Id
) return Node_Id
is
3035 if Ityp
= Base_Type
(Artyp
) then
3038 elsif Is_Enumeration_Type
(Ityp
) then
3040 Make_Attribute_Reference
(Loc
,
3041 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3042 Attribute_Name
=> Name_Pos
,
3043 Expressions
=> New_List
(X
));
3046 return Convert_To
(Artyp
, X
);
3054 function To_Ityp
(X
: Node_Id
) return Node_Id
is
3056 if Is_Enumeration_Type
(Ityp
) then
3058 Make_Attribute_Reference
(Loc
,
3059 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3060 Attribute_Name
=> Name_Val
,
3061 Expressions
=> New_List
(X
));
3063 -- Case where we will do a type conversion
3066 if Ityp
= Base_Type
(Artyp
) then
3069 return Convert_To
(Ityp
, X
);
3074 -- Local Declarations
3076 Lib_Level_Target
: constant Boolean :=
3077 Nkind
(Parent
(Cnode
)) = N_Object_Declaration
3079 Is_Library_Level_Entity
(Defining_Identifier
(Parent
(Cnode
)));
3081 -- If the concatenation declares a library level entity, we call the
3082 -- built-in concatenation routines to prevent code bloat, regardless
3083 -- of optimization level. This is space-efficient, and prevent linking
3084 -- problems when units are compiled with different optimizations.
3086 Opnd_Typ
: Entity_Id
;
3093 -- Start of processing for Expand_Concatenate
3096 -- Choose an appropriate computational type
3098 -- We will be doing calculations of lengths and bounds in this routine
3099 -- and computing one from the other in some cases, e.g. getting the high
3100 -- bound by adding the length-1 to the low bound.
3102 -- We can't just use the index type, or even its base type for this
3103 -- purpose for two reasons. First it might be an enumeration type which
3104 -- is not suitable for computations of any kind, and second it may
3105 -- simply not have enough range. For example if the index type is
3106 -- -128..+127 then lengths can be up to 256, which is out of range of
3109 -- For enumeration types, we can simply use Standard_Integer, this is
3110 -- sufficient since the actual number of enumeration literals cannot
3111 -- possibly exceed the range of integer (remember we will be doing the
3112 -- arithmetic with POS values, not representation values).
3114 if Is_Enumeration_Type
(Ityp
) then
3115 Artyp
:= Standard_Integer
;
3117 -- If index type is Positive, we use the standard unsigned type, to give
3118 -- more room on the top of the range, obviating the need for an overflow
3119 -- check when creating the upper bound. This is needed to avoid junk
3120 -- overflow checks in the common case of String types.
3122 -- ??? Disabled for now
3124 -- elsif Istyp = Standard_Positive then
3125 -- Artyp := Standard_Unsigned;
3127 -- For modular types, we use a 32-bit modular type for types whose size
3128 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3129 -- identity type, and for larger unsigned types we use 64-bits.
3131 elsif Is_Modular_Integer_Type
(Ityp
) then
3132 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
3133 Artyp
:= Standard_Unsigned
;
3134 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
3137 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
3140 -- Similar treatment for signed types
3143 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
3144 Artyp
:= Standard_Integer
;
3145 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
3148 Artyp
:= Standard_Long_Long_Integer
;
3152 -- Supply dummy entry at start of length array
3154 Aggr_Length
(0) := Make_Artyp_Literal
(0);
3156 -- Go through operands setting up the above arrays
3160 Opnd
:= Remove_Head
(Opnds
);
3161 Opnd_Typ
:= Etype
(Opnd
);
3163 -- The parent got messed up when we put the operands in a list,
3164 -- so now put back the proper parent for the saved operand, that
3165 -- is to say the concatenation node, to make sure that each operand
3166 -- is seen as a subexpression, e.g. if actions must be inserted.
3168 Set_Parent
(Opnd
, Cnode
);
3170 -- Set will be True when we have setup one entry in the array
3174 -- Singleton element (or character literal) case
3176 if Base_Type
(Opnd_Typ
) = Ctyp
then
3178 Operands
(NN
) := Opnd
;
3179 Is_Fixed_Length
(NN
) := True;
3180 Fixed_Length
(NN
) := Uint_1
;
3181 Result_May_Be_Null
:= False;
3183 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3184 -- since we know that the result cannot be null).
3186 Opnd_Low_Bound
(NN
) :=
3187 Make_Attribute_Reference
(Loc
,
3188 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
3189 Attribute_Name
=> Name_First
);
3193 -- String literal case (can only occur for strings of course)
3195 elsif Nkind
(Opnd
) = N_String_Literal
then
3196 Len
:= String_Literal_Length
(Opnd_Typ
);
3199 Result_May_Be_Null
:= False;
3202 -- Capture last operand low and high bound if result could be null
3204 if J
= N
and then Result_May_Be_Null
then
3205 Last_Opnd_Low_Bound
:=
3206 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3208 Last_Opnd_High_Bound
:=
3209 Make_Op_Subtract
(Loc
,
3211 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3212 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3215 -- Skip null string literal
3217 if J
< N
and then Len
= 0 then
3222 Operands
(NN
) := Opnd
;
3223 Is_Fixed_Length
(NN
) := True;
3225 -- Set length and bounds
3227 Fixed_Length
(NN
) := Len
;
3229 Opnd_Low_Bound
(NN
) :=
3230 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3237 -- Check constrained case with known bounds
3239 if Is_Constrained
(Opnd_Typ
) then
3241 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3242 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3243 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3244 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3247 -- Fixed length constrained array type with known at compile
3248 -- time bounds is last case of fixed length operand.
3250 if Compile_Time_Known_Value
(Lo
)
3252 Compile_Time_Known_Value
(Hi
)
3255 Loval
: constant Uint
:= Expr_Value
(Lo
);
3256 Hival
: constant Uint
:= Expr_Value
(Hi
);
3257 Len
: constant Uint
:=
3258 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3262 Result_May_Be_Null
:= False;
3265 -- Capture last operand bounds if result could be null
3267 if J
= N
and then Result_May_Be_Null
then
3268 Last_Opnd_Low_Bound
:=
3270 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3272 Last_Opnd_High_Bound
:=
3274 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3277 -- Exclude null length case unless last operand
3279 if J
< N
and then Len
= 0 then
3284 Operands
(NN
) := Opnd
;
3285 Is_Fixed_Length
(NN
) := True;
3286 Fixed_Length
(NN
) := Len
;
3288 Opnd_Low_Bound
(NN
) :=
3290 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3297 -- All cases where the length is not known at compile time, or the
3298 -- special case of an operand which is known to be null but has a
3299 -- lower bound other than 1 or is other than a string type.
3304 -- Capture operand bounds
3306 Opnd_Low_Bound
(NN
) :=
3307 Make_Attribute_Reference
(Loc
,
3309 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3310 Attribute_Name
=> Name_First
);
3312 -- Capture last operand bounds if result could be null
3314 if J
= N
and Result_May_Be_Null
then
3315 Last_Opnd_Low_Bound
:=
3317 Make_Attribute_Reference
(Loc
,
3319 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3320 Attribute_Name
=> Name_First
));
3322 Last_Opnd_High_Bound
:=
3324 Make_Attribute_Reference
(Loc
,
3326 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3327 Attribute_Name
=> Name_Last
));
3330 -- Capture length of operand in entity
3332 Operands
(NN
) := Opnd
;
3333 Is_Fixed_Length
(NN
) := False;
3335 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3338 Make_Object_Declaration
(Loc
,
3339 Defining_Identifier
=> Var_Length
(NN
),
3340 Constant_Present
=> True,
3341 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3343 Make_Attribute_Reference
(Loc
,
3345 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3346 Attribute_Name
=> Name_Length
)));
3350 -- Set next entry in aggregate length array
3352 -- For first entry, make either integer literal for fixed length
3353 -- or a reference to the saved length for variable length.
3356 if Is_Fixed_Length
(1) then
3357 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3359 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
3362 -- If entry is fixed length and only fixed lengths so far, make
3363 -- appropriate new integer literal adding new length.
3365 elsif Is_Fixed_Length
(NN
)
3366 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3369 Make_Integer_Literal
(Loc
,
3370 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3372 -- All other cases, construct an addition node for the length and
3373 -- create an entity initialized to this length.
3376 Ent
:= Make_Temporary
(Loc
, 'L');
3378 if Is_Fixed_Length
(NN
) then
3379 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3381 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3385 Make_Object_Declaration
(Loc
,
3386 Defining_Identifier
=> Ent
,
3387 Constant_Present
=> True,
3388 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3391 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
3392 Right_Opnd
=> Clen
)));
3394 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3401 -- If we have only skipped null operands, return the last operand
3408 -- If we have only one non-null operand, return it and we are done.
3409 -- There is one case in which this cannot be done, and that is when
3410 -- the sole operand is of the element type, in which case it must be
3411 -- converted to an array, and the easiest way of doing that is to go
3412 -- through the normal general circuit.
3414 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3415 Result
:= Operands
(1);
3419 -- Cases where we have a real concatenation
3421 -- Next step is to find the low bound for the result array that we
3422 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3424 -- If the ultimate ancestor of the index subtype is a constrained array
3425 -- definition, then the lower bound is that of the index subtype as
3426 -- specified by (RM 4.5.3(6)).
3428 -- The right test here is to go to the root type, and then the ultimate
3429 -- ancestor is the first subtype of this root type.
3431 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3433 Make_Attribute_Reference
(Loc
,
3435 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3436 Attribute_Name
=> Name_First
);
3438 -- If the first operand in the list has known length we know that
3439 -- the lower bound of the result is the lower bound of this operand.
3441 elsif Is_Fixed_Length
(1) then
3442 Low_Bound
:= Opnd_Low_Bound
(1);
3444 -- OK, we don't know the lower bound, we have to build a horrible
3445 -- if expression node of the form
3447 -- if Cond1'Length /= 0 then
3450 -- if Opnd2'Length /= 0 then
3455 -- The nesting ends either when we hit an operand whose length is known
3456 -- at compile time, or on reaching the last operand, whose low bound we
3457 -- take unconditionally whether or not it is null. It's easiest to do
3458 -- this with a recursive procedure:
3462 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3463 -- Returns the lower bound determined by operands J .. NN
3465 ---------------------
3466 -- Get_Known_Bound --
3467 ---------------------
3469 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3471 if Is_Fixed_Length
(J
) or else J
= NN
then
3472 return New_Copy
(Opnd_Low_Bound
(J
));
3476 Make_If_Expression
(Loc
,
3477 Expressions
=> New_List
(
3481 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3483 Make_Integer_Literal
(Loc
, 0)),
3485 New_Copy
(Opnd_Low_Bound
(J
)),
3486 Get_Known_Bound
(J
+ 1)));
3488 end Get_Known_Bound
;
3491 Ent
:= Make_Temporary
(Loc
, 'L');
3494 Make_Object_Declaration
(Loc
,
3495 Defining_Identifier
=> Ent
,
3496 Constant_Present
=> True,
3497 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3498 Expression
=> Get_Known_Bound
(1)));
3500 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3504 -- Now we can safely compute the upper bound, normally
3505 -- Low_Bound + Length - 1.
3510 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3512 Make_Op_Subtract
(Loc
,
3513 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3514 Right_Opnd
=> Make_Artyp_Literal
(1))));
3516 -- Note that calculation of the high bound may cause overflow in some
3517 -- very weird cases, so in the general case we need an overflow check on
3518 -- the high bound. We can avoid this for the common case of string types
3519 -- and other types whose index is Positive, since we chose a wider range
3520 -- for the arithmetic type.
3522 if Istyp
/= Standard_Positive
then
3523 Activate_Overflow_Check
(High_Bound
);
3526 -- Handle the exceptional case where the result is null, in which case
3527 -- case the bounds come from the last operand (so that we get the proper
3528 -- bounds if the last operand is super-flat).
3530 if Result_May_Be_Null
then
3532 Make_If_Expression
(Loc
,
3533 Expressions
=> New_List
(
3535 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3536 Right_Opnd
=> Make_Artyp_Literal
(0)),
3537 Last_Opnd_Low_Bound
,
3541 Make_If_Expression
(Loc
,
3542 Expressions
=> New_List
(
3544 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3545 Right_Opnd
=> Make_Artyp_Literal
(0)),
3546 Last_Opnd_High_Bound
,
3550 -- Here is where we insert the saved up actions
3552 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3554 -- Now we construct an array object with appropriate bounds. We mark
3555 -- the target as internal to prevent useless initialization when
3556 -- Initialize_Scalars is enabled. Also since this is the actual result
3557 -- entity, we make sure we have debug information for the result.
3559 Ent
:= Make_Temporary
(Loc
, 'S');
3560 Set_Is_Internal
(Ent
);
3561 Set_Needs_Debug_Info
(Ent
);
3563 -- If the bound is statically known to be out of range, we do not want
3564 -- to abort, we want a warning and a runtime constraint error. Note that
3565 -- we have arranged that the result will not be treated as a static
3566 -- constant, so we won't get an illegality during this insertion.
3568 Insert_Action
(Cnode
,
3569 Make_Object_Declaration
(Loc
,
3570 Defining_Identifier
=> Ent
,
3571 Object_Definition
=>
3572 Make_Subtype_Indication
(Loc
,
3573 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3575 Make_Index_Or_Discriminant_Constraint
(Loc
,
3576 Constraints
=> New_List
(
3578 Low_Bound
=> Low_Bound
,
3579 High_Bound
=> High_Bound
))))),
3580 Suppress
=> All_Checks
);
3582 -- If the result of the concatenation appears as the initializing
3583 -- expression of an object declaration, we can just rename the
3584 -- result, rather than copying it.
3586 Set_OK_To_Rename
(Ent
);
3588 -- Catch the static out of range case now
3590 if Raises_Constraint_Error
(High_Bound
) then
3591 raise Concatenation_Error
;
3594 -- Now we will generate the assignments to do the actual concatenation
3596 -- There is one case in which we will not do this, namely when all the
3597 -- following conditions are met:
3599 -- The result type is Standard.String
3601 -- There are nine or fewer retained (non-null) operands
3603 -- The optimization level is -O0
3605 -- The corresponding System.Concat_n.Str_Concat_n routine is
3606 -- available in the run time.
3608 -- The debug flag gnatd.c is not set
3610 -- If all these conditions are met then we generate a call to the
3611 -- relevant concatenation routine. The purpose of this is to avoid
3612 -- undesirable code bloat at -O0.
3614 if Atyp
= Standard_String
3615 and then NN
in 2 .. 9
3616 and then (Lib_Level_Target
3617 or else ((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3618 and then not Debug_Flag_Dot_C
))
3621 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3632 if RTE_Available
(RR
(NN
)) then
3634 Opnds
: constant List_Id
:=
3635 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3638 for J
in 1 .. NN
loop
3639 if Is_List_Member
(Operands
(J
)) then
3640 Remove
(Operands
(J
));
3643 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3645 Make_Aggregate
(Loc
,
3646 Component_Associations
=> New_List
(
3647 Make_Component_Association
(Loc
,
3648 Choices
=> New_List
(
3649 Make_Integer_Literal
(Loc
, 1)),
3650 Expression
=> Operands
(J
)))));
3653 Append_To
(Opnds
, Operands
(J
));
3657 Insert_Action
(Cnode
,
3658 Make_Procedure_Call_Statement
(Loc
,
3659 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3660 Parameter_Associations
=> Opnds
));
3662 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3669 -- Not special case so generate the assignments
3671 Known_Non_Null_Operand_Seen
:= False;
3673 for J
in 1 .. NN
loop
3675 Lo
: constant Node_Id
:=
3677 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3678 Right_Opnd
=> Aggr_Length
(J
- 1));
3680 Hi
: constant Node_Id
:=
3682 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3684 Make_Op_Subtract
(Loc
,
3685 Left_Opnd
=> Aggr_Length
(J
),
3686 Right_Opnd
=> Make_Artyp_Literal
(1)));
3689 -- Singleton case, simple assignment
3691 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3692 Known_Non_Null_Operand_Seen
:= True;
3693 Insert_Action
(Cnode
,
3694 Make_Assignment_Statement
(Loc
,
3696 Make_Indexed_Component
(Loc
,
3697 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3698 Expressions
=> New_List
(To_Ityp
(Lo
))),
3699 Expression
=> Operands
(J
)),
3700 Suppress
=> All_Checks
);
3702 -- Array case, slice assignment, skipped when argument is fixed
3703 -- length and known to be null.
3705 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3708 Make_Assignment_Statement
(Loc
,
3712 New_Occurrence_Of
(Ent
, Loc
),
3715 Low_Bound
=> To_Ityp
(Lo
),
3716 High_Bound
=> To_Ityp
(Hi
))),
3717 Expression
=> Operands
(J
));
3719 if Is_Fixed_Length
(J
) then
3720 Known_Non_Null_Operand_Seen
:= True;
3722 elsif not Known_Non_Null_Operand_Seen
then
3724 -- Here if operand length is not statically known and no
3725 -- operand known to be non-null has been processed yet.
3726 -- If operand length is 0, we do not need to perform the
3727 -- assignment, and we must avoid the evaluation of the
3728 -- high bound of the slice, since it may underflow if the
3729 -- low bound is Ityp'First.
3732 Make_Implicit_If_Statement
(Cnode
,
3736 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3737 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3738 Then_Statements
=> New_List
(Assign
));
3741 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3747 -- Finally we build the result, which is a reference to the array object
3749 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3752 Rewrite
(Cnode
, Result
);
3753 Analyze_And_Resolve
(Cnode
, Atyp
);
3756 when Concatenation_Error
=>
3758 -- Kill warning generated for the declaration of the static out of
3759 -- range high bound, and instead generate a Constraint_Error with
3760 -- an appropriate specific message.
3762 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3763 Apply_Compile_Time_Constraint_Error
3765 Msg
=> "concatenation result upper bound out of range??",
3766 Reason
=> CE_Range_Check_Failed
);
3767 end Expand_Concatenate
;
3769 ---------------------------------------------------
3770 -- Expand_Membership_Minimize_Eliminate_Overflow --
3771 ---------------------------------------------------
3773 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3774 pragma Assert
(Nkind
(N
) = N_In
);
3775 -- Despite the name, this routine applies only to N_In, not to
3776 -- N_Not_In. The latter is always rewritten as not (X in Y).
3778 Result_Type
: constant Entity_Id
:= Etype
(N
);
3779 -- Capture result type, may be a derived boolean type
3781 Loc
: constant Source_Ptr
:= Sloc
(N
);
3782 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3783 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3785 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3786 -- is thus tempting to capture these values, but due to the rewrites
3787 -- that occur as a result of overflow checking, these values change
3788 -- as we go along, and it is safe just to always use Etype explicitly.
3790 Restype
: constant Entity_Id
:= Etype
(N
);
3794 -- Bounds in Minimize calls, not used currently
3796 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3797 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3800 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3802 -- If right operand is a subtype name, and the subtype name has no
3803 -- predicate, then we can just replace the right operand with an
3804 -- explicit range T'First .. T'Last, and use the explicit range code.
3806 if Nkind
(Rop
) /= N_Range
3807 and then No
(Predicate_Function
(Etype
(Rop
)))
3810 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3815 Make_Attribute_Reference
(Loc
,
3816 Attribute_Name
=> Name_First
,
3817 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3819 Make_Attribute_Reference
(Loc
,
3820 Attribute_Name
=> Name_Last
,
3821 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3822 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3826 -- Here for the explicit range case. Note that the bounds of the range
3827 -- have not been processed for minimized or eliminated checks.
3829 if Nkind
(Rop
) = N_Range
then
3830 Minimize_Eliminate_Overflows
3831 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3832 Minimize_Eliminate_Overflows
3833 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3835 -- We have A in B .. C, treated as A >= B and then A <= C
3839 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3840 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3841 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3844 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3845 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3846 L
: constant Entity_Id
:=
3847 Make_Defining_Identifier
(Loc
, Name_uL
);
3848 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3849 Lbound
: constant Node_Id
:=
3850 Convert_To_Bignum
(Low_Bound
(Rop
));
3851 Hbound
: constant Node_Id
:=
3852 Convert_To_Bignum
(High_Bound
(Rop
));
3854 -- Now we rewrite the membership test node to look like
3857 -- Bnn : Result_Type;
3859 -- M : Mark_Id := SS_Mark;
3860 -- L : Bignum := Lopnd;
3862 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3870 -- Insert declaration of L into declarations of bignum block
3873 (Last
(Declarations
(Blk
)),
3874 Make_Object_Declaration
(Loc
,
3875 Defining_Identifier
=> L
,
3876 Object_Definition
=>
3877 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3878 Expression
=> Lopnd
));
3880 -- Insert assignment to Bnn into expressions of bignum block
3883 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3884 Make_Assignment_Statement
(Loc
,
3885 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3889 Make_Function_Call
(Loc
,
3891 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3892 Parameter_Associations
=> New_List
(
3893 New_Occurrence_Of
(L
, Loc
),
3897 Make_Function_Call
(Loc
,
3899 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3900 Parameter_Associations
=> New_List
(
3901 New_Occurrence_Of
(L
, Loc
),
3904 -- Now rewrite the node
3907 Make_Expression_With_Actions
(Loc
,
3908 Actions
=> New_List
(
3909 Make_Object_Declaration
(Loc
,
3910 Defining_Identifier
=> Bnn
,
3911 Object_Definition
=>
3912 New_Occurrence_Of
(Result_Type
, Loc
)),
3914 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3915 Analyze_And_Resolve
(N
, Result_Type
);
3919 -- Here if no bignums around
3922 -- Case where types are all the same
3924 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3926 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3930 -- If types are not all the same, it means that we have rewritten
3931 -- at least one of them to be of type Long_Long_Integer, and we
3932 -- will convert the other operands to Long_Long_Integer.
3935 Convert_To_And_Rewrite
(LLIB
, Lop
);
3936 Set_Analyzed
(Lop
, False);
3937 Analyze_And_Resolve
(Lop
, LLIB
);
3939 -- For the right operand, avoid unnecessary recursion into
3940 -- this routine, we know that overflow is not possible.
3942 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3943 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3944 Set_Analyzed
(Rop
, False);
3945 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3948 -- Now the three operands are of the same signed integer type,
3949 -- so we can use the normal expansion routine for membership,
3950 -- setting the flag to prevent recursion into this procedure.
3952 Set_No_Minimize_Eliminate
(N
);
3956 -- Right operand is a subtype name and the subtype has a predicate. We
3957 -- have to make sure the predicate is checked, and for that we need to
3958 -- use the standard N_In circuitry with appropriate types.
3961 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3963 -- If types are "right", just call Expand_N_In preventing recursion
3965 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3966 Set_No_Minimize_Eliminate
(N
);
3971 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3973 -- For X in T, we want to rewrite our node as
3976 -- Bnn : Result_Type;
3979 -- M : Mark_Id := SS_Mark;
3980 -- Lnn : Long_Long_Integer'Base
3986 -- if not Bignum_In_LLI_Range (Nnn) then
3989 -- Lnn := From_Bignum (Nnn);
3991 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3992 -- and then T'Base (Lnn) in T;
4001 -- A bit gruesome, but there doesn't seem to be a simpler way
4004 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
4005 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
4006 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
4007 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
4008 T
: constant Entity_Id
:= Etype
(Rop
);
4009 TB
: constant Entity_Id
:= Base_Type
(T
);
4013 -- Mark the last membership operation to prevent recursion
4017 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
4018 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4019 Set_No_Minimize_Eliminate
(Nin
);
4021 -- Now decorate the block
4024 (Last
(Declarations
(Blk
)),
4025 Make_Object_Declaration
(Loc
,
4026 Defining_Identifier
=> Lnn
,
4027 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
4030 (Last
(Declarations
(Blk
)),
4031 Make_Object_Declaration
(Loc
,
4032 Defining_Identifier
=> Nnn
,
4033 Object_Definition
=>
4034 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
4037 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
4039 Make_Assignment_Statement
(Loc
,
4040 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
4041 Expression
=> Relocate_Node
(Lop
)),
4043 Make_Implicit_If_Statement
(N
,
4047 Make_Function_Call
(Loc
,
4050 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
4051 Parameter_Associations
=> New_List
(
4052 New_Occurrence_Of
(Nnn
, Loc
)))),
4054 Then_Statements
=> New_List
(
4055 Make_Assignment_Statement
(Loc
,
4056 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4058 New_Occurrence_Of
(Standard_False
, Loc
))),
4060 Else_Statements
=> New_List
(
4061 Make_Assignment_Statement
(Loc
,
4062 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4064 Make_Function_Call
(Loc
,
4066 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4067 Parameter_Associations
=> New_List
(
4068 New_Occurrence_Of
(Nnn
, Loc
)))),
4070 Make_Assignment_Statement
(Loc
,
4071 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4076 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4081 Make_Attribute_Reference
(Loc
,
4082 Attribute_Name
=> Name_First
,
4084 New_Occurrence_Of
(TB
, Loc
))),
4088 Make_Attribute_Reference
(Loc
,
4089 Attribute_Name
=> Name_Last
,
4091 New_Occurrence_Of
(TB
, Loc
))))),
4093 Right_Opnd
=> Nin
))))));
4095 -- Now we can do the rewrite
4098 Make_Expression_With_Actions
(Loc
,
4099 Actions
=> New_List
(
4100 Make_Object_Declaration
(Loc
,
4101 Defining_Identifier
=> Bnn
,
4102 Object_Definition
=>
4103 New_Occurrence_Of
(Result_Type
, Loc
)),
4105 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
4106 Analyze_And_Resolve
(N
, Result_Type
);
4110 -- Not bignum case, but types don't match (this means we rewrote the
4111 -- left operand to be Long_Long_Integer).
4114 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
4116 -- We rewrite the membership test as (where T is the type with
4117 -- the predicate, i.e. the type of the right operand)
4119 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4120 -- and then T'Base (Lop) in T
4123 T
: constant Entity_Id
:= Etype
(Rop
);
4124 TB
: constant Entity_Id
:= Base_Type
(T
);
4128 -- The last membership test is marked to prevent recursion
4132 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
4133 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4134 Set_No_Minimize_Eliminate
(Nin
);
4136 -- Now do the rewrite
4147 Make_Attribute_Reference
(Loc
,
4148 Attribute_Name
=> Name_First
,
4150 New_Occurrence_Of
(TB
, Loc
))),
4153 Make_Attribute_Reference
(Loc
,
4154 Attribute_Name
=> Name_Last
,
4156 New_Occurrence_Of
(TB
, Loc
))))),
4157 Right_Opnd
=> Nin
));
4158 Set_Analyzed
(N
, False);
4159 Analyze_And_Resolve
(N
, Restype
);
4163 end Expand_Membership_Minimize_Eliminate_Overflow
;
4165 ------------------------
4166 -- Expand_N_Allocator --
4167 ------------------------
4169 procedure Expand_N_Allocator
(N
: Node_Id
) is
4170 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4171 Loc
: constant Source_Ptr
:= Sloc
(N
);
4172 PtrT
: constant Entity_Id
:= Etype
(N
);
4174 procedure Rewrite_Coextension
(N
: Node_Id
);
4175 -- Static coextensions have the same lifetime as the entity they
4176 -- constrain. Such occurrences can be rewritten as aliased objects
4177 -- and their unrestricted access used instead of the coextension.
4179 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4180 -- Given a constrained array type E, returns a node representing the
4181 -- code to compute the size in storage elements for the given type.
4182 -- This is done without using the attribute (which malfunctions for
4185 -------------------------
4186 -- Rewrite_Coextension --
4187 -------------------------
4189 procedure Rewrite_Coextension
(N
: Node_Id
) is
4190 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4191 Temp_Decl
: Node_Id
;
4195 -- Cnn : aliased Etyp;
4198 Make_Object_Declaration
(Loc
,
4199 Defining_Identifier
=> Temp_Id
,
4200 Aliased_Present
=> True,
4201 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4203 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4204 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4207 Insert_Action
(N
, Temp_Decl
);
4209 Make_Attribute_Reference
(Loc
,
4210 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4211 Attribute_Name
=> Name_Unrestricted_Access
));
4213 Analyze_And_Resolve
(N
, PtrT
);
4214 end Rewrite_Coextension
;
4216 ------------------------------
4217 -- Size_In_Storage_Elements --
4218 ------------------------------
4220 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4222 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4223 -- However, the reason for the existence of this function is
4224 -- to construct a test for sizes too large, which means near the
4225 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4226 -- is that we get overflows when sizes are greater than 2**31.
4228 -- So what we end up doing for array types is to use the expression:
4230 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4232 -- which avoids this problem. All this is a bit bogus, but it does
4233 -- mean we catch common cases of trying to allocate arrays that
4234 -- are too large, and which in the absence of a check results in
4235 -- undetected chaos ???
4237 -- Note in particular that this is a pessimistic estimate in the
4238 -- case of packed array types, where an array element might occupy
4239 -- just a fraction of a storage element???
4246 for J
in 1 .. Number_Dimensions
(E
) loop
4248 Make_Attribute_Reference
(Loc
,
4249 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4250 Attribute_Name
=> Name_Length
,
4251 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4258 Make_Op_Multiply
(Loc
,
4265 Make_Op_Multiply
(Loc
,
4268 Make_Attribute_Reference
(Loc
,
4269 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4270 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4272 end Size_In_Storage_Elements
;
4276 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4280 Rel_Typ
: Entity_Id
;
4283 -- Start of processing for Expand_N_Allocator
4286 -- RM E.2.3(22). We enforce that the expected type of an allocator
4287 -- shall not be a remote access-to-class-wide-limited-private type
4289 -- Why is this being done at expansion time, seems clearly wrong ???
4291 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4293 -- Processing for anonymous access-to-controlled types. These access
4294 -- types receive a special finalization master which appears in the
4295 -- declarations of the enclosing semantic unit. This expansion is done
4296 -- now to ensure that any additional types generated by this routine or
4297 -- Expand_Allocator_Expression inherit the proper type attributes.
4299 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4300 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4301 and then Needs_Finalization
(Dtyp
)
4303 -- Detect the allocation of an anonymous controlled object where the
4304 -- type of the context is named. For example:
4306 -- procedure Proc (Ptr : Named_Access_Typ);
4307 -- Proc (new Designated_Typ);
4309 -- Regardless of the anonymous-to-named access type conversion, the
4310 -- lifetime of the object must be associated with the named access
4311 -- type. Use the finalization-related attributes of this type.
4313 if Nkind_In
(Parent
(N
), N_Type_Conversion
,
4314 N_Unchecked_Type_Conversion
)
4315 and then Ekind_In
(Etype
(Parent
(N
)), E_Access_Subtype
,
4317 E_General_Access_Type
)
4319 Rel_Typ
:= Etype
(Parent
(N
));
4324 -- Anonymous access-to-controlled types allocate on the global pool.
4325 -- Do not set this attribute on .NET/JVM since those targets do not
4326 -- support pools. Note that this is a "root type only" attribute.
4328 if No
(Associated_Storage_Pool
(PtrT
)) and then VM_Target
= No_VM
then
4329 if Present
(Rel_Typ
) then
4330 Set_Associated_Storage_Pool
4331 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4333 Set_Associated_Storage_Pool
4334 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4338 -- The finalization master must be inserted and analyzed as part of
4339 -- the current semantic unit. Note that the master is updated when
4340 -- analysis changes current units. Note that this is a "root type
4343 if Present
(Rel_Typ
) then
4344 Set_Finalization_Master
4345 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4347 Set_Finalization_Master
4348 (Root_Type
(PtrT
), Current_Anonymous_Master
);
4352 -- Set the storage pool and find the appropriate version of Allocate to
4353 -- call. Do not overwrite the storage pool if it is already set, which
4354 -- can happen for build-in-place function returns (see
4355 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4357 if No
(Storage_Pool
(N
)) then
4358 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4360 if Present
(Pool
) then
4361 Set_Storage_Pool
(N
, Pool
);
4363 if Is_RTE
(Pool
, RE_SS_Pool
) then
4364 if VM_Target
= No_VM
then
4365 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4368 -- In the case of an allocator for a simple storage pool, locate
4369 -- and save a reference to the pool type's Allocate routine.
4371 elsif Present
(Get_Rep_Pragma
4372 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4375 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4376 Alloc_Op
: Entity_Id
;
4378 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4379 while Present
(Alloc_Op
) loop
4380 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4381 and then Present
(First_Formal
(Alloc_Op
))
4382 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4384 Set_Procedure_To_Call
(N
, Alloc_Op
);
4387 Alloc_Op
:= Homonym
(Alloc_Op
);
4392 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4393 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4396 Set_Procedure_To_Call
(N
,
4397 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4402 -- Under certain circumstances we can replace an allocator by an access
4403 -- to statically allocated storage. The conditions, as noted in AARM
4404 -- 3.10 (10c) are as follows:
4406 -- Size and initial value is known at compile time
4407 -- Access type is access-to-constant
4409 -- The allocator is not part of a constraint on a record component,
4410 -- because in that case the inserted actions are delayed until the
4411 -- record declaration is fully analyzed, which is too late for the
4412 -- analysis of the rewritten allocator.
4414 if Is_Access_Constant
(PtrT
)
4415 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4416 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4417 and then Size_Known_At_Compile_Time
4418 (Etype
(Expression
(Expression
(N
))))
4419 and then not Is_Record_Type
(Current_Scope
)
4421 -- Here we can do the optimization. For the allocator
4425 -- We insert an object declaration
4427 -- Tnn : aliased x := y;
4429 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4430 -- marked as requiring static allocation.
4432 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4433 Desig
:= Subtype_Mark
(Expression
(N
));
4435 -- If context is constrained, use constrained subtype directly,
4436 -- so that the constant is not labelled as having a nominally
4437 -- unconstrained subtype.
4439 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4440 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4444 Make_Object_Declaration
(Loc
,
4445 Defining_Identifier
=> Temp
,
4446 Aliased_Present
=> True,
4447 Constant_Present
=> Is_Access_Constant
(PtrT
),
4448 Object_Definition
=> Desig
,
4449 Expression
=> Expression
(Expression
(N
))));
4452 Make_Attribute_Reference
(Loc
,
4453 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4454 Attribute_Name
=> Name_Unrestricted_Access
));
4456 Analyze_And_Resolve
(N
, PtrT
);
4458 -- We set the variable as statically allocated, since we don't want
4459 -- it going on the stack of the current procedure.
4461 Set_Is_Statically_Allocated
(Temp
);
4465 -- Same if the allocator is an access discriminant for a local object:
4466 -- instead of an allocator we create a local value and constrain the
4467 -- enclosing object with the corresponding access attribute.
4469 if Is_Static_Coextension
(N
) then
4470 Rewrite_Coextension
(N
);
4474 -- Check for size too large, we do this because the back end misses
4475 -- proper checks here and can generate rubbish allocation calls when
4476 -- we are near the limit. We only do this for the 32-bit address case
4477 -- since that is from a practical point of view where we see a problem.
4479 if System_Address_Size
= 32
4480 and then not Storage_Checks_Suppressed
(PtrT
)
4481 and then not Storage_Checks_Suppressed
(Dtyp
)
4482 and then not Storage_Checks_Suppressed
(Etyp
)
4484 -- The check we want to generate should look like
4486 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4487 -- raise Storage_Error;
4490 -- where 3.5 gigabytes is a constant large enough to accommodate any
4491 -- reasonable request for. But we can't do it this way because at
4492 -- least at the moment we don't compute this attribute right, and
4493 -- can silently give wrong results when the result gets large. Since
4494 -- this is all about large results, that's bad, so instead we only
4495 -- apply the check for constrained arrays, and manually compute the
4496 -- value of the attribute ???
4498 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4500 Make_Raise_Storage_Error
(Loc
,
4503 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4505 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4506 Reason
=> SE_Object_Too_Large
));
4510 -- If no storage pool has been specified and we have the restriction
4511 -- No_Standard_Allocators_After_Elaboration is present, then generate
4512 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4514 if Nkind
(N
) = N_Allocator
4515 and then No
(Storage_Pool
(N
))
4516 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4519 Make_Procedure_Call_Statement
(Loc
,
4521 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4524 -- Handle case of qualified expression (other than optimization above)
4525 -- First apply constraint checks, because the bounds or discriminants
4526 -- in the aggregate might not match the subtype mark in the allocator.
4528 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4529 Apply_Constraint_Check
4530 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
4532 Expand_Allocator_Expression
(N
);
4536 -- If the allocator is for a type which requires initialization, and
4537 -- there is no initial value (i.e. operand is a subtype indication
4538 -- rather than a qualified expression), then we must generate a call to
4539 -- the initialization routine using an expressions action node:
4541 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4543 -- Here ptr_T is the pointer type for the allocator, and T is the
4544 -- subtype of the allocator. A special case arises if the designated
4545 -- type of the access type is a task or contains tasks. In this case
4546 -- the call to Init (Temp.all ...) is replaced by code that ensures
4547 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4548 -- for details). In addition, if the type T is a task type, then the
4549 -- first argument to Init must be converted to the task record type.
4552 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4558 Init_Arg1
: Node_Id
;
4559 Temp_Decl
: Node_Id
;
4560 Temp_Type
: Entity_Id
;
4563 if No_Initialization
(N
) then
4565 -- Even though this might be a simple allocation, create a custom
4566 -- Allocate if the context requires it. Since .NET/JVM compilers
4567 -- do not support pools, this step is skipped.
4569 if VM_Target
= No_VM
4570 and then Present
(Finalization_Master
(PtrT
))
4572 Build_Allocate_Deallocate_Proc
4574 Is_Allocate
=> True);
4577 -- Case of no initialization procedure present
4579 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4581 -- Case of simple initialization required
4583 if Needs_Simple_Initialization
(T
) then
4584 Check_Restriction
(No_Default_Initialization
, N
);
4585 Rewrite
(Expression
(N
),
4586 Make_Qualified_Expression
(Loc
,
4587 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4588 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4590 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4591 Analyze_And_Resolve
(Expression
(N
), T
);
4592 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4593 Expand_N_Allocator
(N
);
4595 -- No initialization required
4601 -- Case of initialization procedure present, must be called
4604 Check_Restriction
(No_Default_Initialization
, N
);
4606 if not Restriction_Active
(No_Default_Initialization
) then
4607 Init
:= Base_Init_Proc
(T
);
4609 Temp
:= Make_Temporary
(Loc
, 'P');
4611 -- Construct argument list for the initialization routine call
4614 Make_Explicit_Dereference
(Loc
,
4616 New_Occurrence_Of
(Temp
, Loc
));
4618 Set_Assignment_OK
(Init_Arg1
);
4621 -- The initialization procedure expects a specific type. if the
4622 -- context is access to class wide, indicate that the object
4623 -- being allocated has the right specific type.
4625 if Is_Class_Wide_Type
(Dtyp
) then
4626 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4629 -- If designated type is a concurrent type or if it is private
4630 -- type whose definition is a concurrent type, the first
4631 -- argument in the Init routine has to be unchecked conversion
4632 -- to the corresponding record type. If the designated type is
4633 -- a derived type, also convert the argument to its root type.
4635 if Is_Concurrent_Type
(T
) then
4637 Unchecked_Convert_To
(
4638 Corresponding_Record_Type
(T
), Init_Arg1
);
4640 elsif Is_Private_Type
(T
)
4641 and then Present
(Full_View
(T
))
4642 and then Is_Concurrent_Type
(Full_View
(T
))
4645 Unchecked_Convert_To
4646 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4648 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4650 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4653 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4654 Set_Etype
(Init_Arg1
, Ftyp
);
4658 Args
:= New_List
(Init_Arg1
);
4660 -- For the task case, pass the Master_Id of the access type as
4661 -- the value of the _Master parameter, and _Chain as the value
4662 -- of the _Chain parameter (_Chain will be defined as part of
4663 -- the generated code for the allocator).
4665 -- In Ada 2005, the context may be a function that returns an
4666 -- anonymous access type. In that case the Master_Id has been
4667 -- created when expanding the function declaration.
4669 if Has_Task
(T
) then
4670 if No
(Master_Id
(Base_Type
(PtrT
))) then
4672 -- The designated type was an incomplete type, and the
4673 -- access type did not get expanded. Salvage it now.
4675 if not Restriction_Active
(No_Task_Hierarchy
) then
4676 if Present
(Parent
(Base_Type
(PtrT
))) then
4677 Expand_N_Full_Type_Declaration
4678 (Parent
(Base_Type
(PtrT
)));
4680 -- The only other possibility is an itype. For this
4681 -- case, the master must exist in the context. This is
4682 -- the case when the allocator initializes an access
4683 -- component in an init-proc.
4686 pragma Assert
(Is_Itype
(PtrT
));
4687 Build_Master_Renaming
(PtrT
, N
);
4692 -- If the context of the allocator is a declaration or an
4693 -- assignment, we can generate a meaningful image for it,
4694 -- even though subsequent assignments might remove the
4695 -- connection between task and entity. We build this image
4696 -- when the left-hand side is a simple variable, a simple
4697 -- indexed assignment or a simple selected component.
4699 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4701 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4704 if Is_Entity_Name
(Nam
) then
4706 Build_Task_Image_Decls
4709 (Entity
(Nam
), Sloc
(Nam
)), T
);
4711 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4712 N_Selected_Component
)
4713 and then Is_Entity_Name
(Prefix
(Nam
))
4716 Build_Task_Image_Decls
4717 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4719 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4723 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4725 Build_Task_Image_Decls
4726 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4729 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4732 if Restriction_Active
(No_Task_Hierarchy
) then
4734 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4738 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4741 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4743 Decl
:= Last
(Decls
);
4745 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4747 -- Has_Task is false, Decls not used
4753 -- Add discriminants if discriminated type
4756 Dis
: Boolean := False;
4760 if Has_Discriminants
(T
) then
4764 elsif Is_Private_Type
(T
)
4765 and then Present
(Full_View
(T
))
4766 and then Has_Discriminants
(Full_View
(T
))
4769 Typ
:= Full_View
(T
);
4774 -- If the allocated object will be constrained by the
4775 -- default values for discriminants, then build a subtype
4776 -- with those defaults, and change the allocated subtype
4777 -- to that. Note that this happens in fewer cases in Ada
4780 if not Is_Constrained
(Typ
)
4781 and then Present
(Discriminant_Default_Value
4782 (First_Discriminant
(Typ
)))
4783 and then (Ada_Version
< Ada_2005
4785 Object_Type_Has_Constrained_Partial_View
4786 (Typ
, Current_Scope
))
4788 Typ
:= Build_Default_Subtype
(Typ
, N
);
4789 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
4792 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4793 while Present
(Discr
) loop
4794 Nod
:= Node
(Discr
);
4795 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4797 -- AI-416: when the discriminant constraint is an
4798 -- anonymous access type make sure an accessibility
4799 -- check is inserted if necessary (3.10.2(22.q/2))
4801 if Ada_Version
>= Ada_2005
4803 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4805 Apply_Accessibility_Check
4806 (Nod
, Typ
, Insert_Node
=> Nod
);
4814 -- We set the allocator as analyzed so that when we analyze
4815 -- the if expression node, we do not get an unwanted recursive
4816 -- expansion of the allocator expression.
4818 Set_Analyzed
(N
, True);
4819 Nod
:= Relocate_Node
(N
);
4821 -- Here is the transformation:
4822 -- input: new Ctrl_Typ
4823 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4824 -- Ctrl_TypIP (Temp.all, ...);
4825 -- [Deep_]Initialize (Temp.all);
4827 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4828 -- is the subtype of the allocator.
4831 Make_Object_Declaration
(Loc
,
4832 Defining_Identifier
=> Temp
,
4833 Constant_Present
=> True,
4834 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
4837 Set_Assignment_OK
(Temp_Decl
);
4838 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4840 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
4842 -- If the designated type is a task type or contains tasks,
4843 -- create block to activate created tasks, and insert
4844 -- declaration for Task_Image variable ahead of call.
4846 if Has_Task
(T
) then
4848 L
: constant List_Id
:= New_List
;
4851 Build_Task_Allocate_Block
(L
, Nod
, Args
);
4853 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
4854 Insert_Actions
(N
, L
);
4859 Make_Procedure_Call_Statement
(Loc
,
4860 Name
=> New_Occurrence_Of
(Init
, Loc
),
4861 Parameter_Associations
=> Args
));
4864 if Needs_Finalization
(T
) then
4867 -- [Deep_]Initialize (Init_Arg1);
4871 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4874 -- Special processing for .NET/JVM, the allocated object is
4875 -- attached to the finalization master. Generate:
4877 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4879 -- Types derived from [Limited_]Controlled are the only ones
4880 -- considered since they have fields Prev and Next.
4882 if VM_Target
/= No_VM
4883 and then Is_Controlled
(T
)
4884 and then Present
(Finalization_Master
(PtrT
))
4888 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4893 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4894 Analyze_And_Resolve
(N
, PtrT
);
4899 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4900 -- object that has been rewritten as a reference, we displace "this"
4901 -- to reference properly its secondary dispatch table.
4903 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
4904 Displace_Allocator_Pointer
(N
);
4908 when RE_Not_Available
=>
4910 end Expand_N_Allocator
;
4912 -----------------------
4913 -- Expand_N_And_Then --
4914 -----------------------
4916 procedure Expand_N_And_Then
(N
: Node_Id
)
4917 renames Expand_Short_Circuit_Operator
;
4919 ------------------------------
4920 -- Expand_N_Case_Expression --
4921 ------------------------------
4923 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4924 Loc
: constant Source_Ptr
:= Sloc
(N
);
4925 Typ
: constant Entity_Id
:= Etype
(N
);
4936 -- Check for MINIMIZED/ELIMINATED overflow mode
4938 if Minimized_Eliminated_Overflow_Check
(N
) then
4939 Apply_Arithmetic_Overflow_Check
(N
);
4943 -- If the case expression is a predicate specification, do not
4944 -- expand, because it will be converted to the proper predicate
4945 -- form when building the predicate function.
4947 if Ekind_In
(Current_Scope
, E_Function
, E_Procedure
)
4948 and then Is_Predicate_Function
(Current_Scope
)
4955 -- case X is when A => AX, when B => BX ...
4970 -- However, this expansion is wrong for limited types, and also
4971 -- wrong for unconstrained types (since the bounds may not be the
4972 -- same in all branches). Furthermore it involves an extra copy
4973 -- for large objects. So we take care of this by using the following
4974 -- modified expansion for non-elementary types:
4977 -- type Pnn is access all typ;
4981 -- T := AX'Unrestricted_Access;
4983 -- T := BX'Unrestricted_Access;
4989 Make_Case_Statement
(Loc
,
4990 Expression
=> Expression
(N
),
4991 Alternatives
=> New_List
);
4993 -- Preserve the original context for which the case statement is being
4994 -- generated. This is needed by the finalization machinery to prevent
4995 -- the premature finalization of controlled objects found within the
4998 Set_From_Conditional_Expression
(Cstmt
);
5000 Actions
:= New_List
;
5004 if Is_Elementary_Type
(Typ
) then
5008 Pnn
:= Make_Temporary
(Loc
, 'P');
5010 Make_Full_Type_Declaration
(Loc
,
5011 Defining_Identifier
=> Pnn
,
5013 Make_Access_To_Object_Definition
(Loc
,
5014 All_Present
=> True,
5015 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5019 Tnn
:= Make_Temporary
(Loc
, 'T');
5021 -- Create declaration for target of expression, and indicate that it
5022 -- does not require initialization.
5025 Make_Object_Declaration
(Loc
,
5026 Defining_Identifier
=> Tnn
,
5027 Object_Definition
=> New_Occurrence_Of
(Ttyp
, Loc
));
5028 Set_No_Initialization
(Decl
);
5029 Append_To
(Actions
, Decl
);
5031 -- Now process the alternatives
5033 Alt
:= First
(Alternatives
(N
));
5034 while Present
(Alt
) loop
5036 Aexp
: Node_Id
:= Expression
(Alt
);
5037 Aloc
: constant Source_Ptr
:= Sloc
(Aexp
);
5041 -- As described above, take Unrestricted_Access for case of non-
5042 -- scalar types, to avoid big copies, and special cases.
5044 if not Is_Elementary_Type
(Typ
) then
5046 Make_Attribute_Reference
(Aloc
,
5047 Prefix
=> Relocate_Node
(Aexp
),
5048 Attribute_Name
=> Name_Unrestricted_Access
);
5052 Make_Assignment_Statement
(Aloc
,
5053 Name
=> New_Occurrence_Of
(Tnn
, Loc
),
5054 Expression
=> Aexp
));
5056 -- Propagate declarations inserted in the node by Insert_Actions
5057 -- (for example, temporaries generated to remove side effects).
5058 -- These actions must remain attached to the alternative, given
5059 -- that they are generated by the corresponding expression.
5061 if Present
(Sinfo
.Actions
(Alt
)) then
5062 Prepend_List
(Sinfo
.Actions
(Alt
), Stats
);
5066 (Alternatives
(Cstmt
),
5067 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5068 Discrete_Choices
=> Discrete_Choices
(Alt
),
5069 Statements
=> Stats
));
5075 Append_To
(Actions
, Cstmt
);
5077 -- Construct and return final expression with actions
5079 if Is_Elementary_Type
(Typ
) then
5080 Fexp
:= New_Occurrence_Of
(Tnn
, Loc
);
5083 Make_Explicit_Dereference
(Loc
,
5084 Prefix
=> New_Occurrence_Of
(Tnn
, Loc
));
5088 Make_Expression_With_Actions
(Loc
,
5090 Actions
=> Actions
));
5092 Analyze_And_Resolve
(N
, Typ
);
5093 end Expand_N_Case_Expression
;
5095 -----------------------------------
5096 -- Expand_N_Explicit_Dereference --
5097 -----------------------------------
5099 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5101 -- Insert explicit dereference call for the checked storage pool case
5103 Insert_Dereference_Action
(Prefix
(N
));
5105 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5106 -- we set the atomic sync flag.
5108 if Is_Atomic
(Etype
(N
))
5109 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5111 Activate_Atomic_Synchronization
(N
);
5113 end Expand_N_Explicit_Dereference
;
5115 --------------------------------------
5116 -- Expand_N_Expression_With_Actions --
5117 --------------------------------------
5119 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5120 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5121 -- Inspect and process a single action of an expression_with_actions for
5122 -- transient controlled objects. If such objects are found, the routine
5123 -- generates code to clean them up when the context of the expression is
5124 -- evaluated or elaborated.
5126 --------------------
5127 -- Process_Action --
5128 --------------------
5130 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5132 if Nkind
(Act
) = N_Object_Declaration
5133 and then Is_Finalizable_Transient
(Act
, N
)
5135 Process_Transient_Object
(Act
, N
);
5138 -- Avoid processing temporary function results multiple times when
5139 -- dealing with nested expression_with_actions.
5141 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5144 -- Do not process temporary function results in loops. This is done
5145 -- by Expand_N_Loop_Statement and Build_Finalizer.
5147 elsif Nkind
(Act
) = N_Loop_Statement
then
5154 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5158 Acts
: constant List_Id
:= Actions
(N
);
5159 Expr
: constant Node_Id
:= Expression
(N
);
5162 -- Start of processing for Expand_N_Expression_With_Actions
5165 -- Do not evaluate the expression when it denotes an entity because the
5166 -- expression_with_actions node will be replaced by the reference.
5168 if Is_Entity_Name
(Expr
) then
5171 -- Do not evaluate the expression when there are no actions because the
5172 -- expression_with_actions node will be replaced by the expression.
5174 elsif No
(Acts
) or else Is_Empty_List
(Acts
) then
5177 -- Force the evaluation of the expression by capturing its value in a
5178 -- temporary. This ensures that aliases of transient controlled objects
5179 -- do not leak to the expression of the expression_with_actions node:
5182 -- Trans_Id : Ctrl_Typ : ...;
5183 -- Alias : ... := Trans_Id;
5184 -- in ... Alias ... end;
5186 -- In the example above, Trans_Id cannot be finalized at the end of the
5187 -- actions list because this may affect the alias and the final value of
5188 -- the expression_with_actions. Forcing the evaluation encapsulates the
5189 -- reference to the Alias within the actions list:
5192 -- Trans_Id : Ctrl_Typ : ...;
5193 -- Alias : ... := Trans_Id;
5194 -- Val : constant Boolean := ... Alias ...;
5195 -- <finalize Trans_Id>
5198 -- It is now safe to finalize the transient controlled object at the end
5199 -- of the actions list.
5202 Force_Evaluation
(Expr
);
5205 -- Process all transient controlled objects found within the actions of
5208 Act
:= First
(Acts
);
5209 while Present
(Act
) loop
5210 Process_Single_Action
(Act
);
5214 -- Deal with case where there are no actions. In this case we simply
5215 -- rewrite the node with its expression since we don't need the actions
5216 -- and the specification of this node does not allow a null action list.
5218 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5219 -- the expanded tree and relying on being able to retrieve the original
5220 -- tree in cases like this. This raises a whole lot of issues of whether
5221 -- we have problems elsewhere, which will be addressed in the future???
5223 if Is_Empty_List
(Acts
) then
5224 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5226 end Expand_N_Expression_With_Actions
;
5228 ----------------------------
5229 -- Expand_N_If_Expression --
5230 ----------------------------
5232 -- Deal with limited types and condition actions
5234 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5235 procedure Process_Actions
(Actions
: List_Id
);
5236 -- Inspect and process a single action list of an if expression for
5237 -- transient controlled objects. If such objects are found, the routine
5238 -- generates code to clean them up when the context of the expression is
5239 -- evaluated or elaborated.
5241 ---------------------
5242 -- Process_Actions --
5243 ---------------------
5245 procedure Process_Actions
(Actions
: List_Id
) is
5249 Act
:= First
(Actions
);
5250 while Present
(Act
) loop
5251 if Nkind
(Act
) = N_Object_Declaration
5252 and then Is_Finalizable_Transient
(Act
, N
)
5254 Process_Transient_Object
(Act
, N
);
5259 end Process_Actions
;
5263 Loc
: constant Source_Ptr
:= Sloc
(N
);
5264 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5265 Thenx
: constant Node_Id
:= Next
(Cond
);
5266 Elsex
: constant Node_Id
:= Next
(Thenx
);
5267 Typ
: constant Entity_Id
:= Etype
(N
);
5275 Ptr_Typ
: Entity_Id
;
5277 -- Start of processing for Expand_N_If_Expression
5280 -- Check for MINIMIZED/ELIMINATED overflow mode
5282 if Minimized_Eliminated_Overflow_Check
(N
) then
5283 Apply_Arithmetic_Overflow_Check
(N
);
5287 -- Fold at compile time if condition known. We have already folded
5288 -- static if expressions, but it is possible to fold any case in which
5289 -- the condition is known at compile time, even though the result is
5292 -- Note that we don't do the fold of such cases in Sem_Elab because
5293 -- it can cause infinite loops with the expander adding a conditional
5294 -- expression, and Sem_Elab circuitry removing it repeatedly.
5296 if Compile_Time_Known_Value
(Cond
) then
5297 if Is_True
(Expr_Value
(Cond
)) then
5299 Actions
:= Then_Actions
(N
);
5302 Actions
:= Else_Actions
(N
);
5307 if Present
(Actions
) then
5309 Make_Expression_With_Actions
(Loc
,
5310 Expression
=> Relocate_Node
(Expr
),
5311 Actions
=> Actions
));
5312 Analyze_And_Resolve
(N
, Typ
);
5314 Rewrite
(N
, Relocate_Node
(Expr
));
5317 -- Note that the result is never static (legitimate cases of static
5318 -- if expressions were folded in Sem_Eval).
5320 Set_Is_Static_Expression
(N
, False);
5324 -- If the type is limited, and the back end does not handle limited
5325 -- types, then we expand as follows to avoid the possibility of
5326 -- improper copying.
5328 -- type Ptr is access all Typ;
5332 -- Cnn := then-expr'Unrestricted_Access;
5335 -- Cnn := else-expr'Unrestricted_Access;
5338 -- and replace the if expression by a reference to Cnn.all.
5340 -- This special case can be skipped if the back end handles limited
5341 -- types properly and ensures that no incorrect copies are made.
5343 if Is_By_Reference_Type
(Typ
)
5344 and then not Back_End_Handles_Limited_Types
5346 -- When the "then" or "else" expressions involve controlled function
5347 -- calls, generated temporaries are chained on the corresponding list
5348 -- of actions. These temporaries need to be finalized after the if
5349 -- expression is evaluated.
5351 Process_Actions
(Then_Actions
(N
));
5352 Process_Actions
(Else_Actions
(N
));
5355 -- type Ann is access all Typ;
5357 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5360 Make_Full_Type_Declaration
(Loc
,
5361 Defining_Identifier
=> Ptr_Typ
,
5363 Make_Access_To_Object_Definition
(Loc
,
5364 All_Present
=> True,
5365 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5370 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5373 Make_Object_Declaration
(Loc
,
5374 Defining_Identifier
=> Cnn
,
5375 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5379 -- Cnn := <Thenx>'Unrestricted_Access;
5381 -- Cnn := <Elsex>'Unrestricted_Access;
5385 Make_Implicit_If_Statement
(N
,
5386 Condition
=> Relocate_Node
(Cond
),
5387 Then_Statements
=> New_List
(
5388 Make_Assignment_Statement
(Sloc
(Thenx
),
5389 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5391 Make_Attribute_Reference
(Loc
,
5392 Prefix
=> Relocate_Node
(Thenx
),
5393 Attribute_Name
=> Name_Unrestricted_Access
))),
5395 Else_Statements
=> New_List
(
5396 Make_Assignment_Statement
(Sloc
(Elsex
),
5397 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5399 Make_Attribute_Reference
(Loc
,
5400 Prefix
=> Relocate_Node
(Elsex
),
5401 Attribute_Name
=> Name_Unrestricted_Access
))));
5403 -- Preserve the original context for which the if statement is being
5404 -- generated. This is needed by the finalization machinery to prevent
5405 -- the premature finalization of controlled objects found within the
5408 Set_From_Conditional_Expression
(New_If
);
5411 Make_Explicit_Dereference
(Loc
,
5412 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5414 -- If the result is an unconstrained array and the if expression is in a
5415 -- context other than the initializing expression of the declaration of
5416 -- an object, then we pull out the if expression as follows:
5418 -- Cnn : constant typ := if-expression
5420 -- and then replace the if expression with an occurrence of Cnn. This
5421 -- avoids the need in the back end to create on-the-fly variable length
5422 -- temporaries (which it cannot do!)
5424 -- Note that the test for being in an object declaration avoids doing an
5425 -- unnecessary expansion, and also avoids infinite recursion.
5427 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
)
5428 and then (Nkind
(Parent
(N
)) /= N_Object_Declaration
5429 or else Expression
(Parent
(N
)) /= N
)
5432 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5435 Make_Object_Declaration
(Loc
,
5436 Defining_Identifier
=> Cnn
,
5437 Constant_Present
=> True,
5438 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5439 Expression
=> Relocate_Node
(N
),
5440 Has_Init_Expression
=> True));
5442 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
5446 -- For other types, we only need to expand if there are other actions
5447 -- associated with either branch.
5449 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5451 -- We now wrap the actions into the appropriate expression
5453 if Present
(Then_Actions
(N
)) then
5455 Make_Expression_With_Actions
(Sloc
(Thenx
),
5456 Actions
=> Then_Actions
(N
),
5457 Expression
=> Relocate_Node
(Thenx
)));
5459 Set_Then_Actions
(N
, No_List
);
5460 Analyze_And_Resolve
(Thenx
, Typ
);
5463 if Present
(Else_Actions
(N
)) then
5465 Make_Expression_With_Actions
(Sloc
(Elsex
),
5466 Actions
=> Else_Actions
(N
),
5467 Expression
=> Relocate_Node
(Elsex
)));
5469 Set_Else_Actions
(N
, No_List
);
5470 Analyze_And_Resolve
(Elsex
, Typ
);
5475 -- If no actions then no expansion needed, gigi will handle it using the
5476 -- same approach as a C conditional expression.
5482 -- Fall through here for either the limited expansion, or the case of
5483 -- inserting actions for non-limited types. In both these cases, we must
5484 -- move the SLOC of the parent If statement to the newly created one and
5485 -- change it to the SLOC of the expression which, after expansion, will
5486 -- correspond to what is being evaluated.
5488 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
5489 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5490 Set_Sloc
(Parent
(N
), Loc
);
5493 -- Make sure Then_Actions and Else_Actions are appropriately moved
5494 -- to the new if statement.
5496 if Present
(Then_Actions
(N
)) then
5498 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5501 if Present
(Else_Actions
(N
)) then
5503 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5506 Insert_Action
(N
, Decl
);
5507 Insert_Action
(N
, New_If
);
5509 Analyze_And_Resolve
(N
, Typ
);
5510 end Expand_N_If_Expression
;
5516 procedure Expand_N_In
(N
: Node_Id
) is
5517 Loc
: constant Source_Ptr
:= Sloc
(N
);
5518 Restyp
: constant Entity_Id
:= Etype
(N
);
5519 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5520 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5521 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5526 procedure Substitute_Valid_Check
;
5527 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5528 -- test for the left operand being in range of its subtype.
5530 ----------------------------
5531 -- Substitute_Valid_Check --
5532 ----------------------------
5534 procedure Substitute_Valid_Check
is
5537 Make_Attribute_Reference
(Loc
,
5538 Prefix
=> Relocate_Node
(Lop
),
5539 Attribute_Name
=> Name_Valid
));
5541 Analyze_And_Resolve
(N
, Restyp
);
5543 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5544 -- in which case, this usage makes sense, and in any case, we have
5545 -- actually eliminated the danger of optimization above.
5547 if Overflow_Check_Mode
not in Minimized_Or_Eliminated
then
5549 ("??explicit membership test may be optimized away", N
);
5550 Error_Msg_N
-- CODEFIX
5551 ("\??use ''Valid attribute instead", N
);
5555 end Substitute_Valid_Check
;
5557 -- Start of processing for Expand_N_In
5560 -- If set membership case, expand with separate procedure
5562 if Present
(Alternatives
(N
)) then
5563 Expand_Set_Membership
(N
);
5567 -- Not set membership, proceed with expansion
5569 Ltyp
:= Etype
(Left_Opnd
(N
));
5570 Rtyp
:= Etype
(Right_Opnd
(N
));
5572 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5573 -- type, then expand with a separate procedure. Note the use of the
5574 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5576 if Overflow_Check_Mode
in Minimized_Or_Eliminated
5577 and then Is_Signed_Integer_Type
(Ltyp
)
5578 and then not No_Minimize_Eliminate
(N
)
5580 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
5584 -- Check case of explicit test for an expression in range of its
5585 -- subtype. This is suspicious usage and we replace it with a 'Valid
5586 -- test and give a warning for scalar types.
5588 if Is_Scalar_Type
(Ltyp
)
5590 -- Only relevant for source comparisons
5592 and then Comes_From_Source
(N
)
5594 -- In floating-point this is a standard way to check for finite values
5595 -- and using 'Valid would typically be a pessimization.
5597 and then not Is_Floating_Point_Type
(Ltyp
)
5599 -- Don't give the message unless right operand is a type entity and
5600 -- the type of the left operand matches this type. Note that this
5601 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5602 -- checks have changed the type of the left operand.
5604 and then Nkind
(Rop
) in N_Has_Entity
5605 and then Ltyp
= Entity
(Rop
)
5607 -- Skip in VM mode, where we have no sense of invalid values. The
5608 -- warning still seems relevant, but not important enough to worry.
5610 and then VM_Target
= No_VM
5612 -- Skip this for predicated types, where such expressions are a
5613 -- reasonable way of testing if something meets the predicate.
5615 and then not Present
(Predicate_Function
(Ltyp
))
5617 Substitute_Valid_Check
;
5621 -- Do validity check on operands
5623 if Validity_Checks_On
and Validity_Check_Operands
then
5624 Ensure_Valid
(Left_Opnd
(N
));
5625 Validity_Check_Range
(Right_Opnd
(N
));
5628 -- Case of explicit range
5630 if Nkind
(Rop
) = N_Range
then
5632 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
5633 Hi
: constant Node_Id
:= High_Bound
(Rop
);
5635 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
5636 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
5638 Lcheck
: Compare_Result
;
5639 Ucheck
: Compare_Result
;
5641 Warn1
: constant Boolean :=
5642 Constant_Condition_Warnings
5643 and then Comes_From_Source
(N
)
5644 and then not In_Instance
;
5645 -- This must be true for any of the optimization warnings, we
5646 -- clearly want to give them only for source with the flag on. We
5647 -- also skip these warnings in an instance since it may be the
5648 -- case that different instantiations have different ranges.
5650 Warn2
: constant Boolean :=
5652 and then Nkind
(Original_Node
(Rop
)) = N_Range
5653 and then Is_Integer_Type
(Etype
(Lo
));
5654 -- For the case where only one bound warning is elided, we also
5655 -- insist on an explicit range and an integer type. The reason is
5656 -- that the use of enumeration ranges including an end point is
5657 -- common, as is the use of a subtype name, one of whose bounds is
5658 -- the same as the type of the expression.
5661 -- If test is explicit x'First .. x'Last, replace by valid check
5663 -- Could use some individual comments for this complex test ???
5665 if Is_Scalar_Type
(Ltyp
)
5667 -- And left operand is X'First where X matches left operand
5668 -- type (this eliminates cases of type mismatch, including
5669 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5670 -- type of the left operand.
5672 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
5673 and then Attribute_Name
(Lo_Orig
) = Name_First
5674 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
5675 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
5677 -- Same tests for right operand
5679 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
5680 and then Attribute_Name
(Hi_Orig
) = Name_Last
5681 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
5682 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
5684 -- Relevant only for source cases
5686 and then Comes_From_Source
(N
)
5688 -- Omit for VM cases, where we don't have invalid values
5690 and then VM_Target
= No_VM
5692 Substitute_Valid_Check
;
5696 -- If bounds of type are known at compile time, and the end points
5697 -- are known at compile time and identical, this is another case
5698 -- for substituting a valid test. We only do this for discrete
5699 -- types, since it won't arise in practice for float types.
5701 if Comes_From_Source
(N
)
5702 and then Is_Discrete_Type
(Ltyp
)
5703 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
5704 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
5705 and then Compile_Time_Known_Value
(Lo
)
5706 and then Compile_Time_Known_Value
(Hi
)
5707 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
5708 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
5710 -- Kill warnings in instances, since they may be cases where we
5711 -- have a test in the generic that makes sense with some types
5712 -- and not with other types.
5714 and then not In_Instance
5716 Substitute_Valid_Check
;
5720 -- If we have an explicit range, do a bit of optimization based on
5721 -- range analysis (we may be able to kill one or both checks).
5723 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
5724 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
5726 -- If either check is known to fail, replace result by False since
5727 -- the other check does not matter. Preserve the static flag for
5728 -- legality checks, because we are constant-folding beyond RM 4.9.
5730 if Lcheck
= LT
or else Ucheck
= GT
then
5732 Error_Msg_N
("?c?range test optimized away", N
);
5733 Error_Msg_N
("\?c?value is known to be out of range", N
);
5736 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5737 Analyze_And_Resolve
(N
, Restyp
);
5738 Set_Is_Static_Expression
(N
, Static
);
5741 -- If both checks are known to succeed, replace result by True,
5742 -- since we know we are in range.
5744 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5746 Error_Msg_N
("?c?range test optimized away", N
);
5747 Error_Msg_N
("\?c?value is known to be in range", N
);
5750 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5751 Analyze_And_Resolve
(N
, Restyp
);
5752 Set_Is_Static_Expression
(N
, Static
);
5755 -- If lower bound check succeeds and upper bound check is not
5756 -- known to succeed or fail, then replace the range check with
5757 -- a comparison against the upper bound.
5759 elsif Lcheck
in Compare_GE
then
5760 if Warn2
and then not In_Instance
then
5761 Error_Msg_N
("??lower bound test optimized away", Lo
);
5762 Error_Msg_N
("\??value is known to be in range", Lo
);
5768 Right_Opnd
=> High_Bound
(Rop
)));
5769 Analyze_And_Resolve
(N
, Restyp
);
5772 -- If upper bound check succeeds and lower bound check is not
5773 -- known to succeed or fail, then replace the range check with
5774 -- a comparison against the lower bound.
5776 elsif Ucheck
in Compare_LE
then
5777 if Warn2
and then not In_Instance
then
5778 Error_Msg_N
("??upper bound test optimized away", Hi
);
5779 Error_Msg_N
("\??value is known to be in range", Hi
);
5785 Right_Opnd
=> Low_Bound
(Rop
)));
5786 Analyze_And_Resolve
(N
, Restyp
);
5790 -- We couldn't optimize away the range check, but there is one
5791 -- more issue. If we are checking constant conditionals, then we
5792 -- see if we can determine the outcome assuming everything is
5793 -- valid, and if so give an appropriate warning.
5795 if Warn1
and then not Assume_No_Invalid_Values
then
5796 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
5797 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
5799 -- Result is out of range for valid value
5801 if Lcheck
= LT
or else Ucheck
= GT
then
5803 ("?c?value can only be in range if it is invalid", N
);
5805 -- Result is in range for valid value
5807 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5809 ("?c?value can only be out of range if it is invalid", N
);
5811 -- Lower bound check succeeds if value is valid
5813 elsif Warn2
and then Lcheck
in Compare_GE
then
5815 ("?c?lower bound check only fails if it is invalid", Lo
);
5817 -- Upper bound check succeeds if value is valid
5819 elsif Warn2
and then Ucheck
in Compare_LE
then
5821 ("?c?upper bound check only fails for invalid values", Hi
);
5826 -- For all other cases of an explicit range, nothing to be done
5830 -- Here right operand is a subtype mark
5834 Typ
: Entity_Id
:= Etype
(Rop
);
5835 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
5836 Cond
: Node_Id
:= Empty
;
5838 Obj
: Node_Id
:= Lop
;
5839 SCIL_Node
: Node_Id
;
5842 Remove_Side_Effects
(Obj
);
5844 -- For tagged type, do tagged membership operation
5846 if Is_Tagged_Type
(Typ
) then
5848 -- No expansion will be performed when VM_Target, as the VM
5849 -- back-ends will handle the membership tests directly (tags
5850 -- are not explicitly represented in Java objects, so the
5851 -- normal tagged membership expansion is not what we want).
5853 if Tagged_Type_Expansion
then
5854 Tagged_Membership
(N
, SCIL_Node
, New_N
);
5856 Analyze_And_Resolve
(N
, Restyp
);
5858 -- Update decoration of relocated node referenced by the
5861 if Generate_SCIL
and then Present
(SCIL_Node
) then
5862 Set_SCIL_Node
(N
, SCIL_Node
);
5868 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5869 -- This reason we do this is that the bounds may have the wrong
5870 -- type if they come from the original type definition. Also this
5871 -- way we get all the processing above for an explicit range.
5873 -- Don't do this for predicated types, since in this case we
5874 -- want to check the predicate.
5876 elsif Is_Scalar_Type
(Typ
) then
5877 if No
(Predicate_Function
(Typ
)) then
5881 Make_Attribute_Reference
(Loc
,
5882 Attribute_Name
=> Name_First
,
5883 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
5886 Make_Attribute_Reference
(Loc
,
5887 Attribute_Name
=> Name_Last
,
5888 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
5889 Analyze_And_Resolve
(N
, Restyp
);
5894 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5895 -- a membership test if the subtype mark denotes a constrained
5896 -- Unchecked_Union subtype and the expression lacks inferable
5899 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
5900 and then Is_Constrained
(Typ
)
5901 and then not Has_Inferable_Discriminants
(Lop
)
5904 Make_Raise_Program_Error
(Loc
,
5905 Reason
=> PE_Unchecked_Union_Restriction
));
5907 -- Prevent Gigi from generating incorrect code by rewriting the
5908 -- test as False. What is this undocumented thing about ???
5910 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5914 -- Here we have a non-scalar type
5917 Typ
:= Designated_Type
(Typ
);
5920 if not Is_Constrained
(Typ
) then
5921 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5922 Analyze_And_Resolve
(N
, Restyp
);
5924 -- For the constrained array case, we have to check the subscripts
5925 -- for an exact match if the lengths are non-zero (the lengths
5926 -- must match in any case).
5928 elsif Is_Array_Type
(Typ
) then
5929 Check_Subscripts
: declare
5930 function Build_Attribute_Reference
5933 Dim
: Nat
) return Node_Id
;
5934 -- Build attribute reference E'Nam (Dim)
5936 -------------------------------
5937 -- Build_Attribute_Reference --
5938 -------------------------------
5940 function Build_Attribute_Reference
5943 Dim
: Nat
) return Node_Id
5947 Make_Attribute_Reference
(Loc
,
5949 Attribute_Name
=> Nam
,
5950 Expressions
=> New_List
(
5951 Make_Integer_Literal
(Loc
, Dim
)));
5952 end Build_Attribute_Reference
;
5954 -- Start of processing for Check_Subscripts
5957 for J
in 1 .. Number_Dimensions
(Typ
) loop
5958 Evolve_And_Then
(Cond
,
5961 Build_Attribute_Reference
5962 (Duplicate_Subexpr_No_Checks
(Obj
),
5965 Build_Attribute_Reference
5966 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
5968 Evolve_And_Then
(Cond
,
5971 Build_Attribute_Reference
5972 (Duplicate_Subexpr_No_Checks
(Obj
),
5975 Build_Attribute_Reference
5976 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
5985 Right_Opnd
=> Make_Null
(Loc
)),
5986 Right_Opnd
=> Cond
);
5990 Analyze_And_Resolve
(N
, Restyp
);
5991 end Check_Subscripts
;
5993 -- These are the cases where constraint checks may be required,
5994 -- e.g. records with possible discriminants
5997 -- Expand the test into a series of discriminant comparisons.
5998 -- The expression that is built is the negation of the one that
5999 -- is used for checking discriminant constraints.
6001 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6003 if Has_Discriminants
(Typ
) then
6004 Cond
:= Make_Op_Not
(Loc
,
6005 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6008 Cond
:= Make_Or_Else
(Loc
,
6012 Right_Opnd
=> Make_Null
(Loc
)),
6013 Right_Opnd
=> Cond
);
6017 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6021 Analyze_And_Resolve
(N
, Restyp
);
6024 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6025 -- expression of an anonymous access type. This can involve an
6026 -- accessibility test and a tagged type membership test in the
6027 -- case of tagged designated types.
6029 if Ada_Version
>= Ada_2012
6031 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6034 Expr_Entity
: Entity_Id
:= Empty
;
6036 Param_Level
: Node_Id
;
6037 Type_Level
: Node_Id
;
6040 if Is_Entity_Name
(Lop
) then
6041 Expr_Entity
:= Param_Entity
(Lop
);
6043 if not Present
(Expr_Entity
) then
6044 Expr_Entity
:= Entity
(Lop
);
6048 -- If a conversion of the anonymous access value to the
6049 -- tested type would be illegal, then the result is False.
6051 if not Valid_Conversion
6052 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6054 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6055 Analyze_And_Resolve
(N
, Restyp
);
6057 -- Apply an accessibility check if the access object has an
6058 -- associated access level and when the level of the type is
6059 -- less deep than the level of the access parameter. This
6060 -- only occur for access parameters and stand-alone objects
6061 -- of an anonymous access type.
6064 if Present
(Expr_Entity
)
6067 (Effective_Extra_Accessibility
(Expr_Entity
))
6068 and then UI_Gt
(Object_Access_Level
(Lop
),
6069 Type_Access_Level
(Rtyp
))
6073 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
6076 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6078 -- Return True only if the accessibility level of the
6079 -- expression entity is not deeper than the level of
6080 -- the tested access type.
6084 Left_Opnd
=> Relocate_Node
(N
),
6085 Right_Opnd
=> Make_Op_Le
(Loc
,
6086 Left_Opnd
=> Param_Level
,
6087 Right_Opnd
=> Type_Level
)));
6089 Analyze_And_Resolve
(N
);
6092 -- If the designated type is tagged, do tagged membership
6095 -- *** NOTE: we have to check not null before doing the
6096 -- tagged membership test (but maybe that can be done
6097 -- inside Tagged_Membership?).
6099 if Is_Tagged_Type
(Typ
) then
6102 Left_Opnd
=> Relocate_Node
(N
),
6106 Right_Opnd
=> Make_Null
(Loc
))));
6108 -- No expansion will be performed when VM_Target, as
6109 -- the VM back-ends will handle the membership tests
6110 -- directly (tags are not explicitly represented in
6111 -- Java objects, so the normal tagged membership
6112 -- expansion is not what we want).
6114 if Tagged_Type_Expansion
then
6116 -- Note that we have to pass Original_Node, because
6117 -- the membership test might already have been
6118 -- rewritten by earlier parts of membership test.
6121 (Original_Node
(N
), SCIL_Node
, New_N
);
6123 -- Update decoration of relocated node referenced
6124 -- by the SCIL node.
6126 if Generate_SCIL
and then Present
(SCIL_Node
) then
6127 Set_SCIL_Node
(New_N
, SCIL_Node
);
6132 Left_Opnd
=> Relocate_Node
(N
),
6133 Right_Opnd
=> New_N
));
6135 Analyze_And_Resolve
(N
, Restyp
);
6144 -- At this point, we have done the processing required for the basic
6145 -- membership test, but not yet dealt with the predicate.
6149 -- If a predicate is present, then we do the predicate test, but we
6150 -- most certainly want to omit this if we are within the predicate
6151 -- function itself, since otherwise we have an infinite recursion.
6152 -- The check should also not be emitted when testing against a range
6153 -- (the check is only done when the right operand is a subtype; see
6154 -- RM12-4.5.2 (28.1/3-30/3)).
6157 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6161 and then Current_Scope
/= PFunc
6162 and then Nkind
(Rop
) /= N_Range
6166 Left_Opnd
=> Relocate_Node
(N
),
6167 Right_Opnd
=> Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True)));
6169 -- Analyze new expression, mark left operand as analyzed to
6170 -- avoid infinite recursion adding predicate calls. Similarly,
6171 -- suppress further range checks on the call.
6173 Set_Analyzed
(Left_Opnd
(N
));
6174 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6176 -- All done, skip attempt at compile time determination of result
6183 --------------------------------
6184 -- Expand_N_Indexed_Component --
6185 --------------------------------
6187 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6188 Loc
: constant Source_Ptr
:= Sloc
(N
);
6189 Typ
: constant Entity_Id
:= Etype
(N
);
6190 P
: constant Node_Id
:= Prefix
(N
);
6191 T
: constant Entity_Id
:= Etype
(P
);
6195 -- A special optimization, if we have an indexed component that is
6196 -- selecting from a slice, then we can eliminate the slice, since, for
6197 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6198 -- the range check required by the slice. The range check for the slice
6199 -- itself has already been generated. The range check for the
6200 -- subscripting operation is ensured by converting the subject to
6201 -- the subtype of the slice.
6203 -- This optimization not only generates better code, avoiding slice
6204 -- messing especially in the packed case, but more importantly bypasses
6205 -- some problems in handling this peculiar case, for example, the issue
6206 -- of dealing specially with object renamings.
6208 if Nkind
(P
) = N_Slice
6210 -- This optimization is disabled for CodePeer because it can transform
6211 -- an index-check constraint_error into a range-check constraint_error
6212 -- and CodePeer cares about that distinction.
6214 and then not CodePeer_Mode
6217 Make_Indexed_Component
(Loc
,
6218 Prefix
=> Prefix
(P
),
6219 Expressions
=> New_List
(
6221 (Etype
(First_Index
(Etype
(P
))),
6222 First
(Expressions
(N
))))));
6223 Analyze_And_Resolve
(N
, Typ
);
6227 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6228 -- function, then additional actuals must be passed.
6230 if Ada_Version
>= Ada_2005
6231 and then Is_Build_In_Place_Function_Call
(P
)
6233 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6236 -- If the prefix is an access type, then we unconditionally rewrite if
6237 -- as an explicit dereference. This simplifies processing for several
6238 -- cases, including packed array cases and certain cases in which checks
6239 -- must be generated. We used to try to do this only when it was
6240 -- necessary, but it cleans up the code to do it all the time.
6242 if Is_Access_Type
(T
) then
6243 Insert_Explicit_Dereference
(P
);
6244 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6245 Atp
:= Designated_Type
(T
);
6250 -- Generate index and validity checks
6252 Generate_Index_Checks
(N
);
6254 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6255 Apply_Subscript_Validity_Checks
(N
);
6258 -- If selecting from an array with atomic components, and atomic sync
6259 -- is not suppressed for this array type, set atomic sync flag.
6261 if (Has_Atomic_Components
(Atp
)
6262 and then not Atomic_Synchronization_Disabled
(Atp
))
6263 or else (Is_Atomic
(Typ
)
6264 and then not Atomic_Synchronization_Disabled
(Typ
))
6266 Activate_Atomic_Synchronization
(N
);
6269 -- All done for the non-packed case
6271 if not Is_Packed
(Etype
(Prefix
(N
))) then
6275 -- For packed arrays that are not bit-packed (i.e. the case of an array
6276 -- with one or more index types with a non-contiguous enumeration type),
6277 -- we can always use the normal packed element get circuit.
6279 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6280 Expand_Packed_Element_Reference
(N
);
6284 -- For a reference to a component of a bit packed array, we convert it
6285 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6286 -- want to do this for simple references, and not for:
6288 -- Left side of assignment, or prefix of left side of assignment, or
6289 -- prefix of the prefix, to handle packed arrays of packed arrays,
6290 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6292 -- Renaming objects in renaming associations
6293 -- This case is handled when a use of the renamed variable occurs
6295 -- Actual parameters for a procedure call
6296 -- This case is handled in Exp_Ch6.Expand_Actuals
6298 -- The second expression in a 'Read attribute reference
6300 -- The prefix of an address or bit or size attribute reference
6302 -- The following circuit detects these exceptions. Note that we need to
6303 -- deal with implicit dereferences when climbing up the parent chain,
6304 -- with the additional difficulty that the type of parents may have yet
6305 -- to be resolved since prefixes are usually resolved first.
6308 Child
: Node_Id
:= N
;
6309 Parnt
: Node_Id
:= Parent
(N
);
6313 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6316 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6317 N_Procedure_Call_Statement
)
6318 or else (Nkind
(Parnt
) = N_Parameter_Association
6320 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6324 elsif Nkind
(Parnt
) = N_Attribute_Reference
6325 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
6328 and then Prefix
(Parnt
) = Child
6332 elsif Nkind
(Parnt
) = N_Assignment_Statement
6333 and then Name
(Parnt
) = Child
6337 -- If the expression is an index of an indexed component, it must
6338 -- be expanded regardless of context.
6340 elsif Nkind
(Parnt
) = N_Indexed_Component
6341 and then Child
/= Prefix
(Parnt
)
6343 Expand_Packed_Element_Reference
(N
);
6346 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6347 and then Name
(Parent
(Parnt
)) = Parnt
6351 elsif Nkind
(Parnt
) = N_Attribute_Reference
6352 and then Attribute_Name
(Parnt
) = Name_Read
6353 and then Next
(First
(Expressions
(Parnt
))) = Child
6357 elsif Nkind
(Parnt
) = N_Indexed_Component
6358 and then Prefix
(Parnt
) = Child
6362 elsif Nkind
(Parnt
) = N_Selected_Component
6363 and then Prefix
(Parnt
) = Child
6364 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
6366 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
6370 -- If the parent is a dereference, either implicit or explicit,
6371 -- then the packed reference needs to be expanded.
6374 Expand_Packed_Element_Reference
(N
);
6378 -- Keep looking up tree for unchecked expression, or if we are the
6379 -- prefix of a possible assignment left side.
6382 Parnt
:= Parent
(Child
);
6385 end Expand_N_Indexed_Component
;
6387 ---------------------
6388 -- Expand_N_Not_In --
6389 ---------------------
6391 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6392 -- can be done. This avoids needing to duplicate this expansion code.
6394 procedure Expand_N_Not_In
(N
: Node_Id
) is
6395 Loc
: constant Source_Ptr
:= Sloc
(N
);
6396 Typ
: constant Entity_Id
:= Etype
(N
);
6397 Cfs
: constant Boolean := Comes_From_Source
(N
);
6404 Left_Opnd
=> Left_Opnd
(N
),
6405 Right_Opnd
=> Right_Opnd
(N
))));
6407 -- If this is a set membership, preserve list of alternatives
6409 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6411 -- We want this to appear as coming from source if original does (see
6412 -- transformations in Expand_N_In).
6414 Set_Comes_From_Source
(N
, Cfs
);
6415 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6417 -- Now analyze transformed node
6419 Analyze_And_Resolve
(N
, Typ
);
6420 end Expand_N_Not_In
;
6426 -- The only replacement required is for the case of a null of a type that
6427 -- is an access to protected subprogram, or a subtype thereof. We represent
6428 -- such access values as a record, and so we must replace the occurrence of
6429 -- null by the equivalent record (with a null address and a null pointer in
6430 -- it), so that the backend creates the proper value.
6432 procedure Expand_N_Null
(N
: Node_Id
) is
6433 Loc
: constant Source_Ptr
:= Sloc
(N
);
6434 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6438 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6440 Make_Aggregate
(Loc
,
6441 Expressions
=> New_List
(
6442 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6446 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6448 -- For subsequent semantic analysis, the node must retain its type.
6449 -- Gigi in any case replaces this type by the corresponding record
6450 -- type before processing the node.
6456 when RE_Not_Available
=>
6460 ---------------------
6461 -- Expand_N_Op_Abs --
6462 ---------------------
6464 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6465 Loc
: constant Source_Ptr
:= Sloc
(N
);
6466 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6469 Unary_Op_Validity_Checks
(N
);
6471 -- Check for MINIMIZED/ELIMINATED overflow mode
6473 if Minimized_Eliminated_Overflow_Check
(N
) then
6474 Apply_Arithmetic_Overflow_Check
(N
);
6478 -- Deal with software overflow checking
6480 if not Backend_Overflow_Checks_On_Target
6481 and then Is_Signed_Integer_Type
(Etype
(N
))
6482 and then Do_Overflow_Check
(N
)
6484 -- The only case to worry about is when the argument is equal to the
6485 -- largest negative number, so what we do is to insert the check:
6487 -- [constraint_error when Expr = typ'Base'First]
6489 -- with the usual Duplicate_Subexpr use coding for expr
6492 Make_Raise_Constraint_Error
(Loc
,
6495 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6497 Make_Attribute_Reference
(Loc
,
6499 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6500 Attribute_Name
=> Name_First
)),
6501 Reason
=> CE_Overflow_Check_Failed
));
6503 end Expand_N_Op_Abs
;
6505 ---------------------
6506 -- Expand_N_Op_Add --
6507 ---------------------
6509 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6510 Typ
: constant Entity_Id
:= Etype
(N
);
6513 Binary_Op_Validity_Checks
(N
);
6515 -- Check for MINIMIZED/ELIMINATED overflow mode
6517 if Minimized_Eliminated_Overflow_Check
(N
) then
6518 Apply_Arithmetic_Overflow_Check
(N
);
6522 -- N + 0 = 0 + N = N for integer types
6524 if Is_Integer_Type
(Typ
) then
6525 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6526 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6528 Rewrite
(N
, Left_Opnd
(N
));
6531 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6532 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
6534 Rewrite
(N
, Right_Opnd
(N
));
6539 -- Arithmetic overflow checks for signed integer/fixed point types
6541 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
6542 Apply_Arithmetic_Overflow_Check
(N
);
6546 -- Overflow checks for floating-point if -gnateF mode active
6548 Check_Float_Op_Overflow
(N
);
6549 end Expand_N_Op_Add
;
6551 ---------------------
6552 -- Expand_N_Op_And --
6553 ---------------------
6555 procedure Expand_N_Op_And
(N
: Node_Id
) is
6556 Typ
: constant Entity_Id
:= Etype
(N
);
6559 Binary_Op_Validity_Checks
(N
);
6561 if Is_Array_Type
(Etype
(N
)) then
6562 Expand_Boolean_Operator
(N
);
6564 elsif Is_Boolean_Type
(Etype
(N
)) then
6565 Adjust_Condition
(Left_Opnd
(N
));
6566 Adjust_Condition
(Right_Opnd
(N
));
6567 Set_Etype
(N
, Standard_Boolean
);
6568 Adjust_Result_Type
(N
, Typ
);
6570 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
6571 Expand_Intrinsic_Call
(N
, Entity
(N
));
6574 end Expand_N_Op_And
;
6576 ------------------------
6577 -- Expand_N_Op_Concat --
6578 ------------------------
6580 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
6582 -- List of operands to be concatenated
6585 -- Node which is to be replaced by the result of concatenating the nodes
6586 -- in the list Opnds.
6589 -- Ensure validity of both operands
6591 Binary_Op_Validity_Checks
(N
);
6593 -- If we are the left operand of a concatenation higher up the tree,
6594 -- then do nothing for now, since we want to deal with a series of
6595 -- concatenations as a unit.
6597 if Nkind
(Parent
(N
)) = N_Op_Concat
6598 and then N
= Left_Opnd
(Parent
(N
))
6603 -- We get here with a concatenation whose left operand may be a
6604 -- concatenation itself with a consistent type. We need to process
6605 -- these concatenation operands from left to right, which means
6606 -- from the deepest node in the tree to the highest node.
6609 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
6610 Cnode
:= Left_Opnd
(Cnode
);
6613 -- Now Cnode is the deepest concatenation, and its parents are the
6614 -- concatenation nodes above, so now we process bottom up, doing the
6617 -- The outer loop runs more than once if more than one concatenation
6618 -- type is involved.
6621 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
6622 Set_Parent
(Opnds
, N
);
6624 -- The inner loop gathers concatenation operands
6626 Inner
: while Cnode
/= N
6627 and then Base_Type
(Etype
(Cnode
)) =
6628 Base_Type
(Etype
(Parent
(Cnode
)))
6630 Cnode
:= Parent
(Cnode
);
6631 Append
(Right_Opnd
(Cnode
), Opnds
);
6634 -- Note: The following code is a temporary workaround for N731-034
6635 -- and N829-028 and will be kept until the general issue of internal
6636 -- symbol serialization is addressed. The workaround is kept under a
6637 -- debug switch to avoid permiating into the general case.
6639 -- Wrap the node to concatenate into an expression actions node to
6640 -- keep it nicely packaged. This is useful in the case of an assert
6641 -- pragma with a concatenation where we want to be able to delete
6642 -- the concatenation and all its expansion stuff.
6644 if Debug_Flag_Dot_H
then
6646 Cnod
: constant Node_Id
:= Relocate_Node
(Cnode
);
6647 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
6650 -- Note: use Rewrite rather than Replace here, so that for
6651 -- example Why_Not_Static can find the original concatenation
6655 Make_Expression_With_Actions
(Sloc
(Cnode
),
6656 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
6657 Expression
=> Cnod
));
6659 Expand_Concatenate
(Cnod
, Opnds
);
6660 Analyze_And_Resolve
(Cnode
, Typ
);
6666 Expand_Concatenate
(Cnode
, Opnds
);
6669 exit Outer
when Cnode
= N
;
6670 Cnode
:= Parent
(Cnode
);
6672 end Expand_N_Op_Concat
;
6674 ------------------------
6675 -- Expand_N_Op_Divide --
6676 ------------------------
6678 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
6679 Loc
: constant Source_Ptr
:= Sloc
(N
);
6680 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
6681 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
6682 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
6683 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
6684 Typ
: Entity_Id
:= Etype
(N
);
6685 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
6687 Compile_Time_Known_Value
(Ropnd
);
6691 Binary_Op_Validity_Checks
(N
);
6693 -- Check for MINIMIZED/ELIMINATED overflow mode
6695 if Minimized_Eliminated_Overflow_Check
(N
) then
6696 Apply_Arithmetic_Overflow_Check
(N
);
6700 -- Otherwise proceed with expansion of division
6703 Rval
:= Expr_Value
(Ropnd
);
6706 -- N / 1 = N for integer types
6708 if Rknow
and then Rval
= Uint_1
then
6713 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6714 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6715 -- operand is an unsigned integer, as required for this to work.
6717 if Nkind
(Ropnd
) = N_Op_Expon
6718 and then Is_Power_Of_2_For_Shift
(Ropnd
)
6720 -- We cannot do this transformation in configurable run time mode if we
6721 -- have 64-bit integers and long shifts are not available.
6723 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
6726 Make_Op_Shift_Right
(Loc
,
6729 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
6730 Analyze_And_Resolve
(N
, Typ
);
6734 -- Do required fixup of universal fixed operation
6736 if Typ
= Universal_Fixed
then
6737 Fixup_Universal_Fixed_Operation
(N
);
6741 -- Divisions with fixed-point results
6743 if Is_Fixed_Point_Type
(Typ
) then
6745 -- Deal with divide-by-zero check if back end cannot handle them
6746 -- and the flag is set indicating that we need such a check. Note
6747 -- that we don't need to bother here with the case of mixed-mode
6748 -- (Right operand an integer type), since these will be rewritten
6749 -- with conversions to a divide with a fixed-point right operand.
6751 if Do_Division_Check
(N
)
6752 and then not Backend_Divide_Checks_On_Target
6753 and then not Is_Integer_Type
(Rtyp
)
6755 Set_Do_Division_Check
(N
, False);
6757 Make_Raise_Constraint_Error
(Loc
,
6760 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
6761 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
6762 Reason
=> CE_Divide_By_Zero
));
6765 -- No special processing if Treat_Fixed_As_Integer is set, since
6766 -- from a semantic point of view such operations are simply integer
6767 -- operations and will be treated that way.
6769 if not Treat_Fixed_As_Integer
(N
) then
6770 if Is_Integer_Type
(Rtyp
) then
6771 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
6773 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
6777 -- Other cases of division of fixed-point operands. Again we exclude the
6778 -- case where Treat_Fixed_As_Integer is set.
6780 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
6781 and then not Treat_Fixed_As_Integer
(N
)
6783 if Is_Integer_Type
(Typ
) then
6784 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
6786 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6787 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
6790 -- Mixed-mode operations can appear in a non-static universal context,
6791 -- in which case the integer argument must be converted explicitly.
6793 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
6795 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
6797 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
6799 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
6801 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
6803 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
6805 -- Non-fixed point cases, do integer zero divide and overflow checks
6807 elsif Is_Integer_Type
(Typ
) then
6808 Apply_Divide_Checks
(N
);
6811 -- Overflow checks for floating-point if -gnateF mode active
6813 Check_Float_Op_Overflow
(N
);
6814 end Expand_N_Op_Divide
;
6816 --------------------
6817 -- Expand_N_Op_Eq --
6818 --------------------
6820 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
6821 Loc
: constant Source_Ptr
:= Sloc
(N
);
6822 Typ
: constant Entity_Id
:= Etype
(N
);
6823 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
6824 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
6825 Bodies
: constant List_Id
:= New_List
;
6826 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
6828 Typl
: Entity_Id
:= A_Typ
;
6829 Op_Name
: Entity_Id
;
6832 procedure Build_Equality_Call
(Eq
: Entity_Id
);
6833 -- If a constructed equality exists for the type or for its parent,
6834 -- build and analyze call, adding conversions if the operation is
6837 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
6838 -- Determines whether a type has a subcomponent of an unconstrained
6839 -- Unchecked_Union subtype. Typ is a record type.
6841 -------------------------
6842 -- Build_Equality_Call --
6843 -------------------------
6845 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
6846 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
6847 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
6848 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
6851 -- Adjust operands if necessary to comparison type
6853 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
6854 and then not Is_Class_Wide_Type
(A_Typ
)
6856 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
6857 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
6860 -- If we have an Unchecked_Union, we need to add the inferred
6861 -- discriminant values as actuals in the function call. At this
6862 -- point, the expansion has determined that both operands have
6863 -- inferable discriminants.
6865 if Is_Unchecked_Union
(Op_Type
) then
6867 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
6868 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
6870 Lhs_Discr_Vals
: Elist_Id
;
6871 -- List of inferred discriminant values for left operand.
6873 Rhs_Discr_Vals
: Elist_Id
;
6874 -- List of inferred discriminant values for right operand.
6879 Lhs_Discr_Vals
:= New_Elmt_List
;
6880 Rhs_Discr_Vals
:= New_Elmt_List
;
6882 -- Per-object constrained selected components require special
6883 -- attention. If the enclosing scope of the component is an
6884 -- Unchecked_Union, we cannot reference its discriminants
6885 -- directly. This is why we use the extra parameters of the
6886 -- equality function of the enclosing Unchecked_Union.
6888 -- type UU_Type (Discr : Integer := 0) is
6891 -- pragma Unchecked_Union (UU_Type);
6893 -- 1. Unchecked_Union enclosing record:
6895 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6897 -- Comp : UU_Type (Discr);
6899 -- end Enclosing_UU_Type;
6900 -- pragma Unchecked_Union (Enclosing_UU_Type);
6902 -- Obj1 : Enclosing_UU_Type;
6903 -- Obj2 : Enclosing_UU_Type (1);
6905 -- [. . .] Obj1 = Obj2 [. . .]
6909 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6911 -- A and B are the formal parameters of the equality function
6912 -- of Enclosing_UU_Type. The function always has two extra
6913 -- formals to capture the inferred discriminant values for
6914 -- each discriminant of the type.
6916 -- 2. Non-Unchecked_Union enclosing record:
6919 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6922 -- Comp : UU_Type (Discr);
6924 -- end Enclosing_Non_UU_Type;
6926 -- Obj1 : Enclosing_Non_UU_Type;
6927 -- Obj2 : Enclosing_Non_UU_Type (1);
6929 -- ... Obj1 = Obj2 ...
6933 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6934 -- obj1.discr, obj2.discr)) then
6936 -- In this case we can directly reference the discriminants of
6937 -- the enclosing record.
6939 -- Process left operand of equality
6941 if Nkind
(Lhs
) = N_Selected_Component
6943 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
6945 -- If enclosing record is an Unchecked_Union, use formals
6946 -- corresponding to each discriminant. The name of the
6947 -- formal is that of the discriminant, with added suffix,
6948 -- see Exp_Ch3.Build_Record_Equality for details.
6950 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Lhs
))))
6954 (Scope
(Entity
(Selector_Name
(Lhs
))));
6955 while Present
(Discr
) loop
6957 (Make_Identifier
(Loc
,
6958 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
6959 To
=> Lhs_Discr_Vals
);
6960 Next_Discriminant
(Discr
);
6963 -- If enclosing record is of a non-Unchecked_Union type, it
6964 -- is possible to reference its discriminants directly.
6967 Discr
:= First_Discriminant
(Lhs_Type
);
6968 while Present
(Discr
) loop
6970 (Make_Selected_Component
(Loc
,
6971 Prefix
=> Prefix
(Lhs
),
6974 (Get_Discriminant_Value
(Discr
,
6976 Stored_Constraint
(Lhs_Type
)))),
6977 To
=> Lhs_Discr_Vals
);
6978 Next_Discriminant
(Discr
);
6982 -- Otherwise operand is on object with a constrained type.
6983 -- Infer the discriminant values from the constraint.
6987 Discr
:= First_Discriminant
(Lhs_Type
);
6988 while Present
(Discr
) loop
6991 (Get_Discriminant_Value
(Discr
,
6993 Stored_Constraint
(Lhs_Type
))),
6994 To
=> Lhs_Discr_Vals
);
6995 Next_Discriminant
(Discr
);
6999 -- Similar processing for right operand of equality
7001 if Nkind
(Rhs
) = N_Selected_Component
7003 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
7005 if Is_Unchecked_Union
7006 (Scope
(Entity
(Selector_Name
(Rhs
))))
7010 (Scope
(Entity
(Selector_Name
(Rhs
))));
7011 while Present
(Discr
) loop
7013 (Make_Identifier
(Loc
,
7014 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
7015 To
=> Rhs_Discr_Vals
);
7016 Next_Discriminant
(Discr
);
7020 Discr
:= First_Discriminant
(Rhs_Type
);
7021 while Present
(Discr
) loop
7023 (Make_Selected_Component
(Loc
,
7024 Prefix
=> Prefix
(Rhs
),
7026 New_Copy
(Get_Discriminant_Value
7029 Stored_Constraint
(Rhs_Type
)))),
7030 To
=> Rhs_Discr_Vals
);
7031 Next_Discriminant
(Discr
);
7036 Discr
:= First_Discriminant
(Rhs_Type
);
7037 while Present
(Discr
) loop
7039 (New_Copy
(Get_Discriminant_Value
7042 Stored_Constraint
(Rhs_Type
))),
7043 To
=> Rhs_Discr_Vals
);
7044 Next_Discriminant
(Discr
);
7048 -- Now merge the list of discriminant values so that values
7049 -- of corresponding discriminants are adjacent.
7057 Params
:= New_List
(L_Exp
, R_Exp
);
7058 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
7059 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
7060 while Present
(L_Elmt
) loop
7061 Append_To
(Params
, Node
(L_Elmt
));
7062 Append_To
(Params
, Node
(R_Elmt
));
7068 Make_Function_Call
(Loc
,
7069 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7070 Parameter_Associations
=> Params
));
7074 -- Normal case, not an unchecked union
7078 Make_Function_Call
(Loc
,
7079 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7080 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7083 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7084 end Build_Equality_Call
;
7086 ------------------------------------
7087 -- Has_Unconstrained_UU_Component --
7088 ------------------------------------
7090 function Has_Unconstrained_UU_Component
7091 (Typ
: Node_Id
) return Boolean
7093 Tdef
: constant Node_Id
:=
7094 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
7098 function Component_Is_Unconstrained_UU
7099 (Comp
: Node_Id
) return Boolean;
7100 -- Determines whether the subtype of the component is an
7101 -- unconstrained Unchecked_Union.
7103 function Variant_Is_Unconstrained_UU
7104 (Variant
: Node_Id
) return Boolean;
7105 -- Determines whether a component of the variant has an unconstrained
7106 -- Unchecked_Union subtype.
7108 -----------------------------------
7109 -- Component_Is_Unconstrained_UU --
7110 -----------------------------------
7112 function Component_Is_Unconstrained_UU
7113 (Comp
: Node_Id
) return Boolean
7116 if Nkind
(Comp
) /= N_Component_Declaration
then
7121 Sindic
: constant Node_Id
:=
7122 Subtype_Indication
(Component_Definition
(Comp
));
7125 -- Unconstrained nominal type. In the case of a constraint
7126 -- present, the node kind would have been N_Subtype_Indication.
7128 if Nkind
(Sindic
) = N_Identifier
then
7129 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
7134 end Component_Is_Unconstrained_UU
;
7136 ---------------------------------
7137 -- Variant_Is_Unconstrained_UU --
7138 ---------------------------------
7140 function Variant_Is_Unconstrained_UU
7141 (Variant
: Node_Id
) return Boolean
7143 Clist
: constant Node_Id
:= Component_List
(Variant
);
7146 if Is_Empty_List
(Component_Items
(Clist
)) then
7150 -- We only need to test one component
7153 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7156 while Present
(Comp
) loop
7157 if Component_Is_Unconstrained_UU
(Comp
) then
7165 -- None of the components withing the variant were of
7166 -- unconstrained Unchecked_Union type.
7169 end Variant_Is_Unconstrained_UU
;
7171 -- Start of processing for Has_Unconstrained_UU_Component
7174 if Null_Present
(Tdef
) then
7178 Clist
:= Component_List
(Tdef
);
7179 Vpart
:= Variant_Part
(Clist
);
7181 -- Inspect available components
7183 if Present
(Component_Items
(Clist
)) then
7185 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7188 while Present
(Comp
) loop
7190 -- One component is sufficient
7192 if Component_Is_Unconstrained_UU
(Comp
) then
7201 -- Inspect available components withing variants
7203 if Present
(Vpart
) then
7205 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7208 while Present
(Variant
) loop
7210 -- One component within a variant is sufficient
7212 if Variant_Is_Unconstrained_UU
(Variant
) then
7221 -- Neither the available components, nor the components inside the
7222 -- variant parts were of an unconstrained Unchecked_Union subtype.
7225 end Has_Unconstrained_UU_Component
;
7227 -- Start of processing for Expand_N_Op_Eq
7230 Binary_Op_Validity_Checks
(N
);
7232 -- Deal with private types
7234 if Ekind
(Typl
) = E_Private_Type
then
7235 Typl
:= Underlying_Type
(Typl
);
7236 elsif Ekind
(Typl
) = E_Private_Subtype
then
7237 Typl
:= Underlying_Type
(Base_Type
(Typl
));
7242 -- It may happen in error situations that the underlying type is not
7243 -- set. The error will be detected later, here we just defend the
7250 -- Now get the implementation base type (note that plain Base_Type here
7251 -- might lead us back to the private type, which is not what we want!)
7253 Typl
:= Implementation_Base_Type
(Typl
);
7255 -- Equality between variant records results in a call to a routine
7256 -- that has conditional tests of the discriminant value(s), and hence
7257 -- violates the No_Implicit_Conditionals restriction.
7259 if Has_Variant_Part
(Typl
) then
7264 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
7268 ("\comparison of variant records tests discriminants", N
);
7274 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7275 -- means we no longer have a comparison operation, we are all done.
7277 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7279 if Nkind
(N
) /= N_Op_Eq
then
7283 -- Boolean types (requiring handling of non-standard case)
7285 if Is_Boolean_Type
(Typl
) then
7286 Adjust_Condition
(Left_Opnd
(N
));
7287 Adjust_Condition
(Right_Opnd
(N
));
7288 Set_Etype
(N
, Standard_Boolean
);
7289 Adjust_Result_Type
(N
, Typ
);
7293 elsif Is_Array_Type
(Typl
) then
7295 -- If we are doing full validity checking, and it is possible for the
7296 -- array elements to be invalid then expand out array comparisons to
7297 -- make sure that we check the array elements.
7299 if Validity_Check_Operands
7300 and then not Is_Known_Valid
(Component_Type
(Typl
))
7303 Save_Force_Validity_Checks
: constant Boolean :=
7304 Force_Validity_Checks
;
7306 Force_Validity_Checks
:= True;
7308 Expand_Array_Equality
7310 Relocate_Node
(Lhs
),
7311 Relocate_Node
(Rhs
),
7314 Insert_Actions
(N
, Bodies
);
7315 Analyze_And_Resolve
(N
, Standard_Boolean
);
7316 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7319 -- Packed case where both operands are known aligned
7321 elsif Is_Bit_Packed_Array
(Typl
)
7322 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7323 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7325 Expand_Packed_Eq
(N
);
7327 -- Where the component type is elementary we can use a block bit
7328 -- comparison (if supported on the target) exception in the case
7329 -- of floating-point (negative zero issues require element by
7330 -- element comparison), and atomic/VFA types (where we must be sure
7331 -- to load elements independently) and possibly unaligned arrays.
7333 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7334 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7335 and then not Is_Atomic_Or_VFA
(Component_Type
(Typl
))
7336 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7337 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7338 and then Support_Composite_Compare_On_Target
7342 -- For composite and floating-point cases, expand equality loop to
7343 -- make sure of using proper comparisons for tagged types, and
7344 -- correctly handling the floating-point case.
7348 Expand_Array_Equality
7350 Relocate_Node
(Lhs
),
7351 Relocate_Node
(Rhs
),
7354 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7355 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7360 elsif Is_Record_Type
(Typl
) then
7362 -- For tagged types, use the primitive "="
7364 if Is_Tagged_Type
(Typl
) then
7366 -- No need to do anything else compiling under restriction
7367 -- No_Dispatching_Calls. During the semantic analysis we
7368 -- already notified such violation.
7370 if Restriction_Active
(No_Dispatching_Calls
) then
7374 -- If this is derived from an untagged private type completed with
7375 -- a tagged type, it does not have a full view, so we use the
7376 -- primitive operations of the private type. This check should no
7377 -- longer be necessary when these types get their full views???
7379 if Is_Private_Type
(A_Typ
)
7380 and then not Is_Tagged_Type
(A_Typ
)
7381 and then Is_Derived_Type
(A_Typ
)
7382 and then No
(Full_View
(A_Typ
))
7384 -- Search for equality operation, checking that the operands
7385 -- have the same type. Note that we must find a matching entry,
7386 -- or something is very wrong.
7388 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7390 while Present
(Prim
) loop
7391 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7392 and then Etype
(First_Formal
(Node
(Prim
))) =
7393 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7395 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7400 pragma Assert
(Present
(Prim
));
7401 Op_Name
:= Node
(Prim
);
7403 -- Find the type's predefined equality or an overriding
7404 -- user-defined equality. The reason for not simply calling
7405 -- Find_Prim_Op here is that there may be a user-defined
7406 -- overloaded equality op that precedes the equality that we
7407 -- want, so we have to explicitly search (e.g., there could be
7408 -- an equality with two different parameter types).
7411 if Is_Class_Wide_Type
(Typl
) then
7412 Typl
:= Find_Specific_Type
(Typl
);
7415 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7416 while Present
(Prim
) loop
7417 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7418 and then Etype
(First_Formal
(Node
(Prim
))) =
7419 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7421 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7426 pragma Assert
(Present
(Prim
));
7427 Op_Name
:= Node
(Prim
);
7430 Build_Equality_Call
(Op_Name
);
7432 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7433 -- predefined equality operator for a type which has a subcomponent
7434 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7436 elsif Has_Unconstrained_UU_Component
(Typl
) then
7438 Make_Raise_Program_Error
(Loc
,
7439 Reason
=> PE_Unchecked_Union_Restriction
));
7441 -- Prevent Gigi from generating incorrect code by rewriting the
7442 -- equality as a standard False. (is this documented somewhere???)
7445 New_Occurrence_Of
(Standard_False
, Loc
));
7447 elsif Is_Unchecked_Union
(Typl
) then
7449 -- If we can infer the discriminants of the operands, we make a
7450 -- call to the TSS equality function.
7452 if Has_Inferable_Discriminants
(Lhs
)
7454 Has_Inferable_Discriminants
(Rhs
)
7457 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7460 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7461 -- the predefined equality operator for an Unchecked_Union type
7462 -- if either of the operands lack inferable discriminants.
7465 Make_Raise_Program_Error
(Loc
,
7466 Reason
=> PE_Unchecked_Union_Restriction
));
7468 -- Emit a warning on source equalities only, otherwise the
7469 -- message may appear out of place due to internal use. The
7470 -- warning is unconditional because it is required by the
7473 if Comes_From_Source
(N
) then
7475 ("Unchecked_Union discriminants cannot be determined??",
7478 ("\Program_Error will be raised for equality operation??",
7482 -- Prevent Gigi from generating incorrect code by rewriting
7483 -- the equality as a standard False (documented where???).
7486 New_Occurrence_Of
(Standard_False
, Loc
));
7489 -- If a type support function is present (for complex cases), use it
7491 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7493 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7495 -- When comparing two Bounded_Strings, use the primitive equality of
7496 -- the root Super_String type.
7498 elsif Is_Bounded_String
(Typl
) then
7500 First_Elmt
(Collect_Primitive_Operations
(Root_Type
(Typl
)));
7502 while Present
(Prim
) loop
7503 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7504 and then Etype
(First_Formal
(Node
(Prim
))) =
7505 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7506 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7511 -- A Super_String type should always have a primitive equality
7513 pragma Assert
(Present
(Prim
));
7514 Build_Equality_Call
(Node
(Prim
));
7516 -- Otherwise expand the component by component equality. Note that
7517 -- we never use block-bit comparisons for records, because of the
7518 -- problems with gaps. The backend will often be able to recombine
7519 -- the separate comparisons that we generate here.
7522 Remove_Side_Effects
(Lhs
);
7523 Remove_Side_Effects
(Rhs
);
7525 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7527 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7528 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7532 -- Test if result is known at compile time
7534 Rewrite_Comparison
(N
);
7536 -- Special optimization of length comparison
7538 Optimize_Length_Comparison
(N
);
7540 -- One more special case: if we have a comparison of X'Result = expr
7541 -- in floating-point, then if not already there, change expr to be
7542 -- f'Machine (expr) to eliminate surprise from extra precision.
7544 if Is_Floating_Point_Type
(Typl
)
7545 and then Nkind
(Original_Node
(Lhs
)) = N_Attribute_Reference
7546 and then Attribute_Name
(Original_Node
(Lhs
)) = Name_Result
7548 -- Stick in the Typ'Machine call if not already there
7550 if Nkind
(Rhs
) /= N_Attribute_Reference
7551 or else Attribute_Name
(Rhs
) /= Name_Machine
7554 Make_Attribute_Reference
(Loc
,
7555 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
7556 Attribute_Name
=> Name_Machine
,
7557 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
7558 Analyze_And_Resolve
(Rhs
, Typl
);
7563 -----------------------
7564 -- Expand_N_Op_Expon --
7565 -----------------------
7567 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
7568 Loc
: constant Source_Ptr
:= Sloc
(N
);
7569 Typ
: constant Entity_Id
:= Etype
(N
);
7570 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
7571 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
7572 Bastyp
: constant Node_Id
:= Etype
(Base
);
7573 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
7574 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
7575 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
7583 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
7584 -- Given an expression Exp, if the root type is Float or Long_Float,
7585 -- then wrap the expression in a call of Bastyp'Machine, to stop any
7586 -- extra precision. This is done to ensure that X**A = X**B when A is
7587 -- a static constant and B is a variable with the same value. For any
7588 -- other type, the node Exp is returned unchanged.
7594 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
7595 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
7597 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
7599 Make_Attribute_Reference
(Loc
,
7600 Attribute_Name
=> Name_Machine
,
7601 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
7602 Expressions
=> New_List
(Relocate_Node
(Exp
)));
7608 -- Start of processing for Expand_N_Op
7611 Binary_Op_Validity_Checks
(N
);
7613 -- CodePeer wants to see the unexpanded N_Op_Expon node
7615 if CodePeer_Mode
then
7619 -- If either operand is of a private type, then we have the use of an
7620 -- intrinsic operator, and we get rid of the privateness, by using root
7621 -- types of underlying types for the actual operation. Otherwise the
7622 -- private types will cause trouble if we expand multiplications or
7623 -- shifts etc. We also do this transformation if the result type is
7624 -- different from the base type.
7626 if Is_Private_Type
(Etype
(Base
))
7627 or else Is_Private_Type
(Typ
)
7628 or else Is_Private_Type
(Exptyp
)
7629 or else Rtyp
/= Root_Type
(Bastyp
)
7632 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
7633 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
7636 Unchecked_Convert_To
(Typ
,
7638 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
7639 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
7640 Analyze_And_Resolve
(N
, Typ
);
7645 -- Check for MINIMIZED/ELIMINATED overflow mode
7647 if Minimized_Eliminated_Overflow_Check
(N
) then
7648 Apply_Arithmetic_Overflow_Check
(N
);
7652 -- Test for case of known right argument where we can replace the
7653 -- exponentiation by an equivalent expression using multiplication.
7655 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7656 -- configurable run-time mode, we may not have the exponentiation
7657 -- routine available, and we don't want the legality of the program
7658 -- to depend on how clever the compiler is in knowing values.
7660 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
7661 Expv
:= Expr_Value
(Exp
);
7663 -- We only fold small non-negative exponents. You might think we
7664 -- could fold small negative exponents for the real case, but we
7665 -- can't because we are required to raise Constraint_Error for
7666 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7667 -- See ACVC test C4A012B, and it is not worth generating the test.
7669 if Expv
>= 0 and then Expv
<= 4 then
7671 -- X ** 0 = 1 (or 1.0)
7675 -- Call Remove_Side_Effects to ensure that any side effects
7676 -- in the ignored left operand (in particular function calls
7677 -- to user defined functions) are properly executed.
7679 Remove_Side_Effects
(Base
);
7681 if Ekind
(Typ
) in Integer_Kind
then
7682 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
7684 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
7697 Make_Op_Multiply
(Loc
,
7698 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7699 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
7701 -- X ** 3 = X * X * X
7706 Make_Op_Multiply
(Loc
,
7708 Make_Op_Multiply
(Loc
,
7709 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7710 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
7711 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
7716 -- En : constant base'type := base * base;
7721 pragma Assert
(Expv
= 4);
7722 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
7725 Make_Expression_With_Actions
(Loc
,
7726 Actions
=> New_List
(
7727 Make_Object_Declaration
(Loc
,
7728 Defining_Identifier
=> Temp
,
7729 Constant_Present
=> True,
7730 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7733 Make_Op_Multiply
(Loc
,
7735 Duplicate_Subexpr
(Base
),
7737 Duplicate_Subexpr_No_Checks
(Base
))))),
7741 Make_Op_Multiply
(Loc
,
7742 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
7743 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
7747 Analyze_And_Resolve
(N
, Typ
);
7752 -- Deal with optimizing 2 ** expression to shift where possible
7754 -- Note: we used to check that Exptyp was an unsigned type. But that is
7755 -- an unnecessary check, since if Exp is negative, we have a run-time
7756 -- error that is either caught (so we get the right result) or we have
7757 -- suppressed the check, in which case the code is erroneous anyway.
7759 if Is_Integer_Type
(Rtyp
)
7761 -- The base value must be "safe compile-time known", and exactly 2
7763 and then Nkind
(Base
) = N_Integer_Literal
7764 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
7765 and then Expr_Value
(Base
) = Uint_2
7767 -- We only handle cases where the right type is a integer
7769 and then Is_Integer_Type
(Root_Type
(Exptyp
))
7770 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
7772 -- This transformation is not applicable for a modular type with a
7773 -- nonbinary modulus because we do not handle modular reduction in
7774 -- a correct manner if we attempt this transformation in this case.
7776 and then not Non_Binary_Modulus
(Typ
)
7778 -- Handle the cases where our parent is a division or multiplication
7779 -- specially. In these cases we can convert to using a shift at the
7780 -- parent level if we are not doing overflow checking, since it is
7781 -- too tricky to combine the overflow check at the parent level.
7784 and then Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
)
7787 P
: constant Node_Id
:= Parent
(N
);
7788 L
: constant Node_Id
:= Left_Opnd
(P
);
7789 R
: constant Node_Id
:= Right_Opnd
(P
);
7792 if (Nkind
(P
) = N_Op_Multiply
7794 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
7796 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
7797 and then not Do_Overflow_Check
(P
))
7800 (Nkind
(P
) = N_Op_Divide
7801 and then Is_Integer_Type
(Etype
(L
))
7802 and then Is_Unsigned_Type
(Etype
(L
))
7804 and then not Do_Overflow_Check
(P
))
7806 Set_Is_Power_Of_2_For_Shift
(N
);
7811 -- Here we just have 2 ** N on its own, so we can convert this to a
7812 -- shift node. We are prepared to deal with overflow here, and we
7813 -- also have to handle proper modular reduction for binary modular.
7822 -- Maximum shift count with no overflow
7825 -- Set True if we must test the shift count
7828 -- Node for test against TestS
7831 -- Compute maximum shift based on the underlying size. For a
7832 -- modular type this is one less than the size.
7834 if Is_Modular_Integer_Type
(Typ
) then
7836 -- For modular integer types, this is the size of the value
7837 -- being shifted minus one. Any larger values will cause
7838 -- modular reduction to a result of zero. Note that we do
7839 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
7840 -- of 6, since 2**7 should be reduced to zero).
7842 MaxS
:= RM_Size
(Rtyp
) - 1;
7844 -- For signed integer types, we use the size of the value
7845 -- being shifted minus 2. Larger values cause overflow.
7848 MaxS
:= Esize
(Rtyp
) - 2;
7851 -- Determine range to see if it can be larger than MaxS
7854 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
7855 TestS
:= (not OK
) or else Hi
> MaxS
;
7857 -- Signed integer case
7859 if Is_Signed_Integer_Type
(Typ
) then
7861 -- Generate overflow check if overflow is active. Note that
7862 -- we can simply ignore the possibility of overflow if the
7863 -- flag is not set (means that overflow cannot happen or
7864 -- that overflow checks are suppressed).
7866 if Ovflo
and TestS
then
7868 Make_Raise_Constraint_Error
(Loc
,
7871 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
7872 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
7873 Reason
=> CE_Overflow_Check_Failed
));
7876 -- Now rewrite node as Shift_Left (1, right-operand)
7879 Make_Op_Shift_Left
(Loc
,
7880 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7881 Right_Opnd
=> Right_Opnd
(N
)));
7883 -- Modular integer case
7885 else pragma Assert
(Is_Modular_Integer_Type
(Typ
));
7887 -- If shift count can be greater than MaxS, we need to wrap
7888 -- the shift in a test that will reduce the result value to
7889 -- zero if this shift count is exceeded.
7893 -- Note: build node for the comparison first, before we
7894 -- reuse the Right_Opnd, so that we have proper parents
7895 -- in place for the Duplicate_Subexpr call.
7899 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
7900 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
));
7903 Make_If_Expression
(Loc
,
7904 Expressions
=> New_List
(
7906 Make_Integer_Literal
(Loc
, Uint_0
),
7907 Make_Op_Shift_Left
(Loc
,
7908 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7909 Right_Opnd
=> Right_Opnd
(N
)))));
7911 -- If we know shift count cannot be greater than MaxS, then
7912 -- it is safe to just rewrite as a shift with no test.
7916 Make_Op_Shift_Left
(Loc
,
7917 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7918 Right_Opnd
=> Right_Opnd
(N
)));
7922 Analyze_And_Resolve
(N
, Typ
);
7928 -- Fall through if exponentiation must be done using a runtime routine
7930 -- First deal with modular case
7932 if Is_Modular_Integer_Type
(Rtyp
) then
7934 -- Nonbinary modular case, we call the special exponentiation
7935 -- routine for the nonbinary case, converting the argument to
7936 -- Long_Long_Integer and passing the modulus value. Then the
7937 -- result is converted back to the base type.
7939 if Non_Binary_Modulus
(Rtyp
) then
7942 Make_Function_Call
(Loc
,
7944 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
7945 Parameter_Associations
=> New_List
(
7946 Convert_To
(RTE
(RE_Unsigned
), Base
),
7947 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
7950 -- Binary modular case, in this case, we call one of two routines,
7951 -- either the unsigned integer case, or the unsigned long long
7952 -- integer case, with a final "and" operation to do the required mod.
7955 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
7956 Ent
:= RTE
(RE_Exp_Unsigned
);
7958 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
7965 Make_Function_Call
(Loc
,
7966 Name
=> New_Occurrence_Of
(Ent
, Loc
),
7967 Parameter_Associations
=> New_List
(
7968 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
7971 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
7975 -- Common exit point for modular type case
7977 Analyze_And_Resolve
(N
, Typ
);
7980 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7981 -- It is not worth having routines for Short_[Short_]Integer, since for
7982 -- most machines it would not help, and it would generate more code that
7983 -- might need certification when a certified run time is required.
7985 -- In the integer cases, we have two routines, one for when overflow
7986 -- checks are required, and one when they are not required, since there
7987 -- is a real gain in omitting checks on many machines.
7989 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
7990 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
7992 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
7993 or else Rtyp
= Universal_Integer
7995 Etyp
:= Standard_Long_Long_Integer
;
7997 -- Overflow checking is the only choice on the AAMP target, where
7998 -- arithmetic instructions check overflow automatically, so only
7999 -- one version of the exponentiation unit is needed.
8001 if Ovflo
or AAMP_On_Target
then
8002 Rent
:= RE_Exp_Long_Long_Integer
;
8004 Rent
:= RE_Exn_Long_Long_Integer
;
8007 elsif Is_Signed_Integer_Type
(Rtyp
) then
8008 Etyp
:= Standard_Integer
;
8010 -- Overflow checking is the only choice on the AAMP target, where
8011 -- arithmetic instructions check overflow automatically, so only
8012 -- one version of the exponentiation unit is needed.
8014 if Ovflo
or AAMP_On_Target
then
8015 Rent
:= RE_Exp_Integer
;
8017 Rent
:= RE_Exn_Integer
;
8020 -- Floating-point cases. We do not need separate routines for the
8021 -- overflow case here, since in the case of floating-point, we generate
8022 -- infinities anyway as a rule (either that or we automatically trap
8023 -- overflow), and if there is an infinity generated and a range check
8024 -- is required, the check will fail anyway.
8026 -- Historical note: we used to convert everything to Long_Long_Float
8027 -- and call a single common routine, but this had the undesirable effect
8028 -- of giving different results for small static exponent values and the
8029 -- same dynamic values.
8032 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
8034 if Rtyp
= Standard_Float
then
8035 Etyp
:= Standard_Float
;
8036 Rent
:= RE_Exn_Float
;
8038 elsif Rtyp
= Standard_Long_Float
then
8039 Etyp
:= Standard_Long_Float
;
8040 Rent
:= RE_Exn_Long_Float
;
8043 Etyp
:= Standard_Long_Long_Float
;
8044 Rent
:= RE_Exn_Long_Long_Float
;
8048 -- Common processing for integer cases and floating-point cases.
8049 -- If we are in the right type, we can call runtime routine directly
8052 and then Rtyp
/= Universal_Integer
8053 and then Rtyp
/= Universal_Real
8057 Make_Function_Call
(Loc
,
8058 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8059 Parameter_Associations
=> New_List
(Base
, Exp
))));
8061 -- Otherwise we have to introduce conversions (conversions are also
8062 -- required in the universal cases, since the runtime routine is
8063 -- typed using one of the standard types).
8068 Make_Function_Call
(Loc
,
8069 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8070 Parameter_Associations
=> New_List
(
8071 Convert_To
(Etyp
, Base
),
8075 Analyze_And_Resolve
(N
, Typ
);
8079 when RE_Not_Available
=>
8081 end Expand_N_Op_Expon
;
8083 --------------------
8084 -- Expand_N_Op_Ge --
8085 --------------------
8087 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
8088 Typ
: constant Entity_Id
:= Etype
(N
);
8089 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8090 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8091 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8094 Binary_Op_Validity_Checks
(N
);
8096 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8097 -- means we no longer have a comparison operation, we are all done.
8099 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8101 if Nkind
(N
) /= N_Op_Ge
then
8107 if Is_Array_Type
(Typ1
) then
8108 Expand_Array_Comparison
(N
);
8112 -- Deal with boolean operands
8114 if Is_Boolean_Type
(Typ1
) then
8115 Adjust_Condition
(Op1
);
8116 Adjust_Condition
(Op2
);
8117 Set_Etype
(N
, Standard_Boolean
);
8118 Adjust_Result_Type
(N
, Typ
);
8121 Rewrite_Comparison
(N
);
8123 Optimize_Length_Comparison
(N
);
8126 --------------------
8127 -- Expand_N_Op_Gt --
8128 --------------------
8130 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
8131 Typ
: constant Entity_Id
:= Etype
(N
);
8132 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8133 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8134 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8137 Binary_Op_Validity_Checks
(N
);
8139 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8140 -- means we no longer have a comparison operation, we are all done.
8142 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8144 if Nkind
(N
) /= N_Op_Gt
then
8148 -- Deal with array type operands
8150 if Is_Array_Type
(Typ1
) then
8151 Expand_Array_Comparison
(N
);
8155 -- Deal with boolean type operands
8157 if Is_Boolean_Type
(Typ1
) then
8158 Adjust_Condition
(Op1
);
8159 Adjust_Condition
(Op2
);
8160 Set_Etype
(N
, Standard_Boolean
);
8161 Adjust_Result_Type
(N
, Typ
);
8164 Rewrite_Comparison
(N
);
8166 Optimize_Length_Comparison
(N
);
8169 --------------------
8170 -- Expand_N_Op_Le --
8171 --------------------
8173 procedure Expand_N_Op_Le
(N
: Node_Id
) is
8174 Typ
: constant Entity_Id
:= Etype
(N
);
8175 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8176 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8177 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8180 Binary_Op_Validity_Checks
(N
);
8182 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8183 -- means we no longer have a comparison operation, we are all done.
8185 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8187 if Nkind
(N
) /= N_Op_Le
then
8191 -- Deal with array type operands
8193 if Is_Array_Type
(Typ1
) then
8194 Expand_Array_Comparison
(N
);
8198 -- Deal with Boolean type operands
8200 if Is_Boolean_Type
(Typ1
) then
8201 Adjust_Condition
(Op1
);
8202 Adjust_Condition
(Op2
);
8203 Set_Etype
(N
, Standard_Boolean
);
8204 Adjust_Result_Type
(N
, Typ
);
8207 Rewrite_Comparison
(N
);
8209 Optimize_Length_Comparison
(N
);
8212 --------------------
8213 -- Expand_N_Op_Lt --
8214 --------------------
8216 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
8217 Typ
: constant Entity_Id
:= Etype
(N
);
8218 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8219 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8220 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8223 Binary_Op_Validity_Checks
(N
);
8225 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8226 -- means we no longer have a comparison operation, we are all done.
8228 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8230 if Nkind
(N
) /= N_Op_Lt
then
8234 -- Deal with array type operands
8236 if Is_Array_Type
(Typ1
) then
8237 Expand_Array_Comparison
(N
);
8241 -- Deal with Boolean type operands
8243 if Is_Boolean_Type
(Typ1
) then
8244 Adjust_Condition
(Op1
);
8245 Adjust_Condition
(Op2
);
8246 Set_Etype
(N
, Standard_Boolean
);
8247 Adjust_Result_Type
(N
, Typ
);
8250 Rewrite_Comparison
(N
);
8252 Optimize_Length_Comparison
(N
);
8255 -----------------------
8256 -- Expand_N_Op_Minus --
8257 -----------------------
8259 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
8260 Loc
: constant Source_Ptr
:= Sloc
(N
);
8261 Typ
: constant Entity_Id
:= Etype
(N
);
8264 Unary_Op_Validity_Checks
(N
);
8266 -- Check for MINIMIZED/ELIMINATED overflow mode
8268 if Minimized_Eliminated_Overflow_Check
(N
) then
8269 Apply_Arithmetic_Overflow_Check
(N
);
8273 if not Backend_Overflow_Checks_On_Target
8274 and then Is_Signed_Integer_Type
(Etype
(N
))
8275 and then Do_Overflow_Check
(N
)
8277 -- Software overflow checking expands -expr into (0 - expr)
8280 Make_Op_Subtract
(Loc
,
8281 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
8282 Right_Opnd
=> Right_Opnd
(N
)));
8284 Analyze_And_Resolve
(N
, Typ
);
8286 end Expand_N_Op_Minus
;
8288 ---------------------
8289 -- Expand_N_Op_Mod --
8290 ---------------------
8292 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
8293 Loc
: constant Source_Ptr
:= Sloc
(N
);
8294 Typ
: constant Entity_Id
:= Etype
(N
);
8295 DDC
: constant Boolean := Do_Division_Check
(N
);
8308 pragma Warnings
(Off
, Lhi
);
8311 Binary_Op_Validity_Checks
(N
);
8313 -- Check for MINIMIZED/ELIMINATED overflow mode
8315 if Minimized_Eliminated_Overflow_Check
(N
) then
8316 Apply_Arithmetic_Overflow_Check
(N
);
8320 if Is_Integer_Type
(Etype
(N
)) then
8321 Apply_Divide_Checks
(N
);
8323 -- All done if we don't have a MOD any more, which can happen as a
8324 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8326 if Nkind
(N
) /= N_Op_Mod
then
8331 -- Proceed with expansion of mod operator
8333 Left
:= Left_Opnd
(N
);
8334 Right
:= Right_Opnd
(N
);
8336 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
8337 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
8339 -- Convert mod to rem if operands are both known to be non-negative, or
8340 -- both known to be non-positive (these are the cases in which rem and
8341 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8342 -- likely that this will improve the quality of code, (the operation now
8343 -- corresponds to the hardware remainder), and it does not seem likely
8344 -- that it could be harmful. It also avoids some cases of the elaborate
8345 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8348 and then ((Llo
>= 0 and then Rlo
>= 0)
8350 (Lhi
<= 0 and then Rhi
<= 0))
8353 Make_Op_Rem
(Sloc
(N
),
8354 Left_Opnd
=> Left_Opnd
(N
),
8355 Right_Opnd
=> Right_Opnd
(N
)));
8357 -- Instead of reanalyzing the node we do the analysis manually. This
8358 -- avoids anomalies when the replacement is done in an instance and
8359 -- is epsilon more efficient.
8361 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
8363 Set_Do_Division_Check
(N
, DDC
);
8364 Expand_N_Op_Rem
(N
);
8368 -- Otherwise, normal mod processing
8371 -- Apply optimization x mod 1 = 0. We don't really need that with
8372 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
8373 -- certainly harmless.
8375 if Is_Integer_Type
(Etype
(N
))
8376 and then Compile_Time_Known_Value
(Right
)
8377 and then Expr_Value
(Right
) = Uint_1
8379 -- Call Remove_Side_Effects to ensure that any side effects in
8380 -- the ignored left operand (in particular function calls to
8381 -- user defined functions) are properly executed.
8383 Remove_Side_Effects
(Left
);
8385 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8386 Analyze_And_Resolve
(N
, Typ
);
8390 -- If we still have a mod operator and we are in Modify_Tree_For_C
8391 -- mode, and we have a signed integer type, then here is where we do
8392 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8393 -- for the special handling of the annoying case of largest negative
8394 -- number mod minus one.
8396 if Nkind
(N
) = N_Op_Mod
8397 and then Is_Signed_Integer_Type
(Typ
)
8398 and then Modify_Tree_For_C
8400 -- In the general case, we expand A mod B as
8402 -- Tnn : constant typ := A rem B;
8404 -- (if (A >= 0) = (B >= 0) then Tnn
8405 -- elsif Tnn = 0 then 0
8408 -- The comparison can be written simply as A >= 0 if we know that
8409 -- B >= 0 which is a very common case.
8411 -- An important optimization is when B is known at compile time
8412 -- to be 2**K for some constant. In this case we can simply AND
8413 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8414 -- and that works for both the positive and negative cases.
8417 P2
: constant Nat
:= Power_Of_Two
(Right
);
8422 Unchecked_Convert_To
(Typ
,
8425 Unchecked_Convert_To
8426 (Corresponding_Unsigned_Type
(Typ
), Left
),
8428 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
8429 Analyze_And_Resolve
(N
, Typ
);
8434 -- Here for the full rewrite
8437 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
8443 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
8444 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
8446 if not LOK
or else Rlo
< 0 then
8452 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
8453 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
8457 Make_Object_Declaration
(Loc
,
8458 Defining_Identifier
=> Tnn
,
8459 Constant_Present
=> True,
8460 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8464 Right_Opnd
=> Right
)));
8467 Make_If_Expression
(Loc
,
8468 Expressions
=> New_List
(
8470 New_Occurrence_Of
(Tnn
, Loc
),
8471 Make_If_Expression
(Loc
,
8473 Expressions
=> New_List
(
8475 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8476 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
8477 Make_Integer_Literal
(Loc
, 0),
8479 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8481 Duplicate_Subexpr_No_Checks
(Right
)))))));
8483 Analyze_And_Resolve
(N
, Typ
);
8488 -- Deal with annoying case of largest negative number mod minus one.
8489 -- Gigi may not handle this case correctly, because on some targets,
8490 -- the mod value is computed using a divide instruction which gives
8491 -- an overflow trap for this case.
8493 -- It would be a bit more efficient to figure out which targets
8494 -- this is really needed for, but in practice it is reasonable
8495 -- to do the following special check in all cases, since it means
8496 -- we get a clearer message, and also the overhead is minimal given
8497 -- that division is expensive in any case.
8499 -- In fact the check is quite easy, if the right operand is -1, then
8500 -- the mod value is always 0, and we can just ignore the left operand
8501 -- completely in this case.
8503 -- This only applies if we still have a mod operator. Skip if we
8504 -- have already rewritten this (e.g. in the case of eliminated
8505 -- overflow checks which have driven us into bignum mode).
8507 if Nkind
(N
) = N_Op_Mod
then
8509 -- The operand type may be private (e.g. in the expansion of an
8510 -- intrinsic operation) so we must use the underlying type to get
8511 -- the bounds, and convert the literals explicitly.
8515 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
8517 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
8518 and then ((not LOK
) or else (Llo
= LLB
))
8521 Make_If_Expression
(Loc
,
8522 Expressions
=> New_List
(
8524 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8526 Unchecked_Convert_To
(Typ
,
8527 Make_Integer_Literal
(Loc
, -1))),
8528 Unchecked_Convert_To
(Typ
,
8529 Make_Integer_Literal
(Loc
, Uint_0
)),
8530 Relocate_Node
(N
))));
8532 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8533 Analyze_And_Resolve
(N
, Typ
);
8537 end Expand_N_Op_Mod
;
8539 --------------------------
8540 -- Expand_N_Op_Multiply --
8541 --------------------------
8543 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
8544 Loc
: constant Source_Ptr
:= Sloc
(N
);
8545 Lop
: constant Node_Id
:= Left_Opnd
(N
);
8546 Rop
: constant Node_Id
:= Right_Opnd
(N
);
8548 Lp2
: constant Boolean :=
8549 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
8550 Rp2
: constant Boolean :=
8551 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
8553 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
8554 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
8555 Typ
: Entity_Id
:= Etype
(N
);
8558 Binary_Op_Validity_Checks
(N
);
8560 -- Check for MINIMIZED/ELIMINATED overflow mode
8562 if Minimized_Eliminated_Overflow_Check
(N
) then
8563 Apply_Arithmetic_Overflow_Check
(N
);
8567 -- Special optimizations for integer types
8569 if Is_Integer_Type
(Typ
) then
8571 -- N * 0 = 0 for integer types
8573 if Compile_Time_Known_Value
(Rop
)
8574 and then Expr_Value
(Rop
) = Uint_0
8576 -- Call Remove_Side_Effects to ensure that any side effects in
8577 -- the ignored left operand (in particular function calls to
8578 -- user defined functions) are properly executed.
8580 Remove_Side_Effects
(Lop
);
8582 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8583 Analyze_And_Resolve
(N
, Typ
);
8587 -- Similar handling for 0 * N = 0
8589 if Compile_Time_Known_Value
(Lop
)
8590 and then Expr_Value
(Lop
) = Uint_0
8592 Remove_Side_Effects
(Rop
);
8593 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8594 Analyze_And_Resolve
(N
, Typ
);
8598 -- N * 1 = 1 * N = N for integer types
8600 -- This optimisation is not done if we are going to
8601 -- rewrite the product 1 * 2 ** N to a shift.
8603 if Compile_Time_Known_Value
(Rop
)
8604 and then Expr_Value
(Rop
) = Uint_1
8610 elsif Compile_Time_Known_Value
(Lop
)
8611 and then Expr_Value
(Lop
) = Uint_1
8619 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8620 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8621 -- operand is an integer, as required for this to work.
8626 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8630 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
8633 Left_Opnd
=> Right_Opnd
(Lop
),
8634 Right_Opnd
=> Right_Opnd
(Rop
))));
8635 Analyze_And_Resolve
(N
, Typ
);
8639 -- If the result is modular, perform the reduction of the result
8642 if Is_Modular_Integer_Type
(Typ
)
8643 and then not Non_Binary_Modulus
(Typ
)
8648 Make_Op_Shift_Left
(Loc
,
8651 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
8653 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8657 Make_Op_Shift_Left
(Loc
,
8660 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
8663 Analyze_And_Resolve
(N
, Typ
);
8667 -- Same processing for the operands the other way round
8670 if Is_Modular_Integer_Type
(Typ
)
8671 and then not Non_Binary_Modulus
(Typ
)
8676 Make_Op_Shift_Left
(Loc
,
8679 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
8681 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8685 Make_Op_Shift_Left
(Loc
,
8688 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
8691 Analyze_And_Resolve
(N
, Typ
);
8695 -- Do required fixup of universal fixed operation
8697 if Typ
= Universal_Fixed
then
8698 Fixup_Universal_Fixed_Operation
(N
);
8702 -- Multiplications with fixed-point results
8704 if Is_Fixed_Point_Type
(Typ
) then
8706 -- No special processing if Treat_Fixed_As_Integer is set, since from
8707 -- a semantic point of view such operations are simply integer
8708 -- operations and will be treated that way.
8710 if not Treat_Fixed_As_Integer
(N
) then
8712 -- Case of fixed * integer => fixed
8714 if Is_Integer_Type
(Rtyp
) then
8715 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
8717 -- Case of integer * fixed => fixed
8719 elsif Is_Integer_Type
(Ltyp
) then
8720 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
8722 -- Case of fixed * fixed => fixed
8725 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
8729 -- Other cases of multiplication of fixed-point operands. Again we
8730 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8732 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
8733 and then not Treat_Fixed_As_Integer
(N
)
8735 if Is_Integer_Type
(Typ
) then
8736 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
8738 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8739 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
8742 -- Mixed-mode operations can appear in a non-static universal context,
8743 -- in which case the integer argument must be converted explicitly.
8745 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
8746 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
8747 Analyze_And_Resolve
(Rop
, Universal_Real
);
8749 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
8750 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
8751 Analyze_And_Resolve
(Lop
, Universal_Real
);
8753 -- Non-fixed point cases, check software overflow checking required
8755 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
8756 Apply_Arithmetic_Overflow_Check
(N
);
8759 -- Overflow checks for floating-point if -gnateF mode active
8761 Check_Float_Op_Overflow
(N
);
8762 end Expand_N_Op_Multiply
;
8764 --------------------
8765 -- Expand_N_Op_Ne --
8766 --------------------
8768 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
8769 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
8772 -- Case of elementary type with standard operator
8774 if Is_Elementary_Type
(Typ
)
8775 and then Sloc
(Entity
(N
)) = Standard_Location
8777 Binary_Op_Validity_Checks
(N
);
8779 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8780 -- means we no longer have a /= operation, we are all done.
8782 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8784 if Nkind
(N
) /= N_Op_Ne
then
8788 -- Boolean types (requiring handling of non-standard case)
8790 if Is_Boolean_Type
(Typ
) then
8791 Adjust_Condition
(Left_Opnd
(N
));
8792 Adjust_Condition
(Right_Opnd
(N
));
8793 Set_Etype
(N
, Standard_Boolean
);
8794 Adjust_Result_Type
(N
, Typ
);
8797 Rewrite_Comparison
(N
);
8799 -- For all cases other than elementary types, we rewrite node as the
8800 -- negation of an equality operation, and reanalyze. The equality to be
8801 -- used is defined in the same scope and has the same signature. This
8802 -- signature must be set explicitly since in an instance it may not have
8803 -- the same visibility as in the generic unit. This avoids duplicating
8804 -- or factoring the complex code for record/array equality tests etc.
8808 Loc
: constant Source_Ptr
:= Sloc
(N
);
8810 Ne
: constant Entity_Id
:= Entity
(N
);
8813 Binary_Op_Validity_Checks
(N
);
8819 Left_Opnd
=> Left_Opnd
(N
),
8820 Right_Opnd
=> Right_Opnd
(N
)));
8821 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
8823 if Scope
(Ne
) /= Standard_Standard
then
8824 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
8827 -- For navigation purposes, we want to treat the inequality as an
8828 -- implicit reference to the corresponding equality. Preserve the
8829 -- Comes_From_ source flag to generate proper Xref entries.
8831 Preserve_Comes_From_Source
(Neg
, N
);
8832 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
8834 Analyze_And_Resolve
(N
, Standard_Boolean
);
8838 Optimize_Length_Comparison
(N
);
8841 ---------------------
8842 -- Expand_N_Op_Not --
8843 ---------------------
8845 -- If the argument is other than a Boolean array type, there is no special
8846 -- expansion required, except for dealing with validity checks, and non-
8847 -- standard boolean representations.
8849 -- For the packed array case, we call the special routine in Exp_Pakd,
8850 -- except that if the component size is greater than one, we use the
8851 -- standard routine generating a gruesome loop (it is so peculiar to have
8852 -- packed arrays with non-standard Boolean representations anyway, so it
8853 -- does not matter that we do not handle this case efficiently).
8855 -- For the unpacked array case (and for the special packed case where we
8856 -- have non standard Booleans, as discussed above), we generate and insert
8857 -- into the tree the following function definition:
8859 -- function Nnnn (A : arr) is
8862 -- for J in a'range loop
8863 -- B (J) := not A (J);
8868 -- Here arr is the actual subtype of the parameter (and hence always
8869 -- constrained). Then we replace the not with a call to this function.
8871 procedure Expand_N_Op_Not
(N
: Node_Id
) is
8872 Loc
: constant Source_Ptr
:= Sloc
(N
);
8873 Typ
: constant Entity_Id
:= Etype
(N
);
8882 Func_Name
: Entity_Id
;
8883 Loop_Statement
: Node_Id
;
8886 Unary_Op_Validity_Checks
(N
);
8888 -- For boolean operand, deal with non-standard booleans
8890 if Is_Boolean_Type
(Typ
) then
8891 Adjust_Condition
(Right_Opnd
(N
));
8892 Set_Etype
(N
, Standard_Boolean
);
8893 Adjust_Result_Type
(N
, Typ
);
8897 -- Only array types need any other processing
8899 if not Is_Array_Type
(Typ
) then
8903 -- Case of array operand. If bit packed with a component size of 1,
8904 -- handle it in Exp_Pakd if the operand is known to be aligned.
8906 if Is_Bit_Packed_Array
(Typ
)
8907 and then Component_Size
(Typ
) = 1
8908 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
8910 Expand_Packed_Not
(N
);
8914 -- Case of array operand which is not bit-packed. If the context is
8915 -- a safe assignment, call in-place operation, If context is a larger
8916 -- boolean expression in the context of a safe assignment, expansion is
8917 -- done by enclosing operation.
8919 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
8920 Convert_To_Actual_Subtype
(Opnd
);
8921 Arr
:= Etype
(Opnd
);
8922 Ensure_Defined
(Arr
, N
);
8923 Silly_Boolean_Array_Not_Test
(N
, Arr
);
8925 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
8926 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
8927 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8930 -- Special case the negation of a binary operation
8932 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
8933 and then Safe_In_Place_Array_Op
8934 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
8936 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8940 elsif Nkind
(Parent
(N
)) in N_Binary_Op
8941 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
8944 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
8945 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
8946 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
8949 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
8951 -- (not A) op (not B) can be reduced to a single call
8953 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
8956 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
8959 -- A xor (not B) can also be special-cased
8961 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
8968 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
8969 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8970 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
8973 Make_Indexed_Component
(Loc
,
8974 Prefix
=> New_Occurrence_Of
(A
, Loc
),
8975 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8978 Make_Indexed_Component
(Loc
,
8979 Prefix
=> New_Occurrence_Of
(B
, Loc
),
8980 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8983 Make_Implicit_Loop_Statement
(N
,
8984 Identifier
=> Empty
,
8987 Make_Iteration_Scheme
(Loc
,
8988 Loop_Parameter_Specification
=>
8989 Make_Loop_Parameter_Specification
(Loc
,
8990 Defining_Identifier
=> J
,
8991 Discrete_Subtype_Definition
=>
8992 Make_Attribute_Reference
(Loc
,
8993 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
8994 Attribute_Name
=> Name_Range
))),
8996 Statements
=> New_List
(
8997 Make_Assignment_Statement
(Loc
,
8999 Expression
=> Make_Op_Not
(Loc
, A_J
))));
9001 Func_Name
:= Make_Temporary
(Loc
, 'N');
9002 Set_Is_Inlined
(Func_Name
);
9005 Make_Subprogram_Body
(Loc
,
9007 Make_Function_Specification
(Loc
,
9008 Defining_Unit_Name
=> Func_Name
,
9009 Parameter_Specifications
=> New_List
(
9010 Make_Parameter_Specification
(Loc
,
9011 Defining_Identifier
=> A
,
9012 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9013 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9015 Declarations
=> New_List
(
9016 Make_Object_Declaration
(Loc
,
9017 Defining_Identifier
=> B
,
9018 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
9020 Handled_Statement_Sequence
=>
9021 Make_Handled_Sequence_Of_Statements
(Loc
,
9022 Statements
=> New_List
(
9024 Make_Simple_Return_Statement
(Loc
,
9025 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
9028 Make_Function_Call
(Loc
,
9029 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
9030 Parameter_Associations
=> New_List
(Opnd
)));
9032 Analyze_And_Resolve
(N
, Typ
);
9033 end Expand_N_Op_Not
;
9035 --------------------
9036 -- Expand_N_Op_Or --
9037 --------------------
9039 procedure Expand_N_Op_Or
(N
: Node_Id
) is
9040 Typ
: constant Entity_Id
:= Etype
(N
);
9043 Binary_Op_Validity_Checks
(N
);
9045 if Is_Array_Type
(Etype
(N
)) then
9046 Expand_Boolean_Operator
(N
);
9048 elsif Is_Boolean_Type
(Etype
(N
)) then
9049 Adjust_Condition
(Left_Opnd
(N
));
9050 Adjust_Condition
(Right_Opnd
(N
));
9051 Set_Etype
(N
, Standard_Boolean
);
9052 Adjust_Result_Type
(N
, Typ
);
9054 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9055 Expand_Intrinsic_Call
(N
, Entity
(N
));
9060 ----------------------
9061 -- Expand_N_Op_Plus --
9062 ----------------------
9064 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
9066 Unary_Op_Validity_Checks
(N
);
9068 -- Check for MINIMIZED/ELIMINATED overflow mode
9070 if Minimized_Eliminated_Overflow_Check
(N
) then
9071 Apply_Arithmetic_Overflow_Check
(N
);
9074 end Expand_N_Op_Plus
;
9076 ---------------------
9077 -- Expand_N_Op_Rem --
9078 ---------------------
9080 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
9081 Loc
: constant Source_Ptr
:= Sloc
(N
);
9082 Typ
: constant Entity_Id
:= Etype
(N
);
9093 -- Set if corresponding operand can be negative
9095 pragma Unreferenced
(Hi
);
9098 Binary_Op_Validity_Checks
(N
);
9100 -- Check for MINIMIZED/ELIMINATED overflow mode
9102 if Minimized_Eliminated_Overflow_Check
(N
) then
9103 Apply_Arithmetic_Overflow_Check
(N
);
9107 if Is_Integer_Type
(Etype
(N
)) then
9108 Apply_Divide_Checks
(N
);
9110 -- All done if we don't have a REM any more, which can happen as a
9111 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9113 if Nkind
(N
) /= N_Op_Rem
then
9118 -- Proceed with expansion of REM
9120 Left
:= Left_Opnd
(N
);
9121 Right
:= Right_Opnd
(N
);
9123 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9124 -- but it is useful with other back ends (e.g. AAMP), and is certainly
9127 if Is_Integer_Type
(Etype
(N
))
9128 and then Compile_Time_Known_Value
(Right
)
9129 and then Expr_Value
(Right
) = Uint_1
9131 -- Call Remove_Side_Effects to ensure that any side effects in the
9132 -- ignored left operand (in particular function calls to user defined
9133 -- functions) are properly executed.
9135 Remove_Side_Effects
(Left
);
9137 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9138 Analyze_And_Resolve
(N
, Typ
);
9142 -- Deal with annoying case of largest negative number remainder minus
9143 -- one. Gigi may not handle this case correctly, because on some
9144 -- targets, the mod value is computed using a divide instruction
9145 -- which gives an overflow trap for this case.
9147 -- It would be a bit more efficient to figure out which targets this
9148 -- is really needed for, but in practice it is reasonable to do the
9149 -- following special check in all cases, since it means we get a clearer
9150 -- message, and also the overhead is minimal given that division is
9151 -- expensive in any case.
9153 -- In fact the check is quite easy, if the right operand is -1, then
9154 -- the remainder is always 0, and we can just ignore the left operand
9155 -- completely in this case.
9157 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9158 Lneg
:= (not OK
) or else Lo
< 0;
9160 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9161 Rneg
:= (not OK
) or else Lo
< 0;
9163 -- We won't mess with trying to find out if the left operand can really
9164 -- be the largest negative number (that's a pain in the case of private
9165 -- types and this is really marginal). We will just assume that we need
9166 -- the test if the left operand can be negative at all.
9168 if Lneg
and Rneg
then
9170 Make_If_Expression
(Loc
,
9171 Expressions
=> New_List
(
9173 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9175 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
9177 Unchecked_Convert_To
(Typ
,
9178 Make_Integer_Literal
(Loc
, Uint_0
)),
9180 Relocate_Node
(N
))));
9182 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9183 Analyze_And_Resolve
(N
, Typ
);
9185 end Expand_N_Op_Rem
;
9187 -----------------------------
9188 -- Expand_N_Op_Rotate_Left --
9189 -----------------------------
9191 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
9193 Binary_Op_Validity_Checks
(N
);
9195 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9196 -- so we rewrite in terms of logical shifts
9198 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9200 -- where Bits is the shift count mod Esize (the mod operation here
9201 -- deals with ludicrous large shift counts, which are apparently OK).
9203 -- What about nonbinary modulus ???
9206 Loc
: constant Source_Ptr
:= Sloc
(N
);
9207 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9208 Typ
: constant Entity_Id
:= Etype
(N
);
9211 if Modify_Tree_For_C
then
9212 Rewrite
(Right_Opnd
(N
),
9214 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9215 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9217 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9222 Make_Op_Shift_Left
(Loc
,
9223 Left_Opnd
=> Left_Opnd
(N
),
9224 Right_Opnd
=> Right_Opnd
(N
)),
9227 Make_Op_Shift_Right
(Loc
,
9228 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9230 Make_Op_Subtract
(Loc
,
9231 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9233 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9235 Analyze_And_Resolve
(N
, Typ
);
9238 end Expand_N_Op_Rotate_Left
;
9240 ------------------------------
9241 -- Expand_N_Op_Rotate_Right --
9242 ------------------------------
9244 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
9246 Binary_Op_Validity_Checks
(N
);
9248 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9249 -- so we rewrite in terms of logical shifts
9251 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9253 -- where Bits is the shift count mod Esize (the mod operation here
9254 -- deals with ludicrous large shift counts, which are apparently OK).
9256 -- What about nonbinary modulus ???
9259 Loc
: constant Source_Ptr
:= Sloc
(N
);
9260 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9261 Typ
: constant Entity_Id
:= Etype
(N
);
9264 Rewrite
(Right_Opnd
(N
),
9266 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9267 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9269 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9271 if Modify_Tree_For_C
then
9275 Make_Op_Shift_Right
(Loc
,
9276 Left_Opnd
=> Left_Opnd
(N
),
9277 Right_Opnd
=> Right_Opnd
(N
)),
9280 Make_Op_Shift_Left
(Loc
,
9281 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9283 Make_Op_Subtract
(Loc
,
9284 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9286 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9288 Analyze_And_Resolve
(N
, Typ
);
9291 end Expand_N_Op_Rotate_Right
;
9293 ----------------------------
9294 -- Expand_N_Op_Shift_Left --
9295 ----------------------------
9297 -- Note: nothing in this routine depends on left as opposed to right shifts
9298 -- so we share the routine for expanding shift right operations.
9300 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
9302 Binary_Op_Validity_Checks
(N
);
9304 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9305 -- operand is not greater than the word size (since that would not
9306 -- be defined properly by the corresponding C shift operator).
9308 if Modify_Tree_For_C
then
9310 Right
: constant Node_Id
:= Right_Opnd
(N
);
9311 Loc
: constant Source_Ptr
:= Sloc
(Right
);
9312 Typ
: constant Entity_Id
:= Etype
(N
);
9313 Siz
: constant Uint
:= Esize
(Typ
);
9320 if Compile_Time_Known_Value
(Right
) then
9321 if Expr_Value
(Right
) >= Siz
then
9322 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9323 Analyze_And_Resolve
(N
, Typ
);
9326 -- Not compile time known, find range
9329 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9331 -- Nothing to do if known to be OK range, otherwise expand
9333 if not OK
or else Hi
>= Siz
then
9335 -- Prevent recursion on copy of shift node
9337 Orig
:= Relocate_Node
(N
);
9338 Set_Analyzed
(Orig
);
9340 -- Now do the rewrite
9343 Make_If_Expression
(Loc
,
9344 Expressions
=> New_List
(
9346 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
9347 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
9348 Make_Integer_Literal
(Loc
, 0),
9350 Analyze_And_Resolve
(N
, Typ
);
9355 end Expand_N_Op_Shift_Left
;
9357 -----------------------------
9358 -- Expand_N_Op_Shift_Right --
9359 -----------------------------
9361 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
9363 -- Share shift left circuit
9365 Expand_N_Op_Shift_Left
(N
);
9366 end Expand_N_Op_Shift_Right
;
9368 ----------------------------------------
9369 -- Expand_N_Op_Shift_Right_Arithmetic --
9370 ----------------------------------------
9372 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
9374 Binary_Op_Validity_Checks
(N
);
9376 -- If we are in Modify_Tree_For_C mode, there is no shift right
9377 -- arithmetic in C, so we rewrite in terms of logical shifts.
9379 -- Shift_Right (Num, Bits) or
9381 -- then not (Shift_Right (Mask, bits))
9384 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9386 -- Note: in almost all C compilers it would work to just shift a
9387 -- signed integer right, but it's undefined and we cannot rely on it.
9389 -- Note: the above works fine for shift counts greater than or equal
9390 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9391 -- generates all 1'bits.
9393 -- What about nonbinary modulus ???
9396 Loc
: constant Source_Ptr
:= Sloc
(N
);
9397 Typ
: constant Entity_Id
:= Etype
(N
);
9398 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
9399 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
9400 Left
: constant Node_Id
:= Left_Opnd
(N
);
9401 Right
: constant Node_Id
:= Right_Opnd
(N
);
9405 if Modify_Tree_For_C
then
9407 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9408 -- compile time as a single constant.
9410 if Compile_Time_Known_Value
(Right
) then
9412 Val
: constant Uint
:= Expr_Value
(Right
);
9415 if Val
>= Esize
(Typ
) then
9416 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
9420 Make_Integer_Literal
(Loc
,
9421 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
9429 Make_Op_Shift_Right
(Loc
,
9430 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
9431 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
9434 -- Now do the rewrite
9439 Make_Op_Shift_Right
(Loc
,
9441 Right_Opnd
=> Right
),
9443 Make_If_Expression
(Loc
,
9444 Expressions
=> New_List
(
9446 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9447 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
9449 Make_Integer_Literal
(Loc
, 0)))));
9450 Analyze_And_Resolve
(N
, Typ
);
9453 end Expand_N_Op_Shift_Right_Arithmetic
;
9455 --------------------------
9456 -- Expand_N_Op_Subtract --
9457 --------------------------
9459 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
9460 Typ
: constant Entity_Id
:= Etype
(N
);
9463 Binary_Op_Validity_Checks
(N
);
9465 -- Check for MINIMIZED/ELIMINATED overflow mode
9467 if Minimized_Eliminated_Overflow_Check
(N
) then
9468 Apply_Arithmetic_Overflow_Check
(N
);
9472 -- N - 0 = N for integer types
9474 if Is_Integer_Type
(Typ
)
9475 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
9476 and then Expr_Value
(Right_Opnd
(N
)) = 0
9478 Rewrite
(N
, Left_Opnd
(N
));
9482 -- Arithmetic overflow checks for signed integer/fixed point types
9484 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
9485 Apply_Arithmetic_Overflow_Check
(N
);
9488 -- Overflow checks for floating-point if -gnateF mode active
9490 Check_Float_Op_Overflow
(N
);
9491 end Expand_N_Op_Subtract
;
9493 ---------------------
9494 -- Expand_N_Op_Xor --
9495 ---------------------
9497 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
9498 Typ
: constant Entity_Id
:= Etype
(N
);
9501 Binary_Op_Validity_Checks
(N
);
9503 if Is_Array_Type
(Etype
(N
)) then
9504 Expand_Boolean_Operator
(N
);
9506 elsif Is_Boolean_Type
(Etype
(N
)) then
9507 Adjust_Condition
(Left_Opnd
(N
));
9508 Adjust_Condition
(Right_Opnd
(N
));
9509 Set_Etype
(N
, Standard_Boolean
);
9510 Adjust_Result_Type
(N
, Typ
);
9512 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9513 Expand_Intrinsic_Call
(N
, Entity
(N
));
9516 end Expand_N_Op_Xor
;
9518 ----------------------
9519 -- Expand_N_Or_Else --
9520 ----------------------
9522 procedure Expand_N_Or_Else
(N
: Node_Id
)
9523 renames Expand_Short_Circuit_Operator
;
9525 -----------------------------------
9526 -- Expand_N_Qualified_Expression --
9527 -----------------------------------
9529 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
9530 Operand
: constant Node_Id
:= Expression
(N
);
9531 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
9534 -- Do validity check if validity checking operands
9536 if Validity_Checks_On
and Validity_Check_Operands
then
9537 Ensure_Valid
(Operand
);
9540 -- Apply possible constraint check
9542 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
9544 if Do_Range_Check
(Operand
) then
9545 Set_Do_Range_Check
(Operand
, False);
9546 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
9548 end Expand_N_Qualified_Expression
;
9550 ------------------------------------
9551 -- Expand_N_Quantified_Expression --
9552 ------------------------------------
9556 -- for all X in range => Cond
9561 -- for X in range loop
9568 -- Similarly, an existentially quantified expression:
9570 -- for some X in range => Cond
9575 -- for X in range loop
9582 -- In both cases, the iteration may be over a container in which case it is
9583 -- given by an iterator specification, not a loop parameter specification.
9585 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
9586 Actions
: constant List_Id
:= New_List
;
9587 For_All
: constant Boolean := All_Present
(N
);
9588 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
9589 Loc
: constant Source_Ptr
:= Sloc
(N
);
9590 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
9597 -- Create the declaration of the flag which tracks the status of the
9598 -- quantified expression. Generate:
9600 -- Flag : Boolean := (True | False);
9602 Flag
:= Make_Temporary
(Loc
, 'T', N
);
9605 Make_Object_Declaration
(Loc
,
9606 Defining_Identifier
=> Flag
,
9607 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
9609 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
9611 -- Construct the circuitry which tracks the status of the quantified
9612 -- expression. Generate:
9614 -- if [not] Cond then
9615 -- Flag := (False | True);
9619 Cond
:= Relocate_Node
(Condition
(N
));
9622 Cond
:= Make_Op_Not
(Loc
, Cond
);
9626 Make_Implicit_If_Statement
(N
,
9628 Then_Statements
=> New_List
(
9629 Make_Assignment_Statement
(Loc
,
9630 Name
=> New_Occurrence_Of
(Flag
, Loc
),
9632 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
9633 Make_Exit_Statement
(Loc
))));
9635 -- Build the loop equivalent of the quantified expression
9637 if Present
(Iter_Spec
) then
9639 Make_Iteration_Scheme
(Loc
,
9640 Iterator_Specification
=> Iter_Spec
);
9643 Make_Iteration_Scheme
(Loc
,
9644 Loop_Parameter_Specification
=> Loop_Spec
);
9648 Make_Loop_Statement
(Loc
,
9649 Iteration_Scheme
=> Scheme
,
9650 Statements
=> Stmts
,
9651 End_Label
=> Empty
));
9653 -- Transform the quantified expression
9656 Make_Expression_With_Actions
(Loc
,
9657 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
9658 Actions
=> Actions
));
9659 Analyze_And_Resolve
(N
, Standard_Boolean
);
9660 end Expand_N_Quantified_Expression
;
9662 ---------------------------------
9663 -- Expand_N_Selected_Component --
9664 ---------------------------------
9666 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
9667 Loc
: constant Source_Ptr
:= Sloc
(N
);
9668 Par
: constant Node_Id
:= Parent
(N
);
9669 P
: constant Node_Id
:= Prefix
(N
);
9670 S
: constant Node_Id
:= Selector_Name
(N
);
9671 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
9677 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
9678 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9679 -- unless the context of an assignment can provide size information.
9680 -- Don't we have a general routine that does this???
9682 function Is_Subtype_Declaration
return Boolean;
9683 -- The replacement of a discriminant reference by its value is required
9684 -- if this is part of the initialization of an temporary generated by a
9685 -- change of representation. This shows up as the construction of a
9686 -- discriminant constraint for a subtype declared at the same point as
9687 -- the entity in the prefix of the selected component. We recognize this
9688 -- case when the context of the reference is:
9689 -- subtype ST is T(Obj.D);
9690 -- where the entity for Obj comes from source, and ST has the same sloc.
9692 -----------------------
9693 -- In_Left_Hand_Side --
9694 -----------------------
9696 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
9698 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
9699 and then Comp
= Name
(Parent
(Comp
)))
9700 or else (Present
(Parent
(Comp
))
9701 and then Nkind
(Parent
(Comp
)) in N_Subexpr
9702 and then In_Left_Hand_Side
(Parent
(Comp
)));
9703 end In_Left_Hand_Side
;
9705 -----------------------------
9706 -- Is_Subtype_Declaration --
9707 -----------------------------
9709 function Is_Subtype_Declaration
return Boolean is
9710 Par
: constant Node_Id
:= Parent
(N
);
9713 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
9714 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
9715 and then Comes_From_Source
(Entity
(Prefix
(N
)))
9716 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
9717 end Is_Subtype_Declaration
;
9719 -- Start of processing for Expand_N_Selected_Component
9722 -- Insert explicit dereference if required
9724 if Is_Access_Type
(Ptyp
) then
9726 -- First set prefix type to proper access type, in case it currently
9727 -- has a private (non-access) view of this type.
9729 Set_Etype
(P
, Ptyp
);
9731 Insert_Explicit_Dereference
(P
);
9732 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
9734 if Ekind
(Etype
(P
)) = E_Private_Subtype
9735 and then Is_For_Access_Subtype
(Etype
(P
))
9737 Set_Etype
(P
, Base_Type
(Etype
(P
)));
9743 -- Deal with discriminant check required
9745 if Do_Discriminant_Check
(N
) then
9746 if Present
(Discriminant_Checking_Func
9747 (Original_Record_Component
(Entity
(S
))))
9749 -- Present the discriminant checking function to the backend, so
9750 -- that it can inline the call to the function.
9753 (Discriminant_Checking_Func
9754 (Original_Record_Component
(Entity
(S
))),
9757 -- Now reset the flag and generate the call
9759 Set_Do_Discriminant_Check
(N
, False);
9760 Generate_Discriminant_Check
(N
);
9762 -- In the case of Unchecked_Union, no discriminant checking is
9763 -- actually performed.
9766 Set_Do_Discriminant_Check
(N
, False);
9770 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9771 -- function, then additional actuals must be passed.
9773 if Ada_Version
>= Ada_2005
9774 and then Is_Build_In_Place_Function_Call
(P
)
9776 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
9779 -- Gigi cannot handle unchecked conversions that are the prefix of a
9780 -- selected component with discriminants. This must be checked during
9781 -- expansion, because during analysis the type of the selector is not
9782 -- known at the point the prefix is analyzed. If the conversion is the
9783 -- target of an assignment, then we cannot force the evaluation.
9785 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
9786 and then Has_Discriminants
(Etype
(N
))
9787 and then not In_Left_Hand_Side
(N
)
9789 Force_Evaluation
(Prefix
(N
));
9792 -- Remaining processing applies only if selector is a discriminant
9794 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
9796 -- If the selector is a discriminant of a constrained record type,
9797 -- we may be able to rewrite the expression with the actual value
9798 -- of the discriminant, a useful optimization in some cases.
9800 if Is_Record_Type
(Ptyp
)
9801 and then Has_Discriminants
(Ptyp
)
9802 and then Is_Constrained
(Ptyp
)
9804 -- Do this optimization for discrete types only, and not for
9805 -- access types (access discriminants get us into trouble).
9807 if not Is_Discrete_Type
(Etype
(N
)) then
9810 -- Don't do this on the left hand of an assignment statement.
9811 -- Normally one would think that references like this would not
9812 -- occur, but they do in generated code, and mean that we really
9813 -- do want to assign the discriminant.
9815 elsif Nkind
(Par
) = N_Assignment_Statement
9816 and then Name
(Par
) = N
9820 -- Don't do this optimization for the prefix of an attribute or
9821 -- the name of an object renaming declaration since these are
9822 -- contexts where we do not want the value anyway.
9824 elsif (Nkind
(Par
) = N_Attribute_Reference
9825 and then Prefix
(Par
) = N
)
9826 or else Is_Renamed_Object
(N
)
9830 -- Don't do this optimization if we are within the code for a
9831 -- discriminant check, since the whole point of such a check may
9832 -- be to verify the condition on which the code below depends.
9834 elsif Is_In_Discriminant_Check
(N
) then
9837 -- Green light to see if we can do the optimization. There is
9838 -- still one condition that inhibits the optimization below but
9839 -- now is the time to check the particular discriminant.
9842 -- Loop through discriminants to find the matching discriminant
9843 -- constraint to see if we can copy it.
9845 Disc
:= First_Discriminant
(Ptyp
);
9846 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
9847 Discr_Loop
: while Present
(Dcon
) loop
9848 Dval
:= Node
(Dcon
);
9850 -- Check if this is the matching discriminant and if the
9851 -- discriminant value is simple enough to make sense to
9852 -- copy. We don't want to copy complex expressions, and
9853 -- indeed to do so can cause trouble (before we put in
9854 -- this guard, a discriminant expression containing an
9855 -- AND THEN was copied, causing problems for coverage
9858 -- However, if the reference is part of the initialization
9859 -- code generated for an object declaration, we must use
9860 -- the discriminant value from the subtype constraint,
9861 -- because the selected component may be a reference to the
9862 -- object being initialized, whose discriminant is not yet
9863 -- set. This only happens in complex cases involving changes
9864 -- or representation.
9866 if Disc
= Entity
(Selector_Name
(N
))
9867 and then (Is_Entity_Name
(Dval
)
9868 or else Compile_Time_Known_Value
(Dval
)
9869 or else Is_Subtype_Declaration
)
9871 -- Here we have the matching discriminant. Check for
9872 -- the case of a discriminant of a component that is
9873 -- constrained by an outer discriminant, which cannot
9874 -- be optimized away.
9876 if Denotes_Discriminant
9877 (Dval
, Check_Concurrent
=> True)
9881 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
9883 Denotes_Discriminant
9884 (Selector_Name
(Original_Node
(Dval
)), True)
9888 -- Do not retrieve value if constraint is not static. It
9889 -- is generally not useful, and the constraint may be a
9890 -- rewritten outer discriminant in which case it is in
9893 elsif Is_Entity_Name
(Dval
)
9895 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
9896 and then Present
(Expression
(Parent
(Entity
(Dval
))))
9898 Is_OK_Static_Expression
9899 (Expression
(Parent
(Entity
(Dval
))))
9903 -- In the context of a case statement, the expression may
9904 -- have the base type of the discriminant, and we need to
9905 -- preserve the constraint to avoid spurious errors on
9908 elsif Nkind
(Parent
(N
)) = N_Case_Statement
9909 and then Etype
(Dval
) /= Etype
(Disc
)
9912 Make_Qualified_Expression
(Loc
,
9914 New_Occurrence_Of
(Etype
(Disc
), Loc
),
9916 New_Copy_Tree
(Dval
)));
9917 Analyze_And_Resolve
(N
, Etype
(Disc
));
9919 -- In case that comes out as a static expression,
9920 -- reset it (a selected component is never static).
9922 Set_Is_Static_Expression
(N
, False);
9925 -- Otherwise we can just copy the constraint, but the
9926 -- result is certainly not static. In some cases the
9927 -- discriminant constraint has been analyzed in the
9928 -- context of the original subtype indication, but for
9929 -- itypes the constraint might not have been analyzed
9930 -- yet, and this must be done now.
9933 Rewrite
(N
, New_Copy_Tree
(Dval
));
9934 Analyze_And_Resolve
(N
);
9935 Set_Is_Static_Expression
(N
, False);
9941 Next_Discriminant
(Disc
);
9942 end loop Discr_Loop
;
9944 -- Note: the above loop should always find a matching
9945 -- discriminant, but if it does not, we just missed an
9946 -- optimization due to some glitch (perhaps a previous
9947 -- error), so ignore.
9952 -- The only remaining processing is in the case of a discriminant of
9953 -- a concurrent object, where we rewrite the prefix to denote the
9954 -- corresponding record type. If the type is derived and has renamed
9955 -- discriminants, use corresponding discriminant, which is the one
9956 -- that appears in the corresponding record.
9958 if not Is_Concurrent_Type
(Ptyp
) then
9962 Disc
:= Entity
(Selector_Name
(N
));
9964 if Is_Derived_Type
(Ptyp
)
9965 and then Present
(Corresponding_Discriminant
(Disc
))
9967 Disc
:= Corresponding_Discriminant
(Disc
);
9971 Make_Selected_Component
(Loc
,
9973 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
9975 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
9981 -- Set Atomic_Sync_Required if necessary for atomic component
9983 if Nkind
(N
) = N_Selected_Component
then
9985 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
9989 -- If component is atomic, but type is not, setting depends on
9990 -- disable/enable state for the component.
9992 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
9993 Set
:= not Atomic_Synchronization_Disabled
(E
);
9995 -- If component is not atomic, but its type is atomic, setting
9996 -- depends on disable/enable state for the type.
9998 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9999 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
10001 -- If both component and type are atomic, we disable if either
10002 -- component or its type have sync disabled.
10004 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
10005 Set
:= (not Atomic_Synchronization_Disabled
(E
))
10007 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
10013 -- Set flag if required
10016 Activate_Atomic_Synchronization
(N
);
10020 end Expand_N_Selected_Component
;
10022 --------------------
10023 -- Expand_N_Slice --
10024 --------------------
10026 procedure Expand_N_Slice
(N
: Node_Id
) is
10027 Loc
: constant Source_Ptr
:= Sloc
(N
);
10028 Typ
: constant Entity_Id
:= Etype
(N
);
10030 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
10031 -- Check whether the argument is an actual for a procedure call, in
10032 -- which case the expansion of a bit-packed slice is deferred until the
10033 -- call itself is expanded. The reason this is required is that we might
10034 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10035 -- that copy out would be missed if we created a temporary here in
10036 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10037 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10038 -- is harmless to defer expansion in the IN case, since the call
10039 -- processing will still generate the appropriate copy in operation,
10040 -- which will take care of the slice.
10042 procedure Make_Temporary_For_Slice
;
10043 -- Create a named variable for the value of the slice, in cases where
10044 -- the back-end cannot handle it properly, e.g. when packed types or
10045 -- unaligned slices are involved.
10047 -------------------------
10048 -- Is_Procedure_Actual --
10049 -------------------------
10051 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
10052 Par
: Node_Id
:= Parent
(N
);
10056 -- If our parent is a procedure call we can return
10058 if Nkind
(Par
) = N_Procedure_Call_Statement
then
10061 -- If our parent is a type conversion, keep climbing the tree,
10062 -- since a type conversion can be a procedure actual. Also keep
10063 -- climbing if parameter association or a qualified expression,
10064 -- since these are additional cases that do can appear on
10065 -- procedure actuals.
10067 elsif Nkind_In
(Par
, N_Type_Conversion
,
10068 N_Parameter_Association
,
10069 N_Qualified_Expression
)
10071 Par
:= Parent
(Par
);
10073 -- Any other case is not what we are looking for
10079 end Is_Procedure_Actual
;
10081 ------------------------------
10082 -- Make_Temporary_For_Slice --
10083 ------------------------------
10085 procedure Make_Temporary_For_Slice
is
10086 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
10091 Make_Object_Declaration
(Loc
,
10092 Defining_Identifier
=> Ent
,
10093 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10095 Set_No_Initialization
(Decl
);
10097 Insert_Actions
(N
, New_List
(
10099 Make_Assignment_Statement
(Loc
,
10100 Name
=> New_Occurrence_Of
(Ent
, Loc
),
10101 Expression
=> Relocate_Node
(N
))));
10103 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
10104 Analyze_And_Resolve
(N
, Typ
);
10105 end Make_Temporary_For_Slice
;
10109 Pref
: constant Node_Id
:= Prefix
(N
);
10110 Pref_Typ
: Entity_Id
:= Etype
(Pref
);
10112 -- Start of processing for Expand_N_Slice
10115 -- Special handling for access types
10117 if Is_Access_Type
(Pref_Typ
) then
10118 Pref_Typ
:= Designated_Type
(Pref_Typ
);
10121 Make_Explicit_Dereference
(Sloc
(N
),
10122 Prefix
=> Relocate_Node
(Pref
)));
10124 Analyze_And_Resolve
(Pref
, Pref_Typ
);
10127 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10128 -- function, then additional actuals must be passed.
10130 if Ada_Version
>= Ada_2005
10131 and then Is_Build_In_Place_Function_Call
(Pref
)
10133 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
10136 -- The remaining case to be handled is packed slices. We can leave
10137 -- packed slices as they are in the following situations:
10139 -- 1. Right or left side of an assignment (we can handle this
10140 -- situation correctly in the assignment statement expansion).
10142 -- 2. Prefix of indexed component (the slide is optimized away in this
10143 -- case, see the start of Expand_N_Slice.)
10145 -- 3. Object renaming declaration, since we want the name of the
10146 -- slice, not the value.
10148 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10149 -- be required, and this is handled in the expansion of call
10152 -- 5. Prefix of an address attribute (this is an error which is caught
10153 -- elsewhere, and the expansion would interfere with generating the
10156 if not Is_Packed
(Typ
) then
10158 -- Apply transformation for actuals of a function call, where
10159 -- Expand_Actuals is not used.
10161 if Nkind
(Parent
(N
)) = N_Function_Call
10162 and then Is_Possibly_Unaligned_Slice
(N
)
10164 Make_Temporary_For_Slice
;
10167 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
10168 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
10169 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
10173 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
10174 or else Is_Renamed_Object
(N
)
10175 or else Is_Procedure_Actual
(N
)
10179 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
10180 and then Attribute_Name
(Parent
(N
)) = Name_Address
10185 Make_Temporary_For_Slice
;
10187 end Expand_N_Slice
;
10189 ------------------------------
10190 -- Expand_N_Type_Conversion --
10191 ------------------------------
10193 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
10194 Loc
: constant Source_Ptr
:= Sloc
(N
);
10195 Operand
: constant Node_Id
:= Expression
(N
);
10196 Target_Type
: constant Entity_Id
:= Etype
(N
);
10197 Operand_Type
: Entity_Id
:= Etype
(Operand
);
10199 procedure Handle_Changed_Representation
;
10200 -- This is called in the case of record and array type conversions to
10201 -- see if there is a change of representation to be handled. Change of
10202 -- representation is actually handled at the assignment statement level,
10203 -- and what this procedure does is rewrite node N conversion as an
10204 -- assignment to temporary. If there is no change of representation,
10205 -- then the conversion node is unchanged.
10207 procedure Raise_Accessibility_Error
;
10208 -- Called when we know that an accessibility check will fail. Rewrites
10209 -- node N to an appropriate raise statement and outputs warning msgs.
10210 -- The Etype of the raise node is set to Target_Type. Note that in this
10211 -- case the rest of the processing should be skipped (i.e. the call to
10212 -- this procedure will be followed by "goto Done").
10214 procedure Real_Range_Check
;
10215 -- Handles generation of range check for real target value
10217 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
10218 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
10219 -- evaluates to True.
10221 -----------------------------------
10222 -- Handle_Changed_Representation --
10223 -----------------------------------
10225 procedure Handle_Changed_Representation
is
10234 -- Nothing else to do if no change of representation
10236 if Same_Representation
(Operand_Type
, Target_Type
) then
10239 -- The real change of representation work is done by the assignment
10240 -- statement processing. So if this type conversion is appearing as
10241 -- the expression of an assignment statement, nothing needs to be
10242 -- done to the conversion.
10244 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
10247 -- Otherwise we need to generate a temporary variable, and do the
10248 -- change of representation assignment into that temporary variable.
10249 -- The conversion is then replaced by a reference to this variable.
10254 -- If type is unconstrained we have to add a constraint, copied
10255 -- from the actual value of the left hand side.
10257 if not Is_Constrained
(Target_Type
) then
10258 if Has_Discriminants
(Operand_Type
) then
10259 Disc
:= First_Discriminant
(Operand_Type
);
10261 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
10262 Disc
:= First_Stored_Discriminant
(Operand_Type
);
10266 while Present
(Disc
) loop
10268 Make_Selected_Component
(Loc
,
10270 Duplicate_Subexpr_Move_Checks
(Operand
),
10272 Make_Identifier
(Loc
, Chars
(Disc
))));
10273 Next_Discriminant
(Disc
);
10276 elsif Is_Array_Type
(Operand_Type
) then
10277 N_Ix
:= First_Index
(Target_Type
);
10280 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
10282 -- We convert the bounds explicitly. We use an unchecked
10283 -- conversion because bounds checks are done elsewhere.
10288 Unchecked_Convert_To
(Etype
(N_Ix
),
10289 Make_Attribute_Reference
(Loc
,
10291 Duplicate_Subexpr_No_Checks
10292 (Operand
, Name_Req
=> True),
10293 Attribute_Name
=> Name_First
,
10294 Expressions
=> New_List
(
10295 Make_Integer_Literal
(Loc
, J
)))),
10298 Unchecked_Convert_To
(Etype
(N_Ix
),
10299 Make_Attribute_Reference
(Loc
,
10301 Duplicate_Subexpr_No_Checks
10302 (Operand
, Name_Req
=> True),
10303 Attribute_Name
=> Name_Last
,
10304 Expressions
=> New_List
(
10305 Make_Integer_Literal
(Loc
, J
))))));
10312 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
10314 if Present
(Cons
) then
10316 Make_Subtype_Indication
(Loc
,
10317 Subtype_Mark
=> Odef
,
10319 Make_Index_Or_Discriminant_Constraint
(Loc
,
10320 Constraints
=> Cons
));
10323 Temp
:= Make_Temporary
(Loc
, 'C');
10325 Make_Object_Declaration
(Loc
,
10326 Defining_Identifier
=> Temp
,
10327 Object_Definition
=> Odef
);
10329 Set_No_Initialization
(Decl
, True);
10331 -- Insert required actions. It is essential to suppress checks
10332 -- since we have suppressed default initialization, which means
10333 -- that the variable we create may have no discriminants.
10338 Make_Assignment_Statement
(Loc
,
10339 Name
=> New_Occurrence_Of
(Temp
, Loc
),
10340 Expression
=> Relocate_Node
(N
))),
10341 Suppress
=> All_Checks
);
10343 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
10346 end Handle_Changed_Representation
;
10348 -------------------------------
10349 -- Raise_Accessibility_Error --
10350 -------------------------------
10352 procedure Raise_Accessibility_Error
is
10354 Error_Msg_Warn
:= SPARK_Mode
/= On
;
10356 Make_Raise_Program_Error
(Sloc
(N
),
10357 Reason
=> PE_Accessibility_Check_Failed
));
10358 Set_Etype
(N
, Target_Type
);
10360 Error_Msg_N
("<<accessibility check failure", N
);
10361 Error_Msg_NE
("\<<& [", N
, Standard_Program_Error
);
10362 end Raise_Accessibility_Error
;
10364 ----------------------
10365 -- Real_Range_Check --
10366 ----------------------
10368 -- Case of conversions to floating-point or fixed-point. If range checks
10369 -- are enabled and the target type has a range constraint, we convert:
10375 -- Tnn : typ'Base := typ'Base (x);
10376 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10379 -- This is necessary when there is a conversion of integer to float or
10380 -- to fixed-point to ensure that the correct checks are made. It is not
10381 -- necessary for float to float where it is enough to simply set the
10382 -- Do_Range_Check flag.
10384 procedure Real_Range_Check
is
10385 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
10386 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
10387 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
10388 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
10393 -- Nothing to do if conversion was rewritten
10395 if Nkind
(N
) /= N_Type_Conversion
then
10399 -- Nothing to do if range checks suppressed, or target has the same
10400 -- range as the base type (or is the base type).
10402 if Range_Checks_Suppressed
(Target_Type
)
10403 or else (Lo
= Type_Low_Bound
(Btyp
)
10405 Hi
= Type_High_Bound
(Btyp
))
10410 -- Nothing to do if expression is an entity on which checks have been
10413 if Is_Entity_Name
(Operand
)
10414 and then Range_Checks_Suppressed
(Entity
(Operand
))
10419 -- Nothing to do if bounds are all static and we can tell that the
10420 -- expression is within the bounds of the target. Note that if the
10421 -- operand is of an unconstrained floating-point type, then we do
10422 -- not trust it to be in range (might be infinite)
10425 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
10426 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
10429 if (not Is_Floating_Point_Type
(Xtyp
)
10430 or else Is_Constrained
(Xtyp
))
10431 and then Compile_Time_Known_Value
(S_Lo
)
10432 and then Compile_Time_Known_Value
(S_Hi
)
10433 and then Compile_Time_Known_Value
(Hi
)
10434 and then Compile_Time_Known_Value
(Lo
)
10437 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
10438 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
10443 if Is_Real_Type
(Xtyp
) then
10444 S_Lov
:= Expr_Value_R
(S_Lo
);
10445 S_Hiv
:= Expr_Value_R
(S_Hi
);
10447 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
10448 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
10452 and then S_Lov
>= D_Lov
10453 and then S_Hiv
<= D_Hiv
10455 -- Unset the range check flag on the current value of
10456 -- Expression (N), since the captured Operand may have
10457 -- been rewritten (such as for the case of a conversion
10458 -- to a fixed-point type).
10460 Set_Do_Range_Check
(Expression
(N
), False);
10468 -- For float to float conversions, we are done
10470 if Is_Floating_Point_Type
(Xtyp
)
10472 Is_Floating_Point_Type
(Btyp
)
10477 -- Otherwise rewrite the conversion as described above
10479 Conv
:= Relocate_Node
(N
);
10480 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
10481 Set_Etype
(Conv
, Btyp
);
10483 -- Enable overflow except for case of integer to float conversions,
10484 -- where it is never required, since we can never have overflow in
10487 if not Is_Integer_Type
(Etype
(Operand
)) then
10488 Enable_Overflow_Check
(Conv
);
10491 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
10493 Insert_Actions
(N
, New_List
(
10494 Make_Object_Declaration
(Loc
,
10495 Defining_Identifier
=> Tnn
,
10496 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
10497 Constant_Present
=> True,
10498 Expression
=> Conv
),
10500 Make_Raise_Constraint_Error
(Loc
,
10505 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10507 Make_Attribute_Reference
(Loc
,
10508 Attribute_Name
=> Name_First
,
10510 New_Occurrence_Of
(Target_Type
, Loc
))),
10514 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10516 Make_Attribute_Reference
(Loc
,
10517 Attribute_Name
=> Name_Last
,
10519 New_Occurrence_Of
(Target_Type
, Loc
)))),
10520 Reason
=> CE_Range_Check_Failed
)));
10522 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
10523 Analyze_And_Resolve
(N
, Btyp
);
10524 end Real_Range_Check
;
10526 -----------------------------
10527 -- Has_Extra_Accessibility --
10528 -----------------------------
10530 -- Returns true for a formal of an anonymous access type or for
10531 -- an Ada 2012-style stand-alone object of an anonymous access type.
10533 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
10535 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
10536 return Present
(Effective_Extra_Accessibility
(Id
));
10540 end Has_Extra_Accessibility
;
10542 -- Start of processing for Expand_N_Type_Conversion
10545 -- First remove check marks put by the semantic analysis on the type
10546 -- conversion between array types. We need these checks, and they will
10547 -- be generated by this expansion routine, but we do not depend on these
10548 -- flags being set, and since we do intend to expand the checks in the
10549 -- front end, we don't want them on the tree passed to the back end.
10551 if Is_Array_Type
(Target_Type
) then
10552 if Is_Constrained
(Target_Type
) then
10553 Set_Do_Length_Check
(N
, False);
10555 Set_Do_Range_Check
(Operand
, False);
10559 -- Nothing at all to do if conversion is to the identical type so remove
10560 -- the conversion completely, it is useless, except that it may carry
10561 -- an Assignment_OK attribute, which must be propagated to the operand.
10563 if Operand_Type
= Target_Type
then
10564 if Assignment_OK
(N
) then
10565 Set_Assignment_OK
(Operand
);
10568 Rewrite
(N
, Relocate_Node
(Operand
));
10572 -- Nothing to do if this is the second argument of read. This is a
10573 -- "backwards" conversion that will be handled by the specialized code
10574 -- in attribute processing.
10576 if Nkind
(Parent
(N
)) = N_Attribute_Reference
10577 and then Attribute_Name
(Parent
(N
)) = Name_Read
10578 and then Next
(First
(Expressions
(Parent
(N
)))) = N
10583 -- Check for case of converting to a type that has an invariant
10584 -- associated with it. This required an invariant check. We convert
10590 -- do invariant_check (typ (expr)) in typ (expr);
10592 -- using Duplicate_Subexpr to avoid multiple side effects
10594 -- Note: the Comes_From_Source check, and then the resetting of this
10595 -- flag prevents what would otherwise be an infinite recursion.
10597 if Has_Invariants
(Target_Type
)
10598 and then Present
(Invariant_Procedure
(Target_Type
))
10599 and then Comes_From_Source
(N
)
10601 Set_Comes_From_Source
(N
, False);
10603 Make_Expression_With_Actions
(Loc
,
10604 Actions
=> New_List
(
10605 Make_Invariant_Call
(Duplicate_Subexpr
(N
))),
10606 Expression
=> Duplicate_Subexpr_No_Checks
(N
)));
10607 Analyze_And_Resolve
(N
, Target_Type
);
10611 -- Here if we may need to expand conversion
10613 -- If the operand of the type conversion is an arithmetic operation on
10614 -- signed integers, and the based type of the signed integer type in
10615 -- question is smaller than Standard.Integer, we promote both of the
10616 -- operands to type Integer.
10618 -- For example, if we have
10620 -- target-type (opnd1 + opnd2)
10622 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10625 -- target-type (integer(opnd1) + integer(opnd2))
10627 -- We do this because we are always allowed to compute in a larger type
10628 -- if we do the right thing with the result, and in this case we are
10629 -- going to do a conversion which will do an appropriate check to make
10630 -- sure that things are in range of the target type in any case. This
10631 -- avoids some unnecessary intermediate overflows.
10633 -- We might consider a similar transformation in the case where the
10634 -- target is a real type or a 64-bit integer type, and the operand
10635 -- is an arithmetic operation using a 32-bit integer type. However,
10636 -- we do not bother with this case, because it could cause significant
10637 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10638 -- much cheaper, but we don't want different behavior on 32-bit and
10639 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10640 -- handles the configurable run-time cases where 64-bit arithmetic
10641 -- may simply be unavailable.
10643 -- Note: this circuit is partially redundant with respect to the circuit
10644 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10645 -- the processing here. Also we still need the Checks circuit, since we
10646 -- have to be sure not to generate junk overflow checks in the first
10647 -- place, since it would be trick to remove them here.
10649 if Integer_Promotion_Possible
(N
) then
10651 -- All conditions met, go ahead with transformation
10659 Make_Type_Conversion
(Loc
,
10660 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10661 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
10663 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
10664 Set_Right_Opnd
(Opnd
, R
);
10666 if Nkind
(Operand
) in N_Binary_Op
then
10668 Make_Type_Conversion
(Loc
,
10669 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10670 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
10672 Set_Left_Opnd
(Opnd
, L
);
10676 Make_Type_Conversion
(Loc
,
10677 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
10678 Expression
=> Opnd
));
10680 Analyze_And_Resolve
(N
, Target_Type
);
10685 -- Do validity check if validity checking operands
10687 if Validity_Checks_On
and Validity_Check_Operands
then
10688 Ensure_Valid
(Operand
);
10691 -- Special case of converting from non-standard boolean type
10693 if Is_Boolean_Type
(Operand_Type
)
10694 and then (Nonzero_Is_True
(Operand_Type
))
10696 Adjust_Condition
(Operand
);
10697 Set_Etype
(Operand
, Standard_Boolean
);
10698 Operand_Type
:= Standard_Boolean
;
10701 -- Case of converting to an access type
10703 if Is_Access_Type
(Target_Type
) then
10705 -- Apply an accessibility check when the conversion operand is an
10706 -- access parameter (or a renaming thereof), unless conversion was
10707 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10708 -- Note that other checks may still need to be applied below (such
10709 -- as tagged type checks).
10711 if Is_Entity_Name
(Operand
)
10712 and then Has_Extra_Accessibility
(Entity
(Operand
))
10713 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
10714 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
10715 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
10717 Apply_Accessibility_Check
10718 (Operand
, Target_Type
, Insert_Node
=> Operand
);
10720 -- If the level of the operand type is statically deeper than the
10721 -- level of the target type, then force Program_Error. Note that this
10722 -- can only occur for cases where the attribute is within the body of
10723 -- an instantiation, otherwise the conversion will already have been
10724 -- rejected as illegal.
10726 -- Note: warnings are issued by the analyzer for the instance cases
10728 elsif In_Instance_Body
10730 -- The case where the target type is an anonymous access type of
10731 -- a discriminant is excluded, because the level of such a type
10732 -- depends on the context and currently the level returned for such
10733 -- types is zero, resulting in warnings about about check failures
10734 -- in certain legal cases involving class-wide interfaces as the
10735 -- designated type (some cases, such as return statements, are
10736 -- checked at run time, but not clear if these are handled right
10737 -- in general, see 3.10.2(12/2-12.5/3) ???).
10740 not (Ekind
(Target_Type
) = E_Anonymous_Access_Type
10741 and then Present
(Associated_Node_For_Itype
(Target_Type
))
10742 and then Nkind
(Associated_Node_For_Itype
(Target_Type
)) =
10743 N_Discriminant_Specification
)
10745 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
10747 Raise_Accessibility_Error
;
10750 -- When the operand is a selected access discriminant the check needs
10751 -- to be made against the level of the object denoted by the prefix
10752 -- of the selected name. Force Program_Error for this case as well
10753 -- (this accessibility violation can only happen if within the body
10754 -- of an instantiation).
10756 elsif In_Instance_Body
10757 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
10758 and then Nkind
(Operand
) = N_Selected_Component
10759 and then Object_Access_Level
(Operand
) >
10760 Type_Access_Level
(Target_Type
)
10762 Raise_Accessibility_Error
;
10767 -- Case of conversions of tagged types and access to tagged types
10769 -- When needed, that is to say when the expression is class-wide, Add
10770 -- runtime a tag check for (strict) downward conversion by using the
10771 -- membership test, generating:
10773 -- [constraint_error when Operand not in Target_Type'Class]
10775 -- or in the access type case
10777 -- [constraint_error
10778 -- when Operand /= null
10779 -- and then Operand.all not in
10780 -- Designated_Type (Target_Type)'Class]
10782 if (Is_Access_Type
(Target_Type
)
10783 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
10784 or else Is_Tagged_Type
(Target_Type
)
10786 -- Do not do any expansion in the access type case if the parent is a
10787 -- renaming, since this is an error situation which will be caught by
10788 -- Sem_Ch8, and the expansion can interfere with this error check.
10790 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
10794 -- Otherwise, proceed with processing tagged conversion
10796 Tagged_Conversion
: declare
10797 Actual_Op_Typ
: Entity_Id
;
10798 Actual_Targ_Typ
: Entity_Id
;
10799 Make_Conversion
: Boolean := False;
10800 Root_Op_Typ
: Entity_Id
;
10802 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
10803 -- Create a membership check to test whether Operand is a member
10804 -- of Targ_Typ. If the original Target_Type is an access, include
10805 -- a test for null value. The check is inserted at N.
10807 --------------------
10808 -- Make_Tag_Check --
10809 --------------------
10811 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
10816 -- [Constraint_Error
10817 -- when Operand /= null
10818 -- and then Operand.all not in Targ_Typ]
10820 if Is_Access_Type
(Target_Type
) then
10822 Make_And_Then
(Loc
,
10825 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10826 Right_Opnd
=> Make_Null
(Loc
)),
10831 Make_Explicit_Dereference
(Loc
,
10832 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
10833 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
10836 -- [Constraint_Error when Operand not in Targ_Typ]
10841 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10842 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
10846 Make_Raise_Constraint_Error
(Loc
,
10848 Reason
=> CE_Tag_Check_Failed
));
10849 end Make_Tag_Check
;
10851 -- Start of processing for Tagged_Conversion
10854 -- Handle entities from the limited view
10856 if Is_Access_Type
(Operand_Type
) then
10858 Available_View
(Designated_Type
(Operand_Type
));
10860 Actual_Op_Typ
:= Operand_Type
;
10863 if Is_Access_Type
(Target_Type
) then
10865 Available_View
(Designated_Type
(Target_Type
));
10867 Actual_Targ_Typ
:= Target_Type
;
10870 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
10872 -- Ada 2005 (AI-251): Handle interface type conversion
10874 if Is_Interface
(Actual_Op_Typ
)
10876 Is_Interface
(Actual_Targ_Typ
)
10878 Expand_Interface_Conversion
(N
);
10882 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
10884 -- Create a runtime tag check for a downward class-wide type
10887 if Is_Class_Wide_Type
(Actual_Op_Typ
)
10888 and then Actual_Op_Typ
/= Actual_Targ_Typ
10889 and then Root_Op_Typ
/= Actual_Targ_Typ
10890 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
10891 Use_Full_View
=> True)
10893 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
10894 Make_Conversion
:= True;
10897 -- AI05-0073: If the result subtype of the function is defined
10898 -- by an access_definition designating a specific tagged type
10899 -- T, a check is made that the result value is null or the tag
10900 -- of the object designated by the result value identifies T.
10901 -- Constraint_Error is raised if this check fails.
10903 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
10906 Func_Typ
: Entity_Id
;
10909 -- Climb scope stack looking for the enclosing function
10911 Func
:= Current_Scope
;
10912 while Present
(Func
)
10913 and then Ekind
(Func
) /= E_Function
10915 Func
:= Scope
(Func
);
10918 -- The function's return subtype must be defined using
10919 -- an access definition.
10921 if Nkind
(Result_Definition
(Parent
(Func
))) =
10922 N_Access_Definition
10924 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
10926 -- The return subtype denotes a specific tagged type,
10927 -- in other words, a non class-wide type.
10929 if Is_Tagged_Type
(Func_Typ
)
10930 and then not Is_Class_Wide_Type
(Func_Typ
)
10932 Make_Tag_Check
(Actual_Targ_Typ
);
10933 Make_Conversion
:= True;
10939 -- We have generated a tag check for either a class-wide type
10940 -- conversion or for AI05-0073.
10942 if Make_Conversion
then
10947 Make_Unchecked_Type_Conversion
(Loc
,
10948 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
10949 Expression
=> Relocate_Node
(Expression
(N
)));
10951 Analyze_And_Resolve
(N
, Target_Type
);
10955 end Tagged_Conversion
;
10957 -- Case of other access type conversions
10959 elsif Is_Access_Type
(Target_Type
) then
10960 Apply_Constraint_Check
(Operand
, Target_Type
);
10962 -- Case of conversions from a fixed-point type
10964 -- These conversions require special expansion and processing, found in
10965 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10966 -- since from a semantic point of view, these are simple integer
10967 -- conversions, which do not need further processing.
10969 elsif Is_Fixed_Point_Type
(Operand_Type
)
10970 and then not Conversion_OK
(N
)
10972 -- We should never see universal fixed at this case, since the
10973 -- expansion of the constituent divide or multiply should have
10974 -- eliminated the explicit mention of universal fixed.
10976 pragma Assert
(Operand_Type
/= Universal_Fixed
);
10978 -- Check for special case of the conversion to universal real that
10979 -- occurs as a result of the use of a round attribute. In this case,
10980 -- the real type for the conversion is taken from the target type of
10981 -- the Round attribute and the result must be marked as rounded.
10983 if Target_Type
= Universal_Real
10984 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
10985 and then Attribute_Name
(Parent
(N
)) = Name_Round
10987 Set_Rounded_Result
(N
);
10988 Set_Etype
(N
, Etype
(Parent
(N
)));
10991 -- Otherwise do correct fixed-conversion, but skip these if the
10992 -- Conversion_OK flag is set, because from a semantic point of view
10993 -- these are simple integer conversions needing no further processing
10994 -- (the backend will simply treat them as integers).
10996 if not Conversion_OK
(N
) then
10997 if Is_Fixed_Point_Type
(Etype
(N
)) then
10998 Expand_Convert_Fixed_To_Fixed
(N
);
11001 elsif Is_Integer_Type
(Etype
(N
)) then
11002 Expand_Convert_Fixed_To_Integer
(N
);
11005 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
11006 Expand_Convert_Fixed_To_Float
(N
);
11011 -- Case of conversions to a fixed-point type
11013 -- These conversions require special expansion and processing, found in
11014 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
11015 -- since from a semantic point of view, these are simple integer
11016 -- conversions, which do not need further processing.
11018 elsif Is_Fixed_Point_Type
(Target_Type
)
11019 and then not Conversion_OK
(N
)
11021 if Is_Integer_Type
(Operand_Type
) then
11022 Expand_Convert_Integer_To_Fixed
(N
);
11025 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
11026 Expand_Convert_Float_To_Fixed
(N
);
11030 -- Case of float-to-integer conversions
11032 -- We also handle float-to-fixed conversions with Conversion_OK set
11033 -- since semantically the fixed-point target is treated as though it
11034 -- were an integer in such cases.
11036 elsif Is_Floating_Point_Type
(Operand_Type
)
11038 (Is_Integer_Type
(Target_Type
)
11040 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
11042 -- One more check here, gcc is still not able to do conversions of
11043 -- this type with proper overflow checking, and so gigi is doing an
11044 -- approximation of what is required by doing floating-point compares
11045 -- with the end-point. But that can lose precision in some cases, and
11046 -- give a wrong result. Converting the operand to Universal_Real is
11047 -- helpful, but still does not catch all cases with 64-bit integers
11048 -- on targets with only 64-bit floats.
11050 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
11051 -- Can this code be removed ???
11053 if Do_Range_Check
(Operand
) then
11055 Make_Type_Conversion
(Loc
,
11057 New_Occurrence_Of
(Universal_Real
, Loc
),
11059 Relocate_Node
(Operand
)));
11061 Set_Etype
(Operand
, Universal_Real
);
11062 Enable_Range_Check
(Operand
);
11063 Set_Do_Range_Check
(Expression
(Operand
), False);
11066 -- Case of array conversions
11068 -- Expansion of array conversions, add required length/range checks but
11069 -- only do this if there is no change of representation. For handling of
11070 -- this case, see Handle_Changed_Representation.
11072 elsif Is_Array_Type
(Target_Type
) then
11073 if Is_Constrained
(Target_Type
) then
11074 Apply_Length_Check
(Operand
, Target_Type
);
11076 Apply_Range_Check
(Operand
, Target_Type
);
11079 Handle_Changed_Representation
;
11081 -- Case of conversions of discriminated types
11083 -- Add required discriminant checks if target is constrained. Again this
11084 -- change is skipped if we have a change of representation.
11086 elsif Has_Discriminants
(Target_Type
)
11087 and then Is_Constrained
(Target_Type
)
11089 Apply_Discriminant_Check
(Operand
, Target_Type
);
11090 Handle_Changed_Representation
;
11092 -- Case of all other record conversions. The only processing required
11093 -- is to check for a change of representation requiring the special
11094 -- assignment processing.
11096 elsif Is_Record_Type
(Target_Type
) then
11098 -- Ada 2005 (AI-216): Program_Error is raised when converting from
11099 -- a derived Unchecked_Union type to an unconstrained type that is
11100 -- not Unchecked_Union if the operand lacks inferable discriminants.
11102 if Is_Derived_Type
(Operand_Type
)
11103 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
11104 and then not Is_Constrained
(Target_Type
)
11105 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
11106 and then not Has_Inferable_Discriminants
(Operand
)
11108 -- To prevent Gigi from generating illegal code, we generate a
11109 -- Program_Error node, but we give it the target type of the
11110 -- conversion (is this requirement documented somewhere ???)
11113 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
11114 Reason
=> PE_Unchecked_Union_Restriction
);
11117 Set_Etype
(PE
, Target_Type
);
11122 Handle_Changed_Representation
;
11125 -- Case of conversions of enumeration types
11127 elsif Is_Enumeration_Type
(Target_Type
) then
11129 -- Special processing is required if there is a change of
11130 -- representation (from enumeration representation clauses).
11132 if not Same_Representation
(Target_Type
, Operand_Type
) then
11134 -- Convert: x(y) to x'val (ytyp'val (y))
11137 Make_Attribute_Reference
(Loc
,
11138 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11139 Attribute_Name
=> Name_Val
,
11140 Expressions
=> New_List
(
11141 Make_Attribute_Reference
(Loc
,
11142 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
11143 Attribute_Name
=> Name_Pos
,
11144 Expressions
=> New_List
(Operand
)))));
11146 Analyze_And_Resolve
(N
, Target_Type
);
11149 -- Case of conversions to floating-point
11151 elsif Is_Floating_Point_Type
(Target_Type
) then
11155 -- At this stage, either the conversion node has been transformed into
11156 -- some other equivalent expression, or left as a conversion that can be
11157 -- handled by Gigi, in the following cases:
11159 -- Conversions with no change of representation or type
11161 -- Numeric conversions involving integer, floating- and fixed-point
11162 -- values. Fixed-point values are allowed only if Conversion_OK is
11163 -- set, i.e. if the fixed-point values are to be treated as integers.
11165 -- No other conversions should be passed to Gigi
11167 -- Check: are these rules stated in sinfo??? if so, why restate here???
11169 -- The only remaining step is to generate a range check if we still have
11170 -- a type conversion at this stage and Do_Range_Check is set. For now we
11171 -- do this only for conversions of discrete types and for float-to-float
11174 if Nkind
(N
) = N_Type_Conversion
then
11176 -- For now we only support floating-point cases where both source
11177 -- and target are floating-point types. Conversions where the source
11178 -- and target involve integer or fixed-point types are still TBD,
11179 -- though not clear whether those can even happen at this point, due
11180 -- to transformations above. ???
11182 if Is_Floating_Point_Type
(Etype
(N
))
11183 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
11185 if Do_Range_Check
(Expression
(N
))
11186 and then Is_Floating_Point_Type
(Target_Type
)
11188 Generate_Range_Check
11189 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
11192 -- Discrete-to-discrete conversions
11194 elsif Is_Discrete_Type
(Etype
(N
)) then
11196 Expr
: constant Node_Id
:= Expression
(N
);
11201 if Do_Range_Check
(Expr
)
11202 and then Is_Discrete_Type
(Etype
(Expr
))
11204 Set_Do_Range_Check
(Expr
, False);
11206 -- Before we do a range check, we have to deal with treating
11207 -- a fixed-point operand as an integer. The way we do this
11208 -- is simply to do an unchecked conversion to an appropriate
11209 -- integer type large enough to hold the result.
11211 -- This code is not active yet, because we are only dealing
11212 -- with discrete types so far ???
11214 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
11215 and then Treat_Fixed_As_Integer
(Expr
)
11217 Ftyp
:= Base_Type
(Etype
(Expr
));
11219 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
11220 Ityp
:= Standard_Long_Long_Integer
;
11222 Ityp
:= Standard_Integer
;
11225 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11228 -- Reset overflow flag, since the range check will include
11229 -- dealing with possible overflow, and generate the check.
11230 -- If Address is either a source type or target type,
11231 -- suppress range check to avoid typing anomalies when
11232 -- it is a visible integer type.
11234 Set_Do_Overflow_Check
(N
, False);
11236 if not Is_Descendent_Of_Address
(Etype
(Expr
))
11237 and then not Is_Descendent_Of_Address
(Target_Type
)
11239 Generate_Range_Check
11240 (Expr
, Target_Type
, CE_Range_Check_Failed
);
11247 -- Here at end of processing
11250 -- Apply predicate check if required. Note that we can't just call
11251 -- Apply_Predicate_Check here, because the type looks right after
11252 -- the conversion and it would omit the check. The Comes_From_Source
11253 -- guard is necessary to prevent infinite recursions when we generate
11254 -- internal conversions for the purpose of checking predicates.
11256 if Present
(Predicate_Function
(Target_Type
))
11257 and then Target_Type
/= Operand_Type
11258 and then Comes_From_Source
(N
)
11261 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
11264 -- Avoid infinite recursion on the subsequent expansion of
11265 -- of the copy of the original type conversion.
11267 Set_Comes_From_Source
(New_Expr
, False);
11268 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
11271 end Expand_N_Type_Conversion
;
11273 -----------------------------------
11274 -- Expand_N_Unchecked_Expression --
11275 -----------------------------------
11277 -- Remove the unchecked expression node from the tree. Its job was simply
11278 -- to make sure that its constituent expression was handled with checks
11279 -- off, and now that that is done, we can remove it from the tree, and
11280 -- indeed must, since Gigi does not expect to see these nodes.
11282 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
11283 Exp
: constant Node_Id
:= Expression
(N
);
11285 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
11287 end Expand_N_Unchecked_Expression
;
11289 ----------------------------------------
11290 -- Expand_N_Unchecked_Type_Conversion --
11291 ----------------------------------------
11293 -- If this cannot be handled by Gigi and we haven't already made a
11294 -- temporary for it, do it now.
11296 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
11297 Target_Type
: constant Entity_Id
:= Etype
(N
);
11298 Operand
: constant Node_Id
:= Expression
(N
);
11299 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11302 -- Nothing at all to do if conversion is to the identical type so remove
11303 -- the conversion completely, it is useless, except that it may carry
11304 -- an Assignment_OK indication which must be propagated to the operand.
11306 if Operand_Type
= Target_Type
then
11308 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
11310 if Assignment_OK
(N
) then
11311 Set_Assignment_OK
(Operand
);
11314 Rewrite
(N
, Relocate_Node
(Operand
));
11318 -- If we have a conversion of a compile time known value to a target
11319 -- type and the value is in range of the target type, then we can simply
11320 -- replace the construct by an integer literal of the correct type. We
11321 -- only apply this to integer types being converted. Possibly it may
11322 -- apply in other cases, but it is too much trouble to worry about.
11324 -- Note that we do not do this transformation if the Kill_Range_Check
11325 -- flag is set, since then the value may be outside the expected range.
11326 -- This happens in the Normalize_Scalars case.
11328 -- We also skip this if either the target or operand type is biased
11329 -- because in this case, the unchecked conversion is supposed to
11330 -- preserve the bit pattern, not the integer value.
11332 if Is_Integer_Type
(Target_Type
)
11333 and then not Has_Biased_Representation
(Target_Type
)
11334 and then Is_Integer_Type
(Operand_Type
)
11335 and then not Has_Biased_Representation
(Operand_Type
)
11336 and then Compile_Time_Known_Value
(Operand
)
11337 and then not Kill_Range_Check
(N
)
11340 Val
: constant Uint
:= Expr_Value
(Operand
);
11343 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
11345 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
11347 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
11349 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
11351 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
11353 -- If Address is the target type, just set the type to avoid a
11354 -- spurious type error on the literal when Address is a visible
11357 if Is_Descendent_Of_Address
(Target_Type
) then
11358 Set_Etype
(N
, Target_Type
);
11360 Analyze_And_Resolve
(N
, Target_Type
);
11368 -- Nothing to do if conversion is safe
11370 if Safe_Unchecked_Type_Conversion
(N
) then
11374 -- Otherwise force evaluation unless Assignment_OK flag is set (this
11375 -- flag indicates ??? More comments needed here)
11377 if Assignment_OK
(N
) then
11380 Force_Evaluation
(N
);
11382 end Expand_N_Unchecked_Type_Conversion
;
11384 ----------------------------
11385 -- Expand_Record_Equality --
11386 ----------------------------
11388 -- For non-variant records, Equality is expanded when needed into:
11390 -- and then Lhs.Discr1 = Rhs.Discr1
11392 -- and then Lhs.Discrn = Rhs.Discrn
11393 -- and then Lhs.Cmp1 = Rhs.Cmp1
11395 -- and then Lhs.Cmpn = Rhs.Cmpn
11397 -- The expression is folded by the back-end for adjacent fields. This
11398 -- function is called for tagged record in only one occasion: for imple-
11399 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11400 -- otherwise the primitive "=" is used directly.
11402 function Expand_Record_Equality
11407 Bodies
: List_Id
) return Node_Id
11409 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11414 First_Time
: Boolean := True;
11416 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
11417 -- Return the next discriminant or component to compare, starting with
11418 -- C, skipping inherited components.
11420 ------------------------
11421 -- Element_To_Compare --
11422 ------------------------
11424 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
11430 -- Exit loop when the next element to be compared is found, or
11431 -- there is no more such element.
11433 exit when No
(Comp
);
11435 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
11438 -- Skip inherited components
11440 -- Note: for a tagged type, we always generate the "=" primitive
11441 -- for the base type (not on the first subtype), so the test for
11442 -- Comp /= Original_Record_Component (Comp) is True for
11443 -- inherited components only.
11445 (Is_Tagged_Type
(Typ
)
11446 and then Comp
/= Original_Record_Component
(Comp
))
11450 or else Chars
(Comp
) = Name_uTag
11452 -- The .NET/JVM version of type Root_Controlled contains two
11453 -- fields which should not be considered part of the object. To
11454 -- achieve proper equiality between two controlled objects on
11455 -- .NET/JVM, skip _Parent whenever it has type Root_Controlled.
11457 or else (Chars
(Comp
) = Name_uParent
11458 and then VM_Target
/= No_VM
11459 and then Etype
(Comp
) = RTE
(RE_Root_Controlled
))
11461 -- Skip interface elements (secondary tags???)
11463 or else Is_Interface
(Etype
(Comp
)));
11465 Next_Entity
(Comp
);
11469 end Element_To_Compare
;
11471 -- Start of processing for Expand_Record_Equality
11474 -- Generates the following code: (assuming that Typ has one Discr and
11475 -- component C2 is also a record)
11478 -- and then Lhs.Discr1 = Rhs.Discr1
11479 -- and then Lhs.C1 = Rhs.C1
11480 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11482 -- and then Lhs.Cmpn = Rhs.Cmpn
11484 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
11485 C
:= Element_To_Compare
(First_Entity
(Typ
));
11486 while Present
(C
) loop
11494 First_Time
:= False;
11498 New_Lhs
:= New_Copy_Tree
(Lhs
);
11499 New_Rhs
:= New_Copy_Tree
(Rhs
);
11503 Expand_Composite_Equality
(Nod
, Etype
(C
),
11505 Make_Selected_Component
(Loc
,
11507 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11509 Make_Selected_Component
(Loc
,
11511 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11514 -- If some (sub)component is an unchecked_union, the whole
11515 -- operation will raise program error.
11517 if Nkind
(Check
) = N_Raise_Program_Error
then
11519 Set_Etype
(Result
, Standard_Boolean
);
11523 Make_And_Then
(Loc
,
11524 Left_Opnd
=> Result
,
11525 Right_Opnd
=> Check
);
11529 C
:= Element_To_Compare
(Next_Entity
(C
));
11533 end Expand_Record_Equality
;
11535 ---------------------------
11536 -- Expand_Set_Membership --
11537 ---------------------------
11539 procedure Expand_Set_Membership
(N
: Node_Id
) is
11540 Lop
: constant Node_Id
:= Left_Opnd
(N
);
11544 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
11545 -- If the alternative is a subtype mark, create a simple membership
11546 -- test. Otherwise create an equality test for it.
11552 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
11554 L
: constant Node_Id
:= New_Copy
(Lop
);
11555 R
: constant Node_Id
:= Relocate_Node
(Alt
);
11558 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
11559 or else Nkind
(Alt
) = N_Range
11562 Make_In
(Sloc
(Alt
),
11567 Make_Op_Eq
(Sloc
(Alt
),
11575 -- Start of processing for Expand_Set_Membership
11578 Remove_Side_Effects
(Lop
);
11580 Alt
:= Last
(Alternatives
(N
));
11581 Res
:= Make_Cond
(Alt
);
11584 while Present
(Alt
) loop
11586 Make_Or_Else
(Sloc
(Alt
),
11587 Left_Opnd
=> Make_Cond
(Alt
),
11588 Right_Opnd
=> Res
);
11593 Analyze_And_Resolve
(N
, Standard_Boolean
);
11594 end Expand_Set_Membership
;
11596 -----------------------------------
11597 -- Expand_Short_Circuit_Operator --
11598 -----------------------------------
11600 -- Deal with special expansion if actions are present for the right operand
11601 -- and deal with optimizing case of arguments being True or False. We also
11602 -- deal with the special case of non-standard boolean values.
11604 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
11605 Loc
: constant Source_Ptr
:= Sloc
(N
);
11606 Typ
: constant Entity_Id
:= Etype
(N
);
11607 Left
: constant Node_Id
:= Left_Opnd
(N
);
11608 Right
: constant Node_Id
:= Right_Opnd
(N
);
11609 LocR
: constant Source_Ptr
:= Sloc
(Right
);
11612 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
11613 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
11614 -- If Left = Shortcut_Value then Right need not be evaluated
11617 -- Deal with non-standard booleans
11619 if Is_Boolean_Type
(Typ
) then
11620 Adjust_Condition
(Left
);
11621 Adjust_Condition
(Right
);
11622 Set_Etype
(N
, Standard_Boolean
);
11625 -- Check for cases where left argument is known to be True or False
11627 if Compile_Time_Known_Value
(Left
) then
11629 -- Mark SCO for left condition as compile time known
11631 if Generate_SCO
and then Comes_From_Source
(Left
) then
11632 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
11635 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11636 -- Any actions associated with Right will be executed unconditionally
11637 -- and can thus be inserted into the tree unconditionally.
11639 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
11640 if Present
(Actions
(N
)) then
11641 Insert_Actions
(N
, Actions
(N
));
11644 Rewrite
(N
, Right
);
11646 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11647 -- In this case we can forget the actions associated with Right,
11648 -- since they will never be executed.
11651 Kill_Dead_Code
(Right
);
11652 Kill_Dead_Code
(Actions
(N
));
11653 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11656 Adjust_Result_Type
(N
, Typ
);
11660 -- If Actions are present for the right operand, we have to do some
11661 -- special processing. We can't just let these actions filter back into
11662 -- code preceding the short circuit (which is what would have happened
11663 -- if we had not trapped them in the short-circuit form), since they
11664 -- must only be executed if the right operand of the short circuit is
11665 -- executed and not otherwise.
11667 if Present
(Actions
(N
)) then
11668 Actlist
:= Actions
(N
);
11670 -- We now use an Expression_With_Actions node for the right operand
11671 -- of the short-circuit form. Note that this solves the traceability
11672 -- problems for coverage analysis.
11675 Make_Expression_With_Actions
(LocR
,
11676 Expression
=> Relocate_Node
(Right
),
11677 Actions
=> Actlist
));
11679 Set_Actions
(N
, No_List
);
11680 Analyze_And_Resolve
(Right
, Standard_Boolean
);
11682 Adjust_Result_Type
(N
, Typ
);
11686 -- No actions present, check for cases of right argument True/False
11688 if Compile_Time_Known_Value
(Right
) then
11690 -- Mark SCO for left condition as compile time known
11692 if Generate_SCO
and then Comes_From_Source
(Right
) then
11693 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
11696 -- Change (Left and then True), (Left or else False) to Left.
11697 -- Note that we know there are no actions associated with the right
11698 -- operand, since we just checked for this case above.
11700 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
11703 -- Change (Left and then False), (Left or else True) to Right,
11704 -- making sure to preserve any side effects associated with the Left
11708 Remove_Side_Effects
(Left
);
11709 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11713 Adjust_Result_Type
(N
, Typ
);
11714 end Expand_Short_Circuit_Operator
;
11716 -------------------------------------
11717 -- Fixup_Universal_Fixed_Operation --
11718 -------------------------------------
11720 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
11721 Conv
: constant Node_Id
:= Parent
(N
);
11724 -- We must have a type conversion immediately above us
11726 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
11728 -- Normally the type conversion gives our target type. The exception
11729 -- occurs in the case of the Round attribute, where the conversion
11730 -- will be to universal real, and our real type comes from the Round
11731 -- attribute (as well as an indication that we must round the result)
11733 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
11734 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
11736 Set_Etype
(N
, Etype
(Parent
(Conv
)));
11737 Set_Rounded_Result
(N
);
11739 -- Normal case where type comes from conversion above us
11742 Set_Etype
(N
, Etype
(Conv
));
11744 end Fixup_Universal_Fixed_Operation
;
11746 ---------------------------------
11747 -- Has_Inferable_Discriminants --
11748 ---------------------------------
11750 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
11752 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
11753 -- Determines whether the left-most prefix of a selected component is a
11754 -- formal parameter in a subprogram. Assumes N is a selected component.
11756 --------------------------------
11757 -- Prefix_Is_Formal_Parameter --
11758 --------------------------------
11760 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
11761 Sel_Comp
: Node_Id
;
11764 -- Move to the left-most prefix by climbing up the tree
11767 while Present
(Parent
(Sel_Comp
))
11768 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
11770 Sel_Comp
:= Parent
(Sel_Comp
);
11773 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
11774 end Prefix_Is_Formal_Parameter
;
11776 -- Start of processing for Has_Inferable_Discriminants
11779 -- For selected components, the subtype of the selector must be a
11780 -- constrained Unchecked_Union. If the component is subject to a
11781 -- per-object constraint, then the enclosing object must have inferable
11784 if Nkind
(N
) = N_Selected_Component
then
11785 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
11787 -- A small hack. If we have a per-object constrained selected
11788 -- component of a formal parameter, return True since we do not
11789 -- know the actual parameter association yet.
11791 if Prefix_Is_Formal_Parameter
(N
) then
11794 -- Otherwise, check the enclosing object and the selector
11797 return Has_Inferable_Discriminants
(Prefix
(N
))
11798 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
11801 -- The call to Has_Inferable_Discriminants will determine whether
11802 -- the selector has a constrained Unchecked_Union nominal type.
11805 return Has_Inferable_Discriminants
(Selector_Name
(N
));
11808 -- A qualified expression has inferable discriminants if its subtype
11809 -- mark is a constrained Unchecked_Union subtype.
11811 elsif Nkind
(N
) = N_Qualified_Expression
then
11812 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
11813 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
11815 -- For all other names, it is sufficient to have a constrained
11816 -- Unchecked_Union nominal subtype.
11819 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
11820 and then Is_Constrained
(Etype
(N
));
11822 end Has_Inferable_Discriminants
;
11824 -------------------------------
11825 -- Insert_Dereference_Action --
11826 -------------------------------
11828 procedure Insert_Dereference_Action
(N
: Node_Id
) is
11830 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
11831 -- Return true if type of P is derived from Checked_Pool;
11833 -----------------------------
11834 -- Is_Checked_Storage_Pool --
11835 -----------------------------
11837 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
11846 while T
/= Etype
(T
) loop
11847 if Is_RTE
(T
, RE_Checked_Pool
) then
11855 end Is_Checked_Storage_Pool
;
11859 Typ
: constant Entity_Id
:= Etype
(N
);
11860 Desig
: constant Entity_Id
:= Available_View
(Designated_Type
(Typ
));
11861 Loc
: constant Source_Ptr
:= Sloc
(N
);
11862 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
11863 Pnod
: constant Node_Id
:= Parent
(N
);
11869 Size_Bits
: Node_Id
;
11872 -- Start of processing for Insert_Dereference_Action
11875 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
11877 -- Do not re-expand a dereference which has already been processed by
11880 if Has_Dereference_Action
(Pnod
) then
11883 -- Do not perform this type of expansion for internally-generated
11886 elsif not Comes_From_Source
(Original_Node
(Pnod
)) then
11889 -- A dereference action is only applicable to objects which have been
11890 -- allocated on a checked pool.
11892 elsif not Is_Checked_Storage_Pool
(Pool
) then
11896 -- Extract the address of the dereferenced object. Generate:
11898 -- Addr : System.Address := <N>'Pool_Address;
11900 Addr
:= Make_Temporary
(Loc
, 'P');
11903 Make_Object_Declaration
(Loc
,
11904 Defining_Identifier
=> Addr
,
11905 Object_Definition
=>
11906 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
11908 Make_Attribute_Reference
(Loc
,
11909 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
11910 Attribute_Name
=> Name_Pool_Address
)));
11912 -- Calculate the size of the dereferenced object. Generate:
11914 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11917 Make_Explicit_Dereference
(Loc
,
11918 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11919 Set_Has_Dereference_Action
(Deref
);
11922 Make_Attribute_Reference
(Loc
,
11924 Attribute_Name
=> Name_Size
);
11926 -- Special case of an unconstrained array: need to add descriptor size
11928 if Is_Array_Type
(Desig
)
11929 and then not Is_Constrained
(First_Subtype
(Desig
))
11934 Make_Attribute_Reference
(Loc
,
11936 New_Occurrence_Of
(First_Subtype
(Desig
), Loc
),
11937 Attribute_Name
=> Name_Descriptor_Size
),
11938 Right_Opnd
=> Size_Bits
);
11941 Size
:= Make_Temporary
(Loc
, 'S');
11943 Make_Object_Declaration
(Loc
,
11944 Defining_Identifier
=> Size
,
11945 Object_Definition
=>
11946 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
11948 Make_Op_Divide
(Loc
,
11949 Left_Opnd
=> Size_Bits
,
11950 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
11952 -- Calculate the alignment of the dereferenced object. Generate:
11953 -- Alig : constant Storage_Count := <N>.all'Alignment;
11956 Make_Explicit_Dereference
(Loc
,
11957 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11958 Set_Has_Dereference_Action
(Deref
);
11960 Alig
:= Make_Temporary
(Loc
, 'A');
11962 Make_Object_Declaration
(Loc
,
11963 Defining_Identifier
=> Alig
,
11964 Object_Definition
=>
11965 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
11967 Make_Attribute_Reference
(Loc
,
11969 Attribute_Name
=> Name_Alignment
)));
11971 -- A dereference of a controlled object requires special processing. The
11972 -- finalization machinery requests additional space from the underlying
11973 -- pool to allocate and hide two pointers. As a result, a checked pool
11974 -- may mark the wrong memory as valid. Since checked pools do not have
11975 -- knowledge of hidden pointers, we have to bring the two pointers back
11976 -- in view in order to restore the original state of the object.
11978 if Needs_Finalization
(Desig
) then
11980 -- Adjust the address and size of the dereferenced object. Generate:
11981 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11984 Make_Procedure_Call_Statement
(Loc
,
11986 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
11987 Parameter_Associations
=> New_List
(
11988 New_Occurrence_Of
(Addr
, Loc
),
11989 New_Occurrence_Of
(Size
, Loc
),
11990 New_Occurrence_Of
(Alig
, Loc
)));
11992 -- Class-wide types complicate things because we cannot determine
11993 -- statically whether the actual object is truly controlled. We must
11994 -- generate a runtime check to detect this property. Generate:
11996 -- if Needs_Finalization (<N>.all'Tag) then
12000 if Is_Class_Wide_Type
(Desig
) then
12002 Make_Explicit_Dereference
(Loc
,
12003 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
12004 Set_Has_Dereference_Action
(Deref
);
12007 Make_Implicit_If_Statement
(N
,
12009 Make_Function_Call
(Loc
,
12011 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
12012 Parameter_Associations
=> New_List
(
12013 Make_Attribute_Reference
(Loc
,
12015 Attribute_Name
=> Name_Tag
))),
12016 Then_Statements
=> New_List
(Stmt
));
12019 Insert_Action
(N
, Stmt
);
12023 -- Dereference (Pool, Addr, Size, Alig);
12026 Make_Procedure_Call_Statement
(Loc
,
12029 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
12030 Parameter_Associations
=> New_List
(
12031 New_Occurrence_Of
(Pool
, Loc
),
12032 New_Occurrence_Of
(Addr
, Loc
),
12033 New_Occurrence_Of
(Size
, Loc
),
12034 New_Occurrence_Of
(Alig
, Loc
))));
12036 -- Mark the explicit dereference as processed to avoid potential
12037 -- infinite expansion.
12039 Set_Has_Dereference_Action
(Pnod
);
12042 when RE_Not_Available
=>
12044 end Insert_Dereference_Action
;
12046 --------------------------------
12047 -- Integer_Promotion_Possible --
12048 --------------------------------
12050 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
12051 Operand
: constant Node_Id
:= Expression
(N
);
12052 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12053 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
12056 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
12060 -- We only do the transformation for source constructs. We assume
12061 -- that the expander knows what it is doing when it generates code.
12063 Comes_From_Source
(N
)
12065 -- If the operand type is Short_Integer or Short_Short_Integer,
12066 -- then we will promote to Integer, which is available on all
12067 -- targets, and is sufficient to ensure no intermediate overflow.
12068 -- Furthermore it is likely to be as efficient or more efficient
12069 -- than using the smaller type for the computation so we do this
12070 -- unconditionally.
12073 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
12075 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
12077 -- Test for interesting operation, which includes addition,
12078 -- division, exponentiation, multiplication, subtraction, absolute
12079 -- value and unary negation. Unary "+" is omitted since it is a
12080 -- no-op and thus can't overflow.
12082 and then Nkind_In
(Operand
, N_Op_Abs
,
12089 end Integer_Promotion_Possible
;
12091 ------------------------------
12092 -- Make_Array_Comparison_Op --
12093 ------------------------------
12095 -- This is a hand-coded expansion of the following generic function:
12098 -- type elem is (<>);
12099 -- type index is (<>);
12100 -- type a is array (index range <>) of elem;
12102 -- function Gnnn (X : a; Y: a) return boolean is
12103 -- J : index := Y'first;
12106 -- if X'length = 0 then
12109 -- elsif Y'length = 0 then
12113 -- for I in X'range loop
12114 -- if X (I) = Y (J) then
12115 -- if J = Y'last then
12118 -- J := index'succ (J);
12122 -- return X (I) > Y (J);
12126 -- return X'length > Y'length;
12130 -- Note that since we are essentially doing this expansion by hand, we
12131 -- do not need to generate an actual or formal generic part, just the
12132 -- instantiated function itself.
12134 -- Perhaps we could have the actual generic available in the run-time,
12135 -- obtained by rtsfind, and actually expand a real instantiation ???
12137 function Make_Array_Comparison_Op
12139 Nod
: Node_Id
) return Node_Id
12141 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12143 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
12144 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
12145 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
12146 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12148 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
12150 Loop_Statement
: Node_Id
;
12151 Loop_Body
: Node_Id
;
12153 Inner_If
: Node_Id
;
12154 Final_Expr
: Node_Id
;
12155 Func_Body
: Node_Id
;
12156 Func_Name
: Entity_Id
;
12162 -- if J = Y'last then
12165 -- J := index'succ (J);
12169 Make_Implicit_If_Statement
(Nod
,
12172 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
12174 Make_Attribute_Reference
(Loc
,
12175 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12176 Attribute_Name
=> Name_Last
)),
12178 Then_Statements
=> New_List
(
12179 Make_Exit_Statement
(Loc
)),
12183 Make_Assignment_Statement
(Loc
,
12184 Name
=> New_Occurrence_Of
(J
, Loc
),
12186 Make_Attribute_Reference
(Loc
,
12187 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
12188 Attribute_Name
=> Name_Succ
,
12189 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
12191 -- if X (I) = Y (J) then
12194 -- return X (I) > Y (J);
12198 Make_Implicit_If_Statement
(Nod
,
12202 Make_Indexed_Component
(Loc
,
12203 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12204 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
12207 Make_Indexed_Component
(Loc
,
12208 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12209 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
12211 Then_Statements
=> New_List
(Inner_If
),
12213 Else_Statements
=> New_List
(
12214 Make_Simple_Return_Statement
(Loc
,
12218 Make_Indexed_Component
(Loc
,
12219 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12220 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
12223 Make_Indexed_Component
(Loc
,
12224 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12225 Expressions
=> New_List
(
12226 New_Occurrence_Of
(J
, Loc
)))))));
12228 -- for I in X'range loop
12233 Make_Implicit_Loop_Statement
(Nod
,
12234 Identifier
=> Empty
,
12236 Iteration_Scheme
=>
12237 Make_Iteration_Scheme
(Loc
,
12238 Loop_Parameter_Specification
=>
12239 Make_Loop_Parameter_Specification
(Loc
,
12240 Defining_Identifier
=> I
,
12241 Discrete_Subtype_Definition
=>
12242 Make_Attribute_Reference
(Loc
,
12243 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12244 Attribute_Name
=> Name_Range
))),
12246 Statements
=> New_List
(Loop_Body
));
12248 -- if X'length = 0 then
12250 -- elsif Y'length = 0 then
12253 -- for ... loop ... end loop;
12254 -- return X'length > Y'length;
12258 Make_Attribute_Reference
(Loc
,
12259 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12260 Attribute_Name
=> Name_Length
);
12263 Make_Attribute_Reference
(Loc
,
12264 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12265 Attribute_Name
=> Name_Length
);
12269 Left_Opnd
=> Length1
,
12270 Right_Opnd
=> Length2
);
12273 Make_Implicit_If_Statement
(Nod
,
12277 Make_Attribute_Reference
(Loc
,
12278 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12279 Attribute_Name
=> Name_Length
),
12281 Make_Integer_Literal
(Loc
, 0)),
12285 Make_Simple_Return_Statement
(Loc
,
12286 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
12288 Elsif_Parts
=> New_List
(
12289 Make_Elsif_Part
(Loc
,
12293 Make_Attribute_Reference
(Loc
,
12294 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12295 Attribute_Name
=> Name_Length
),
12297 Make_Integer_Literal
(Loc
, 0)),
12301 Make_Simple_Return_Statement
(Loc
,
12302 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
12304 Else_Statements
=> New_List
(
12306 Make_Simple_Return_Statement
(Loc
,
12307 Expression
=> Final_Expr
)));
12311 Formals
:= New_List
(
12312 Make_Parameter_Specification
(Loc
,
12313 Defining_Identifier
=> X
,
12314 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12316 Make_Parameter_Specification
(Loc
,
12317 Defining_Identifier
=> Y
,
12318 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12320 -- function Gnnn (...) return boolean is
12321 -- J : index := Y'first;
12326 Func_Name
:= Make_Temporary
(Loc
, 'G');
12329 Make_Subprogram_Body
(Loc
,
12331 Make_Function_Specification
(Loc
,
12332 Defining_Unit_Name
=> Func_Name
,
12333 Parameter_Specifications
=> Formals
,
12334 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
12336 Declarations
=> New_List
(
12337 Make_Object_Declaration
(Loc
,
12338 Defining_Identifier
=> J
,
12339 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
12341 Make_Attribute_Reference
(Loc
,
12342 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12343 Attribute_Name
=> Name_First
))),
12345 Handled_Statement_Sequence
=>
12346 Make_Handled_Sequence_Of_Statements
(Loc
,
12347 Statements
=> New_List
(If_Stat
)));
12350 end Make_Array_Comparison_Op
;
12352 ---------------------------
12353 -- Make_Boolean_Array_Op --
12354 ---------------------------
12356 -- For logical operations on boolean arrays, expand in line the following,
12357 -- replacing 'and' with 'or' or 'xor' where needed:
12359 -- function Annn (A : typ; B: typ) return typ is
12362 -- for J in A'range loop
12363 -- C (J) := A (J) op B (J);
12368 -- Here typ is the boolean array type
12370 function Make_Boolean_Array_Op
12372 N
: Node_Id
) return Node_Id
12374 Loc
: constant Source_Ptr
:= Sloc
(N
);
12376 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
12377 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12378 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
12379 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12387 Func_Name
: Entity_Id
;
12388 Func_Body
: Node_Id
;
12389 Loop_Statement
: Node_Id
;
12393 Make_Indexed_Component
(Loc
,
12394 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12395 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12398 Make_Indexed_Component
(Loc
,
12399 Prefix
=> New_Occurrence_Of
(B
, Loc
),
12400 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12403 Make_Indexed_Component
(Loc
,
12404 Prefix
=> New_Occurrence_Of
(C
, Loc
),
12405 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12407 if Nkind
(N
) = N_Op_And
then
12411 Right_Opnd
=> B_J
);
12413 elsif Nkind
(N
) = N_Op_Or
then
12417 Right_Opnd
=> B_J
);
12423 Right_Opnd
=> B_J
);
12427 Make_Implicit_Loop_Statement
(N
,
12428 Identifier
=> Empty
,
12430 Iteration_Scheme
=>
12431 Make_Iteration_Scheme
(Loc
,
12432 Loop_Parameter_Specification
=>
12433 Make_Loop_Parameter_Specification
(Loc
,
12434 Defining_Identifier
=> J
,
12435 Discrete_Subtype_Definition
=>
12436 Make_Attribute_Reference
(Loc
,
12437 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12438 Attribute_Name
=> Name_Range
))),
12440 Statements
=> New_List
(
12441 Make_Assignment_Statement
(Loc
,
12443 Expression
=> Op
)));
12445 Formals
:= New_List
(
12446 Make_Parameter_Specification
(Loc
,
12447 Defining_Identifier
=> A
,
12448 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12450 Make_Parameter_Specification
(Loc
,
12451 Defining_Identifier
=> B
,
12452 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12454 Func_Name
:= Make_Temporary
(Loc
, 'A');
12455 Set_Is_Inlined
(Func_Name
);
12458 Make_Subprogram_Body
(Loc
,
12460 Make_Function_Specification
(Loc
,
12461 Defining_Unit_Name
=> Func_Name
,
12462 Parameter_Specifications
=> Formals
,
12463 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
12465 Declarations
=> New_List
(
12466 Make_Object_Declaration
(Loc
,
12467 Defining_Identifier
=> C
,
12468 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
12470 Handled_Statement_Sequence
=>
12471 Make_Handled_Sequence_Of_Statements
(Loc
,
12472 Statements
=> New_List
(
12474 Make_Simple_Return_Statement
(Loc
,
12475 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
12478 end Make_Boolean_Array_Op
;
12480 -----------------------------------------
12481 -- Minimized_Eliminated_Overflow_Check --
12482 -----------------------------------------
12484 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
12487 Is_Signed_Integer_Type
(Etype
(N
))
12488 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
12489 end Minimized_Eliminated_Overflow_Check
;
12491 --------------------------------
12492 -- Optimize_Length_Comparison --
12493 --------------------------------
12495 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
12496 Loc
: constant Source_Ptr
:= Sloc
(N
);
12497 Typ
: constant Entity_Id
:= Etype
(N
);
12502 -- First and Last attribute reference nodes, which end up as left and
12503 -- right operands of the optimized result.
12506 -- True for comparison operand of zero
12509 -- Comparison operand, set only if Is_Zero is false
12512 -- Entity whose length is being compared
12515 -- Integer_Literal node for length attribute expression, or Empty
12516 -- if there is no such expression present.
12519 -- Type of array index to which 'Length is applied
12521 Op
: Node_Kind
:= Nkind
(N
);
12522 -- Kind of comparison operator, gets flipped if operands backwards
12524 function Is_Optimizable
(N
: Node_Id
) return Boolean;
12525 -- Tests N to see if it is an optimizable comparison value (defined as
12526 -- constant zero or one, or something else where the value is known to
12527 -- be positive and in the range of 32-bits, and where the corresponding
12528 -- Length value is also known to be 32-bits. If result is true, sets
12529 -- Is_Zero, Ityp, and Comp accordingly.
12531 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
12532 -- Tests if N is a length attribute applied to a simple entity. If so,
12533 -- returns True, and sets Ent to the entity, and Index to the integer
12534 -- literal provided as an attribute expression, or to Empty if none.
12535 -- Also returns True if the expression is a generated type conversion
12536 -- whose expression is of the desired form. This latter case arises
12537 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12538 -- to check for being in range, which is not needed in this context.
12539 -- Returns False if neither condition holds.
12541 function Prepare_64
(N
: Node_Id
) return Node_Id
;
12542 -- Given a discrete expression, returns a Long_Long_Integer typed
12543 -- expression representing the underlying value of the expression.
12544 -- This is done with an unchecked conversion to the result type. We
12545 -- use unchecked conversion to handle the enumeration type case.
12547 ----------------------
12548 -- Is_Entity_Length --
12549 ----------------------
12551 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
12553 if Nkind
(N
) = N_Attribute_Reference
12554 and then Attribute_Name
(N
) = Name_Length
12555 and then Is_Entity_Name
(Prefix
(N
))
12557 Ent
:= Entity
(Prefix
(N
));
12559 if Present
(Expressions
(N
)) then
12560 Index
:= First
(Expressions
(N
));
12567 elsif Nkind
(N
) = N_Type_Conversion
12568 and then not Comes_From_Source
(N
)
12570 return Is_Entity_Length
(Expression
(N
));
12575 end Is_Entity_Length
;
12577 --------------------
12578 -- Is_Optimizable --
12579 --------------------
12581 function Is_Optimizable
(N
: Node_Id
) return Boolean is
12589 if Compile_Time_Known_Value
(N
) then
12590 Val
:= Expr_Value
(N
);
12592 if Val
= Uint_0
then
12597 elsif Val
= Uint_1
then
12604 -- Here we have to make sure of being within 32-bits
12606 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12609 or else Lo
< Uint_1
12610 or else Hi
> UI_From_Int
(Int
'Last)
12615 -- Comparison value was within range, so now we must check the index
12616 -- value to make sure it is also within 32-bits.
12618 Indx
:= First_Index
(Etype
(Ent
));
12620 if Present
(Index
) then
12621 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
12626 Ityp
:= Etype
(Indx
);
12628 if Esize
(Ityp
) > 32 then
12635 end Is_Optimizable
;
12641 function Prepare_64
(N
: Node_Id
) return Node_Id
is
12643 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
12646 -- Start of processing for Optimize_Length_Comparison
12649 -- Nothing to do if not a comparison
12651 if Op
not in N_Op_Compare
then
12655 -- Nothing to do if special -gnatd.P debug flag set
12657 if Debug_Flag_Dot_PP
then
12661 -- Ent'Length op 0/1
12663 if Is_Entity_Length
(Left_Opnd
(N
))
12664 and then Is_Optimizable
(Right_Opnd
(N
))
12668 -- 0/1 op Ent'Length
12670 elsif Is_Entity_Length
(Right_Opnd
(N
))
12671 and then Is_Optimizable
(Left_Opnd
(N
))
12673 -- Flip comparison to opposite sense
12676 when N_Op_Lt
=> Op
:= N_Op_Gt
;
12677 when N_Op_Le
=> Op
:= N_Op_Ge
;
12678 when N_Op_Gt
=> Op
:= N_Op_Lt
;
12679 when N_Op_Ge
=> Op
:= N_Op_Le
;
12680 when others => null;
12683 -- Else optimization not possible
12689 -- Fall through if we will do the optimization
12691 -- Cases to handle:
12693 -- X'Length = 0 => X'First > X'Last
12694 -- X'Length = 1 => X'First = X'Last
12695 -- X'Length = n => X'First + (n - 1) = X'Last
12697 -- X'Length /= 0 => X'First <= X'Last
12698 -- X'Length /= 1 => X'First /= X'Last
12699 -- X'Length /= n => X'First + (n - 1) /= X'Last
12701 -- X'Length >= 0 => always true, warn
12702 -- X'Length >= 1 => X'First <= X'Last
12703 -- X'Length >= n => X'First + (n - 1) <= X'Last
12705 -- X'Length > 0 => X'First <= X'Last
12706 -- X'Length > 1 => X'First < X'Last
12707 -- X'Length > n => X'First + (n - 1) < X'Last
12709 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12710 -- X'Length <= 1 => X'First >= X'Last
12711 -- X'Length <= n => X'First + (n - 1) >= X'Last
12713 -- X'Length < 0 => always false (warn)
12714 -- X'Length < 1 => X'First > X'Last
12715 -- X'Length < n => X'First + (n - 1) > X'Last
12717 -- Note: for the cases of n (not constant 0,1), we require that the
12718 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12719 -- and the same for the comparison value. Then we do the comparison
12720 -- using 64-bit arithmetic (actually long long integer), so that we
12721 -- cannot have overflow intefering with the result.
12723 -- First deal with warning cases
12732 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
12733 Analyze_And_Resolve
(N
, Typ
);
12734 Warn_On_Known_Condition
(N
);
12741 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
12742 Analyze_And_Resolve
(N
, Typ
);
12743 Warn_On_Known_Condition
(N
);
12747 if Constant_Condition_Warnings
12748 and then Comes_From_Source
(Original_Node
(N
))
12750 Error_Msg_N
("could replace by ""'=""?c?", N
);
12760 -- Build the First reference we will use
12763 Make_Attribute_Reference
(Loc
,
12764 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12765 Attribute_Name
=> Name_First
);
12767 if Present
(Index
) then
12768 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
12771 -- If general value case, then do the addition of (n - 1), and
12772 -- also add the needed conversions to type Long_Long_Integer.
12774 if Present
(Comp
) then
12777 Left_Opnd
=> Prepare_64
(Left
),
12779 Make_Op_Subtract
(Loc
,
12780 Left_Opnd
=> Prepare_64
(Comp
),
12781 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
12784 -- Build the Last reference we will use
12787 Make_Attribute_Reference
(Loc
,
12788 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12789 Attribute_Name
=> Name_Last
);
12791 if Present
(Index
) then
12792 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
12795 -- If general operand, convert Last reference to Long_Long_Integer
12797 if Present
(Comp
) then
12798 Right
:= Prepare_64
(Right
);
12801 -- Check for cases to optimize
12803 -- X'Length = 0 => X'First > X'Last
12804 -- X'Length < 1 => X'First > X'Last
12805 -- X'Length < n => X'First + (n - 1) > X'Last
12807 if (Is_Zero
and then Op
= N_Op_Eq
)
12808 or else (not Is_Zero
and then Op
= N_Op_Lt
)
12813 Right_Opnd
=> Right
);
12815 -- X'Length = 1 => X'First = X'Last
12816 -- X'Length = n => X'First + (n - 1) = X'Last
12818 elsif not Is_Zero
and then Op
= N_Op_Eq
then
12822 Right_Opnd
=> Right
);
12824 -- X'Length /= 0 => X'First <= X'Last
12825 -- X'Length > 0 => X'First <= X'Last
12827 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
12831 Right_Opnd
=> Right
);
12833 -- X'Length /= 1 => X'First /= X'Last
12834 -- X'Length /= n => X'First + (n - 1) /= X'Last
12836 elsif not Is_Zero
and then Op
= N_Op_Ne
then
12840 Right_Opnd
=> Right
);
12842 -- X'Length >= 1 => X'First <= X'Last
12843 -- X'Length >= n => X'First + (n - 1) <= X'Last
12845 elsif not Is_Zero
and then Op
= N_Op_Ge
then
12849 Right_Opnd
=> Right
);
12851 -- X'Length > 1 => X'First < X'Last
12852 -- X'Length > n => X'First + (n = 1) < X'Last
12854 elsif not Is_Zero
and then Op
= N_Op_Gt
then
12858 Right_Opnd
=> Right
);
12860 -- X'Length <= 1 => X'First >= X'Last
12861 -- X'Length <= n => X'First + (n - 1) >= X'Last
12863 elsif not Is_Zero
and then Op
= N_Op_Le
then
12867 Right_Opnd
=> Right
);
12869 -- Should not happen at this stage
12872 raise Program_Error
;
12875 -- Rewrite and finish up
12877 Rewrite
(N
, Result
);
12878 Analyze_And_Resolve
(N
, Typ
);
12880 end Optimize_Length_Comparison
;
12882 ------------------------------
12883 -- Process_Transient_Object --
12884 ------------------------------
12886 procedure Process_Transient_Object
12888 Rel_Node
: Node_Id
)
12890 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
12891 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
12892 Obj_Typ
: constant Node_Id
:= Etype
(Obj_Id
);
12893 Desig_Typ
: Entity_Id
;
12895 Hook_Id
: Entity_Id
;
12896 Hook_Insert
: Node_Id
;
12897 Ptr_Id
: Entity_Id
;
12899 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Rel_Node
);
12900 -- The node on which to insert the hook as an action. This is usually
12901 -- the innermost enclosing non-transient construct.
12903 Fin_Context
: Node_Id
;
12904 -- The node after which to insert the finalization actions of the
12905 -- transient controlled object.
12908 if Is_Boolean_Type
(Etype
(Rel_Node
)) then
12909 Fin_Context
:= Last
(Actions
(Rel_Node
));
12911 Fin_Context
:= Hook_Context
;
12914 -- Step 1: Create the access type which provides a reference to the
12915 -- transient controlled object.
12917 if Is_Access_Type
(Obj_Typ
) then
12918 Desig_Typ
:= Directly_Designated_Type
(Obj_Typ
);
12920 Desig_Typ
:= Obj_Typ
;
12923 Desig_Typ
:= Base_Type
(Desig_Typ
);
12926 -- Ann : access [all] <Desig_Typ>;
12928 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
12930 Insert_Action
(Hook_Context
,
12931 Make_Full_Type_Declaration
(Loc
,
12932 Defining_Identifier
=> Ptr_Id
,
12934 Make_Access_To_Object_Definition
(Loc
,
12935 All_Present
=> Ekind
(Obj_Typ
) = E_General_Access_Type
,
12936 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))));
12938 -- Step 2: Create a temporary which acts as a hook to the transient
12939 -- controlled object. Generate:
12941 -- Hook : Ptr_Id := null;
12943 Hook_Id
:= Make_Temporary
(Loc
, 'T');
12945 Insert_Action
(Hook_Context
,
12946 Make_Object_Declaration
(Loc
,
12947 Defining_Identifier
=> Hook_Id
,
12948 Object_Definition
=> New_Occurrence_Of
(Ptr_Id
, Loc
)));
12950 -- Mark the hook as created for the purposes of exporting the transient
12951 -- controlled object out of the expression_with_action or if expression.
12952 -- This signals the machinery in Build_Finalizer to treat this case in
12953 -- a special manner.
12955 Set_Status_Flag_Or_Transient_Decl
(Hook_Id
, Decl
);
12957 -- Step 3: Associate the transient object to the hook
12959 -- This must be inserted right after the object declaration, so that
12960 -- the assignment is executed if, and only if, the object is actually
12961 -- created (whereas the declaration of the hook pointer, and the
12962 -- finalization call, may be inserted at an outer level, and may
12963 -- remain unused for some executions, if the actual creation of
12964 -- the object is conditional).
12966 -- The use of unchecked conversion / unrestricted access is needed to
12967 -- avoid an accessibility violation. Note that the finalization code is
12968 -- structured in such a way that the "hook" is processed only when it
12969 -- points to an existing object.
12971 if Is_Access_Type
(Obj_Typ
) then
12973 Unchecked_Convert_To
12975 Expr
=> New_Occurrence_Of
(Obj_Id
, Loc
));
12978 Make_Attribute_Reference
(Loc
,
12979 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
12980 Attribute_Name
=> Name_Unrestricted_Access
);
12984 -- Hook := Ptr_Id (Obj_Id);
12986 -- Hook := Obj_Id'Unrestricted_Access;
12988 -- When the transient object is initialized by an aggregate, the hook
12989 -- must capture the object after the last component assignment takes
12990 -- place. Only then is the object fully initialized.
12992 if Ekind
(Obj_Id
) = E_Variable
12993 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
12995 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
12997 -- Otherwise the hook seizes the related object immediately
13000 Hook_Insert
:= Decl
;
13003 Insert_After_And_Analyze
(Hook_Insert
,
13004 Make_Assignment_Statement
(Loc
,
13005 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13006 Expression
=> Expr
));
13008 -- Step 4: Finalize the hook after the context has been evaluated or
13009 -- elaborated. Generate:
13011 -- if Hook /= null then
13012 -- [Deep_]Finalize (Hook.all);
13016 -- When the node is part of a return statement, there is no need to
13017 -- insert a finalization call, as the general finalization mechanism
13018 -- (see Build_Finalizer) would take care of the transient controlled
13019 -- object on subprogram exit. Note that it would also be impossible to
13020 -- insert the finalization code after the return statement as this will
13021 -- render it unreachable.
13023 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
13026 -- Otherwise finalize the hook
13029 Insert_Action_After
(Fin_Context
,
13030 Make_Implicit_If_Statement
(Decl
,
13033 Left_Opnd
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13034 Right_Opnd
=> Make_Null
(Loc
)),
13036 Then_Statements
=> New_List
(
13039 Make_Explicit_Dereference
(Loc
,
13040 Prefix
=> New_Occurrence_Of
(Hook_Id
, Loc
)),
13043 Make_Assignment_Statement
(Loc
,
13044 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13045 Expression
=> Make_Null
(Loc
)))));
13047 end Process_Transient_Object
;
13049 ------------------------
13050 -- Rewrite_Comparison --
13051 ------------------------
13053 procedure Rewrite_Comparison
(N
: Node_Id
) is
13054 Warning_Generated
: Boolean := False;
13055 -- Set to True if first pass with Assume_Valid generates a warning in
13056 -- which case we skip the second pass to avoid warning overloaded.
13059 -- Set to Standard_True or Standard_False
13062 if Nkind
(N
) = N_Type_Conversion
then
13063 Rewrite_Comparison
(Expression
(N
));
13066 elsif Nkind
(N
) not in N_Op_Compare
then
13070 -- Now start looking at the comparison in detail. We potentially go
13071 -- through this loop twice. The first time, Assume_Valid is set False
13072 -- in the call to Compile_Time_Compare. If this call results in a
13073 -- clear result of always True or Always False, that's decisive and
13074 -- we are done. Otherwise we repeat the processing with Assume_Valid
13075 -- set to True to generate additional warnings. We can skip that step
13076 -- if Constant_Condition_Warnings is False.
13078 for AV
in False .. True loop
13080 Typ
: constant Entity_Id
:= Etype
(N
);
13081 Op1
: constant Node_Id
:= Left_Opnd
(N
);
13082 Op2
: constant Node_Id
:= Right_Opnd
(N
);
13084 Res
: constant Compare_Result
:=
13085 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
13086 -- Res indicates if compare outcome can be compile time determined
13088 True_Result
: Boolean;
13089 False_Result
: Boolean;
13092 case N_Op_Compare
(Nkind
(N
)) is
13094 True_Result
:= Res
= EQ
;
13095 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
13098 True_Result
:= Res
in Compare_GE
;
13099 False_Result
:= Res
= LT
;
13102 and then Constant_Condition_Warnings
13103 and then Comes_From_Source
(Original_Node
(N
))
13104 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
13105 and then not In_Instance
13106 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
13107 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
13110 ("can never be greater than, could replace by ""'=""?c?",
13112 Warning_Generated
:= True;
13116 True_Result
:= Res
= GT
;
13117 False_Result
:= Res
in Compare_LE
;
13120 True_Result
:= Res
= LT
;
13121 False_Result
:= Res
in Compare_GE
;
13124 True_Result
:= Res
in Compare_LE
;
13125 False_Result
:= Res
= GT
;
13128 and then Constant_Condition_Warnings
13129 and then Comes_From_Source
(Original_Node
(N
))
13130 and then Nkind
(Original_Node
(N
)) = N_Op_Le
13131 and then not In_Instance
13132 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
13133 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
13136 ("can never be less than, could replace by ""'=""?c?", N
);
13137 Warning_Generated
:= True;
13141 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
13142 False_Result
:= Res
= EQ
;
13145 -- If this is the first iteration, then we actually convert the
13146 -- comparison into True or False, if the result is certain.
13149 if True_Result
or False_Result
then
13150 Result
:= Boolean_Literals
(True_Result
);
13153 New_Occurrence_Of
(Result
, Sloc
(N
))));
13154 Analyze_And_Resolve
(N
, Typ
);
13155 Warn_On_Known_Condition
(N
);
13159 -- If this is the second iteration (AV = True), and the original
13160 -- node comes from source and we are not in an instance, then give
13161 -- a warning if we know result would be True or False. Note: we
13162 -- know Constant_Condition_Warnings is set if we get here.
13164 elsif Comes_From_Source
(Original_Node
(N
))
13165 and then not In_Instance
13167 if True_Result
then
13169 ("condition can only be False if invalid values present??",
13171 elsif False_Result
then
13173 ("condition can only be True if invalid values present??",
13179 -- Skip second iteration if not warning on constant conditions or
13180 -- if the first iteration already generated a warning of some kind or
13181 -- if we are in any case assuming all values are valid (so that the
13182 -- first iteration took care of the valid case).
13184 exit when not Constant_Condition_Warnings
;
13185 exit when Warning_Generated
;
13186 exit when Assume_No_Invalid_Values
;
13188 end Rewrite_Comparison
;
13190 ----------------------------
13191 -- Safe_In_Place_Array_Op --
13192 ----------------------------
13194 function Safe_In_Place_Array_Op
13197 Op2
: Node_Id
) return Boolean
13199 Target
: Entity_Id
;
13201 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
13202 -- Operand is safe if it cannot overlap part of the target of the
13203 -- operation. If the operand and the target are identical, the operand
13204 -- is safe. The operand can be empty in the case of negation.
13206 function Is_Unaliased
(N
: Node_Id
) return Boolean;
13207 -- Check that N is a stand-alone entity
13213 function Is_Unaliased
(N
: Node_Id
) return Boolean is
13217 and then No
(Address_Clause
(Entity
(N
)))
13218 and then No
(Renamed_Object
(Entity
(N
)));
13221 ---------------------
13222 -- Is_Safe_Operand --
13223 ---------------------
13225 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
13230 elsif Is_Entity_Name
(Op
) then
13231 return Is_Unaliased
(Op
);
13233 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
13234 return Is_Unaliased
(Prefix
(Op
));
13236 elsif Nkind
(Op
) = N_Slice
then
13238 Is_Unaliased
(Prefix
(Op
))
13239 and then Entity
(Prefix
(Op
)) /= Target
;
13241 elsif Nkind
(Op
) = N_Op_Not
then
13242 return Is_Safe_Operand
(Right_Opnd
(Op
));
13247 end Is_Safe_Operand
;
13249 -- Start of processing for Safe_In_Place_Array_Op
13252 -- Skip this processing if the component size is different from system
13253 -- storage unit (since at least for NOT this would cause problems).
13255 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
13258 -- Cannot do in place stuff on VM_Target since cannot pass addresses
13260 elsif VM_Target
/= No_VM
then
13263 -- Cannot do in place stuff if non-standard Boolean representation
13265 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
13268 elsif not Is_Unaliased
(Lhs
) then
13272 Target
:= Entity
(Lhs
);
13273 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
13275 end Safe_In_Place_Array_Op
;
13277 -----------------------
13278 -- Tagged_Membership --
13279 -----------------------
13281 -- There are two different cases to consider depending on whether the right
13282 -- operand is a class-wide type or not. If not we just compare the actual
13283 -- tag of the left expr to the target type tag:
13285 -- Left_Expr.Tag = Right_Type'Tag;
13287 -- If it is a class-wide type we use the RT function CW_Membership which is
13288 -- usually implemented by looking in the ancestor tables contained in the
13289 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13291 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13292 -- function IW_Membership which is usually implemented by looking in the
13293 -- table of abstract interface types plus the ancestor table contained in
13294 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13296 procedure Tagged_Membership
13298 SCIL_Node
: out Node_Id
;
13299 Result
: out Node_Id
)
13301 Left
: constant Node_Id
:= Left_Opnd
(N
);
13302 Right
: constant Node_Id
:= Right_Opnd
(N
);
13303 Loc
: constant Source_Ptr
:= Sloc
(N
);
13305 Full_R_Typ
: Entity_Id
;
13306 Left_Type
: Entity_Id
;
13307 New_Node
: Node_Id
;
13308 Right_Type
: Entity_Id
;
13312 SCIL_Node
:= Empty
;
13314 -- Handle entities from the limited view
13316 Left_Type
:= Available_View
(Etype
(Left
));
13317 Right_Type
:= Available_View
(Etype
(Right
));
13319 -- In the case where the type is an access type, the test is applied
13320 -- using the designated types (needed in Ada 2012 for implicit anonymous
13321 -- access conversions, for AI05-0149).
13323 if Is_Access_Type
(Right_Type
) then
13324 Left_Type
:= Designated_Type
(Left_Type
);
13325 Right_Type
:= Designated_Type
(Right_Type
);
13328 if Is_Class_Wide_Type
(Left_Type
) then
13329 Left_Type
:= Root_Type
(Left_Type
);
13332 if Is_Class_Wide_Type
(Right_Type
) then
13333 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
13335 Full_R_Typ
:= Underlying_Type
(Right_Type
);
13339 Make_Selected_Component
(Loc
,
13340 Prefix
=> Relocate_Node
(Left
),
13342 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
13344 if Is_Class_Wide_Type
(Right_Type
) then
13346 -- No need to issue a run-time check if we statically know that the
13347 -- result of this membership test is always true. For example,
13348 -- considering the following declarations:
13350 -- type Iface is interface;
13351 -- type T is tagged null record;
13352 -- type DT is new T and Iface with null record;
13357 -- These membership tests are always true:
13360 -- Obj2 in T'Class;
13361 -- Obj2 in Iface'Class;
13363 -- We do not need to handle cases where the membership is illegal.
13366 -- Obj1 in DT'Class; -- Compile time error
13367 -- Obj1 in Iface'Class; -- Compile time error
13369 if not Is_Class_Wide_Type
(Left_Type
)
13370 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
13371 Use_Full_View
=> True)
13372 or else (Is_Interface
(Etype
(Right_Type
))
13373 and then Interface_Present_In_Ancestor
13375 Iface
=> Etype
(Right_Type
))))
13377 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
13381 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13383 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
13385 -- Support to: "Iface_CW_Typ in Typ'Class"
13387 or else Is_Interface
(Left_Type
)
13389 -- Issue error if IW_Membership operation not available in a
13390 -- configurable run time setting.
13392 if not RTE_Available
(RE_IW_Membership
) then
13394 ("dynamic membership test on interface types", N
);
13400 Make_Function_Call
(Loc
,
13401 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
13402 Parameter_Associations
=> New_List
(
13403 Make_Attribute_Reference
(Loc
,
13405 Attribute_Name
=> Name_Address
),
13406 New_Occurrence_Of
(
13407 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
13410 -- Ada 95: Normal case
13413 Build_CW_Membership
(Loc
,
13414 Obj_Tag_Node
=> Obj_Tag
,
13416 New_Occurrence_Of
(
13417 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
13419 New_Node
=> New_Node
);
13421 -- Generate the SCIL node for this class-wide membership test.
13422 -- Done here because the previous call to Build_CW_Membership
13423 -- relocates Obj_Tag.
13425 if Generate_SCIL
then
13426 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
13427 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
13428 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
13431 Result
:= New_Node
;
13434 -- Right_Type is not a class-wide type
13437 -- No need to check the tag of the object if Right_Typ is abstract
13439 if Is_Abstract_Type
(Right_Type
) then
13440 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
13445 Left_Opnd
=> Obj_Tag
,
13448 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
13451 end Tagged_Membership
;
13453 ------------------------------
13454 -- Unary_Op_Validity_Checks --
13455 ------------------------------
13457 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
13459 if Validity_Checks_On
and Validity_Check_Operands
then
13460 Ensure_Valid
(Right_Opnd
(N
));
13462 end Unary_Op_Validity_Checks
;