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
425 Unit_Id
:= Cunit_Entity
(Current_Sem_Unit
);
427 -- Find the entity of the current unit
429 if Ekind
(Unit_Id
) = E_Subprogram_Body
then
431 -- When processing subprogram bodies, the proper scope is always that
434 Subp_Body
:= Unit_Id
;
435 while Present
(Subp_Body
)
436 and then Nkind
(Subp_Body
) /= N_Subprogram_Body
438 Subp_Body
:= Parent
(Subp_Body
);
441 Unit_Id
:= Corresponding_Spec
(Subp_Body
);
444 Loc
:= Sloc
(Unit_Id
);
445 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
447 -- Find the declarations list of the current unit
449 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
450 Unit_Decl
:= Specification
(Unit_Decl
);
451 Decls
:= Visible_Declarations
(Unit_Decl
);
454 Decls
:= New_List
(Make_Null_Statement
(Loc
));
455 Set_Visible_Declarations
(Unit_Decl
, Decls
);
457 elsif Is_Empty_List
(Decls
) then
458 Append_To
(Decls
, Make_Null_Statement
(Loc
));
462 Decls
:= Declarations
(Unit_Decl
);
465 Decls
:= New_List
(Make_Null_Statement
(Loc
));
466 Set_Declarations
(Unit_Decl
, Decls
);
468 elsif Is_Empty_List
(Decls
) then
469 Append_To
(Decls
, Make_Null_Statement
(Loc
));
473 -- The current unit has an existing anonymous master, traverse its
474 -- declarations and locate the entity.
476 if Has_Anonymous_Master
(Unit_Id
) then
479 Fin_Mas_Id
: Entity_Id
;
482 Decl
:= First
(Decls
);
483 while Present
(Decl
) loop
485 -- Look for the first variable in the declarations whole type
486 -- is Finalization_Master.
488 if Nkind
(Decl
) = N_Object_Declaration
then
489 Fin_Mas_Id
:= Defining_Identifier
(Decl
);
491 if Ekind
(Fin_Mas_Id
) = E_Variable
492 and then Etype
(Fin_Mas_Id
) = RTE
(RE_Finalization_Master
)
501 -- The master was not found even though the unit was labeled as
507 -- Create a new anonymous master
511 First_Decl
: constant Node_Id
:= First
(Decls
);
513 Fin_Mas_Id
: Entity_Id
;
516 -- Since the master and its associated initialization is inserted
517 -- at top level, use the scope of the unit when analyzing.
519 Push_Scope
(Unit_Id
);
521 -- Create the finalization master
524 Make_Defining_Identifier
(Loc
,
525 Chars
=> New_External_Name
(Chars
(Unit_Id
), "AM"));
528 -- <Fin_Mas_Id> : Finalization_Master;
531 Make_Object_Declaration
(Loc
,
532 Defining_Identifier
=> Fin_Mas_Id
,
534 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
536 Insert_Before_And_Analyze
(First_Decl
, Action
);
538 -- Mark the unit to prevent the generation of multiple masters
540 Set_Has_Anonymous_Master
(Unit_Id
);
542 -- Do not set the base pool and mode of operation on .NET/JVM
543 -- since those targets do not support pools and all VM masters
544 -- are heterogeneous by default.
546 if VM_Target
= No_VM
then
550 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
553 Make_Procedure_Call_Statement
(Loc
,
555 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
557 Parameter_Associations
=> New_List
(
558 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
559 Make_Attribute_Reference
(Loc
,
561 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
562 Attribute_Name
=> Name_Unrestricted_Access
)));
564 Insert_Before_And_Analyze
(First_Decl
, Action
);
567 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
570 Make_Procedure_Call_Statement
(Loc
,
572 New_Occurrence_Of
(RTE
(RE_Set_Is_Heterogeneous
), Loc
),
573 Parameter_Associations
=> New_List
(
574 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)));
576 Insert_Before_And_Analyze
(First_Decl
, Action
);
579 -- Restore the original state of the scope stack
586 end Current_Anonymous_Master
;
588 --------------------------------
589 -- Displace_Allocator_Pointer --
590 --------------------------------
592 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
593 Loc
: constant Source_Ptr
:= Sloc
(N
);
594 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
600 -- Do nothing in case of VM targets: the virtual machine will handle
601 -- interfaces directly.
603 if not Tagged_Type_Expansion
then
607 pragma Assert
(Nkind
(N
) = N_Identifier
608 and then Nkind
(Orig_Node
) = N_Allocator
);
610 PtrT
:= Etype
(Orig_Node
);
611 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
612 Etyp
:= Etype
(Expression
(Orig_Node
));
614 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
616 -- If the type of the allocator expression is not an interface type
617 -- we can generate code to reference the record component containing
618 -- the pointer to the secondary dispatch table.
620 if not Is_Interface
(Etyp
) then
622 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
625 -- 1) Get access to the allocated object
628 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
632 -- 2) Add the conversion to displace the pointer to reference
633 -- the secondary dispatch table.
635 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
636 Analyze_And_Resolve
(N
, Dtyp
);
638 -- 3) The 'access to the secondary dispatch table will be used
639 -- as the value returned by the allocator.
642 Make_Attribute_Reference
(Loc
,
643 Prefix
=> Relocate_Node
(N
),
644 Attribute_Name
=> Name_Access
));
645 Set_Etype
(N
, Saved_Typ
);
649 -- If the type of the allocator expression is an interface type we
650 -- generate a run-time call to displace "this" to reference the
651 -- component containing the pointer to the secondary dispatch table
652 -- or else raise Constraint_Error if the actual object does not
653 -- implement the target interface. This case corresponds to the
654 -- following example:
656 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
658 -- return new Iface_2'Class'(Obj);
663 Unchecked_Convert_To
(PtrT
,
664 Make_Function_Call
(Loc
,
665 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
666 Parameter_Associations
=> New_List
(
667 Unchecked_Convert_To
(RTE
(RE_Address
),
673 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
675 Analyze_And_Resolve
(N
, PtrT
);
678 end Displace_Allocator_Pointer
;
680 ---------------------------------
681 -- Expand_Allocator_Expression --
682 ---------------------------------
684 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
685 Loc
: constant Source_Ptr
:= Sloc
(N
);
686 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
687 PtrT
: constant Entity_Id
:= Etype
(N
);
688 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
690 procedure Apply_Accessibility_Check
692 Built_In_Place
: Boolean := False);
693 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
694 -- type, generate an accessibility check to verify that the level of the
695 -- type of the created object is not deeper than the level of the access
696 -- type. If the type of the qualified expression is class-wide, then
697 -- always generate the check (except in the case where it is known to be
698 -- unnecessary, see comment below). Otherwise, only generate the check
699 -- if the level of the qualified expression type is statically deeper
700 -- than the access type.
702 -- Although the static accessibility will generally have been performed
703 -- as a legality check, it won't have been done in cases where the
704 -- allocator appears in generic body, so a run-time check is needed in
705 -- general. One special case is when the access type is declared in the
706 -- same scope as the class-wide allocator, in which case the check can
707 -- never fail, so it need not be generated.
709 -- As an open issue, there seem to be cases where the static level
710 -- associated with the class-wide object's underlying type is not
711 -- sufficient to perform the proper accessibility check, such as for
712 -- allocators in nested subprograms or accept statements initialized by
713 -- class-wide formals when the actual originates outside at a deeper
714 -- static level. The nested subprogram case might require passing
715 -- accessibility levels along with class-wide parameters, and the task
716 -- case seems to be an actual gap in the language rules that needs to
717 -- be fixed by the ARG. ???
719 -------------------------------
720 -- Apply_Accessibility_Check --
721 -------------------------------
723 procedure Apply_Accessibility_Check
725 Built_In_Place
: Boolean := False)
727 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
735 if Ada_Version
>= Ada_2005
736 and then Is_Class_Wide_Type
(DesigT
)
737 and then (Tagged_Type_Expansion
or else VM_Target
/= No_VM
)
738 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
740 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
742 (Is_Class_Wide_Type
(Etype
(Exp
))
743 and then Scope
(PtrT
) /= Current_Scope
))
745 -- If the allocator was built in place, Ref is already a reference
746 -- to the access object initialized to the result of the allocator
747 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
748 -- Remove_Side_Effects for cases where the build-in-place call may
749 -- still be the prefix of the reference (to avoid generating
750 -- duplicate calls). Otherwise, it is the entity associated with
751 -- the object containing the address of the allocated object.
753 if Built_In_Place
then
754 Remove_Side_Effects
(Ref
);
755 Obj_Ref
:= New_Copy_Tree
(Ref
);
757 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
760 -- For access to interface types we must generate code to displace
761 -- the pointer to the base of the object since the subsequent code
762 -- references components located in the TSD of the object (which
763 -- is associated with the primary dispatch table --see a-tags.ads)
764 -- and also generates code invoking Free, which requires also a
765 -- reference to the base of the unallocated object.
767 if Is_Interface
(DesigT
) and then Tagged_Type_Expansion
then
769 Unchecked_Convert_To
(Etype
(Obj_Ref
),
770 Make_Function_Call
(Loc
,
772 New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
773 Parameter_Associations
=> New_List
(
774 Unchecked_Convert_To
(RTE
(RE_Address
),
775 New_Copy_Tree
(Obj_Ref
)))));
778 -- Step 1: Create the object clean up code
782 -- Deallocate the object if the accessibility check fails. This
783 -- is done only on targets or profiles that support deallocation.
787 if RTE_Available
(RE_Free
) then
788 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
789 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
791 Append_To
(Stmts
, Free_Stmt
);
793 -- The target or profile cannot deallocate objects
799 -- Finalize the object if applicable. Generate:
801 -- [Deep_]Finalize (Obj_Ref.all);
803 if Needs_Finalization
(DesigT
) then
807 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
810 -- When the target or profile supports deallocation, wrap the
811 -- finalization call in a block to ensure proper deallocation
812 -- even if finalization fails. Generate:
822 if Present
(Free_Stmt
) then
824 Make_Block_Statement
(Loc
,
825 Handled_Statement_Sequence
=>
826 Make_Handled_Sequence_Of_Statements
(Loc
,
827 Statements
=> New_List
(Fin_Call
),
829 Exception_Handlers
=> New_List
(
830 Make_Exception_Handler
(Loc
,
831 Exception_Choices
=> New_List
(
832 Make_Others_Choice
(Loc
)),
834 Statements
=> New_List
(
835 New_Copy_Tree
(Free_Stmt
),
836 Make_Raise_Statement
(Loc
))))));
839 Prepend_To
(Stmts
, Fin_Call
);
842 -- Signal the accessibility failure through a Program_Error
845 Make_Raise_Program_Error
(Loc
,
846 Condition
=> New_Occurrence_Of
(Standard_True
, Loc
),
847 Reason
=> PE_Accessibility_Check_Failed
));
849 -- Step 2: Create the accessibility comparison
855 Make_Attribute_Reference
(Loc
,
857 Attribute_Name
=> Name_Tag
);
859 -- For tagged types, determine the accessibility level by looking
860 -- at the type specific data of the dispatch table. Generate:
862 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
864 if Tagged_Type_Expansion
then
865 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
867 -- Use a runtime call to determine the accessibility level when
868 -- compiling on virtual machine targets. Generate:
870 -- Get_Access_Level (Ref'Tag)
874 Make_Function_Call
(Loc
,
876 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
877 Parameter_Associations
=> New_List
(Obj_Ref
));
884 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
886 -- Due to the complexity and side effects of the check, utilize an
887 -- if statement instead of the regular Program_Error circuitry.
890 Make_Implicit_If_Statement
(N
,
892 Then_Statements
=> Stmts
));
894 end Apply_Accessibility_Check
;
898 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
899 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
900 T
: constant Entity_Id
:= Entity
(Indic
);
902 Tag_Assign
: Node_Id
;
906 TagT
: Entity_Id
:= Empty
;
907 -- Type used as source for tag assignment
909 TagR
: Node_Id
:= Empty
;
910 -- Target reference for tag assignment
912 -- Start of processing for Expand_Allocator_Expression
915 -- Handle call to C++ constructor
917 if Is_CPP_Constructor_Call
(Exp
) then
918 Make_CPP_Constructor_Call_In_Allocator
920 Function_Call
=> Exp
);
924 -- In the case of an Ada 2012 allocator whose initial value comes from a
925 -- function call, pass "the accessibility level determined by the point
926 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
927 -- Expand_Call but it couldn't be done there (because the Etype of the
928 -- allocator wasn't set then) so we generate the parameter here. See
929 -- the Boolean variable Defer in (a block within) Expand_Call.
931 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
936 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
937 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
939 Subp
:= Entity
(Name
(Exp
));
942 Subp
:= Ultimate_Alias
(Subp
);
944 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
945 Add_Extra_Actual_To_Call
946 (Subprogram_Call
=> Exp
,
947 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
948 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
953 -- Case of tagged type or type requiring finalization
955 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
957 -- Ada 2005 (AI-318-02): If the initialization expression is a call
958 -- to a build-in-place function, then access to the allocated object
959 -- must be passed to the function. Currently we limit such functions
960 -- to those with constrained limited result subtypes, but eventually
961 -- we plan to expand the allowed forms of functions that are treated
962 -- as build-in-place.
964 if Ada_Version
>= Ada_2005
965 and then Is_Build_In_Place_Function_Call
(Exp
)
967 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
968 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
972 -- Actions inserted before:
973 -- Temp : constant ptr_T := new T'(Expression);
974 -- Temp._tag = T'tag; -- when not class-wide
975 -- [Deep_]Adjust (Temp.all);
977 -- We analyze by hand the new internal allocator to avoid any
978 -- recursion and inappropriate call to Initialize.
980 -- We don't want to remove side effects when the expression must be
981 -- built in place. In the case of a build-in-place function call,
982 -- that could lead to a duplication of the call, which was already
983 -- substituted for the allocator.
985 if not Aggr_In_Place
then
986 Remove_Side_Effects
(Exp
);
989 Temp
:= Make_Temporary
(Loc
, 'P', N
);
991 -- For a class wide allocation generate the following code:
993 -- type Equiv_Record is record ... end record;
994 -- implicit subtype CW is <Class_Wide_Subytpe>;
995 -- temp : PtrT := new CW'(CW!(expr));
997 if Is_Class_Wide_Type
(T
) then
998 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
1000 -- Ada 2005 (AI-251): If the expression is a class-wide interface
1001 -- object we generate code to move up "this" to reference the
1002 -- base of the object before allocating the new object.
1004 -- Note that Exp'Address is recursively expanded into a call
1005 -- to Base_Address (Exp.Tag)
1007 if Is_Class_Wide_Type
(Etype
(Exp
))
1008 and then Is_Interface
(Etype
(Exp
))
1009 and then Tagged_Type_Expansion
1013 Unchecked_Convert_To
(Entity
(Indic
),
1014 Make_Explicit_Dereference
(Loc
,
1015 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
1016 Make_Attribute_Reference
(Loc
,
1018 Attribute_Name
=> Name_Address
)))));
1022 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
1025 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
1028 -- Processing for allocators returning non-interface types
1030 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1031 if Aggr_In_Place
then
1033 Make_Object_Declaration
(Loc
,
1034 Defining_Identifier
=> Temp
,
1035 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1037 Make_Allocator
(Loc
,
1039 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1041 -- Copy the Comes_From_Source flag for the allocator we just
1042 -- built, since logically this allocator is a replacement of
1043 -- the original allocator node. This is for proper handling of
1044 -- restriction No_Implicit_Heap_Allocations.
1046 Set_Comes_From_Source
1047 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1049 Set_No_Initialization
(Expression
(Temp_Decl
));
1050 Insert_Action
(N
, Temp_Decl
);
1052 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1053 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1055 -- Attach the object to the associated finalization master.
1056 -- This is done manually on .NET/JVM since those compilers do
1057 -- no support pools and can't benefit from internally generated
1058 -- Allocate / Deallocate procedures.
1060 if VM_Target
/= No_VM
1061 and then Is_Controlled
(DesigT
)
1062 and then Present
(Finalization_Master
(PtrT
))
1066 (Obj_Ref
=> New_Occurrence_Of
(Temp
, Loc
),
1071 Node
:= Relocate_Node
(N
);
1072 Set_Analyzed
(Node
);
1075 Make_Object_Declaration
(Loc
,
1076 Defining_Identifier
=> Temp
,
1077 Constant_Present
=> True,
1078 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1079 Expression
=> Node
);
1081 Insert_Action
(N
, Temp_Decl
);
1082 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1084 -- Attach the object to the associated finalization master.
1085 -- This is done manually on .NET/JVM since those compilers do
1086 -- no support pools and can't benefit from internally generated
1087 -- Allocate / Deallocate procedures.
1089 if VM_Target
/= No_VM
1090 and then Is_Controlled
(DesigT
)
1091 and then Present
(Finalization_Master
(PtrT
))
1095 (Obj_Ref
=> New_Occurrence_Of
(Temp
, Loc
),
1100 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1101 -- interface type. In this case we use the type of the qualified
1102 -- expression to allocate the object.
1106 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1111 Make_Full_Type_Declaration
(Loc
,
1112 Defining_Identifier
=> Def_Id
,
1114 Make_Access_To_Object_Definition
(Loc
,
1115 All_Present
=> True,
1116 Null_Exclusion_Present
=> False,
1118 Is_Access_Constant
(Etype
(N
)),
1119 Subtype_Indication
=>
1120 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1122 Insert_Action
(N
, New_Decl
);
1124 -- Inherit the allocation-related attributes from the original
1127 Set_Finalization_Master
1128 (Def_Id
, Finalization_Master
(PtrT
));
1130 Set_Associated_Storage_Pool
1131 (Def_Id
, Associated_Storage_Pool
(PtrT
));
1133 -- Declare the object using the previous type declaration
1135 if Aggr_In_Place
then
1137 Make_Object_Declaration
(Loc
,
1138 Defining_Identifier
=> Temp
,
1139 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1141 Make_Allocator
(Loc
,
1142 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1144 -- Copy the Comes_From_Source flag for the allocator we just
1145 -- built, since logically this allocator is a replacement of
1146 -- the original allocator node. This is for proper handling
1147 -- of restriction No_Implicit_Heap_Allocations.
1149 Set_Comes_From_Source
1150 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1152 Set_No_Initialization
(Expression
(Temp_Decl
));
1153 Insert_Action
(N
, Temp_Decl
);
1155 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1156 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1159 Node
:= Relocate_Node
(N
);
1160 Set_Analyzed
(Node
);
1163 Make_Object_Declaration
(Loc
,
1164 Defining_Identifier
=> Temp
,
1165 Constant_Present
=> True,
1166 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1167 Expression
=> Node
);
1169 Insert_Action
(N
, Temp_Decl
);
1170 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1173 -- Generate an additional object containing the address of the
1174 -- returned object. The type of this second object declaration
1175 -- is the correct type required for the common processing that
1176 -- is still performed by this subprogram. The displacement of
1177 -- this pointer to reference the component associated with the
1178 -- interface type will be done at the end of common processing.
1181 Make_Object_Declaration
(Loc
,
1182 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
1183 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1185 Unchecked_Convert_To
(PtrT
,
1186 New_Occurrence_Of
(Temp
, Loc
)));
1188 Insert_Action
(N
, New_Decl
);
1190 Temp_Decl
:= New_Decl
;
1191 Temp
:= Defining_Identifier
(New_Decl
);
1195 Apply_Accessibility_Check
(Temp
);
1197 -- Generate the tag assignment
1199 -- Suppress the tag assignment when VM_Target because VM tags are
1200 -- represented implicitly in objects.
1202 if not Tagged_Type_Expansion
then
1205 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1206 -- interface objects because in this case the tag does not change.
1208 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1209 pragma Assert
(Is_Class_Wide_Type
1210 (Directly_Designated_Type
(Etype
(N
))));
1213 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1215 TagR
:= New_Occurrence_Of
(Temp
, Loc
);
1217 elsif Is_Private_Type
(T
)
1218 and then Is_Tagged_Type
(Underlying_Type
(T
))
1220 TagT
:= Underlying_Type
(T
);
1222 Unchecked_Convert_To
(Underlying_Type
(T
),
1223 Make_Explicit_Dereference
(Loc
,
1224 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
1227 if Present
(TagT
) then
1229 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1233 Make_Assignment_Statement
(Loc
,
1235 Make_Selected_Component
(Loc
,
1239 (First_Tag_Component
(Full_T
), Loc
)),
1242 Unchecked_Convert_To
(RTE
(RE_Tag
),
1245 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1248 -- The previous assignment has to be done in any case
1250 Set_Assignment_OK
(Name
(Tag_Assign
));
1251 Insert_Action
(N
, Tag_Assign
);
1254 if Needs_Finalization
(DesigT
) and then Needs_Finalization
(T
) then
1256 -- Generate an Adjust call if the object will be moved. In Ada
1257 -- 2005, the object may be inherently limited, in which case
1258 -- there is no Adjust procedure, and the object is built in
1259 -- place. In Ada 95, the object can be limited but not
1260 -- inherently limited if this allocator came from a return
1261 -- statement (we're allocating the result on the secondary
1262 -- stack). In that case, the object will be moved, so we _do_
1265 if not Aggr_In_Place
1266 and then not Is_Limited_View
(T
)
1270 -- An unchecked conversion is needed in the classwide case
1271 -- because the designated type can be an ancestor of the
1272 -- subtype mark of the allocator.
1276 Unchecked_Convert_To
(T
,
1277 Make_Explicit_Dereference
(Loc
,
1278 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
1283 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1284 Analyze_And_Resolve
(N
, PtrT
);
1286 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1287 -- component containing the secondary dispatch table of the interface
1290 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1291 Displace_Allocator_Pointer
(N
);
1294 elsif Aggr_In_Place
then
1295 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1297 Make_Object_Declaration
(Loc
,
1298 Defining_Identifier
=> Temp
,
1299 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1301 Make_Allocator
(Loc
,
1302 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1304 -- Copy the Comes_From_Source flag for the allocator we just built,
1305 -- since logically this allocator is a replacement of the original
1306 -- allocator node. This is for proper handling of restriction
1307 -- No_Implicit_Heap_Allocations.
1309 Set_Comes_From_Source
1310 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1312 Set_No_Initialization
(Expression
(Temp_Decl
));
1313 Insert_Action
(N
, Temp_Decl
);
1315 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1316 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1318 -- Attach the object to the associated finalization master. Thisis
1319 -- done manually on .NET/JVM since those compilers do no support
1320 -- pools and cannot benefit from internally generated Allocate and
1321 -- Deallocate procedures.
1323 if VM_Target
/= No_VM
1324 and then Is_Controlled
(DesigT
)
1325 and then Present
(Finalization_Master
(PtrT
))
1329 (Obj_Ref
=> New_Occurrence_Of
(Temp
, Loc
),
1333 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1334 Analyze_And_Resolve
(N
, PtrT
);
1336 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1337 Install_Null_Excluding_Check
(Exp
);
1339 elsif Is_Access_Type
(DesigT
)
1340 and then Nkind
(Exp
) = N_Allocator
1341 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1343 -- Apply constraint to designated subtype indication
1345 Apply_Constraint_Check
1346 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1348 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1350 -- Propagate constraint_error to enclosing allocator
1352 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1356 Build_Allocate_Deallocate_Proc
(N
, True);
1359 -- type A is access T1;
1360 -- X : A := new T2'(...);
1361 -- T1 and T2 can be different subtypes, and we might need to check
1362 -- both constraints. First check against the type of the qualified
1365 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1367 if Do_Range_Check
(Exp
) then
1368 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1371 -- A check is also needed in cases where the designated subtype is
1372 -- constrained and differs from the subtype given in the qualified
1373 -- expression. Note that the check on the qualified expression does
1374 -- not allow sliding, but this check does (a relaxation from Ada 83).
1376 if Is_Constrained
(DesigT
)
1377 and then not Subtypes_Statically_Match
(T
, DesigT
)
1379 Apply_Constraint_Check
1380 (Exp
, DesigT
, No_Sliding
=> False);
1382 if Do_Range_Check
(Exp
) then
1383 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1387 -- For an access to unconstrained packed array, GIGI needs to see an
1388 -- expression with a constrained subtype in order to compute the
1389 -- proper size for the allocator.
1391 if Is_Array_Type
(T
)
1392 and then not Is_Constrained
(T
)
1393 and then Is_Packed
(T
)
1396 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1397 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1400 Make_Subtype_Declaration
(Loc
,
1401 Defining_Identifier
=> ConstrT
,
1402 Subtype_Indication
=>
1403 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1404 Freeze_Itype
(ConstrT
, Exp
);
1405 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1409 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1410 -- to a build-in-place function, then access to the allocated object
1411 -- must be passed to the function. Currently we limit such functions
1412 -- to those with constrained limited result subtypes, but eventually
1413 -- we plan to expand the allowed forms of functions that are treated
1414 -- as build-in-place.
1416 if Ada_Version
>= Ada_2005
1417 and then Is_Build_In_Place_Function_Call
(Exp
)
1419 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1424 when RE_Not_Available
=>
1426 end Expand_Allocator_Expression
;
1428 -----------------------------
1429 -- Expand_Array_Comparison --
1430 -----------------------------
1432 -- Expansion is only required in the case of array types. For the unpacked
1433 -- case, an appropriate runtime routine is called. For packed cases, and
1434 -- also in some other cases where a runtime routine cannot be called, the
1435 -- form of the expansion is:
1437 -- [body for greater_nn; boolean_expression]
1439 -- The body is built by Make_Array_Comparison_Op, and the form of the
1440 -- Boolean expression depends on the operator involved.
1442 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1443 Loc
: constant Source_Ptr
:= Sloc
(N
);
1444 Op1
: Node_Id
:= Left_Opnd
(N
);
1445 Op2
: Node_Id
:= Right_Opnd
(N
);
1446 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1447 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1450 Func_Body
: Node_Id
;
1451 Func_Name
: Entity_Id
;
1455 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1456 -- True for byte addressable target
1458 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1459 -- Returns True if the length of the given operand is known to be less
1460 -- than 4. Returns False if this length is known to be four or greater
1461 -- or is not known at compile time.
1463 ------------------------
1464 -- Length_Less_Than_4 --
1465 ------------------------
1467 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1468 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1471 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1472 return String_Literal_Length
(Otyp
) < 4;
1476 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1477 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1478 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1483 if Compile_Time_Known_Value
(Lo
) then
1484 Lov
:= Expr_Value
(Lo
);
1489 if Compile_Time_Known_Value
(Hi
) then
1490 Hiv
:= Expr_Value
(Hi
);
1495 return Hiv
< Lov
+ 3;
1498 end Length_Less_Than_4
;
1500 -- Start of processing for Expand_Array_Comparison
1503 -- Deal first with unpacked case, where we can call a runtime routine
1504 -- except that we avoid this for targets for which are not addressable
1505 -- by bytes, and for the JVM/CIL, since they do not support direct
1506 -- addressing of array components.
1508 if not Is_Bit_Packed_Array
(Typ1
)
1509 and then Byte_Addressable
1510 and then VM_Target
= No_VM
1512 -- The call we generate is:
1514 -- Compare_Array_xn[_Unaligned]
1515 -- (left'address, right'address, left'length, right'length) <op> 0
1517 -- x = U for unsigned, S for signed
1518 -- n = 8,16,32,64 for component size
1519 -- Add _Unaligned if length < 4 and component size is 8.
1520 -- <op> is the standard comparison operator
1522 if Component_Size
(Typ1
) = 8 then
1523 if Length_Less_Than_4
(Op1
)
1525 Length_Less_Than_4
(Op2
)
1527 if Is_Unsigned_Type
(Ctyp
) then
1528 Comp
:= RE_Compare_Array_U8_Unaligned
;
1530 Comp
:= RE_Compare_Array_S8_Unaligned
;
1534 if Is_Unsigned_Type
(Ctyp
) then
1535 Comp
:= RE_Compare_Array_U8
;
1537 Comp
:= RE_Compare_Array_S8
;
1541 elsif Component_Size
(Typ1
) = 16 then
1542 if Is_Unsigned_Type
(Ctyp
) then
1543 Comp
:= RE_Compare_Array_U16
;
1545 Comp
:= RE_Compare_Array_S16
;
1548 elsif Component_Size
(Typ1
) = 32 then
1549 if Is_Unsigned_Type
(Ctyp
) then
1550 Comp
:= RE_Compare_Array_U32
;
1552 Comp
:= RE_Compare_Array_S32
;
1555 else pragma Assert
(Component_Size
(Typ1
) = 64);
1556 if Is_Unsigned_Type
(Ctyp
) then
1557 Comp
:= RE_Compare_Array_U64
;
1559 Comp
:= RE_Compare_Array_S64
;
1563 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1564 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1567 Make_Function_Call
(Sloc
(Op1
),
1568 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1570 Parameter_Associations
=> New_List
(
1571 Make_Attribute_Reference
(Loc
,
1572 Prefix
=> Relocate_Node
(Op1
),
1573 Attribute_Name
=> Name_Address
),
1575 Make_Attribute_Reference
(Loc
,
1576 Prefix
=> Relocate_Node
(Op2
),
1577 Attribute_Name
=> Name_Address
),
1579 Make_Attribute_Reference
(Loc
,
1580 Prefix
=> Relocate_Node
(Op1
),
1581 Attribute_Name
=> Name_Length
),
1583 Make_Attribute_Reference
(Loc
,
1584 Prefix
=> Relocate_Node
(Op2
),
1585 Attribute_Name
=> Name_Length
))));
1588 Make_Integer_Literal
(Sloc
(Op2
),
1591 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1592 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1596 -- Cases where we cannot make runtime call
1598 -- For (a <= b) we convert to not (a > b)
1600 if Chars
(N
) = Name_Op_Le
then
1606 Right_Opnd
=> Op2
)));
1607 Analyze_And_Resolve
(N
, Standard_Boolean
);
1610 -- For < the Boolean expression is
1611 -- greater__nn (op2, op1)
1613 elsif Chars
(N
) = Name_Op_Lt
then
1614 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1618 Op1
:= Right_Opnd
(N
);
1619 Op2
:= Left_Opnd
(N
);
1621 -- For (a >= b) we convert to not (a < b)
1623 elsif Chars
(N
) = Name_Op_Ge
then
1629 Right_Opnd
=> Op2
)));
1630 Analyze_And_Resolve
(N
, Standard_Boolean
);
1633 -- For > the Boolean expression is
1634 -- greater__nn (op1, op2)
1637 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1638 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1641 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1643 Make_Function_Call
(Loc
,
1644 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1645 Parameter_Associations
=> New_List
(Op1
, Op2
));
1647 Insert_Action
(N
, Func_Body
);
1649 Analyze_And_Resolve
(N
, Standard_Boolean
);
1652 when RE_Not_Available
=>
1654 end Expand_Array_Comparison
;
1656 ---------------------------
1657 -- Expand_Array_Equality --
1658 ---------------------------
1660 -- Expand an equality function for multi-dimensional arrays. Here is an
1661 -- example of such a function for Nb_Dimension = 2
1663 -- function Enn (A : atyp; B : btyp) return boolean is
1665 -- if (A'length (1) = 0 or else A'length (2) = 0)
1667 -- (B'length (1) = 0 or else B'length (2) = 0)
1669 -- return True; -- RM 4.5.2(22)
1672 -- if A'length (1) /= B'length (1)
1674 -- A'length (2) /= B'length (2)
1676 -- return False; -- RM 4.5.2(23)
1680 -- A1 : Index_T1 := A'first (1);
1681 -- B1 : Index_T1 := B'first (1);
1685 -- A2 : Index_T2 := A'first (2);
1686 -- B2 : Index_T2 := B'first (2);
1689 -- if A (A1, A2) /= B (B1, B2) then
1693 -- exit when A2 = A'last (2);
1694 -- A2 := Index_T2'succ (A2);
1695 -- B2 := Index_T2'succ (B2);
1699 -- exit when A1 = A'last (1);
1700 -- A1 := Index_T1'succ (A1);
1701 -- B1 := Index_T1'succ (B1);
1708 -- Note on the formal types used (atyp and btyp). If either of the arrays
1709 -- is of a private type, we use the underlying type, and do an unchecked
1710 -- conversion of the actual. If either of the arrays has a bound depending
1711 -- on a discriminant, then we use the base type since otherwise we have an
1712 -- escaped discriminant in the function.
1714 -- If both arrays are constrained and have the same bounds, we can generate
1715 -- a loop with an explicit iteration scheme using a 'Range attribute over
1718 function Expand_Array_Equality
1723 Typ
: Entity_Id
) return Node_Id
1725 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1726 Decls
: constant List_Id
:= New_List
;
1727 Index_List1
: constant List_Id
:= New_List
;
1728 Index_List2
: constant List_Id
:= New_List
;
1732 Func_Name
: Entity_Id
;
1733 Func_Body
: Node_Id
;
1735 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1736 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1740 -- The parameter types to be used for the formals
1745 Num
: Int
) return Node_Id
;
1746 -- This builds the attribute reference Arr'Nam (Expr)
1748 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1749 -- Create one statement to compare corresponding components, designated
1750 -- by a full set of indexes.
1752 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1753 -- Given one of the arguments, computes the appropriate type to be used
1754 -- for that argument in the corresponding function formal
1756 function Handle_One_Dimension
1758 Index
: Node_Id
) return Node_Id
;
1759 -- This procedure returns the following code
1762 -- Bn : Index_T := B'First (N);
1766 -- exit when An = A'Last (N);
1767 -- An := Index_T'Succ (An)
1768 -- Bn := Index_T'Succ (Bn)
1772 -- If both indexes are constrained and identical, the procedure
1773 -- returns a simpler loop:
1775 -- for An in A'Range (N) loop
1779 -- N is the dimension for which we are generating a loop. Index is the
1780 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1781 -- xxx statement is either the loop or declare for the next dimension
1782 -- or if this is the last dimension the comparison of corresponding
1783 -- components of the arrays.
1785 -- The actual way the code works is to return the comparison of
1786 -- corresponding components for the N+1 call. That's neater.
1788 function Test_Empty_Arrays
return Node_Id
;
1789 -- This function constructs the test for both arrays being empty
1790 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1792 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1794 function Test_Lengths_Correspond
return Node_Id
;
1795 -- This function constructs the test for arrays having different lengths
1796 -- in at least one index position, in which case the resulting code is:
1798 -- A'length (1) /= B'length (1)
1800 -- A'length (2) /= B'length (2)
1811 Num
: Int
) return Node_Id
1815 Make_Attribute_Reference
(Loc
,
1816 Attribute_Name
=> Nam
,
1817 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1818 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1821 ------------------------
1822 -- Component_Equality --
1823 ------------------------
1825 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1830 -- if a(i1...) /= b(j1...) then return false; end if;
1833 Make_Indexed_Component
(Loc
,
1834 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1835 Expressions
=> Index_List1
);
1838 Make_Indexed_Component
(Loc
,
1839 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1840 Expressions
=> Index_List2
);
1842 Test
:= Expand_Composite_Equality
1843 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1845 -- If some (sub)component is an unchecked_union, the whole operation
1846 -- will raise program error.
1848 if Nkind
(Test
) = N_Raise_Program_Error
then
1850 -- This node is going to be inserted at a location where a
1851 -- statement is expected: clear its Etype so analysis will set
1852 -- it to the expected Standard_Void_Type.
1854 Set_Etype
(Test
, Empty
);
1859 Make_Implicit_If_Statement
(Nod
,
1860 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1861 Then_Statements
=> New_List
(
1862 Make_Simple_Return_Statement
(Loc
,
1863 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1865 end Component_Equality
;
1871 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1882 T
:= Underlying_Type
(T
);
1884 X
:= First_Index
(T
);
1885 while Present
(X
) loop
1886 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1888 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1901 --------------------------
1902 -- Handle_One_Dimension --
1903 ---------------------------
1905 function Handle_One_Dimension
1907 Index
: Node_Id
) return Node_Id
1909 Need_Separate_Indexes
: constant Boolean :=
1910 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1911 -- If the index types are identical, and we are working with
1912 -- constrained types, then we can use the same index for both
1915 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1918 Index_T
: Entity_Id
;
1923 if N
> Number_Dimensions
(Ltyp
) then
1924 return Component_Equality
(Ltyp
);
1927 -- Case where we generate a loop
1929 Index_T
:= Base_Type
(Etype
(Index
));
1931 if Need_Separate_Indexes
then
1932 Bn
:= Make_Temporary
(Loc
, 'B');
1937 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1938 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1940 Stm_List
:= New_List
(
1941 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1943 if Need_Separate_Indexes
then
1945 -- Generate guard for loop, followed by increments of indexes
1947 Append_To
(Stm_List
,
1948 Make_Exit_Statement
(Loc
,
1951 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1952 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1954 Append_To
(Stm_List
,
1955 Make_Assignment_Statement
(Loc
,
1956 Name
=> New_Occurrence_Of
(An
, Loc
),
1958 Make_Attribute_Reference
(Loc
,
1959 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1960 Attribute_Name
=> Name_Succ
,
1961 Expressions
=> New_List
(
1962 New_Occurrence_Of
(An
, Loc
)))));
1964 Append_To
(Stm_List
,
1965 Make_Assignment_Statement
(Loc
,
1966 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1968 Make_Attribute_Reference
(Loc
,
1969 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1970 Attribute_Name
=> Name_Succ
,
1971 Expressions
=> New_List
(
1972 New_Occurrence_Of
(Bn
, Loc
)))));
1975 -- If separate indexes, we need a declare block for An and Bn, and a
1976 -- loop without an iteration scheme.
1978 if Need_Separate_Indexes
then
1980 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1983 Make_Block_Statement
(Loc
,
1984 Declarations
=> New_List
(
1985 Make_Object_Declaration
(Loc
,
1986 Defining_Identifier
=> An
,
1987 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1988 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1990 Make_Object_Declaration
(Loc
,
1991 Defining_Identifier
=> Bn
,
1992 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1993 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1995 Handled_Statement_Sequence
=>
1996 Make_Handled_Sequence_Of_Statements
(Loc
,
1997 Statements
=> New_List
(Loop_Stm
)));
1999 -- If no separate indexes, return loop statement with explicit
2000 -- iteration scheme on its own
2004 Make_Implicit_Loop_Statement
(Nod
,
2005 Statements
=> Stm_List
,
2007 Make_Iteration_Scheme
(Loc
,
2008 Loop_Parameter_Specification
=>
2009 Make_Loop_Parameter_Specification
(Loc
,
2010 Defining_Identifier
=> An
,
2011 Discrete_Subtype_Definition
=>
2012 Arr_Attr
(A
, Name_Range
, N
))));
2015 end Handle_One_Dimension
;
2017 -----------------------
2018 -- Test_Empty_Arrays --
2019 -----------------------
2021 function Test_Empty_Arrays
return Node_Id
is
2031 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2034 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2035 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2039 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
2040 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2049 Left_Opnd
=> Relocate_Node
(Alist
),
2050 Right_Opnd
=> Atest
);
2054 Left_Opnd
=> Relocate_Node
(Blist
),
2055 Right_Opnd
=> Btest
);
2062 Right_Opnd
=> Blist
);
2063 end Test_Empty_Arrays
;
2065 -----------------------------
2066 -- Test_Lengths_Correspond --
2067 -----------------------------
2069 function Test_Lengths_Correspond
return Node_Id
is
2075 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2078 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2079 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
2086 Left_Opnd
=> Relocate_Node
(Result
),
2087 Right_Opnd
=> Rtest
);
2092 end Test_Lengths_Correspond
;
2094 -- Start of processing for Expand_Array_Equality
2097 Ltyp
:= Get_Arg_Type
(Lhs
);
2098 Rtyp
:= Get_Arg_Type
(Rhs
);
2100 -- For now, if the argument types are not the same, go to the base type,
2101 -- since the code assumes that the formals have the same type. This is
2102 -- fixable in future ???
2104 if Ltyp
/= Rtyp
then
2105 Ltyp
:= Base_Type
(Ltyp
);
2106 Rtyp
:= Base_Type
(Rtyp
);
2107 pragma Assert
(Ltyp
= Rtyp
);
2110 -- Build list of formals for function
2112 Formals
:= New_List
(
2113 Make_Parameter_Specification
(Loc
,
2114 Defining_Identifier
=> A
,
2115 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
2117 Make_Parameter_Specification
(Loc
,
2118 Defining_Identifier
=> B
,
2119 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
2121 Func_Name
:= Make_Temporary
(Loc
, 'E');
2123 -- Build statement sequence for function
2126 Make_Subprogram_Body
(Loc
,
2128 Make_Function_Specification
(Loc
,
2129 Defining_Unit_Name
=> Func_Name
,
2130 Parameter_Specifications
=> Formals
,
2131 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2133 Declarations
=> Decls
,
2135 Handled_Statement_Sequence
=>
2136 Make_Handled_Sequence_Of_Statements
(Loc
,
2137 Statements
=> New_List
(
2139 Make_Implicit_If_Statement
(Nod
,
2140 Condition
=> Test_Empty_Arrays
,
2141 Then_Statements
=> New_List
(
2142 Make_Simple_Return_Statement
(Loc
,
2144 New_Occurrence_Of
(Standard_True
, Loc
)))),
2146 Make_Implicit_If_Statement
(Nod
,
2147 Condition
=> Test_Lengths_Correspond
,
2148 Then_Statements
=> New_List
(
2149 Make_Simple_Return_Statement
(Loc
,
2150 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
2152 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
2154 Make_Simple_Return_Statement
(Loc
,
2155 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2157 Set_Has_Completion
(Func_Name
, True);
2158 Set_Is_Inlined
(Func_Name
);
2160 -- If the array type is distinct from the type of the arguments, it
2161 -- is the full view of a private type. Apply an unchecked conversion
2162 -- to insure that analysis of the call succeeds.
2172 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
2174 L
:= OK_Convert_To
(Ltyp
, Lhs
);
2178 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
2180 R
:= OK_Convert_To
(Rtyp
, Rhs
);
2183 Actuals
:= New_List
(L
, R
);
2186 Append_To
(Bodies
, Func_Body
);
2189 Make_Function_Call
(Loc
,
2190 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2191 Parameter_Associations
=> Actuals
);
2192 end Expand_Array_Equality
;
2194 -----------------------------
2195 -- Expand_Boolean_Operator --
2196 -----------------------------
2198 -- Note that we first get the actual subtypes of the operands, since we
2199 -- always want to deal with types that have bounds.
2201 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2202 Typ
: constant Entity_Id
:= Etype
(N
);
2205 -- Special case of bit packed array where both operands are known to be
2206 -- properly aligned. In this case we use an efficient run time routine
2207 -- to carry out the operation (see System.Bit_Ops).
2209 if Is_Bit_Packed_Array
(Typ
)
2210 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2211 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2213 Expand_Packed_Boolean_Operator
(N
);
2217 -- For the normal non-packed case, the general expansion is to build
2218 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2219 -- and then inserting it into the tree. The original operator node is
2220 -- then rewritten as a call to this function. We also use this in the
2221 -- packed case if either operand is a possibly unaligned object.
2224 Loc
: constant Source_Ptr
:= Sloc
(N
);
2225 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2226 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2227 Func_Body
: Node_Id
;
2228 Func_Name
: Entity_Id
;
2231 Convert_To_Actual_Subtype
(L
);
2232 Convert_To_Actual_Subtype
(R
);
2233 Ensure_Defined
(Etype
(L
), N
);
2234 Ensure_Defined
(Etype
(R
), N
);
2235 Apply_Length_Check
(R
, Etype
(L
));
2237 if Nkind
(N
) = N_Op_Xor
then
2238 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2241 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2242 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2244 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2246 elsif Nkind
(Parent
(N
)) = N_Op_Not
2247 and then Nkind
(N
) = N_Op_And
2248 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2249 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2254 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2255 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2256 Insert_Action
(N
, Func_Body
);
2258 -- Now rewrite the expression with a call
2261 Make_Function_Call
(Loc
,
2262 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2263 Parameter_Associations
=>
2266 Make_Type_Conversion
2267 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2269 Analyze_And_Resolve
(N
, Typ
);
2272 end Expand_Boolean_Operator
;
2274 ------------------------------------------------
2275 -- Expand_Compare_Minimize_Eliminate_Overflow --
2276 ------------------------------------------------
2278 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2279 Loc
: constant Source_Ptr
:= Sloc
(N
);
2281 Result_Type
: constant Entity_Id
:= Etype
(N
);
2282 -- Capture result type (could be a derived boolean type)
2287 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2288 -- Entity for Long_Long_Integer'Base
2290 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2291 -- Current overflow checking mode
2294 procedure Set_False
;
2295 -- These procedures rewrite N with an occurrence of Standard_True or
2296 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2302 procedure Set_False
is
2304 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2305 Warn_On_Known_Condition
(N
);
2312 procedure Set_True
is
2314 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2315 Warn_On_Known_Condition
(N
);
2318 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2321 -- Nothing to do unless we have a comparison operator with operands
2322 -- that are signed integer types, and we are operating in either
2323 -- MINIMIZED or ELIMINATED overflow checking mode.
2325 if Nkind
(N
) not in N_Op_Compare
2326 or else Check
not in Minimized_Or_Eliminated
2327 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2332 -- OK, this is the case we are interested in. First step is to process
2333 -- our operands using the Minimize_Eliminate circuitry which applies
2334 -- this processing to the two operand subtrees.
2336 Minimize_Eliminate_Overflows
2337 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2338 Minimize_Eliminate_Overflows
2339 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2341 -- See if the range information decides the result of the comparison.
2342 -- We can only do this if we in fact have full range information (which
2343 -- won't be the case if either operand is bignum at this stage).
2345 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2346 case N_Op_Compare
(Nkind
(N
)) is
2348 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2350 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2357 elsif Lhi
< Rlo
then
2364 elsif Lhi
<= Rlo
then
2371 elsif Lhi
<= Rlo
then
2378 elsif Lhi
< Rlo
then
2383 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2385 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2390 -- All done if we did the rewrite
2392 if Nkind
(N
) not in N_Op_Compare
then
2397 -- Otherwise, time to do the comparison
2400 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2401 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2404 -- If the two operands have the same signed integer type we are
2405 -- all set, nothing more to do. This is the case where either
2406 -- both operands were unchanged, or we rewrote both of them to
2407 -- be Long_Long_Integer.
2409 -- Note: Entity for the comparison may be wrong, but it's not worth
2410 -- the effort to change it, since the back end does not use it.
2412 if Is_Signed_Integer_Type
(Ltype
)
2413 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2417 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2419 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2421 Left
: Node_Id
:= Left_Opnd
(N
);
2422 Right
: Node_Id
:= Right_Opnd
(N
);
2423 -- Bignum references for left and right operands
2426 if not Is_RTE
(Ltype
, RE_Bignum
) then
2427 Left
:= Convert_To_Bignum
(Left
);
2428 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2429 Right
:= Convert_To_Bignum
(Right
);
2432 -- We rewrite our node with:
2435 -- Bnn : Result_Type;
2437 -- M : Mark_Id := SS_Mark;
2439 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2447 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2448 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2452 case N_Op_Compare
(Nkind
(N
)) is
2453 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2454 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2455 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2456 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2457 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2458 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2461 -- Insert assignment to Bnn into the bignum block
2464 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2465 Make_Assignment_Statement
(Loc
,
2466 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2468 Make_Function_Call
(Loc
,
2470 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2471 Parameter_Associations
=> New_List
(Left
, Right
))));
2473 -- Now do the rewrite with expression actions
2476 Make_Expression_With_Actions
(Loc
,
2477 Actions
=> New_List
(
2478 Make_Object_Declaration
(Loc
,
2479 Defining_Identifier
=> Bnn
,
2480 Object_Definition
=>
2481 New_Occurrence_Of
(Result_Type
, Loc
)),
2483 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2484 Analyze_And_Resolve
(N
, Result_Type
);
2488 -- No bignums involved, but types are different, so we must have
2489 -- rewritten one of the operands as a Long_Long_Integer but not
2492 -- If left operand is Long_Long_Integer, convert right operand
2493 -- and we are done (with a comparison of two Long_Long_Integers).
2495 elsif Ltype
= LLIB
then
2496 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2497 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2500 -- If right operand is Long_Long_Integer, convert left operand
2501 -- and we are done (with a comparison of two Long_Long_Integers).
2503 -- This is the only remaining possibility
2505 else pragma Assert
(Rtype
= LLIB
);
2506 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2507 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2511 end Expand_Compare_Minimize_Eliminate_Overflow
;
2513 -------------------------------
2514 -- Expand_Composite_Equality --
2515 -------------------------------
2517 -- This function is only called for comparing internal fields of composite
2518 -- types when these fields are themselves composites. This is a special
2519 -- case because it is not possible to respect normal Ada visibility rules.
2521 function Expand_Composite_Equality
2526 Bodies
: List_Id
) return Node_Id
2528 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2529 Full_Type
: Entity_Id
;
2533 function Find_Primitive_Eq
return Node_Id
;
2534 -- AI05-0123: Locate primitive equality for type if it exists, and
2535 -- build the corresponding call. If operation is abstract, replace
2536 -- call with an explicit raise. Return Empty if there is no primitive.
2538 -----------------------
2539 -- Find_Primitive_Eq --
2540 -----------------------
2542 function Find_Primitive_Eq
return Node_Id
is
2547 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2548 while Present
(Prim_E
) loop
2549 Prim
:= Node
(Prim_E
);
2551 -- Locate primitive equality with the right signature
2553 if Chars
(Prim
) = Name_Op_Eq
2554 and then Etype
(First_Formal
(Prim
)) =
2555 Etype
(Next_Formal
(First_Formal
(Prim
)))
2556 and then Etype
(Prim
) = Standard_Boolean
2558 if Is_Abstract_Subprogram
(Prim
) then
2560 Make_Raise_Program_Error
(Loc
,
2561 Reason
=> PE_Explicit_Raise
);
2565 Make_Function_Call
(Loc
,
2566 Name
=> New_Occurrence_Of
(Prim
, Loc
),
2567 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2574 -- If not found, predefined operation will be used
2577 end Find_Primitive_Eq
;
2579 -- Start of processing for Expand_Composite_Equality
2582 if Is_Private_Type
(Typ
) then
2583 Full_Type
:= Underlying_Type
(Typ
);
2588 -- If the private type has no completion the context may be the
2589 -- expansion of a composite equality for a composite type with some
2590 -- still incomplete components. The expression will not be analyzed
2591 -- until the enclosing type is completed, at which point this will be
2592 -- properly expanded, unless there is a bona fide completion error.
2594 if No
(Full_Type
) then
2595 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2598 Full_Type
:= Base_Type
(Full_Type
);
2600 -- When the base type itself is private, use the full view to expand
2601 -- the composite equality.
2603 if Is_Private_Type
(Full_Type
) then
2604 Full_Type
:= Underlying_Type
(Full_Type
);
2607 -- Case of array types
2609 if Is_Array_Type
(Full_Type
) then
2611 -- If the operand is an elementary type other than a floating-point
2612 -- type, then we can simply use the built-in block bitwise equality,
2613 -- since the predefined equality operators always apply and bitwise
2614 -- equality is fine for all these cases.
2616 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2617 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2619 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2621 -- For composite component types, and floating-point types, use the
2622 -- expansion. This deals with tagged component types (where we use
2623 -- the applicable equality routine) and floating-point, (where we
2624 -- need to worry about negative zeroes), and also the case of any
2625 -- composite type recursively containing such fields.
2628 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2631 -- Case of tagged record types
2633 elsif Is_Tagged_Type
(Full_Type
) then
2635 -- Call the primitive operation "=" of this type
2637 if Is_Class_Wide_Type
(Full_Type
) then
2638 Full_Type
:= Root_Type
(Full_Type
);
2641 -- If this is derived from an untagged private type completed with a
2642 -- tagged type, it does not have a full view, so we use the primitive
2643 -- operations of the private type. This check should no longer be
2644 -- necessary when these types receive their full views ???
2646 if Is_Private_Type
(Typ
)
2647 and then not Is_Tagged_Type
(Typ
)
2648 and then not Is_Controlled
(Typ
)
2649 and then Is_Derived_Type
(Typ
)
2650 and then No
(Full_View
(Typ
))
2652 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2654 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2658 Eq_Op
:= Node
(Prim
);
2659 exit when Chars
(Eq_Op
) = Name_Op_Eq
2660 and then Etype
(First_Formal
(Eq_Op
)) =
2661 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2662 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2664 pragma Assert
(Present
(Prim
));
2667 Eq_Op
:= Node
(Prim
);
2670 Make_Function_Call
(Loc
,
2671 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2672 Parameter_Associations
=>
2674 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2675 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2677 -- Case of untagged record types
2679 elsif Is_Record_Type
(Full_Type
) then
2680 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2682 if Present
(Eq_Op
) then
2683 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2685 -- Inherited equality from parent type. Convert the actuals to
2686 -- match signature of operation.
2689 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2693 Make_Function_Call
(Loc
,
2694 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2695 Parameter_Associations
=> New_List
(
2696 OK_Convert_To
(T
, Lhs
),
2697 OK_Convert_To
(T
, Rhs
)));
2701 -- Comparison between Unchecked_Union components
2703 if Is_Unchecked_Union
(Full_Type
) then
2705 Lhs_Type
: Node_Id
:= Full_Type
;
2706 Rhs_Type
: Node_Id
:= Full_Type
;
2707 Lhs_Discr_Val
: Node_Id
;
2708 Rhs_Discr_Val
: Node_Id
;
2713 if Nkind
(Lhs
) = N_Selected_Component
then
2714 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2719 if Nkind
(Rhs
) = N_Selected_Component
then
2720 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2723 -- Lhs of the composite equality
2725 if Is_Constrained
(Lhs_Type
) then
2727 -- Since the enclosing record type can never be an
2728 -- Unchecked_Union (this code is executed for records
2729 -- that do not have variants), we may reference its
2732 if Nkind
(Lhs
) = N_Selected_Component
2733 and then Has_Per_Object_Constraint
2734 (Entity
(Selector_Name
(Lhs
)))
2737 Make_Selected_Component
(Loc
,
2738 Prefix
=> Prefix
(Lhs
),
2741 (Get_Discriminant_Value
2742 (First_Discriminant
(Lhs_Type
),
2744 Stored_Constraint
(Lhs_Type
))));
2749 (Get_Discriminant_Value
2750 (First_Discriminant
(Lhs_Type
),
2752 Stored_Constraint
(Lhs_Type
)));
2756 -- It is not possible to infer the discriminant since
2757 -- the subtype is not constrained.
2760 Make_Raise_Program_Error
(Loc
,
2761 Reason
=> PE_Unchecked_Union_Restriction
);
2764 -- Rhs of the composite equality
2766 if Is_Constrained
(Rhs_Type
) then
2767 if Nkind
(Rhs
) = N_Selected_Component
2768 and then Has_Per_Object_Constraint
2769 (Entity
(Selector_Name
(Rhs
)))
2772 Make_Selected_Component
(Loc
,
2773 Prefix
=> Prefix
(Rhs
),
2776 (Get_Discriminant_Value
2777 (First_Discriminant
(Rhs_Type
),
2779 Stored_Constraint
(Rhs_Type
))));
2784 (Get_Discriminant_Value
2785 (First_Discriminant
(Rhs_Type
),
2787 Stored_Constraint
(Rhs_Type
)));
2792 Make_Raise_Program_Error
(Loc
,
2793 Reason
=> PE_Unchecked_Union_Restriction
);
2796 -- Call the TSS equality function with the inferred
2797 -- discriminant values.
2800 Make_Function_Call
(Loc
,
2801 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2802 Parameter_Associations
=> New_List
(
2809 -- All cases other than comparing Unchecked_Union types
2813 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2816 Make_Function_Call
(Loc
,
2818 New_Occurrence_Of
(Eq_Op
, Loc
),
2819 Parameter_Associations
=> New_List
(
2820 OK_Convert_To
(T
, Lhs
),
2821 OK_Convert_To
(T
, Rhs
)));
2826 -- Equality composes in Ada 2012 for untagged record types. It also
2827 -- composes for bounded strings, because they are part of the
2828 -- predefined environment. We could make it compose for bounded
2829 -- strings by making them tagged, or by making sure all subcomponents
2830 -- are set to the same value, even when not used. Instead, we have
2831 -- this special case in the compiler, because it's more efficient.
2833 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2835 -- If no TSS has been created for the type, check whether there is
2836 -- a primitive equality declared for it.
2839 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2842 -- Use user-defined primitive if it exists, otherwise use
2843 -- predefined equality.
2845 if Present
(Op
) then
2848 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2853 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2856 -- Non-composite types (always use predefined equality)
2859 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2861 end Expand_Composite_Equality
;
2863 ------------------------
2864 -- Expand_Concatenate --
2865 ------------------------
2867 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2868 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2870 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2871 -- Result type of concatenation
2873 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2874 -- Component type. Elements of this component type can appear as one
2875 -- of the operands of concatenation as well as arrays.
2877 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2880 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2881 -- Index type. This is the base type of the index subtype, and is used
2882 -- for all computed bounds (which may be out of range of Istyp in the
2883 -- case of null ranges).
2886 -- This is the type we use to do arithmetic to compute the bounds and
2887 -- lengths of operands. The choice of this type is a little subtle and
2888 -- is discussed in a separate section at the start of the body code.
2890 Concatenation_Error
: exception;
2891 -- Raised if concatenation is sure to raise a CE
2893 Result_May_Be_Null
: Boolean := True;
2894 -- Reset to False if at least one operand is encountered which is known
2895 -- at compile time to be non-null. Used for handling the special case
2896 -- of setting the high bound to the last operand high bound for a null
2897 -- result, thus ensuring a proper high bound in the super-flat case.
2899 N
: constant Nat
:= List_Length
(Opnds
);
2900 -- Number of concatenation operands including possibly null operands
2903 -- Number of operands excluding any known to be null, except that the
2904 -- last operand is always retained, in case it provides the bounds for
2908 -- Current operand being processed in the loop through operands. After
2909 -- this loop is complete, always contains the last operand (which is not
2910 -- the same as Operands (NN), since null operands are skipped).
2912 -- Arrays describing the operands, only the first NN entries of each
2913 -- array are set (NN < N when we exclude known null operands).
2915 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2916 -- True if length of corresponding operand known at compile time
2918 Operands
: array (1 .. N
) of Node_Id
;
2919 -- Set to the corresponding entry in the Opnds list (but note that null
2920 -- operands are excluded, so not all entries in the list are stored).
2922 Fixed_Length
: array (1 .. N
) of Uint
;
2923 -- Set to length of operand. Entries in this array are set only if the
2924 -- corresponding entry in Is_Fixed_Length is True.
2926 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2927 -- Set to lower bound of operand. Either an integer literal in the case
2928 -- where the bound is known at compile time, else actual lower bound.
2929 -- The operand low bound is of type Ityp.
2931 Var_Length
: array (1 .. N
) of Entity_Id
;
2932 -- Set to an entity of type Natural that contains the length of an
2933 -- operand whose length is not known at compile time. Entries in this
2934 -- array are set only if the corresponding entry in Is_Fixed_Length
2935 -- is False. The entity is of type Artyp.
2937 Aggr_Length
: array (0 .. N
) of Node_Id
;
2938 -- The J'th entry in an expression node that represents the total length
2939 -- of operands 1 through J. It is either an integer literal node, or a
2940 -- reference to a constant entity with the right value, so it is fine
2941 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2942 -- entry always is set to zero. The length is of type Artyp.
2944 Low_Bound
: Node_Id
;
2945 -- A tree node representing the low bound of the result (of type Ityp).
2946 -- This is either an integer literal node, or an identifier reference to
2947 -- a constant entity initialized to the appropriate value.
2949 Last_Opnd_Low_Bound
: Node_Id
;
2950 -- A tree node representing the low bound of the last operand. This
2951 -- need only be set if the result could be null. It is used for the
2952 -- special case of setting the right low bound for a null result.
2953 -- This is of type Ityp.
2955 Last_Opnd_High_Bound
: Node_Id
;
2956 -- A tree node representing the high bound of the last operand. This
2957 -- need only be set if the result could be null. It is used for the
2958 -- special case of setting the right high bound for a null result.
2959 -- This is of type Ityp.
2961 High_Bound
: Node_Id
;
2962 -- A tree node representing the high bound of the result (of type Ityp)
2965 -- Result of the concatenation (of type Ityp)
2967 Actions
: constant List_Id
:= New_List
;
2968 -- Collect actions to be inserted
2970 Known_Non_Null_Operand_Seen
: Boolean;
2971 -- Set True during generation of the assignments of operands into
2972 -- result once an operand known to be non-null has been seen.
2974 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2975 -- This function makes an N_Integer_Literal node that is returned in
2976 -- analyzed form with the type set to Artyp. Importantly this literal
2977 -- is not flagged as static, so that if we do computations with it that
2978 -- result in statically detected out of range conditions, we will not
2979 -- generate error messages but instead warning messages.
2981 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2982 -- Given a node of type Ityp, returns the corresponding value of type
2983 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2984 -- For enum types, the Pos of the value is returned.
2986 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2987 -- The inverse function (uses Val in the case of enumeration types)
2989 ------------------------
2990 -- Make_Artyp_Literal --
2991 ------------------------
2993 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2994 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2996 Set_Etype
(Result
, Artyp
);
2997 Set_Analyzed
(Result
, True);
2998 Set_Is_Static_Expression
(Result
, False);
3000 end Make_Artyp_Literal
;
3006 function To_Artyp
(X
: Node_Id
) return Node_Id
is
3008 if Ityp
= Base_Type
(Artyp
) then
3011 elsif Is_Enumeration_Type
(Ityp
) then
3013 Make_Attribute_Reference
(Loc
,
3014 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3015 Attribute_Name
=> Name_Pos
,
3016 Expressions
=> New_List
(X
));
3019 return Convert_To
(Artyp
, X
);
3027 function To_Ityp
(X
: Node_Id
) return Node_Id
is
3029 if Is_Enumeration_Type
(Ityp
) then
3031 Make_Attribute_Reference
(Loc
,
3032 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3033 Attribute_Name
=> Name_Val
,
3034 Expressions
=> New_List
(X
));
3036 -- Case where we will do a type conversion
3039 if Ityp
= Base_Type
(Artyp
) then
3042 return Convert_To
(Ityp
, X
);
3047 -- Local Declarations
3049 Lib_Level_Target
: constant Boolean :=
3050 Nkind
(Parent
(Cnode
)) = N_Object_Declaration
3052 Is_Library_Level_Entity
(Defining_Identifier
(Parent
(Cnode
)));
3054 -- If the concatenation declares a library level entity, we call the
3055 -- built-in concatenation routines to prevent code bloat, regardless
3056 -- of optimization level. This is space-efficient, and prevent linking
3057 -- problems when units are compiled with different optimizations.
3059 Opnd_Typ
: Entity_Id
;
3066 -- Start of processing for Expand_Concatenate
3069 -- Choose an appropriate computational type
3071 -- We will be doing calculations of lengths and bounds in this routine
3072 -- and computing one from the other in some cases, e.g. getting the high
3073 -- bound by adding the length-1 to the low bound.
3075 -- We can't just use the index type, or even its base type for this
3076 -- purpose for two reasons. First it might be an enumeration type which
3077 -- is not suitable for computations of any kind, and second it may
3078 -- simply not have enough range. For example if the index type is
3079 -- -128..+127 then lengths can be up to 256, which is out of range of
3082 -- For enumeration types, we can simply use Standard_Integer, this is
3083 -- sufficient since the actual number of enumeration literals cannot
3084 -- possibly exceed the range of integer (remember we will be doing the
3085 -- arithmetic with POS values, not representation values).
3087 if Is_Enumeration_Type
(Ityp
) then
3088 Artyp
:= Standard_Integer
;
3090 -- If index type is Positive, we use the standard unsigned type, to give
3091 -- more room on the top of the range, obviating the need for an overflow
3092 -- check when creating the upper bound. This is needed to avoid junk
3093 -- overflow checks in the common case of String types.
3095 -- ??? Disabled for now
3097 -- elsif Istyp = Standard_Positive then
3098 -- Artyp := Standard_Unsigned;
3100 -- For modular types, we use a 32-bit modular type for types whose size
3101 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3102 -- identity type, and for larger unsigned types we use 64-bits.
3104 elsif Is_Modular_Integer_Type
(Ityp
) then
3105 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
3106 Artyp
:= Standard_Unsigned
;
3107 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
3110 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
3113 -- Similar treatment for signed types
3116 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
3117 Artyp
:= Standard_Integer
;
3118 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
3121 Artyp
:= Standard_Long_Long_Integer
;
3125 -- Supply dummy entry at start of length array
3127 Aggr_Length
(0) := Make_Artyp_Literal
(0);
3129 -- Go through operands setting up the above arrays
3133 Opnd
:= Remove_Head
(Opnds
);
3134 Opnd_Typ
:= Etype
(Opnd
);
3136 -- The parent got messed up when we put the operands in a list,
3137 -- so now put back the proper parent for the saved operand, that
3138 -- is to say the concatenation node, to make sure that each operand
3139 -- is seen as a subexpression, e.g. if actions must be inserted.
3141 Set_Parent
(Opnd
, Cnode
);
3143 -- Set will be True when we have setup one entry in the array
3147 -- Singleton element (or character literal) case
3149 if Base_Type
(Opnd_Typ
) = Ctyp
then
3151 Operands
(NN
) := Opnd
;
3152 Is_Fixed_Length
(NN
) := True;
3153 Fixed_Length
(NN
) := Uint_1
;
3154 Result_May_Be_Null
:= False;
3156 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3157 -- since we know that the result cannot be null).
3159 Opnd_Low_Bound
(NN
) :=
3160 Make_Attribute_Reference
(Loc
,
3161 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
3162 Attribute_Name
=> Name_First
);
3166 -- String literal case (can only occur for strings of course)
3168 elsif Nkind
(Opnd
) = N_String_Literal
then
3169 Len
:= String_Literal_Length
(Opnd_Typ
);
3172 Result_May_Be_Null
:= False;
3175 -- Capture last operand low and high bound if result could be null
3177 if J
= N
and then Result_May_Be_Null
then
3178 Last_Opnd_Low_Bound
:=
3179 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3181 Last_Opnd_High_Bound
:=
3182 Make_Op_Subtract
(Loc
,
3184 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3185 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3188 -- Skip null string literal
3190 if J
< N
and then Len
= 0 then
3195 Operands
(NN
) := Opnd
;
3196 Is_Fixed_Length
(NN
) := True;
3198 -- Set length and bounds
3200 Fixed_Length
(NN
) := Len
;
3202 Opnd_Low_Bound
(NN
) :=
3203 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3210 -- Check constrained case with known bounds
3212 if Is_Constrained
(Opnd_Typ
) then
3214 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3215 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3216 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3217 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3220 -- Fixed length constrained array type with known at compile
3221 -- time bounds is last case of fixed length operand.
3223 if Compile_Time_Known_Value
(Lo
)
3225 Compile_Time_Known_Value
(Hi
)
3228 Loval
: constant Uint
:= Expr_Value
(Lo
);
3229 Hival
: constant Uint
:= Expr_Value
(Hi
);
3230 Len
: constant Uint
:=
3231 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3235 Result_May_Be_Null
:= False;
3238 -- Capture last operand bounds if result could be null
3240 if J
= N
and then Result_May_Be_Null
then
3241 Last_Opnd_Low_Bound
:=
3243 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3245 Last_Opnd_High_Bound
:=
3247 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3250 -- Exclude null length case unless last operand
3252 if J
< N
and then Len
= 0 then
3257 Operands
(NN
) := Opnd
;
3258 Is_Fixed_Length
(NN
) := True;
3259 Fixed_Length
(NN
) := Len
;
3261 Opnd_Low_Bound
(NN
) :=
3263 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3270 -- All cases where the length is not known at compile time, or the
3271 -- special case of an operand which is known to be null but has a
3272 -- lower bound other than 1 or is other than a string type.
3277 -- Capture operand bounds
3279 Opnd_Low_Bound
(NN
) :=
3280 Make_Attribute_Reference
(Loc
,
3282 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3283 Attribute_Name
=> Name_First
);
3285 -- Capture last operand bounds if result could be null
3287 if J
= N
and Result_May_Be_Null
then
3288 Last_Opnd_Low_Bound
:=
3290 Make_Attribute_Reference
(Loc
,
3292 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3293 Attribute_Name
=> Name_First
));
3295 Last_Opnd_High_Bound
:=
3297 Make_Attribute_Reference
(Loc
,
3299 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3300 Attribute_Name
=> Name_Last
));
3303 -- Capture length of operand in entity
3305 Operands
(NN
) := Opnd
;
3306 Is_Fixed_Length
(NN
) := False;
3308 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3311 Make_Object_Declaration
(Loc
,
3312 Defining_Identifier
=> Var_Length
(NN
),
3313 Constant_Present
=> True,
3314 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3316 Make_Attribute_Reference
(Loc
,
3318 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3319 Attribute_Name
=> Name_Length
)));
3323 -- Set next entry in aggregate length array
3325 -- For first entry, make either integer literal for fixed length
3326 -- or a reference to the saved length for variable length.
3329 if Is_Fixed_Length
(1) then
3330 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3332 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
3335 -- If entry is fixed length and only fixed lengths so far, make
3336 -- appropriate new integer literal adding new length.
3338 elsif Is_Fixed_Length
(NN
)
3339 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3342 Make_Integer_Literal
(Loc
,
3343 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3345 -- All other cases, construct an addition node for the length and
3346 -- create an entity initialized to this length.
3349 Ent
:= Make_Temporary
(Loc
, 'L');
3351 if Is_Fixed_Length
(NN
) then
3352 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3354 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3358 Make_Object_Declaration
(Loc
,
3359 Defining_Identifier
=> Ent
,
3360 Constant_Present
=> True,
3361 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3364 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
3365 Right_Opnd
=> Clen
)));
3367 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3374 -- If we have only skipped null operands, return the last operand
3381 -- If we have only one non-null operand, return it and we are done.
3382 -- There is one case in which this cannot be done, and that is when
3383 -- the sole operand is of the element type, in which case it must be
3384 -- converted to an array, and the easiest way of doing that is to go
3385 -- through the normal general circuit.
3387 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3388 Result
:= Operands
(1);
3392 -- Cases where we have a real concatenation
3394 -- Next step is to find the low bound for the result array that we
3395 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3397 -- If the ultimate ancestor of the index subtype is a constrained array
3398 -- definition, then the lower bound is that of the index subtype as
3399 -- specified by (RM 4.5.3(6)).
3401 -- The right test here is to go to the root type, and then the ultimate
3402 -- ancestor is the first subtype of this root type.
3404 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3406 Make_Attribute_Reference
(Loc
,
3408 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3409 Attribute_Name
=> Name_First
);
3411 -- If the first operand in the list has known length we know that
3412 -- the lower bound of the result is the lower bound of this operand.
3414 elsif Is_Fixed_Length
(1) then
3415 Low_Bound
:= Opnd_Low_Bound
(1);
3417 -- OK, we don't know the lower bound, we have to build a horrible
3418 -- if expression node of the form
3420 -- if Cond1'Length /= 0 then
3423 -- if Opnd2'Length /= 0 then
3428 -- The nesting ends either when we hit an operand whose length is known
3429 -- at compile time, or on reaching the last operand, whose low bound we
3430 -- take unconditionally whether or not it is null. It's easiest to do
3431 -- this with a recursive procedure:
3435 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3436 -- Returns the lower bound determined by operands J .. NN
3438 ---------------------
3439 -- Get_Known_Bound --
3440 ---------------------
3442 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3444 if Is_Fixed_Length
(J
) or else J
= NN
then
3445 return New_Copy
(Opnd_Low_Bound
(J
));
3449 Make_If_Expression
(Loc
,
3450 Expressions
=> New_List
(
3454 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3456 Make_Integer_Literal
(Loc
, 0)),
3458 New_Copy
(Opnd_Low_Bound
(J
)),
3459 Get_Known_Bound
(J
+ 1)));
3461 end Get_Known_Bound
;
3464 Ent
:= Make_Temporary
(Loc
, 'L');
3467 Make_Object_Declaration
(Loc
,
3468 Defining_Identifier
=> Ent
,
3469 Constant_Present
=> True,
3470 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3471 Expression
=> Get_Known_Bound
(1)));
3473 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3477 -- Now we can safely compute the upper bound, normally
3478 -- Low_Bound + Length - 1.
3483 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3485 Make_Op_Subtract
(Loc
,
3486 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3487 Right_Opnd
=> Make_Artyp_Literal
(1))));
3489 -- Note that calculation of the high bound may cause overflow in some
3490 -- very weird cases, so in the general case we need an overflow check on
3491 -- the high bound. We can avoid this for the common case of string types
3492 -- and other types whose index is Positive, since we chose a wider range
3493 -- for the arithmetic type.
3495 if Istyp
/= Standard_Positive
then
3496 Activate_Overflow_Check
(High_Bound
);
3499 -- Handle the exceptional case where the result is null, in which case
3500 -- case the bounds come from the last operand (so that we get the proper
3501 -- bounds if the last operand is super-flat).
3503 if Result_May_Be_Null
then
3505 Make_If_Expression
(Loc
,
3506 Expressions
=> New_List
(
3508 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3509 Right_Opnd
=> Make_Artyp_Literal
(0)),
3510 Last_Opnd_Low_Bound
,
3514 Make_If_Expression
(Loc
,
3515 Expressions
=> New_List
(
3517 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3518 Right_Opnd
=> Make_Artyp_Literal
(0)),
3519 Last_Opnd_High_Bound
,
3523 -- Here is where we insert the saved up actions
3525 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3527 -- Now we construct an array object with appropriate bounds. We mark
3528 -- the target as internal to prevent useless initialization when
3529 -- Initialize_Scalars is enabled. Also since this is the actual result
3530 -- entity, we make sure we have debug information for the result.
3532 Ent
:= Make_Temporary
(Loc
, 'S');
3533 Set_Is_Internal
(Ent
);
3534 Set_Needs_Debug_Info
(Ent
);
3536 -- If the bound is statically known to be out of range, we do not want
3537 -- to abort, we want a warning and a runtime constraint error. Note that
3538 -- we have arranged that the result will not be treated as a static
3539 -- constant, so we won't get an illegality during this insertion.
3541 Insert_Action
(Cnode
,
3542 Make_Object_Declaration
(Loc
,
3543 Defining_Identifier
=> Ent
,
3544 Object_Definition
=>
3545 Make_Subtype_Indication
(Loc
,
3546 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3548 Make_Index_Or_Discriminant_Constraint
(Loc
,
3549 Constraints
=> New_List
(
3551 Low_Bound
=> Low_Bound
,
3552 High_Bound
=> High_Bound
))))),
3553 Suppress
=> All_Checks
);
3555 -- If the result of the concatenation appears as the initializing
3556 -- expression of an object declaration, we can just rename the
3557 -- result, rather than copying it.
3559 Set_OK_To_Rename
(Ent
);
3561 -- Catch the static out of range case now
3563 if Raises_Constraint_Error
(High_Bound
) then
3564 raise Concatenation_Error
;
3567 -- Now we will generate the assignments to do the actual concatenation
3569 -- There is one case in which we will not do this, namely when all the
3570 -- following conditions are met:
3572 -- The result type is Standard.String
3574 -- There are nine or fewer retained (non-null) operands
3576 -- The optimization level is -O0
3578 -- The corresponding System.Concat_n.Str_Concat_n routine is
3579 -- available in the run time.
3581 -- The debug flag gnatd.c is not set
3583 -- If all these conditions are met then we generate a call to the
3584 -- relevant concatenation routine. The purpose of this is to avoid
3585 -- undesirable code bloat at -O0.
3587 if Atyp
= Standard_String
3588 and then NN
in 2 .. 9
3589 and then (Lib_Level_Target
3590 or else ((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3591 and then not Debug_Flag_Dot_C
))
3594 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3605 if RTE_Available
(RR
(NN
)) then
3607 Opnds
: constant List_Id
:=
3608 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3611 for J
in 1 .. NN
loop
3612 if Is_List_Member
(Operands
(J
)) then
3613 Remove
(Operands
(J
));
3616 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3618 Make_Aggregate
(Loc
,
3619 Component_Associations
=> New_List
(
3620 Make_Component_Association
(Loc
,
3621 Choices
=> New_List
(
3622 Make_Integer_Literal
(Loc
, 1)),
3623 Expression
=> Operands
(J
)))));
3626 Append_To
(Opnds
, Operands
(J
));
3630 Insert_Action
(Cnode
,
3631 Make_Procedure_Call_Statement
(Loc
,
3632 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3633 Parameter_Associations
=> Opnds
));
3635 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3642 -- Not special case so generate the assignments
3644 Known_Non_Null_Operand_Seen
:= False;
3646 for J
in 1 .. NN
loop
3648 Lo
: constant Node_Id
:=
3650 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3651 Right_Opnd
=> Aggr_Length
(J
- 1));
3653 Hi
: constant Node_Id
:=
3655 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3657 Make_Op_Subtract
(Loc
,
3658 Left_Opnd
=> Aggr_Length
(J
),
3659 Right_Opnd
=> Make_Artyp_Literal
(1)));
3662 -- Singleton case, simple assignment
3664 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3665 Known_Non_Null_Operand_Seen
:= True;
3666 Insert_Action
(Cnode
,
3667 Make_Assignment_Statement
(Loc
,
3669 Make_Indexed_Component
(Loc
,
3670 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3671 Expressions
=> New_List
(To_Ityp
(Lo
))),
3672 Expression
=> Operands
(J
)),
3673 Suppress
=> All_Checks
);
3675 -- Array case, slice assignment, skipped when argument is fixed
3676 -- length and known to be null.
3678 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3681 Make_Assignment_Statement
(Loc
,
3685 New_Occurrence_Of
(Ent
, Loc
),
3688 Low_Bound
=> To_Ityp
(Lo
),
3689 High_Bound
=> To_Ityp
(Hi
))),
3690 Expression
=> Operands
(J
));
3692 if Is_Fixed_Length
(J
) then
3693 Known_Non_Null_Operand_Seen
:= True;
3695 elsif not Known_Non_Null_Operand_Seen
then
3697 -- Here if operand length is not statically known and no
3698 -- operand known to be non-null has been processed yet.
3699 -- If operand length is 0, we do not need to perform the
3700 -- assignment, and we must avoid the evaluation of the
3701 -- high bound of the slice, since it may underflow if the
3702 -- low bound is Ityp'First.
3705 Make_Implicit_If_Statement
(Cnode
,
3709 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3710 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3711 Then_Statements
=> New_List
(Assign
));
3714 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3720 -- Finally we build the result, which is a reference to the array object
3722 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3725 Rewrite
(Cnode
, Result
);
3726 Analyze_And_Resolve
(Cnode
, Atyp
);
3729 when Concatenation_Error
=>
3731 -- Kill warning generated for the declaration of the static out of
3732 -- range high bound, and instead generate a Constraint_Error with
3733 -- an appropriate specific message.
3735 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3736 Apply_Compile_Time_Constraint_Error
3738 Msg
=> "concatenation result upper bound out of range??",
3739 Reason
=> CE_Range_Check_Failed
);
3740 end Expand_Concatenate
;
3742 ---------------------------------------------------
3743 -- Expand_Membership_Minimize_Eliminate_Overflow --
3744 ---------------------------------------------------
3746 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3747 pragma Assert
(Nkind
(N
) = N_In
);
3748 -- Despite the name, this routine applies only to N_In, not to
3749 -- N_Not_In. The latter is always rewritten as not (X in Y).
3751 Result_Type
: constant Entity_Id
:= Etype
(N
);
3752 -- Capture result type, may be a derived boolean type
3754 Loc
: constant Source_Ptr
:= Sloc
(N
);
3755 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3756 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3758 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3759 -- is thus tempting to capture these values, but due to the rewrites
3760 -- that occur as a result of overflow checking, these values change
3761 -- as we go along, and it is safe just to always use Etype explicitly.
3763 Restype
: constant Entity_Id
:= Etype
(N
);
3767 -- Bounds in Minimize calls, not used currently
3769 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3770 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3773 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3775 -- If right operand is a subtype name, and the subtype name has no
3776 -- predicate, then we can just replace the right operand with an
3777 -- explicit range T'First .. T'Last, and use the explicit range code.
3779 if Nkind
(Rop
) /= N_Range
3780 and then No
(Predicate_Function
(Etype
(Rop
)))
3783 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3788 Make_Attribute_Reference
(Loc
,
3789 Attribute_Name
=> Name_First
,
3790 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3792 Make_Attribute_Reference
(Loc
,
3793 Attribute_Name
=> Name_Last
,
3794 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3795 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3799 -- Here for the explicit range case. Note that the bounds of the range
3800 -- have not been processed for minimized or eliminated checks.
3802 if Nkind
(Rop
) = N_Range
then
3803 Minimize_Eliminate_Overflows
3804 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3805 Minimize_Eliminate_Overflows
3806 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3808 -- We have A in B .. C, treated as A >= B and then A <= C
3812 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3813 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3814 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3817 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3818 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3819 L
: constant Entity_Id
:=
3820 Make_Defining_Identifier
(Loc
, Name_uL
);
3821 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3822 Lbound
: constant Node_Id
:=
3823 Convert_To_Bignum
(Low_Bound
(Rop
));
3824 Hbound
: constant Node_Id
:=
3825 Convert_To_Bignum
(High_Bound
(Rop
));
3827 -- Now we rewrite the membership test node to look like
3830 -- Bnn : Result_Type;
3832 -- M : Mark_Id := SS_Mark;
3833 -- L : Bignum := Lopnd;
3835 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3843 -- Insert declaration of L into declarations of bignum block
3846 (Last
(Declarations
(Blk
)),
3847 Make_Object_Declaration
(Loc
,
3848 Defining_Identifier
=> L
,
3849 Object_Definition
=>
3850 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3851 Expression
=> Lopnd
));
3853 -- Insert assignment to Bnn into expressions of bignum block
3856 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3857 Make_Assignment_Statement
(Loc
,
3858 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3862 Make_Function_Call
(Loc
,
3864 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3865 Parameter_Associations
=> New_List
(
3866 New_Occurrence_Of
(L
, Loc
),
3870 Make_Function_Call
(Loc
,
3872 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3873 Parameter_Associations
=> New_List
(
3874 New_Occurrence_Of
(L
, Loc
),
3877 -- Now rewrite the node
3880 Make_Expression_With_Actions
(Loc
,
3881 Actions
=> New_List
(
3882 Make_Object_Declaration
(Loc
,
3883 Defining_Identifier
=> Bnn
,
3884 Object_Definition
=>
3885 New_Occurrence_Of
(Result_Type
, Loc
)),
3887 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3888 Analyze_And_Resolve
(N
, Result_Type
);
3892 -- Here if no bignums around
3895 -- Case where types are all the same
3897 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3899 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3903 -- If types are not all the same, it means that we have rewritten
3904 -- at least one of them to be of type Long_Long_Integer, and we
3905 -- will convert the other operands to Long_Long_Integer.
3908 Convert_To_And_Rewrite
(LLIB
, Lop
);
3909 Set_Analyzed
(Lop
, False);
3910 Analyze_And_Resolve
(Lop
, LLIB
);
3912 -- For the right operand, avoid unnecessary recursion into
3913 -- this routine, we know that overflow is not possible.
3915 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3916 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3917 Set_Analyzed
(Rop
, False);
3918 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3921 -- Now the three operands are of the same signed integer type,
3922 -- so we can use the normal expansion routine for membership,
3923 -- setting the flag to prevent recursion into this procedure.
3925 Set_No_Minimize_Eliminate
(N
);
3929 -- Right operand is a subtype name and the subtype has a predicate. We
3930 -- have to make sure the predicate is checked, and for that we need to
3931 -- use the standard N_In circuitry with appropriate types.
3934 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3936 -- If types are "right", just call Expand_N_In preventing recursion
3938 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3939 Set_No_Minimize_Eliminate
(N
);
3944 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3946 -- For X in T, we want to rewrite our node as
3949 -- Bnn : Result_Type;
3952 -- M : Mark_Id := SS_Mark;
3953 -- Lnn : Long_Long_Integer'Base
3959 -- if not Bignum_In_LLI_Range (Nnn) then
3962 -- Lnn := From_Bignum (Nnn);
3964 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3965 -- and then T'Base (Lnn) in T;
3974 -- A bit gruesome, but there doesn't seem to be a simpler way
3977 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3978 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3979 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3980 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3981 T
: constant Entity_Id
:= Etype
(Rop
);
3982 TB
: constant Entity_Id
:= Base_Type
(T
);
3986 -- Mark the last membership operation to prevent recursion
3990 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3991 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3992 Set_No_Minimize_Eliminate
(Nin
);
3994 -- Now decorate the block
3997 (Last
(Declarations
(Blk
)),
3998 Make_Object_Declaration
(Loc
,
3999 Defining_Identifier
=> Lnn
,
4000 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
4003 (Last
(Declarations
(Blk
)),
4004 Make_Object_Declaration
(Loc
,
4005 Defining_Identifier
=> Nnn
,
4006 Object_Definition
=>
4007 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
4010 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
4012 Make_Assignment_Statement
(Loc
,
4013 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
4014 Expression
=> Relocate_Node
(Lop
)),
4016 Make_Implicit_If_Statement
(N
,
4020 Make_Function_Call
(Loc
,
4023 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
4024 Parameter_Associations
=> New_List
(
4025 New_Occurrence_Of
(Nnn
, Loc
)))),
4027 Then_Statements
=> New_List
(
4028 Make_Assignment_Statement
(Loc
,
4029 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4031 New_Occurrence_Of
(Standard_False
, Loc
))),
4033 Else_Statements
=> New_List
(
4034 Make_Assignment_Statement
(Loc
,
4035 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4037 Make_Function_Call
(Loc
,
4039 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4040 Parameter_Associations
=> New_List
(
4041 New_Occurrence_Of
(Nnn
, Loc
)))),
4043 Make_Assignment_Statement
(Loc
,
4044 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4049 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4054 Make_Attribute_Reference
(Loc
,
4055 Attribute_Name
=> Name_First
,
4057 New_Occurrence_Of
(TB
, Loc
))),
4061 Make_Attribute_Reference
(Loc
,
4062 Attribute_Name
=> Name_Last
,
4064 New_Occurrence_Of
(TB
, Loc
))))),
4066 Right_Opnd
=> Nin
))))));
4068 -- Now we can do the rewrite
4071 Make_Expression_With_Actions
(Loc
,
4072 Actions
=> New_List
(
4073 Make_Object_Declaration
(Loc
,
4074 Defining_Identifier
=> Bnn
,
4075 Object_Definition
=>
4076 New_Occurrence_Of
(Result_Type
, Loc
)),
4078 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
4079 Analyze_And_Resolve
(N
, Result_Type
);
4083 -- Not bignum case, but types don't match (this means we rewrote the
4084 -- left operand to be Long_Long_Integer).
4087 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
4089 -- We rewrite the membership test as (where T is the type with
4090 -- the predicate, i.e. the type of the right operand)
4092 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4093 -- and then T'Base (Lop) in T
4096 T
: constant Entity_Id
:= Etype
(Rop
);
4097 TB
: constant Entity_Id
:= Base_Type
(T
);
4101 -- The last membership test is marked to prevent recursion
4105 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
4106 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4107 Set_No_Minimize_Eliminate
(Nin
);
4109 -- Now do the rewrite
4120 Make_Attribute_Reference
(Loc
,
4121 Attribute_Name
=> Name_First
,
4123 New_Occurrence_Of
(TB
, Loc
))),
4126 Make_Attribute_Reference
(Loc
,
4127 Attribute_Name
=> Name_Last
,
4129 New_Occurrence_Of
(TB
, Loc
))))),
4130 Right_Opnd
=> Nin
));
4131 Set_Analyzed
(N
, False);
4132 Analyze_And_Resolve
(N
, Restype
);
4136 end Expand_Membership_Minimize_Eliminate_Overflow
;
4138 ------------------------
4139 -- Expand_N_Allocator --
4140 ------------------------
4142 procedure Expand_N_Allocator
(N
: Node_Id
) is
4143 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4144 Loc
: constant Source_Ptr
:= Sloc
(N
);
4145 PtrT
: constant Entity_Id
:= Etype
(N
);
4147 procedure Rewrite_Coextension
(N
: Node_Id
);
4148 -- Static coextensions have the same lifetime as the entity they
4149 -- constrain. Such occurrences can be rewritten as aliased objects
4150 -- and their unrestricted access used instead of the coextension.
4152 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4153 -- Given a constrained array type E, returns a node representing the
4154 -- code to compute the size in storage elements for the given type.
4155 -- This is done without using the attribute (which malfunctions for
4158 -------------------------
4159 -- Rewrite_Coextension --
4160 -------------------------
4162 procedure Rewrite_Coextension
(N
: Node_Id
) is
4163 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4164 Temp_Decl
: Node_Id
;
4168 -- Cnn : aliased Etyp;
4171 Make_Object_Declaration
(Loc
,
4172 Defining_Identifier
=> Temp_Id
,
4173 Aliased_Present
=> True,
4174 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4176 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4177 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4180 Insert_Action
(N
, Temp_Decl
);
4182 Make_Attribute_Reference
(Loc
,
4183 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4184 Attribute_Name
=> Name_Unrestricted_Access
));
4186 Analyze_And_Resolve
(N
, PtrT
);
4187 end Rewrite_Coextension
;
4189 ------------------------------
4190 -- Size_In_Storage_Elements --
4191 ------------------------------
4193 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4195 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4196 -- However, the reason for the existence of this function is
4197 -- to construct a test for sizes too large, which means near the
4198 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4199 -- is that we get overflows when sizes are greater than 2**31.
4201 -- So what we end up doing for array types is to use the expression:
4203 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4205 -- which avoids this problem. All this is a bit bogus, but it does
4206 -- mean we catch common cases of trying to allocate arrays that
4207 -- are too large, and which in the absence of a check results in
4208 -- undetected chaos ???
4210 -- Note in particular that this is a pessimistic estimate in the
4211 -- case of packed array types, where an array element might occupy
4212 -- just a fraction of a storage element???
4219 for J
in 1 .. Number_Dimensions
(E
) loop
4221 Make_Attribute_Reference
(Loc
,
4222 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4223 Attribute_Name
=> Name_Length
,
4224 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4231 Make_Op_Multiply
(Loc
,
4238 Make_Op_Multiply
(Loc
,
4241 Make_Attribute_Reference
(Loc
,
4242 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4243 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4245 end Size_In_Storage_Elements
;
4249 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4253 Rel_Typ
: Entity_Id
;
4256 -- Start of processing for Expand_N_Allocator
4259 -- RM E.2.3(22). We enforce that the expected type of an allocator
4260 -- shall not be a remote access-to-class-wide-limited-private type
4262 -- Why is this being done at expansion time, seems clearly wrong ???
4264 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4266 -- Processing for anonymous access-to-controlled types. These access
4267 -- types receive a special finalization master which appears in the
4268 -- declarations of the enclosing semantic unit. This expansion is done
4269 -- now to ensure that any additional types generated by this routine or
4270 -- Expand_Allocator_Expression inherit the proper type attributes.
4272 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4273 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4274 and then Needs_Finalization
(Dtyp
)
4276 -- Detect the allocation of an anonymous controlled object where the
4277 -- type of the context is named. For example:
4279 -- procedure Proc (Ptr : Named_Access_Typ);
4280 -- Proc (new Designated_Typ);
4282 -- Regardless of the anonymous-to-named access type conversion, the
4283 -- lifetime of the object must be associated with the named access
4284 -- type. Use the finalization-related attributes of this type.
4286 if Nkind_In
(Parent
(N
), N_Type_Conversion
,
4287 N_Unchecked_Type_Conversion
)
4288 and then Ekind_In
(Etype
(Parent
(N
)), E_Access_Subtype
,
4290 E_General_Access_Type
)
4292 Rel_Typ
:= Etype
(Parent
(N
));
4297 -- Anonymous access-to-controlled types allocate on the global pool.
4298 -- Do not set this attribute on .NET/JVM since those targets do not
4299 -- support pools. Note that this is a "root type only" attribute.
4301 if No
(Associated_Storage_Pool
(PtrT
)) and then VM_Target
= No_VM
then
4302 if Present
(Rel_Typ
) then
4303 Set_Associated_Storage_Pool
4304 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4306 Set_Associated_Storage_Pool
4307 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4311 -- The finalization master must be inserted and analyzed as part of
4312 -- the current semantic unit. Note that the master is updated when
4313 -- analysis changes current units. Note that this is a "root type
4316 if Present
(Rel_Typ
) then
4317 Set_Finalization_Master
4318 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4320 Set_Finalization_Master
4321 (Root_Type
(PtrT
), Current_Anonymous_Master
);
4325 -- Set the storage pool and find the appropriate version of Allocate to
4326 -- call. Do not overwrite the storage pool if it is already set, which
4327 -- can happen for build-in-place function returns (see
4328 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4330 if No
(Storage_Pool
(N
)) then
4331 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4333 if Present
(Pool
) then
4334 Set_Storage_Pool
(N
, Pool
);
4336 if Is_RTE
(Pool
, RE_SS_Pool
) then
4337 if VM_Target
= No_VM
then
4338 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4341 -- In the case of an allocator for a simple storage pool, locate
4342 -- and save a reference to the pool type's Allocate routine.
4344 elsif Present
(Get_Rep_Pragma
4345 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4348 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4349 Alloc_Op
: Entity_Id
;
4351 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4352 while Present
(Alloc_Op
) loop
4353 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4354 and then Present
(First_Formal
(Alloc_Op
))
4355 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4357 Set_Procedure_To_Call
(N
, Alloc_Op
);
4360 Alloc_Op
:= Homonym
(Alloc_Op
);
4365 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4366 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4369 Set_Procedure_To_Call
(N
,
4370 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4375 -- Under certain circumstances we can replace an allocator by an access
4376 -- to statically allocated storage. The conditions, as noted in AARM
4377 -- 3.10 (10c) are as follows:
4379 -- Size and initial value is known at compile time
4380 -- Access type is access-to-constant
4382 -- The allocator is not part of a constraint on a record component,
4383 -- because in that case the inserted actions are delayed until the
4384 -- record declaration is fully analyzed, which is too late for the
4385 -- analysis of the rewritten allocator.
4387 if Is_Access_Constant
(PtrT
)
4388 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4389 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4390 and then Size_Known_At_Compile_Time
4391 (Etype
(Expression
(Expression
(N
))))
4392 and then not Is_Record_Type
(Current_Scope
)
4394 -- Here we can do the optimization. For the allocator
4398 -- We insert an object declaration
4400 -- Tnn : aliased x := y;
4402 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4403 -- marked as requiring static allocation.
4405 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4406 Desig
:= Subtype_Mark
(Expression
(N
));
4408 -- If context is constrained, use constrained subtype directly,
4409 -- so that the constant is not labelled as having a nominally
4410 -- unconstrained subtype.
4412 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4413 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4417 Make_Object_Declaration
(Loc
,
4418 Defining_Identifier
=> Temp
,
4419 Aliased_Present
=> True,
4420 Constant_Present
=> Is_Access_Constant
(PtrT
),
4421 Object_Definition
=> Desig
,
4422 Expression
=> Expression
(Expression
(N
))));
4425 Make_Attribute_Reference
(Loc
,
4426 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4427 Attribute_Name
=> Name_Unrestricted_Access
));
4429 Analyze_And_Resolve
(N
, PtrT
);
4431 -- We set the variable as statically allocated, since we don't want
4432 -- it going on the stack of the current procedure.
4434 Set_Is_Statically_Allocated
(Temp
);
4438 -- Same if the allocator is an access discriminant for a local object:
4439 -- instead of an allocator we create a local value and constrain the
4440 -- enclosing object with the corresponding access attribute.
4442 if Is_Static_Coextension
(N
) then
4443 Rewrite_Coextension
(N
);
4447 -- Check for size too large, we do this because the back end misses
4448 -- proper checks here and can generate rubbish allocation calls when
4449 -- we are near the limit. We only do this for the 32-bit address case
4450 -- since that is from a practical point of view where we see a problem.
4452 if System_Address_Size
= 32
4453 and then not Storage_Checks_Suppressed
(PtrT
)
4454 and then not Storage_Checks_Suppressed
(Dtyp
)
4455 and then not Storage_Checks_Suppressed
(Etyp
)
4457 -- The check we want to generate should look like
4459 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4460 -- raise Storage_Error;
4463 -- where 3.5 gigabytes is a constant large enough to accommodate any
4464 -- reasonable request for. But we can't do it this way because at
4465 -- least at the moment we don't compute this attribute right, and
4466 -- can silently give wrong results when the result gets large. Since
4467 -- this is all about large results, that's bad, so instead we only
4468 -- apply the check for constrained arrays, and manually compute the
4469 -- value of the attribute ???
4471 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4473 Make_Raise_Storage_Error
(Loc
,
4476 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4478 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4479 Reason
=> SE_Object_Too_Large
));
4483 -- If no storage pool has been specified and we have the restriction
4484 -- No_Standard_Allocators_After_Elaboration is present, then generate
4485 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4487 if Nkind
(N
) = N_Allocator
4488 and then No
(Storage_Pool
(N
))
4489 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4492 Make_Procedure_Call_Statement
(Loc
,
4494 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4497 -- Handle case of qualified expression (other than optimization above)
4498 -- First apply constraint checks, because the bounds or discriminants
4499 -- in the aggregate might not match the subtype mark in the allocator.
4501 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4502 Apply_Constraint_Check
4503 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
4505 Expand_Allocator_Expression
(N
);
4509 -- If the allocator is for a type which requires initialization, and
4510 -- there is no initial value (i.e. operand is a subtype indication
4511 -- rather than a qualified expression), then we must generate a call to
4512 -- the initialization routine using an expressions action node:
4514 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4516 -- Here ptr_T is the pointer type for the allocator, and T is the
4517 -- subtype of the allocator. A special case arises if the designated
4518 -- type of the access type is a task or contains tasks. In this case
4519 -- the call to Init (Temp.all ...) is replaced by code that ensures
4520 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4521 -- for details). In addition, if the type T is a task type, then the
4522 -- first argument to Init must be converted to the task record type.
4525 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4531 Init_Arg1
: Node_Id
;
4532 Temp_Decl
: Node_Id
;
4533 Temp_Type
: Entity_Id
;
4536 if No_Initialization
(N
) then
4538 -- Even though this might be a simple allocation, create a custom
4539 -- Allocate if the context requires it. Since .NET/JVM compilers
4540 -- do not support pools, this step is skipped.
4542 if VM_Target
= No_VM
4543 and then Present
(Finalization_Master
(PtrT
))
4545 Build_Allocate_Deallocate_Proc
4547 Is_Allocate
=> True);
4550 -- Case of no initialization procedure present
4552 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4554 -- Case of simple initialization required
4556 if Needs_Simple_Initialization
(T
) then
4557 Check_Restriction
(No_Default_Initialization
, N
);
4558 Rewrite
(Expression
(N
),
4559 Make_Qualified_Expression
(Loc
,
4560 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4561 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4563 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4564 Analyze_And_Resolve
(Expression
(N
), T
);
4565 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4566 Expand_N_Allocator
(N
);
4568 -- No initialization required
4574 -- Case of initialization procedure present, must be called
4577 Check_Restriction
(No_Default_Initialization
, N
);
4579 if not Restriction_Active
(No_Default_Initialization
) then
4580 Init
:= Base_Init_Proc
(T
);
4582 Temp
:= Make_Temporary
(Loc
, 'P');
4584 -- Construct argument list for the initialization routine call
4587 Make_Explicit_Dereference
(Loc
,
4589 New_Occurrence_Of
(Temp
, Loc
));
4591 Set_Assignment_OK
(Init_Arg1
);
4594 -- The initialization procedure expects a specific type. if the
4595 -- context is access to class wide, indicate that the object
4596 -- being allocated has the right specific type.
4598 if Is_Class_Wide_Type
(Dtyp
) then
4599 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4602 -- If designated type is a concurrent type or if it is private
4603 -- type whose definition is a concurrent type, the first
4604 -- argument in the Init routine has to be unchecked conversion
4605 -- to the corresponding record type. If the designated type is
4606 -- a derived type, also convert the argument to its root type.
4608 if Is_Concurrent_Type
(T
) then
4610 Unchecked_Convert_To
(
4611 Corresponding_Record_Type
(T
), Init_Arg1
);
4613 elsif Is_Private_Type
(T
)
4614 and then Present
(Full_View
(T
))
4615 and then Is_Concurrent_Type
(Full_View
(T
))
4618 Unchecked_Convert_To
4619 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4621 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4623 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4626 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4627 Set_Etype
(Init_Arg1
, Ftyp
);
4631 Args
:= New_List
(Init_Arg1
);
4633 -- For the task case, pass the Master_Id of the access type as
4634 -- the value of the _Master parameter, and _Chain as the value
4635 -- of the _Chain parameter (_Chain will be defined as part of
4636 -- the generated code for the allocator).
4638 -- In Ada 2005, the context may be a function that returns an
4639 -- anonymous access type. In that case the Master_Id has been
4640 -- created when expanding the function declaration.
4642 if Has_Task
(T
) then
4643 if No
(Master_Id
(Base_Type
(PtrT
))) then
4645 -- The designated type was an incomplete type, and the
4646 -- access type did not get expanded. Salvage it now.
4648 if not Restriction_Active
(No_Task_Hierarchy
) then
4649 if Present
(Parent
(Base_Type
(PtrT
))) then
4650 Expand_N_Full_Type_Declaration
4651 (Parent
(Base_Type
(PtrT
)));
4653 -- The only other possibility is an itype. For this
4654 -- case, the master must exist in the context. This is
4655 -- the case when the allocator initializes an access
4656 -- component in an init-proc.
4659 pragma Assert
(Is_Itype
(PtrT
));
4660 Build_Master_Renaming
(PtrT
, N
);
4665 -- If the context of the allocator is a declaration or an
4666 -- assignment, we can generate a meaningful image for it,
4667 -- even though subsequent assignments might remove the
4668 -- connection between task and entity. We build this image
4669 -- when the left-hand side is a simple variable, a simple
4670 -- indexed assignment or a simple selected component.
4672 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4674 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4677 if Is_Entity_Name
(Nam
) then
4679 Build_Task_Image_Decls
4682 (Entity
(Nam
), Sloc
(Nam
)), T
);
4684 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4685 N_Selected_Component
)
4686 and then Is_Entity_Name
(Prefix
(Nam
))
4689 Build_Task_Image_Decls
4690 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4692 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4696 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4698 Build_Task_Image_Decls
4699 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4702 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4705 if Restriction_Active
(No_Task_Hierarchy
) then
4707 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4711 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4714 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4716 Decl
:= Last
(Decls
);
4718 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4720 -- Has_Task is false, Decls not used
4726 -- Add discriminants if discriminated type
4729 Dis
: Boolean := False;
4733 if Has_Discriminants
(T
) then
4737 elsif Is_Private_Type
(T
)
4738 and then Present
(Full_View
(T
))
4739 and then Has_Discriminants
(Full_View
(T
))
4742 Typ
:= Full_View
(T
);
4747 -- If the allocated object will be constrained by the
4748 -- default values for discriminants, then build a subtype
4749 -- with those defaults, and change the allocated subtype
4750 -- to that. Note that this happens in fewer cases in Ada
4753 if not Is_Constrained
(Typ
)
4754 and then Present
(Discriminant_Default_Value
4755 (First_Discriminant
(Typ
)))
4756 and then (Ada_Version
< Ada_2005
4758 Object_Type_Has_Constrained_Partial_View
4759 (Typ
, Current_Scope
))
4761 Typ
:= Build_Default_Subtype
(Typ
, N
);
4762 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
4765 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4766 while Present
(Discr
) loop
4767 Nod
:= Node
(Discr
);
4768 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4770 -- AI-416: when the discriminant constraint is an
4771 -- anonymous access type make sure an accessibility
4772 -- check is inserted if necessary (3.10.2(22.q/2))
4774 if Ada_Version
>= Ada_2005
4776 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4778 Apply_Accessibility_Check
4779 (Nod
, Typ
, Insert_Node
=> Nod
);
4787 -- We set the allocator as analyzed so that when we analyze
4788 -- the if expression node, we do not get an unwanted recursive
4789 -- expansion of the allocator expression.
4791 Set_Analyzed
(N
, True);
4792 Nod
:= Relocate_Node
(N
);
4794 -- Here is the transformation:
4795 -- input: new Ctrl_Typ
4796 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4797 -- Ctrl_TypIP (Temp.all, ...);
4798 -- [Deep_]Initialize (Temp.all);
4800 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4801 -- is the subtype of the allocator.
4804 Make_Object_Declaration
(Loc
,
4805 Defining_Identifier
=> Temp
,
4806 Constant_Present
=> True,
4807 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
4810 Set_Assignment_OK
(Temp_Decl
);
4811 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4813 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
4815 -- If the designated type is a task type or contains tasks,
4816 -- create block to activate created tasks, and insert
4817 -- declaration for Task_Image variable ahead of call.
4819 if Has_Task
(T
) then
4821 L
: constant List_Id
:= New_List
;
4824 Build_Task_Allocate_Block
(L
, Nod
, Args
);
4826 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
4827 Insert_Actions
(N
, L
);
4832 Make_Procedure_Call_Statement
(Loc
,
4833 Name
=> New_Occurrence_Of
(Init
, Loc
),
4834 Parameter_Associations
=> Args
));
4837 if Needs_Finalization
(T
) then
4840 -- [Deep_]Initialize (Init_Arg1);
4844 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4847 -- Special processing for .NET/JVM, the allocated object is
4848 -- attached to the finalization master. Generate:
4850 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4852 -- Types derived from [Limited_]Controlled are the only ones
4853 -- considered since they have fields Prev and Next.
4855 if VM_Target
/= No_VM
4856 and then Is_Controlled
(T
)
4857 and then Present
(Finalization_Master
(PtrT
))
4861 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4866 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4867 Analyze_And_Resolve
(N
, PtrT
);
4872 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4873 -- object that has been rewritten as a reference, we displace "this"
4874 -- to reference properly its secondary dispatch table.
4876 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
4877 Displace_Allocator_Pointer
(N
);
4881 when RE_Not_Available
=>
4883 end Expand_N_Allocator
;
4885 -----------------------
4886 -- Expand_N_And_Then --
4887 -----------------------
4889 procedure Expand_N_And_Then
(N
: Node_Id
)
4890 renames Expand_Short_Circuit_Operator
;
4892 ------------------------------
4893 -- Expand_N_Case_Expression --
4894 ------------------------------
4896 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4897 Loc
: constant Source_Ptr
:= Sloc
(N
);
4898 Typ
: constant Entity_Id
:= Etype
(N
);
4909 -- Check for MINIMIZED/ELIMINATED overflow mode
4911 if Minimized_Eliminated_Overflow_Check
(N
) then
4912 Apply_Arithmetic_Overflow_Check
(N
);
4916 -- If the case expression is a predicate specification, do not
4917 -- expand, because it will be converted to the proper predicate
4918 -- form when building the predicate function.
4920 if Ekind_In
(Current_Scope
, E_Function
, E_Procedure
)
4921 and then Is_Predicate_Function
(Current_Scope
)
4928 -- case X is when A => AX, when B => BX ...
4943 -- However, this expansion is wrong for limited types, and also
4944 -- wrong for unconstrained types (since the bounds may not be the
4945 -- same in all branches). Furthermore it involves an extra copy
4946 -- for large objects. So we take care of this by using the following
4947 -- modified expansion for non-elementary types:
4950 -- type Pnn is access all typ;
4954 -- T := AX'Unrestricted_Access;
4956 -- T := BX'Unrestricted_Access;
4962 Make_Case_Statement
(Loc
,
4963 Expression
=> Expression
(N
),
4964 Alternatives
=> New_List
);
4966 -- Preserve the original context for which the case statement is being
4967 -- generated. This is needed by the finalization machinery to prevent
4968 -- the premature finalization of controlled objects found within the
4971 Set_From_Conditional_Expression
(Cstmt
);
4973 Actions
:= New_List
;
4977 if Is_Elementary_Type
(Typ
) then
4981 Pnn
:= Make_Temporary
(Loc
, 'P');
4983 Make_Full_Type_Declaration
(Loc
,
4984 Defining_Identifier
=> Pnn
,
4986 Make_Access_To_Object_Definition
(Loc
,
4987 All_Present
=> True,
4988 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
4992 Tnn
:= Make_Temporary
(Loc
, 'T');
4994 -- Create declaration for target of expression, and indicate that it
4995 -- does not require initialization.
4998 Make_Object_Declaration
(Loc
,
4999 Defining_Identifier
=> Tnn
,
5000 Object_Definition
=> New_Occurrence_Of
(Ttyp
, Loc
));
5001 Set_No_Initialization
(Decl
);
5002 Append_To
(Actions
, Decl
);
5004 -- Now process the alternatives
5006 Alt
:= First
(Alternatives
(N
));
5007 while Present
(Alt
) loop
5009 Aexp
: Node_Id
:= Expression
(Alt
);
5010 Aloc
: constant Source_Ptr
:= Sloc
(Aexp
);
5014 -- As described above, take Unrestricted_Access for case of non-
5015 -- scalar types, to avoid big copies, and special cases.
5017 if not Is_Elementary_Type
(Typ
) then
5019 Make_Attribute_Reference
(Aloc
,
5020 Prefix
=> Relocate_Node
(Aexp
),
5021 Attribute_Name
=> Name_Unrestricted_Access
);
5025 Make_Assignment_Statement
(Aloc
,
5026 Name
=> New_Occurrence_Of
(Tnn
, Loc
),
5027 Expression
=> Aexp
));
5029 -- Propagate declarations inserted in the node by Insert_Actions
5030 -- (for example, temporaries generated to remove side effects).
5031 -- These actions must remain attached to the alternative, given
5032 -- that they are generated by the corresponding expression.
5034 if Present
(Sinfo
.Actions
(Alt
)) then
5035 Prepend_List
(Sinfo
.Actions
(Alt
), Stats
);
5039 (Alternatives
(Cstmt
),
5040 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5041 Discrete_Choices
=> Discrete_Choices
(Alt
),
5042 Statements
=> Stats
));
5048 Append_To
(Actions
, Cstmt
);
5050 -- Construct and return final expression with actions
5052 if Is_Elementary_Type
(Typ
) then
5053 Fexp
:= New_Occurrence_Of
(Tnn
, Loc
);
5056 Make_Explicit_Dereference
(Loc
,
5057 Prefix
=> New_Occurrence_Of
(Tnn
, Loc
));
5061 Make_Expression_With_Actions
(Loc
,
5063 Actions
=> Actions
));
5065 Analyze_And_Resolve
(N
, Typ
);
5066 end Expand_N_Case_Expression
;
5068 -----------------------------------
5069 -- Expand_N_Explicit_Dereference --
5070 -----------------------------------
5072 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5074 -- Insert explicit dereference call for the checked storage pool case
5076 Insert_Dereference_Action
(Prefix
(N
));
5078 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5079 -- we set the atomic sync flag.
5081 if Is_Atomic
(Etype
(N
))
5082 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5084 Activate_Atomic_Synchronization
(N
);
5086 end Expand_N_Explicit_Dereference
;
5088 --------------------------------------
5089 -- Expand_N_Expression_With_Actions --
5090 --------------------------------------
5092 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5093 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5094 -- Inspect and process a single action of an expression_with_actions for
5095 -- transient controlled objects. If such objects are found, the routine
5096 -- generates code to clean them up when the context of the expression is
5097 -- evaluated or elaborated.
5099 --------------------
5100 -- Process_Action --
5101 --------------------
5103 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5105 if Nkind
(Act
) = N_Object_Declaration
5106 and then Is_Finalizable_Transient
(Act
, N
)
5108 Process_Transient_Object
(Act
, N
);
5111 -- Avoid processing temporary function results multiple times when
5112 -- dealing with nested expression_with_actions.
5114 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5117 -- Do not process temporary function results in loops. This is done
5118 -- by Expand_N_Loop_Statement and Build_Finalizer.
5120 elsif Nkind
(Act
) = N_Loop_Statement
then
5127 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5131 Acts
: constant List_Id
:= Actions
(N
);
5132 Expr
: constant Node_Id
:= Expression
(N
);
5135 -- Start of processing for Expand_N_Expression_With_Actions
5138 -- Do not evaluate the expression when it denotes an entity because the
5139 -- expression_with_actions node will be replaced by the reference.
5141 if Is_Entity_Name
(Expr
) then
5144 -- Do not evaluate the expression when there are no actions because the
5145 -- expression_with_actions node will be replaced by the expression.
5147 elsif No
(Acts
) or else Is_Empty_List
(Acts
) then
5150 -- Force the evaluation of the expression by capturing its value in a
5151 -- temporary. This ensures that aliases of transient controlled objects
5152 -- do not leak to the expression of the expression_with_actions node:
5155 -- Trans_Id : Ctrl_Typ : ...;
5156 -- Alias : ... := Trans_Id;
5157 -- in ... Alias ... end;
5159 -- In the example above, Trans_Id cannot be finalized at the end of the
5160 -- actions list because this may affect the alias and the final value of
5161 -- the expression_with_actions. Forcing the evaluation encapsulates the
5162 -- reference to the Alias within the actions list:
5165 -- Trans_Id : Ctrl_Typ : ...;
5166 -- Alias : ... := Trans_Id;
5167 -- Val : constant Boolean := ... Alias ...;
5168 -- <finalize Trans_Id>
5171 -- It is now safe to finalize the transient controlled object at the end
5172 -- of the actions list.
5175 Force_Evaluation
(Expr
);
5178 -- Process all transient controlled objects found within the actions of
5181 Act
:= First
(Acts
);
5182 while Present
(Act
) loop
5183 Process_Single_Action
(Act
);
5187 -- Deal with case where there are no actions. In this case we simply
5188 -- rewrite the node with its expression since we don't need the actions
5189 -- and the specification of this node does not allow a null action list.
5191 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5192 -- the expanded tree and relying on being able to retrieve the original
5193 -- tree in cases like this. This raises a whole lot of issues of whether
5194 -- we have problems elsewhere, which will be addressed in the future???
5196 if Is_Empty_List
(Acts
) then
5197 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5199 end Expand_N_Expression_With_Actions
;
5201 ----------------------------
5202 -- Expand_N_If_Expression --
5203 ----------------------------
5205 -- Deal with limited types and condition actions
5207 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5208 procedure Process_Actions
(Actions
: List_Id
);
5209 -- Inspect and process a single action list of an if expression for
5210 -- transient controlled objects. If such objects are found, the routine
5211 -- generates code to clean them up when the context of the expression is
5212 -- evaluated or elaborated.
5214 ---------------------
5215 -- Process_Actions --
5216 ---------------------
5218 procedure Process_Actions
(Actions
: List_Id
) is
5222 Act
:= First
(Actions
);
5223 while Present
(Act
) loop
5224 if Nkind
(Act
) = N_Object_Declaration
5225 and then Is_Finalizable_Transient
(Act
, N
)
5227 Process_Transient_Object
(Act
, N
);
5232 end Process_Actions
;
5236 Loc
: constant Source_Ptr
:= Sloc
(N
);
5237 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5238 Thenx
: constant Node_Id
:= Next
(Cond
);
5239 Elsex
: constant Node_Id
:= Next
(Thenx
);
5240 Typ
: constant Entity_Id
:= Etype
(N
);
5248 Ptr_Typ
: Entity_Id
;
5250 -- Start of processing for Expand_N_If_Expression
5253 -- Check for MINIMIZED/ELIMINATED overflow mode
5255 if Minimized_Eliminated_Overflow_Check
(N
) then
5256 Apply_Arithmetic_Overflow_Check
(N
);
5260 -- Fold at compile time if condition known. We have already folded
5261 -- static if expressions, but it is possible to fold any case in which
5262 -- the condition is known at compile time, even though the result is
5265 -- Note that we don't do the fold of such cases in Sem_Elab because
5266 -- it can cause infinite loops with the expander adding a conditional
5267 -- expression, and Sem_Elab circuitry removing it repeatedly.
5269 if Compile_Time_Known_Value
(Cond
) then
5270 if Is_True
(Expr_Value
(Cond
)) then
5272 Actions
:= Then_Actions
(N
);
5275 Actions
:= Else_Actions
(N
);
5280 if Present
(Actions
) then
5282 Make_Expression_With_Actions
(Loc
,
5283 Expression
=> Relocate_Node
(Expr
),
5284 Actions
=> Actions
));
5285 Analyze_And_Resolve
(N
, Typ
);
5287 Rewrite
(N
, Relocate_Node
(Expr
));
5290 -- Note that the result is never static (legitimate cases of static
5291 -- if expressions were folded in Sem_Eval).
5293 Set_Is_Static_Expression
(N
, False);
5297 -- If the type is limited, and the back end does not handle limited
5298 -- types, then we expand as follows to avoid the possibility of
5299 -- improper copying.
5301 -- type Ptr is access all Typ;
5305 -- Cnn := then-expr'Unrestricted_Access;
5308 -- Cnn := else-expr'Unrestricted_Access;
5311 -- and replace the if expression by a reference to Cnn.all.
5313 -- This special case can be skipped if the back end handles limited
5314 -- types properly and ensures that no incorrect copies are made.
5316 if Is_By_Reference_Type
(Typ
)
5317 and then not Back_End_Handles_Limited_Types
5319 -- When the "then" or "else" expressions involve controlled function
5320 -- calls, generated temporaries are chained on the corresponding list
5321 -- of actions. These temporaries need to be finalized after the if
5322 -- expression is evaluated.
5324 Process_Actions
(Then_Actions
(N
));
5325 Process_Actions
(Else_Actions
(N
));
5328 -- type Ann is access all Typ;
5330 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5333 Make_Full_Type_Declaration
(Loc
,
5334 Defining_Identifier
=> Ptr_Typ
,
5336 Make_Access_To_Object_Definition
(Loc
,
5337 All_Present
=> True,
5338 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5343 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5346 Make_Object_Declaration
(Loc
,
5347 Defining_Identifier
=> Cnn
,
5348 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5352 -- Cnn := <Thenx>'Unrestricted_Access;
5354 -- Cnn := <Elsex>'Unrestricted_Access;
5358 Make_Implicit_If_Statement
(N
,
5359 Condition
=> Relocate_Node
(Cond
),
5360 Then_Statements
=> New_List
(
5361 Make_Assignment_Statement
(Sloc
(Thenx
),
5362 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5364 Make_Attribute_Reference
(Loc
,
5365 Prefix
=> Relocate_Node
(Thenx
),
5366 Attribute_Name
=> Name_Unrestricted_Access
))),
5368 Else_Statements
=> New_List
(
5369 Make_Assignment_Statement
(Sloc
(Elsex
),
5370 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5372 Make_Attribute_Reference
(Loc
,
5373 Prefix
=> Relocate_Node
(Elsex
),
5374 Attribute_Name
=> Name_Unrestricted_Access
))));
5376 -- Preserve the original context for which the if statement is being
5377 -- generated. This is needed by the finalization machinery to prevent
5378 -- the premature finalization of controlled objects found within the
5381 Set_From_Conditional_Expression
(New_If
);
5384 Make_Explicit_Dereference
(Loc
,
5385 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5387 -- If the result is an unconstrained array and the if expression is in a
5388 -- context other than the initializing expression of the declaration of
5389 -- an object, then we pull out the if expression as follows:
5391 -- Cnn : constant typ := if-expression
5393 -- and then replace the if expression with an occurrence of Cnn. This
5394 -- avoids the need in the back end to create on-the-fly variable length
5395 -- temporaries (which it cannot do!)
5397 -- Note that the test for being in an object declaration avoids doing an
5398 -- unnecessary expansion, and also avoids infinite recursion.
5400 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
)
5401 and then (Nkind
(Parent
(N
)) /= N_Object_Declaration
5402 or else Expression
(Parent
(N
)) /= N
)
5405 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5408 Make_Object_Declaration
(Loc
,
5409 Defining_Identifier
=> Cnn
,
5410 Constant_Present
=> True,
5411 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5412 Expression
=> Relocate_Node
(N
),
5413 Has_Init_Expression
=> True));
5415 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
5419 -- For other types, we only need to expand if there are other actions
5420 -- associated with either branch.
5422 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5424 -- We now wrap the actions into the appropriate expression
5426 if Present
(Then_Actions
(N
)) then
5428 Make_Expression_With_Actions
(Sloc
(Thenx
),
5429 Actions
=> Then_Actions
(N
),
5430 Expression
=> Relocate_Node
(Thenx
)));
5432 Set_Then_Actions
(N
, No_List
);
5433 Analyze_And_Resolve
(Thenx
, Typ
);
5436 if Present
(Else_Actions
(N
)) then
5438 Make_Expression_With_Actions
(Sloc
(Elsex
),
5439 Actions
=> Else_Actions
(N
),
5440 Expression
=> Relocate_Node
(Elsex
)));
5442 Set_Else_Actions
(N
, No_List
);
5443 Analyze_And_Resolve
(Elsex
, Typ
);
5448 -- If no actions then no expansion needed, gigi will handle it using the
5449 -- same approach as a C conditional expression.
5455 -- Fall through here for either the limited expansion, or the case of
5456 -- inserting actions for non-limited types. In both these cases, we must
5457 -- move the SLOC of the parent If statement to the newly created one and
5458 -- change it to the SLOC of the expression which, after expansion, will
5459 -- correspond to what is being evaluated.
5461 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
5462 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5463 Set_Sloc
(Parent
(N
), Loc
);
5466 -- Make sure Then_Actions and Else_Actions are appropriately moved
5467 -- to the new if statement.
5469 if Present
(Then_Actions
(N
)) then
5471 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5474 if Present
(Else_Actions
(N
)) then
5476 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5479 Insert_Action
(N
, Decl
);
5480 Insert_Action
(N
, New_If
);
5482 Analyze_And_Resolve
(N
, Typ
);
5483 end Expand_N_If_Expression
;
5489 procedure Expand_N_In
(N
: Node_Id
) is
5490 Loc
: constant Source_Ptr
:= Sloc
(N
);
5491 Restyp
: constant Entity_Id
:= Etype
(N
);
5492 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5493 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5494 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5499 procedure Substitute_Valid_Check
;
5500 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5501 -- test for the left operand being in range of its subtype.
5503 ----------------------------
5504 -- Substitute_Valid_Check --
5505 ----------------------------
5507 procedure Substitute_Valid_Check
is
5510 Make_Attribute_Reference
(Loc
,
5511 Prefix
=> Relocate_Node
(Lop
),
5512 Attribute_Name
=> Name_Valid
));
5514 Analyze_And_Resolve
(N
, Restyp
);
5516 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5517 -- in which case, this usage makes sense, and in any case, we have
5518 -- actually eliminated the danger of optimization above.
5520 if Overflow_Check_Mode
not in Minimized_Or_Eliminated
then
5522 ("??explicit membership test may be optimized away", N
);
5523 Error_Msg_N
-- CODEFIX
5524 ("\??use ''Valid attribute instead", N
);
5528 end Substitute_Valid_Check
;
5530 -- Start of processing for Expand_N_In
5533 -- If set membership case, expand with separate procedure
5535 if Present
(Alternatives
(N
)) then
5536 Expand_Set_Membership
(N
);
5540 -- Not set membership, proceed with expansion
5542 Ltyp
:= Etype
(Left_Opnd
(N
));
5543 Rtyp
:= Etype
(Right_Opnd
(N
));
5545 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5546 -- type, then expand with a separate procedure. Note the use of the
5547 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5549 if Overflow_Check_Mode
in Minimized_Or_Eliminated
5550 and then Is_Signed_Integer_Type
(Ltyp
)
5551 and then not No_Minimize_Eliminate
(N
)
5553 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
5557 -- Check case of explicit test for an expression in range of its
5558 -- subtype. This is suspicious usage and we replace it with a 'Valid
5559 -- test and give a warning for scalar types.
5561 if Is_Scalar_Type
(Ltyp
)
5563 -- Only relevant for source comparisons
5565 and then Comes_From_Source
(N
)
5567 -- In floating-point this is a standard way to check for finite values
5568 -- and using 'Valid would typically be a pessimization.
5570 and then not Is_Floating_Point_Type
(Ltyp
)
5572 -- Don't give the message unless right operand is a type entity and
5573 -- the type of the left operand matches this type. Note that this
5574 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5575 -- checks have changed the type of the left operand.
5577 and then Nkind
(Rop
) in N_Has_Entity
5578 and then Ltyp
= Entity
(Rop
)
5580 -- Skip in VM mode, where we have no sense of invalid values. The
5581 -- warning still seems relevant, but not important enough to worry.
5583 and then VM_Target
= No_VM
5585 -- Skip this for predicated types, where such expressions are a
5586 -- reasonable way of testing if something meets the predicate.
5588 and then not Present
(Predicate_Function
(Ltyp
))
5590 Substitute_Valid_Check
;
5594 -- Do validity check on operands
5596 if Validity_Checks_On
and Validity_Check_Operands
then
5597 Ensure_Valid
(Left_Opnd
(N
));
5598 Validity_Check_Range
(Right_Opnd
(N
));
5601 -- Case of explicit range
5603 if Nkind
(Rop
) = N_Range
then
5605 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
5606 Hi
: constant Node_Id
:= High_Bound
(Rop
);
5608 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
5609 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
5611 Lcheck
: Compare_Result
;
5612 Ucheck
: Compare_Result
;
5614 Warn1
: constant Boolean :=
5615 Constant_Condition_Warnings
5616 and then Comes_From_Source
(N
)
5617 and then not In_Instance
;
5618 -- This must be true for any of the optimization warnings, we
5619 -- clearly want to give them only for source with the flag on. We
5620 -- also skip these warnings in an instance since it may be the
5621 -- case that different instantiations have different ranges.
5623 Warn2
: constant Boolean :=
5625 and then Nkind
(Original_Node
(Rop
)) = N_Range
5626 and then Is_Integer_Type
(Etype
(Lo
));
5627 -- For the case where only one bound warning is elided, we also
5628 -- insist on an explicit range and an integer type. The reason is
5629 -- that the use of enumeration ranges including an end point is
5630 -- common, as is the use of a subtype name, one of whose bounds is
5631 -- the same as the type of the expression.
5634 -- If test is explicit x'First .. x'Last, replace by valid check
5636 -- Could use some individual comments for this complex test ???
5638 if Is_Scalar_Type
(Ltyp
)
5640 -- And left operand is X'First where X matches left operand
5641 -- type (this eliminates cases of type mismatch, including
5642 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5643 -- type of the left operand.
5645 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
5646 and then Attribute_Name
(Lo_Orig
) = Name_First
5647 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
5648 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
5650 -- Same tests for right operand
5652 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
5653 and then Attribute_Name
(Hi_Orig
) = Name_Last
5654 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
5655 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
5657 -- Relevant only for source cases
5659 and then Comes_From_Source
(N
)
5661 -- Omit for VM cases, where we don't have invalid values
5663 and then VM_Target
= No_VM
5665 Substitute_Valid_Check
;
5669 -- If bounds of type are known at compile time, and the end points
5670 -- are known at compile time and identical, this is another case
5671 -- for substituting a valid test. We only do this for discrete
5672 -- types, since it won't arise in practice for float types.
5674 if Comes_From_Source
(N
)
5675 and then Is_Discrete_Type
(Ltyp
)
5676 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
5677 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
5678 and then Compile_Time_Known_Value
(Lo
)
5679 and then Compile_Time_Known_Value
(Hi
)
5680 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
5681 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
5683 -- Kill warnings in instances, since they may be cases where we
5684 -- have a test in the generic that makes sense with some types
5685 -- and not with other types.
5687 and then not In_Instance
5689 Substitute_Valid_Check
;
5693 -- If we have an explicit range, do a bit of optimization based on
5694 -- range analysis (we may be able to kill one or both checks).
5696 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
5697 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
5699 -- If either check is known to fail, replace result by False since
5700 -- the other check does not matter. Preserve the static flag for
5701 -- legality checks, because we are constant-folding beyond RM 4.9.
5703 if Lcheck
= LT
or else Ucheck
= GT
then
5705 Error_Msg_N
("?c?range test optimized away", N
);
5706 Error_Msg_N
("\?c?value is known to be out of range", N
);
5709 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5710 Analyze_And_Resolve
(N
, Restyp
);
5711 Set_Is_Static_Expression
(N
, Static
);
5714 -- If both checks are known to succeed, replace result by True,
5715 -- since we know we are in range.
5717 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5719 Error_Msg_N
("?c?range test optimized away", N
);
5720 Error_Msg_N
("\?c?value is known to be in range", N
);
5723 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5724 Analyze_And_Resolve
(N
, Restyp
);
5725 Set_Is_Static_Expression
(N
, Static
);
5728 -- If lower bound check succeeds and upper bound check is not
5729 -- known to succeed or fail, then replace the range check with
5730 -- a comparison against the upper bound.
5732 elsif Lcheck
in Compare_GE
then
5733 if Warn2
and then not In_Instance
then
5734 Error_Msg_N
("??lower bound test optimized away", Lo
);
5735 Error_Msg_N
("\??value is known to be in range", Lo
);
5741 Right_Opnd
=> High_Bound
(Rop
)));
5742 Analyze_And_Resolve
(N
, Restyp
);
5745 -- If upper bound check succeeds and lower bound check is not
5746 -- known to succeed or fail, then replace the range check with
5747 -- a comparison against the lower bound.
5749 elsif Ucheck
in Compare_LE
then
5750 if Warn2
and then not In_Instance
then
5751 Error_Msg_N
("??upper bound test optimized away", Hi
);
5752 Error_Msg_N
("\??value is known to be in range", Hi
);
5758 Right_Opnd
=> Low_Bound
(Rop
)));
5759 Analyze_And_Resolve
(N
, Restyp
);
5763 -- We couldn't optimize away the range check, but there is one
5764 -- more issue. If we are checking constant conditionals, then we
5765 -- see if we can determine the outcome assuming everything is
5766 -- valid, and if so give an appropriate warning.
5768 if Warn1
and then not Assume_No_Invalid_Values
then
5769 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
5770 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
5772 -- Result is out of range for valid value
5774 if Lcheck
= LT
or else Ucheck
= GT
then
5776 ("?c?value can only be in range if it is invalid", N
);
5778 -- Result is in range for valid value
5780 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5782 ("?c?value can only be out of range if it is invalid", N
);
5784 -- Lower bound check succeeds if value is valid
5786 elsif Warn2
and then Lcheck
in Compare_GE
then
5788 ("?c?lower bound check only fails if it is invalid", Lo
);
5790 -- Upper bound check succeeds if value is valid
5792 elsif Warn2
and then Ucheck
in Compare_LE
then
5794 ("?c?upper bound check only fails for invalid values", Hi
);
5799 -- For all other cases of an explicit range, nothing to be done
5803 -- Here right operand is a subtype mark
5807 Typ
: Entity_Id
:= Etype
(Rop
);
5808 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
5809 Cond
: Node_Id
:= Empty
;
5811 Obj
: Node_Id
:= Lop
;
5812 SCIL_Node
: Node_Id
;
5815 Remove_Side_Effects
(Obj
);
5817 -- For tagged type, do tagged membership operation
5819 if Is_Tagged_Type
(Typ
) then
5821 -- No expansion will be performed when VM_Target, as the VM
5822 -- back-ends will handle the membership tests directly (tags
5823 -- are not explicitly represented in Java objects, so the
5824 -- normal tagged membership expansion is not what we want).
5826 if Tagged_Type_Expansion
then
5827 Tagged_Membership
(N
, SCIL_Node
, New_N
);
5829 Analyze_And_Resolve
(N
, Restyp
);
5831 -- Update decoration of relocated node referenced by the
5834 if Generate_SCIL
and then Present
(SCIL_Node
) then
5835 Set_SCIL_Node
(N
, SCIL_Node
);
5841 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5842 -- This reason we do this is that the bounds may have the wrong
5843 -- type if they come from the original type definition. Also this
5844 -- way we get all the processing above for an explicit range.
5846 -- Don't do this for predicated types, since in this case we
5847 -- want to check the predicate.
5849 elsif Is_Scalar_Type
(Typ
) then
5850 if No
(Predicate_Function
(Typ
)) then
5854 Make_Attribute_Reference
(Loc
,
5855 Attribute_Name
=> Name_First
,
5856 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
5859 Make_Attribute_Reference
(Loc
,
5860 Attribute_Name
=> Name_Last
,
5861 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
5862 Analyze_And_Resolve
(N
, Restyp
);
5867 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5868 -- a membership test if the subtype mark denotes a constrained
5869 -- Unchecked_Union subtype and the expression lacks inferable
5872 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
5873 and then Is_Constrained
(Typ
)
5874 and then not Has_Inferable_Discriminants
(Lop
)
5877 Make_Raise_Program_Error
(Loc
,
5878 Reason
=> PE_Unchecked_Union_Restriction
));
5880 -- Prevent Gigi from generating incorrect code by rewriting the
5881 -- test as False. What is this undocumented thing about ???
5883 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5887 -- Here we have a non-scalar type
5890 Typ
:= Designated_Type
(Typ
);
5893 if not Is_Constrained
(Typ
) then
5894 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5895 Analyze_And_Resolve
(N
, Restyp
);
5897 -- For the constrained array case, we have to check the subscripts
5898 -- for an exact match if the lengths are non-zero (the lengths
5899 -- must match in any case).
5901 elsif Is_Array_Type
(Typ
) then
5902 Check_Subscripts
: declare
5903 function Build_Attribute_Reference
5906 Dim
: Nat
) return Node_Id
;
5907 -- Build attribute reference E'Nam (Dim)
5909 -------------------------------
5910 -- Build_Attribute_Reference --
5911 -------------------------------
5913 function Build_Attribute_Reference
5916 Dim
: Nat
) return Node_Id
5920 Make_Attribute_Reference
(Loc
,
5922 Attribute_Name
=> Nam
,
5923 Expressions
=> New_List
(
5924 Make_Integer_Literal
(Loc
, Dim
)));
5925 end Build_Attribute_Reference
;
5927 -- Start of processing for Check_Subscripts
5930 for J
in 1 .. Number_Dimensions
(Typ
) loop
5931 Evolve_And_Then
(Cond
,
5934 Build_Attribute_Reference
5935 (Duplicate_Subexpr_No_Checks
(Obj
),
5938 Build_Attribute_Reference
5939 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
5941 Evolve_And_Then
(Cond
,
5944 Build_Attribute_Reference
5945 (Duplicate_Subexpr_No_Checks
(Obj
),
5948 Build_Attribute_Reference
5949 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
5958 Right_Opnd
=> Make_Null
(Loc
)),
5959 Right_Opnd
=> Cond
);
5963 Analyze_And_Resolve
(N
, Restyp
);
5964 end Check_Subscripts
;
5966 -- These are the cases where constraint checks may be required,
5967 -- e.g. records with possible discriminants
5970 -- Expand the test into a series of discriminant comparisons.
5971 -- The expression that is built is the negation of the one that
5972 -- is used for checking discriminant constraints.
5974 Obj
:= Relocate_Node
(Left_Opnd
(N
));
5976 if Has_Discriminants
(Typ
) then
5977 Cond
:= Make_Op_Not
(Loc
,
5978 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
5981 Cond
:= Make_Or_Else
(Loc
,
5985 Right_Opnd
=> Make_Null
(Loc
)),
5986 Right_Opnd
=> Cond
);
5990 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
5994 Analyze_And_Resolve
(N
, Restyp
);
5997 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5998 -- expression of an anonymous access type. This can involve an
5999 -- accessibility test and a tagged type membership test in the
6000 -- case of tagged designated types.
6002 if Ada_Version
>= Ada_2012
6004 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6007 Expr_Entity
: Entity_Id
:= Empty
;
6009 Param_Level
: Node_Id
;
6010 Type_Level
: Node_Id
;
6013 if Is_Entity_Name
(Lop
) then
6014 Expr_Entity
:= Param_Entity
(Lop
);
6016 if not Present
(Expr_Entity
) then
6017 Expr_Entity
:= Entity
(Lop
);
6021 -- If a conversion of the anonymous access value to the
6022 -- tested type would be illegal, then the result is False.
6024 if not Valid_Conversion
6025 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6027 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6028 Analyze_And_Resolve
(N
, Restyp
);
6030 -- Apply an accessibility check if the access object has an
6031 -- associated access level and when the level of the type is
6032 -- less deep than the level of the access parameter. This
6033 -- only occur for access parameters and stand-alone objects
6034 -- of an anonymous access type.
6037 if Present
(Expr_Entity
)
6040 (Effective_Extra_Accessibility
(Expr_Entity
))
6041 and then UI_Gt
(Object_Access_Level
(Lop
),
6042 Type_Access_Level
(Rtyp
))
6046 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
6049 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6051 -- Return True only if the accessibility level of the
6052 -- expression entity is not deeper than the level of
6053 -- the tested access type.
6057 Left_Opnd
=> Relocate_Node
(N
),
6058 Right_Opnd
=> Make_Op_Le
(Loc
,
6059 Left_Opnd
=> Param_Level
,
6060 Right_Opnd
=> Type_Level
)));
6062 Analyze_And_Resolve
(N
);
6065 -- If the designated type is tagged, do tagged membership
6068 -- *** NOTE: we have to check not null before doing the
6069 -- tagged membership test (but maybe that can be done
6070 -- inside Tagged_Membership?).
6072 if Is_Tagged_Type
(Typ
) then
6075 Left_Opnd
=> Relocate_Node
(N
),
6079 Right_Opnd
=> Make_Null
(Loc
))));
6081 -- No expansion will be performed when VM_Target, as
6082 -- the VM back-ends will handle the membership tests
6083 -- directly (tags are not explicitly represented in
6084 -- Java objects, so the normal tagged membership
6085 -- expansion is not what we want).
6087 if Tagged_Type_Expansion
then
6089 -- Note that we have to pass Original_Node, because
6090 -- the membership test might already have been
6091 -- rewritten by earlier parts of membership test.
6094 (Original_Node
(N
), SCIL_Node
, New_N
);
6096 -- Update decoration of relocated node referenced
6097 -- by the SCIL node.
6099 if Generate_SCIL
and then Present
(SCIL_Node
) then
6100 Set_SCIL_Node
(New_N
, SCIL_Node
);
6105 Left_Opnd
=> Relocate_Node
(N
),
6106 Right_Opnd
=> New_N
));
6108 Analyze_And_Resolve
(N
, Restyp
);
6117 -- At this point, we have done the processing required for the basic
6118 -- membership test, but not yet dealt with the predicate.
6122 -- If a predicate is present, then we do the predicate test, but we
6123 -- most certainly want to omit this if we are within the predicate
6124 -- function itself, since otherwise we have an infinite recursion.
6125 -- The check should also not be emitted when testing against a range
6126 -- (the check is only done when the right operand is a subtype; see
6127 -- RM12-4.5.2 (28.1/3-30/3)).
6130 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6134 and then Current_Scope
/= PFunc
6135 and then Nkind
(Rop
) /= N_Range
6139 Left_Opnd
=> Relocate_Node
(N
),
6140 Right_Opnd
=> Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True)));
6142 -- Analyze new expression, mark left operand as analyzed to
6143 -- avoid infinite recursion adding predicate calls. Similarly,
6144 -- suppress further range checks on the call.
6146 Set_Analyzed
(Left_Opnd
(N
));
6147 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6149 -- All done, skip attempt at compile time determination of result
6156 --------------------------------
6157 -- Expand_N_Indexed_Component --
6158 --------------------------------
6160 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6161 Loc
: constant Source_Ptr
:= Sloc
(N
);
6162 Typ
: constant Entity_Id
:= Etype
(N
);
6163 P
: constant Node_Id
:= Prefix
(N
);
6164 T
: constant Entity_Id
:= Etype
(P
);
6168 -- A special optimization, if we have an indexed component that is
6169 -- selecting from a slice, then we can eliminate the slice, since, for
6170 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6171 -- the range check required by the slice. The range check for the slice
6172 -- itself has already been generated. The range check for the
6173 -- subscripting operation is ensured by converting the subject to
6174 -- the subtype of the slice.
6176 -- This optimization not only generates better code, avoiding slice
6177 -- messing especially in the packed case, but more importantly bypasses
6178 -- some problems in handling this peculiar case, for example, the issue
6179 -- of dealing specially with object renamings.
6181 if Nkind
(P
) = N_Slice
6183 -- This optimization is disabled for CodePeer because it can transform
6184 -- an index-check constraint_error into a range-check constraint_error
6185 -- and CodePeer cares about that distinction.
6187 and then not CodePeer_Mode
6190 Make_Indexed_Component
(Loc
,
6191 Prefix
=> Prefix
(P
),
6192 Expressions
=> New_List
(
6194 (Etype
(First_Index
(Etype
(P
))),
6195 First
(Expressions
(N
))))));
6196 Analyze_And_Resolve
(N
, Typ
);
6200 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6201 -- function, then additional actuals must be passed.
6203 if Ada_Version
>= Ada_2005
6204 and then Is_Build_In_Place_Function_Call
(P
)
6206 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6209 -- If the prefix is an access type, then we unconditionally rewrite if
6210 -- as an explicit dereference. This simplifies processing for several
6211 -- cases, including packed array cases and certain cases in which checks
6212 -- must be generated. We used to try to do this only when it was
6213 -- necessary, but it cleans up the code to do it all the time.
6215 if Is_Access_Type
(T
) then
6216 Insert_Explicit_Dereference
(P
);
6217 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6218 Atp
:= Designated_Type
(T
);
6223 -- Generate index and validity checks
6225 Generate_Index_Checks
(N
);
6227 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6228 Apply_Subscript_Validity_Checks
(N
);
6231 -- If selecting from an array with atomic components, and atomic sync
6232 -- is not suppressed for this array type, set atomic sync flag.
6234 if (Has_Atomic_Components
(Atp
)
6235 and then not Atomic_Synchronization_Disabled
(Atp
))
6236 or else (Is_Atomic
(Typ
)
6237 and then not Atomic_Synchronization_Disabled
(Typ
))
6239 Activate_Atomic_Synchronization
(N
);
6242 -- All done for the non-packed case
6244 if not Is_Packed
(Etype
(Prefix
(N
))) then
6248 -- For packed arrays that are not bit-packed (i.e. the case of an array
6249 -- with one or more index types with a non-contiguous enumeration type),
6250 -- we can always use the normal packed element get circuit.
6252 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6253 Expand_Packed_Element_Reference
(N
);
6257 -- For a reference to a component of a bit packed array, we convert it
6258 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6259 -- want to do this for simple references, and not for:
6261 -- Left side of assignment, or prefix of left side of assignment, or
6262 -- prefix of the prefix, to handle packed arrays of packed arrays,
6263 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6265 -- Renaming objects in renaming associations
6266 -- This case is handled when a use of the renamed variable occurs
6268 -- Actual parameters for a procedure call
6269 -- This case is handled in Exp_Ch6.Expand_Actuals
6271 -- The second expression in a 'Read attribute reference
6273 -- The prefix of an address or bit or size attribute reference
6275 -- The following circuit detects these exceptions
6278 Child
: Node_Id
:= N
;
6279 Parnt
: Node_Id
:= Parent
(N
);
6283 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6286 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6287 N_Procedure_Call_Statement
)
6288 or else (Nkind
(Parnt
) = N_Parameter_Association
6290 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6294 elsif Nkind
(Parnt
) = N_Attribute_Reference
6295 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
6298 and then Prefix
(Parnt
) = Child
6302 elsif Nkind
(Parnt
) = N_Assignment_Statement
6303 and then Name
(Parnt
) = Child
6307 -- If the expression is an index of an indexed component, it must
6308 -- be expanded regardless of context.
6310 elsif Nkind
(Parnt
) = N_Indexed_Component
6311 and then Child
/= Prefix
(Parnt
)
6313 Expand_Packed_Element_Reference
(N
);
6316 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6317 and then Name
(Parent
(Parnt
)) = Parnt
6321 elsif Nkind
(Parnt
) = N_Attribute_Reference
6322 and then Attribute_Name
(Parnt
) = Name_Read
6323 and then Next
(First
(Expressions
(Parnt
))) = Child
6327 elsif Nkind_In
(Parnt
, N_Indexed_Component
, N_Selected_Component
)
6328 and then Prefix
(Parnt
) = Child
6333 Expand_Packed_Element_Reference
(N
);
6337 -- Keep looking up tree for unchecked expression, or if we are the
6338 -- prefix of a possible assignment left side.
6341 Parnt
:= Parent
(Child
);
6344 end Expand_N_Indexed_Component
;
6346 ---------------------
6347 -- Expand_N_Not_In --
6348 ---------------------
6350 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6351 -- can be done. This avoids needing to duplicate this expansion code.
6353 procedure Expand_N_Not_In
(N
: Node_Id
) is
6354 Loc
: constant Source_Ptr
:= Sloc
(N
);
6355 Typ
: constant Entity_Id
:= Etype
(N
);
6356 Cfs
: constant Boolean := Comes_From_Source
(N
);
6363 Left_Opnd
=> Left_Opnd
(N
),
6364 Right_Opnd
=> Right_Opnd
(N
))));
6366 -- If this is a set membership, preserve list of alternatives
6368 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6370 -- We want this to appear as coming from source if original does (see
6371 -- transformations in Expand_N_In).
6373 Set_Comes_From_Source
(N
, Cfs
);
6374 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6376 -- Now analyze transformed node
6378 Analyze_And_Resolve
(N
, Typ
);
6379 end Expand_N_Not_In
;
6385 -- The only replacement required is for the case of a null of a type that
6386 -- is an access to protected subprogram, or a subtype thereof. We represent
6387 -- such access values as a record, and so we must replace the occurrence of
6388 -- null by the equivalent record (with a null address and a null pointer in
6389 -- it), so that the backend creates the proper value.
6391 procedure Expand_N_Null
(N
: Node_Id
) is
6392 Loc
: constant Source_Ptr
:= Sloc
(N
);
6393 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6397 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6399 Make_Aggregate
(Loc
,
6400 Expressions
=> New_List
(
6401 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6405 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6407 -- For subsequent semantic analysis, the node must retain its type.
6408 -- Gigi in any case replaces this type by the corresponding record
6409 -- type before processing the node.
6415 when RE_Not_Available
=>
6419 ---------------------
6420 -- Expand_N_Op_Abs --
6421 ---------------------
6423 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6424 Loc
: constant Source_Ptr
:= Sloc
(N
);
6425 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6428 Unary_Op_Validity_Checks
(N
);
6430 -- Check for MINIMIZED/ELIMINATED overflow mode
6432 if Minimized_Eliminated_Overflow_Check
(N
) then
6433 Apply_Arithmetic_Overflow_Check
(N
);
6437 -- Deal with software overflow checking
6439 if not Backend_Overflow_Checks_On_Target
6440 and then Is_Signed_Integer_Type
(Etype
(N
))
6441 and then Do_Overflow_Check
(N
)
6443 -- The only case to worry about is when the argument is equal to the
6444 -- largest negative number, so what we do is to insert the check:
6446 -- [constraint_error when Expr = typ'Base'First]
6448 -- with the usual Duplicate_Subexpr use coding for expr
6451 Make_Raise_Constraint_Error
(Loc
,
6454 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6456 Make_Attribute_Reference
(Loc
,
6458 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6459 Attribute_Name
=> Name_First
)),
6460 Reason
=> CE_Overflow_Check_Failed
));
6462 end Expand_N_Op_Abs
;
6464 ---------------------
6465 -- Expand_N_Op_Add --
6466 ---------------------
6468 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6469 Typ
: constant Entity_Id
:= Etype
(N
);
6472 Binary_Op_Validity_Checks
(N
);
6474 -- Check for MINIMIZED/ELIMINATED overflow mode
6476 if Minimized_Eliminated_Overflow_Check
(N
) then
6477 Apply_Arithmetic_Overflow_Check
(N
);
6481 -- N + 0 = 0 + N = N for integer types
6483 if Is_Integer_Type
(Typ
) then
6484 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6485 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6487 Rewrite
(N
, Left_Opnd
(N
));
6490 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6491 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
6493 Rewrite
(N
, Right_Opnd
(N
));
6498 -- Arithmetic overflow checks for signed integer/fixed point types
6500 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
6501 Apply_Arithmetic_Overflow_Check
(N
);
6505 -- Overflow checks for floating-point if -gnateF mode active
6507 Check_Float_Op_Overflow
(N
);
6508 end Expand_N_Op_Add
;
6510 ---------------------
6511 -- Expand_N_Op_And --
6512 ---------------------
6514 procedure Expand_N_Op_And
(N
: Node_Id
) is
6515 Typ
: constant Entity_Id
:= Etype
(N
);
6518 Binary_Op_Validity_Checks
(N
);
6520 if Is_Array_Type
(Etype
(N
)) then
6521 Expand_Boolean_Operator
(N
);
6523 elsif Is_Boolean_Type
(Etype
(N
)) then
6524 Adjust_Condition
(Left_Opnd
(N
));
6525 Adjust_Condition
(Right_Opnd
(N
));
6526 Set_Etype
(N
, Standard_Boolean
);
6527 Adjust_Result_Type
(N
, Typ
);
6529 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
6530 Expand_Intrinsic_Call
(N
, Entity
(N
));
6533 end Expand_N_Op_And
;
6535 ------------------------
6536 -- Expand_N_Op_Concat --
6537 ------------------------
6539 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
6541 -- List of operands to be concatenated
6544 -- Node which is to be replaced by the result of concatenating the nodes
6545 -- in the list Opnds.
6548 -- Ensure validity of both operands
6550 Binary_Op_Validity_Checks
(N
);
6552 -- If we are the left operand of a concatenation higher up the tree,
6553 -- then do nothing for now, since we want to deal with a series of
6554 -- concatenations as a unit.
6556 if Nkind
(Parent
(N
)) = N_Op_Concat
6557 and then N
= Left_Opnd
(Parent
(N
))
6562 -- We get here with a concatenation whose left operand may be a
6563 -- concatenation itself with a consistent type. We need to process
6564 -- these concatenation operands from left to right, which means
6565 -- from the deepest node in the tree to the highest node.
6568 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
6569 Cnode
:= Left_Opnd
(Cnode
);
6572 -- Now Cnode is the deepest concatenation, and its parents are the
6573 -- concatenation nodes above, so now we process bottom up, doing the
6576 -- The outer loop runs more than once if more than one concatenation
6577 -- type is involved.
6580 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
6581 Set_Parent
(Opnds
, N
);
6583 -- The inner loop gathers concatenation operands
6585 Inner
: while Cnode
/= N
6586 and then Base_Type
(Etype
(Cnode
)) =
6587 Base_Type
(Etype
(Parent
(Cnode
)))
6589 Cnode
:= Parent
(Cnode
);
6590 Append
(Right_Opnd
(Cnode
), Opnds
);
6593 -- Note: The following code is a temporary workaround for N731-034
6594 -- and N829-028 and will be kept until the general issue of internal
6595 -- symbol serialization is addressed. The workaround is kept under a
6596 -- debug switch to avoid permiating into the general case.
6598 -- Wrap the node to concatenate into an expression actions node to
6599 -- keep it nicely packaged. This is useful in the case of an assert
6600 -- pragma with a concatenation where we want to be able to delete
6601 -- the concatenation and all its expansion stuff.
6603 if Debug_Flag_Dot_H
then
6605 Cnod
: constant Node_Id
:= Relocate_Node
(Cnode
);
6606 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
6609 -- Note: use Rewrite rather than Replace here, so that for
6610 -- example Why_Not_Static can find the original concatenation
6614 Make_Expression_With_Actions
(Sloc
(Cnode
),
6615 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
6616 Expression
=> Cnod
));
6618 Expand_Concatenate
(Cnod
, Opnds
);
6619 Analyze_And_Resolve
(Cnode
, Typ
);
6625 Expand_Concatenate
(Cnode
, Opnds
);
6628 exit Outer
when Cnode
= N
;
6629 Cnode
:= Parent
(Cnode
);
6631 end Expand_N_Op_Concat
;
6633 ------------------------
6634 -- Expand_N_Op_Divide --
6635 ------------------------
6637 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
6638 Loc
: constant Source_Ptr
:= Sloc
(N
);
6639 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
6640 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
6641 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
6642 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
6643 Typ
: Entity_Id
:= Etype
(N
);
6644 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
6646 Compile_Time_Known_Value
(Ropnd
);
6650 Binary_Op_Validity_Checks
(N
);
6652 -- Check for MINIMIZED/ELIMINATED overflow mode
6654 if Minimized_Eliminated_Overflow_Check
(N
) then
6655 Apply_Arithmetic_Overflow_Check
(N
);
6659 -- Otherwise proceed with expansion of division
6662 Rval
:= Expr_Value
(Ropnd
);
6665 -- N / 1 = N for integer types
6667 if Rknow
and then Rval
= Uint_1
then
6672 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6673 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6674 -- operand is an unsigned integer, as required for this to work.
6676 if Nkind
(Ropnd
) = N_Op_Expon
6677 and then Is_Power_Of_2_For_Shift
(Ropnd
)
6679 -- We cannot do this transformation in configurable run time mode if we
6680 -- have 64-bit integers and long shifts are not available.
6682 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
6685 Make_Op_Shift_Right
(Loc
,
6688 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
6689 Analyze_And_Resolve
(N
, Typ
);
6693 -- Do required fixup of universal fixed operation
6695 if Typ
= Universal_Fixed
then
6696 Fixup_Universal_Fixed_Operation
(N
);
6700 -- Divisions with fixed-point results
6702 if Is_Fixed_Point_Type
(Typ
) then
6704 -- Deal with divide-by-zero check if back end cannot handle them
6705 -- and the flag is set indicating that we need such a check. Note
6706 -- that we don't need to bother here with the case of mixed-mode
6707 -- (Right operand an integer type), since these will be rewritten
6708 -- with conversions to a divide with a fixed-point right operand.
6710 if Do_Division_Check
(N
)
6711 and then not Backend_Divide_Checks_On_Target
6712 and then not Is_Integer_Type
(Rtyp
)
6714 Set_Do_Division_Check
(N
, False);
6716 Make_Raise_Constraint_Error
(Loc
,
6719 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
6720 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
6721 Reason
=> CE_Divide_By_Zero
));
6724 -- No special processing if Treat_Fixed_As_Integer is set, since
6725 -- from a semantic point of view such operations are simply integer
6726 -- operations and will be treated that way.
6728 if not Treat_Fixed_As_Integer
(N
) then
6729 if Is_Integer_Type
(Rtyp
) then
6730 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
6732 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
6736 -- Other cases of division of fixed-point operands. Again we exclude the
6737 -- case where Treat_Fixed_As_Integer is set.
6739 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
6740 and then not Treat_Fixed_As_Integer
(N
)
6742 if Is_Integer_Type
(Typ
) then
6743 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
6745 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6746 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
6749 -- Mixed-mode operations can appear in a non-static universal context,
6750 -- in which case the integer argument must be converted explicitly.
6752 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
6754 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
6756 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
6758 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
6760 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
6762 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
6764 -- Non-fixed point cases, do integer zero divide and overflow checks
6766 elsif Is_Integer_Type
(Typ
) then
6767 Apply_Divide_Checks
(N
);
6770 -- Overflow checks for floating-point if -gnateF mode active
6772 Check_Float_Op_Overflow
(N
);
6773 end Expand_N_Op_Divide
;
6775 --------------------
6776 -- Expand_N_Op_Eq --
6777 --------------------
6779 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
6780 Loc
: constant Source_Ptr
:= Sloc
(N
);
6781 Typ
: constant Entity_Id
:= Etype
(N
);
6782 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
6783 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
6784 Bodies
: constant List_Id
:= New_List
;
6785 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
6787 Typl
: Entity_Id
:= A_Typ
;
6788 Op_Name
: Entity_Id
;
6791 procedure Build_Equality_Call
(Eq
: Entity_Id
);
6792 -- If a constructed equality exists for the type or for its parent,
6793 -- build and analyze call, adding conversions if the operation is
6796 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
6797 -- Determines whether a type has a subcomponent of an unconstrained
6798 -- Unchecked_Union subtype. Typ is a record type.
6800 -------------------------
6801 -- Build_Equality_Call --
6802 -------------------------
6804 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
6805 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
6806 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
6807 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
6810 -- Adjust operands if necessary to comparison type
6812 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
6813 and then not Is_Class_Wide_Type
(A_Typ
)
6815 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
6816 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
6819 -- If we have an Unchecked_Union, we need to add the inferred
6820 -- discriminant values as actuals in the function call. At this
6821 -- point, the expansion has determined that both operands have
6822 -- inferable discriminants.
6824 if Is_Unchecked_Union
(Op_Type
) then
6826 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
6827 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
6829 Lhs_Discr_Vals
: Elist_Id
;
6830 -- List of inferred discriminant values for left operand.
6832 Rhs_Discr_Vals
: Elist_Id
;
6833 -- List of inferred discriminant values for right operand.
6838 Lhs_Discr_Vals
:= New_Elmt_List
;
6839 Rhs_Discr_Vals
:= New_Elmt_List
;
6841 -- Per-object constrained selected components require special
6842 -- attention. If the enclosing scope of the component is an
6843 -- Unchecked_Union, we cannot reference its discriminants
6844 -- directly. This is why we use the extra parameters of the
6845 -- equality function of the enclosing Unchecked_Union.
6847 -- type UU_Type (Discr : Integer := 0) is
6850 -- pragma Unchecked_Union (UU_Type);
6852 -- 1. Unchecked_Union enclosing record:
6854 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6856 -- Comp : UU_Type (Discr);
6858 -- end Enclosing_UU_Type;
6859 -- pragma Unchecked_Union (Enclosing_UU_Type);
6861 -- Obj1 : Enclosing_UU_Type;
6862 -- Obj2 : Enclosing_UU_Type (1);
6864 -- [. . .] Obj1 = Obj2 [. . .]
6868 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6870 -- A and B are the formal parameters of the equality function
6871 -- of Enclosing_UU_Type. The function always has two extra
6872 -- formals to capture the inferred discriminant values for
6873 -- each discriminant of the type.
6875 -- 2. Non-Unchecked_Union enclosing record:
6878 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6881 -- Comp : UU_Type (Discr);
6883 -- end Enclosing_Non_UU_Type;
6885 -- Obj1 : Enclosing_Non_UU_Type;
6886 -- Obj2 : Enclosing_Non_UU_Type (1);
6888 -- ... Obj1 = Obj2 ...
6892 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6893 -- obj1.discr, obj2.discr)) then
6895 -- In this case we can directly reference the discriminants of
6896 -- the enclosing record.
6898 -- Process left operand of equality
6900 if Nkind
(Lhs
) = N_Selected_Component
6902 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
6904 -- If enclosing record is an Unchecked_Union, use formals
6905 -- corresponding to each discriminant. The name of the
6906 -- formal is that of the discriminant, with added suffix,
6907 -- see Exp_Ch3.Build_Record_Equality for details.
6909 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Lhs
))))
6913 (Scope
(Entity
(Selector_Name
(Lhs
))));
6914 while Present
(Discr
) loop
6916 (Make_Identifier
(Loc
,
6917 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
6918 To
=> Lhs_Discr_Vals
);
6919 Next_Discriminant
(Discr
);
6922 -- If enclosing record is of a non-Unchecked_Union type, it
6923 -- is possible to reference its discriminants directly.
6926 Discr
:= First_Discriminant
(Lhs_Type
);
6927 while Present
(Discr
) loop
6929 (Make_Selected_Component
(Loc
,
6930 Prefix
=> Prefix
(Lhs
),
6933 (Get_Discriminant_Value
(Discr
,
6935 Stored_Constraint
(Lhs_Type
)))),
6936 To
=> Lhs_Discr_Vals
);
6937 Next_Discriminant
(Discr
);
6941 -- Otherwise operand is on object with a constrained type.
6942 -- Infer the discriminant values from the constraint.
6946 Discr
:= First_Discriminant
(Lhs_Type
);
6947 while Present
(Discr
) loop
6950 (Get_Discriminant_Value
(Discr
,
6952 Stored_Constraint
(Lhs_Type
))),
6953 To
=> Lhs_Discr_Vals
);
6954 Next_Discriminant
(Discr
);
6958 -- Similar processing for right operand of equality
6960 if Nkind
(Rhs
) = N_Selected_Component
6962 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
6964 if Is_Unchecked_Union
6965 (Scope
(Entity
(Selector_Name
(Rhs
))))
6969 (Scope
(Entity
(Selector_Name
(Rhs
))));
6970 while Present
(Discr
) loop
6972 (Make_Identifier
(Loc
,
6973 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
6974 To
=> Rhs_Discr_Vals
);
6975 Next_Discriminant
(Discr
);
6979 Discr
:= First_Discriminant
(Rhs_Type
);
6980 while Present
(Discr
) loop
6982 (Make_Selected_Component
(Loc
,
6983 Prefix
=> Prefix
(Rhs
),
6985 New_Copy
(Get_Discriminant_Value
6988 Stored_Constraint
(Rhs_Type
)))),
6989 To
=> Rhs_Discr_Vals
);
6990 Next_Discriminant
(Discr
);
6995 Discr
:= First_Discriminant
(Rhs_Type
);
6996 while Present
(Discr
) loop
6998 (New_Copy
(Get_Discriminant_Value
7001 Stored_Constraint
(Rhs_Type
))),
7002 To
=> Rhs_Discr_Vals
);
7003 Next_Discriminant
(Discr
);
7007 -- Now merge the list of discriminant values so that values
7008 -- of corresponding discriminants are adjacent.
7016 Params
:= New_List
(L_Exp
, R_Exp
);
7017 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
7018 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
7019 while Present
(L_Elmt
) loop
7020 Append_To
(Params
, Node
(L_Elmt
));
7021 Append_To
(Params
, Node
(R_Elmt
));
7027 Make_Function_Call
(Loc
,
7028 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7029 Parameter_Associations
=> Params
));
7033 -- Normal case, not an unchecked union
7037 Make_Function_Call
(Loc
,
7038 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7039 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7042 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7043 end Build_Equality_Call
;
7045 ------------------------------------
7046 -- Has_Unconstrained_UU_Component --
7047 ------------------------------------
7049 function Has_Unconstrained_UU_Component
7050 (Typ
: Node_Id
) return Boolean
7052 Tdef
: constant Node_Id
:=
7053 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
7057 function Component_Is_Unconstrained_UU
7058 (Comp
: Node_Id
) return Boolean;
7059 -- Determines whether the subtype of the component is an
7060 -- unconstrained Unchecked_Union.
7062 function Variant_Is_Unconstrained_UU
7063 (Variant
: Node_Id
) return Boolean;
7064 -- Determines whether a component of the variant has an unconstrained
7065 -- Unchecked_Union subtype.
7067 -----------------------------------
7068 -- Component_Is_Unconstrained_UU --
7069 -----------------------------------
7071 function Component_Is_Unconstrained_UU
7072 (Comp
: Node_Id
) return Boolean
7075 if Nkind
(Comp
) /= N_Component_Declaration
then
7080 Sindic
: constant Node_Id
:=
7081 Subtype_Indication
(Component_Definition
(Comp
));
7084 -- Unconstrained nominal type. In the case of a constraint
7085 -- present, the node kind would have been N_Subtype_Indication.
7087 if Nkind
(Sindic
) = N_Identifier
then
7088 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
7093 end Component_Is_Unconstrained_UU
;
7095 ---------------------------------
7096 -- Variant_Is_Unconstrained_UU --
7097 ---------------------------------
7099 function Variant_Is_Unconstrained_UU
7100 (Variant
: Node_Id
) return Boolean
7102 Clist
: constant Node_Id
:= Component_List
(Variant
);
7105 if Is_Empty_List
(Component_Items
(Clist
)) then
7109 -- We only need to test one component
7112 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7115 while Present
(Comp
) loop
7116 if Component_Is_Unconstrained_UU
(Comp
) then
7124 -- None of the components withing the variant were of
7125 -- unconstrained Unchecked_Union type.
7128 end Variant_Is_Unconstrained_UU
;
7130 -- Start of processing for Has_Unconstrained_UU_Component
7133 if Null_Present
(Tdef
) then
7137 Clist
:= Component_List
(Tdef
);
7138 Vpart
:= Variant_Part
(Clist
);
7140 -- Inspect available components
7142 if Present
(Component_Items
(Clist
)) then
7144 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7147 while Present
(Comp
) loop
7149 -- One component is sufficient
7151 if Component_Is_Unconstrained_UU
(Comp
) then
7160 -- Inspect available components withing variants
7162 if Present
(Vpart
) then
7164 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7167 while Present
(Variant
) loop
7169 -- One component within a variant is sufficient
7171 if Variant_Is_Unconstrained_UU
(Variant
) then
7180 -- Neither the available components, nor the components inside the
7181 -- variant parts were of an unconstrained Unchecked_Union subtype.
7184 end Has_Unconstrained_UU_Component
;
7186 -- Start of processing for Expand_N_Op_Eq
7189 Binary_Op_Validity_Checks
(N
);
7191 -- Deal with private types
7193 if Ekind
(Typl
) = E_Private_Type
then
7194 Typl
:= Underlying_Type
(Typl
);
7195 elsif Ekind
(Typl
) = E_Private_Subtype
then
7196 Typl
:= Underlying_Type
(Base_Type
(Typl
));
7201 -- It may happen in error situations that the underlying type is not
7202 -- set. The error will be detected later, here we just defend the
7209 -- Now get the implementation base type (note that plain Base_Type here
7210 -- might lead us back to the private type, which is not what we want!)
7212 Typl
:= Implementation_Base_Type
(Typl
);
7214 -- Equality between variant records results in a call to a routine
7215 -- that has conditional tests of the discriminant value(s), and hence
7216 -- violates the No_Implicit_Conditionals restriction.
7218 if Has_Variant_Part
(Typl
) then
7223 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
7227 ("\comparison of variant records tests discriminants", N
);
7233 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7234 -- means we no longer have a comparison operation, we are all done.
7236 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7238 if Nkind
(N
) /= N_Op_Eq
then
7242 -- Boolean types (requiring handling of non-standard case)
7244 if Is_Boolean_Type
(Typl
) then
7245 Adjust_Condition
(Left_Opnd
(N
));
7246 Adjust_Condition
(Right_Opnd
(N
));
7247 Set_Etype
(N
, Standard_Boolean
);
7248 Adjust_Result_Type
(N
, Typ
);
7252 elsif Is_Array_Type
(Typl
) then
7254 -- If we are doing full validity checking, and it is possible for the
7255 -- array elements to be invalid then expand out array comparisons to
7256 -- make sure that we check the array elements.
7258 if Validity_Check_Operands
7259 and then not Is_Known_Valid
(Component_Type
(Typl
))
7262 Save_Force_Validity_Checks
: constant Boolean :=
7263 Force_Validity_Checks
;
7265 Force_Validity_Checks
:= True;
7267 Expand_Array_Equality
7269 Relocate_Node
(Lhs
),
7270 Relocate_Node
(Rhs
),
7273 Insert_Actions
(N
, Bodies
);
7274 Analyze_And_Resolve
(N
, Standard_Boolean
);
7275 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7278 -- Packed case where both operands are known aligned
7280 elsif Is_Bit_Packed_Array
(Typl
)
7281 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7282 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7284 Expand_Packed_Eq
(N
);
7286 -- Where the component type is elementary we can use a block bit
7287 -- comparison (if supported on the target) exception in the case
7288 -- of floating-point (negative zero issues require element by
7289 -- element comparison), and atomic types (where we must be sure
7290 -- to load elements independently) and possibly unaligned arrays.
7292 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7293 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7294 and then not Is_Atomic
(Component_Type
(Typl
))
7295 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7296 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7297 and then Support_Composite_Compare_On_Target
7301 -- For composite and floating-point cases, expand equality loop to
7302 -- make sure of using proper comparisons for tagged types, and
7303 -- correctly handling the floating-point case.
7307 Expand_Array_Equality
7309 Relocate_Node
(Lhs
),
7310 Relocate_Node
(Rhs
),
7313 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7314 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7319 elsif Is_Record_Type
(Typl
) then
7321 -- For tagged types, use the primitive "="
7323 if Is_Tagged_Type
(Typl
) then
7325 -- No need to do anything else compiling under restriction
7326 -- No_Dispatching_Calls. During the semantic analysis we
7327 -- already notified such violation.
7329 if Restriction_Active
(No_Dispatching_Calls
) then
7333 -- If this is derived from an untagged private type completed with
7334 -- a tagged type, it does not have a full view, so we use the
7335 -- primitive operations of the private type. This check should no
7336 -- longer be necessary when these types get their full views???
7338 if Is_Private_Type
(A_Typ
)
7339 and then not Is_Tagged_Type
(A_Typ
)
7340 and then Is_Derived_Type
(A_Typ
)
7341 and then No
(Full_View
(A_Typ
))
7343 -- Search for equality operation, checking that the operands
7344 -- have the same type. Note that we must find a matching entry,
7345 -- or something is very wrong.
7347 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7349 while Present
(Prim
) loop
7350 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7351 and then Etype
(First_Formal
(Node
(Prim
))) =
7352 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7354 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7359 pragma Assert
(Present
(Prim
));
7360 Op_Name
:= Node
(Prim
);
7362 -- Find the type's predefined equality or an overriding
7363 -- user-defined equality. The reason for not simply calling
7364 -- Find_Prim_Op here is that there may be a user-defined
7365 -- overloaded equality op that precedes the equality that we
7366 -- want, so we have to explicitly search (e.g., there could be
7367 -- an equality with two different parameter types).
7370 if Is_Class_Wide_Type
(Typl
) then
7371 Typl
:= Find_Specific_Type
(Typl
);
7374 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7375 while Present
(Prim
) loop
7376 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7377 and then Etype
(First_Formal
(Node
(Prim
))) =
7378 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7380 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7385 pragma Assert
(Present
(Prim
));
7386 Op_Name
:= Node
(Prim
);
7389 Build_Equality_Call
(Op_Name
);
7391 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7392 -- predefined equality operator for a type which has a subcomponent
7393 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7395 elsif Has_Unconstrained_UU_Component
(Typl
) then
7397 Make_Raise_Program_Error
(Loc
,
7398 Reason
=> PE_Unchecked_Union_Restriction
));
7400 -- Prevent Gigi from generating incorrect code by rewriting the
7401 -- equality as a standard False. (is this documented somewhere???)
7404 New_Occurrence_Of
(Standard_False
, Loc
));
7406 elsif Is_Unchecked_Union
(Typl
) then
7408 -- If we can infer the discriminants of the operands, we make a
7409 -- call to the TSS equality function.
7411 if Has_Inferable_Discriminants
(Lhs
)
7413 Has_Inferable_Discriminants
(Rhs
)
7416 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7419 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7420 -- the predefined equality operator for an Unchecked_Union type
7421 -- if either of the operands lack inferable discriminants.
7424 Make_Raise_Program_Error
(Loc
,
7425 Reason
=> PE_Unchecked_Union_Restriction
));
7427 -- Emit a warning on source equalities only, otherwise the
7428 -- message may appear out of place due to internal use. The
7429 -- warning is unconditional because it is required by the
7432 if Comes_From_Source
(N
) then
7434 ("Unchecked_Union discriminants cannot be determined??",
7437 ("\Program_Error will be raised for equality operation??",
7441 -- Prevent Gigi from generating incorrect code by rewriting
7442 -- the equality as a standard False (documented where???).
7445 New_Occurrence_Of
(Standard_False
, Loc
));
7448 -- If a type support function is present (for complex cases), use it
7450 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7452 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7454 -- When comparing two Bounded_Strings, use the primitive equality of
7455 -- the root Super_String type.
7457 elsif Is_Bounded_String
(Typl
) then
7459 First_Elmt
(Collect_Primitive_Operations
(Root_Type
(Typl
)));
7461 while Present
(Prim
) loop
7462 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7463 and then Etype
(First_Formal
(Node
(Prim
))) =
7464 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7465 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7470 -- A Super_String type should always have a primitive equality
7472 pragma Assert
(Present
(Prim
));
7473 Build_Equality_Call
(Node
(Prim
));
7475 -- Otherwise expand the component by component equality. Note that
7476 -- we never use block-bit comparisons for records, because of the
7477 -- problems with gaps. The backend will often be able to recombine
7478 -- the separate comparisons that we generate here.
7481 Remove_Side_Effects
(Lhs
);
7482 Remove_Side_Effects
(Rhs
);
7484 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7486 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7487 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7491 -- Test if result is known at compile time
7493 Rewrite_Comparison
(N
);
7495 Optimize_Length_Comparison
(N
);
7498 -----------------------
7499 -- Expand_N_Op_Expon --
7500 -----------------------
7502 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
7503 Loc
: constant Source_Ptr
:= Sloc
(N
);
7504 Typ
: constant Entity_Id
:= Etype
(N
);
7505 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
7506 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
7507 Bastyp
: constant Node_Id
:= Etype
(Base
);
7508 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
7509 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
7510 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
7519 Binary_Op_Validity_Checks
(N
);
7521 -- CodePeer wants to see the unexpanded N_Op_Expon node
7523 if CodePeer_Mode
then
7527 -- If either operand is of a private type, then we have the use of an
7528 -- intrinsic operator, and we get rid of the privateness, by using root
7529 -- types of underlying types for the actual operation. Otherwise the
7530 -- private types will cause trouble if we expand multiplications or
7531 -- shifts etc. We also do this transformation if the result type is
7532 -- different from the base type.
7534 if Is_Private_Type
(Etype
(Base
))
7535 or else Is_Private_Type
(Typ
)
7536 or else Is_Private_Type
(Exptyp
)
7537 or else Rtyp
/= Root_Type
(Bastyp
)
7540 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
7541 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
7544 Unchecked_Convert_To
(Typ
,
7546 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
7547 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
7548 Analyze_And_Resolve
(N
, Typ
);
7553 -- Check for MINIMIZED/ELIMINATED overflow mode
7555 if Minimized_Eliminated_Overflow_Check
(N
) then
7556 Apply_Arithmetic_Overflow_Check
(N
);
7560 -- Test for case of known right argument where we can replace the
7561 -- exponentiation by an equivalent expression using multiplication.
7563 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7564 -- configurable run-time mode, we may not have the exponentiation
7565 -- routine available, and we don't want the legality of the program
7566 -- to depend on how clever the compiler is in knowing values.
7568 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
7569 Expv
:= Expr_Value
(Exp
);
7571 -- We only fold small non-negative exponents. You might think we
7572 -- could fold small negative exponents for the real case, but we
7573 -- can't because we are required to raise Constraint_Error for
7574 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7575 -- See ACVC test C4A012B.
7577 if Expv
>= 0 and then Expv
<= 4 then
7579 -- X ** 0 = 1 (or 1.0)
7583 -- Call Remove_Side_Effects to ensure that any side effects
7584 -- in the ignored left operand (in particular function calls
7585 -- to user defined functions) are properly executed.
7587 Remove_Side_Effects
(Base
);
7589 if Ekind
(Typ
) in Integer_Kind
then
7590 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
7592 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
7604 Make_Op_Multiply
(Loc
,
7605 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7606 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7608 -- X ** 3 = X * X * X
7612 Make_Op_Multiply
(Loc
,
7614 Make_Op_Multiply
(Loc
,
7615 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7616 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
7617 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7622 -- En : constant base'type := base * base;
7627 pragma Assert
(Expv
= 4);
7628 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
7631 Make_Expression_With_Actions
(Loc
,
7632 Actions
=> New_List
(
7633 Make_Object_Declaration
(Loc
,
7634 Defining_Identifier
=> Temp
,
7635 Constant_Present
=> True,
7636 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7638 Make_Op_Multiply
(Loc
,
7640 Duplicate_Subexpr
(Base
),
7642 Duplicate_Subexpr_No_Checks
(Base
)))),
7645 Make_Op_Multiply
(Loc
,
7646 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
7647 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
)));
7651 Analyze_And_Resolve
(N
, Typ
);
7656 -- Deal with optimizing 2 ** expression to shift where possible
7658 -- Note: we used to check that Exptyp was an unsigned type. But that is
7659 -- an unnecessary check, since if Exp is negative, we have a run-time
7660 -- error that is either caught (so we get the right result) or we have
7661 -- suppressed the check, in which case the code is erroneous anyway.
7663 if Is_Integer_Type
(Rtyp
)
7665 -- The base value must be safe, compile-time known, and exactly 2
7667 and then Nkind
(Base
) = N_Integer_Literal
7668 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
7669 and then Expr_Value
(Base
) = Uint_2
7671 -- We only handle cases where the right type is a integer
7673 and then Is_Integer_Type
(Root_Type
(Exptyp
))
7674 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
7676 -- This transformation is not applicable for a modular type with a
7677 -- nonbinary modulus because we do not handle modular reduction in
7678 -- a correct manner if we attempt this transformation in this case.
7680 and then not Non_Binary_Modulus
(Typ
)
7682 -- Handle the cases where our parent is a division or multiplication
7683 -- specially. In these cases we can convert to using a shift at the
7684 -- parent level if we are not doing overflow checking, since it is
7685 -- too tricky to combine the overflow check at the parent level.
7688 and then Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
)
7691 P
: constant Node_Id
:= Parent
(N
);
7692 L
: constant Node_Id
:= Left_Opnd
(P
);
7693 R
: constant Node_Id
:= Right_Opnd
(P
);
7696 if (Nkind
(P
) = N_Op_Multiply
7698 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
7700 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
7701 and then not Do_Overflow_Check
(P
))
7704 (Nkind
(P
) = N_Op_Divide
7705 and then Is_Integer_Type
(Etype
(L
))
7706 and then Is_Unsigned_Type
(Etype
(L
))
7708 and then not Do_Overflow_Check
(P
))
7710 Set_Is_Power_Of_2_For_Shift
(N
);
7715 -- Here we just have 2 ** N on its own, so we can convert this to a
7716 -- shift node. We are prepared to deal with overflow here, and we
7717 -- also have to handle proper modular reduction for binary modular.
7726 -- Maximum shift count with no overflow
7729 -- Set True if we must test the shift count
7732 -- Compute maximum shift based on the underlying size. For a
7733 -- modular type this is one less than the size.
7735 if Is_Modular_Integer_Type
(Typ
) then
7737 -- For modular integer types, this is the size of the value
7738 -- being shifted minus one. Any larger values will cause
7739 -- modular reduction to a result of zero. Note that we do
7740 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
7741 -- of 6, since 2**7 should be reduced to zero).
7743 MaxS
:= RM_Size
(Rtyp
) - 1;
7745 -- For signed integer types, we use the size of the value
7746 -- being shifted minus 2. Larger values cause overflow.
7749 MaxS
:= Esize
(Rtyp
) - 2;
7752 -- Determine range to see if it can be larger than MaxS
7755 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
7756 TestS
:= (not OK
) or else Hi
> MaxS
;
7758 -- Signed integer case
7760 if Is_Signed_Integer_Type
(Typ
) then
7762 -- Generate overflow check if overflow is active. Note that
7763 -- we can simply ignore the possibility of overflow if the
7764 -- flag is not set (means that overflow cannot happen or
7765 -- that overflow checks are suppressed).
7767 if Ovflo
and TestS
then
7769 Make_Raise_Constraint_Error
(Loc
,
7772 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
7773 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
7774 Reason
=> CE_Overflow_Check_Failed
));
7777 -- Now rewrite node as Shift_Left (1, right-operand)
7780 Make_Op_Shift_Left
(Loc
,
7781 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7782 Right_Opnd
=> Right_Opnd
(N
)));
7784 -- Modular integer case
7786 else pragma Assert
(Is_Modular_Integer_Type
(Typ
));
7788 -- If shift count can be greater than MaxS, we need to wrap
7789 -- the shift in a test that will reduce the result value to
7790 -- zero if this shift count is exceeded.
7794 Make_If_Expression
(Loc
,
7795 Expressions
=> New_List
(
7797 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
7798 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
7800 Make_Integer_Literal
(Loc
, Uint_0
),
7802 Make_Op_Shift_Left
(Loc
,
7803 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7804 Right_Opnd
=> Right_Opnd
(N
)))));
7806 -- If we know shift count cannot be greater than MaxS, then
7807 -- it is safe to just rewrite as a shift with no test.
7811 Make_Op_Shift_Left
(Loc
,
7812 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7813 Right_Opnd
=> Right_Opnd
(N
)));
7817 Analyze_And_Resolve
(N
, Typ
);
7823 -- Fall through if exponentiation must be done using a runtime routine
7825 -- First deal with modular case
7827 if Is_Modular_Integer_Type
(Rtyp
) then
7829 -- Non-binary case, we call the special exponentiation routine for
7830 -- the non-binary case, converting the argument to Long_Long_Integer
7831 -- and passing the modulus value. Then the result is converted back
7832 -- to the base type.
7834 if Non_Binary_Modulus
(Rtyp
) then
7837 Make_Function_Call
(Loc
,
7839 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
7840 Parameter_Associations
=> New_List
(
7841 Convert_To
(RTE
(RE_Unsigned
), Base
),
7842 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
7845 -- Binary case, in this case, we call one of two routines, either the
7846 -- unsigned integer case, or the unsigned long long integer case,
7847 -- with a final "and" operation to do the required mod.
7850 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
7851 Ent
:= RTE
(RE_Exp_Unsigned
);
7853 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
7860 Make_Function_Call
(Loc
,
7861 Name
=> New_Occurrence_Of
(Ent
, Loc
),
7862 Parameter_Associations
=> New_List
(
7863 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
7866 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
7870 -- Common exit point for modular type case
7872 Analyze_And_Resolve
(N
, Typ
);
7875 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7876 -- It is not worth having routines for Short_[Short_]Integer, since for
7877 -- most machines it would not help, and it would generate more code that
7878 -- might need certification when a certified run time is required.
7880 -- In the integer cases, we have two routines, one for when overflow
7881 -- checks are required, and one when they are not required, since there
7882 -- is a real gain in omitting checks on many machines.
7884 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
7885 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
7887 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
7888 or else Rtyp
= Universal_Integer
7890 Etyp
:= Standard_Long_Long_Integer
;
7892 -- Overflow checking is the only choice on the AAMP target, where
7893 -- arithmetic instructions check overflow automatically, so only
7894 -- one version of the exponentiation unit is needed.
7896 if Ovflo
or AAMP_On_Target
then
7897 Rent
:= RE_Exp_Long_Long_Integer
;
7899 Rent
:= RE_Exn_Long_Long_Integer
;
7902 elsif Is_Signed_Integer_Type
(Rtyp
) then
7903 Etyp
:= Standard_Integer
;
7905 -- Overflow checking is the only choice on the AAMP target, where
7906 -- arithmetic instructions check overflow automatically, so only
7907 -- one version of the exponentiation unit is needed.
7909 if Ovflo
or AAMP_On_Target
then
7910 Rent
:= RE_Exp_Integer
;
7912 Rent
:= RE_Exn_Integer
;
7915 -- Floating-point cases, always done using Long_Long_Float. We do not
7916 -- need separate routines for the overflow case here, since in the case
7917 -- of floating-point, we generate infinities anyway as a rule (either
7918 -- that or we automatically trap overflow), and if there is an infinity
7919 -- generated and a range check is required, the check will fail anyway.
7922 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
7923 Etyp
:= Standard_Long_Long_Float
;
7924 Rent
:= RE_Exn_Long_Long_Float
;
7927 -- Common processing for integer cases and floating-point cases.
7928 -- If we are in the right type, we can call runtime routine directly
7931 and then Rtyp
/= Universal_Integer
7932 and then Rtyp
/= Universal_Real
7935 Make_Function_Call
(Loc
,
7936 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
7937 Parameter_Associations
=> New_List
(Base
, Exp
)));
7939 -- Otherwise we have to introduce conversions (conversions are also
7940 -- required in the universal cases, since the runtime routine is
7941 -- typed using one of the standard types).
7946 Make_Function_Call
(Loc
,
7947 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
7948 Parameter_Associations
=> New_List
(
7949 Convert_To
(Etyp
, Base
),
7953 Analyze_And_Resolve
(N
, Typ
);
7957 when RE_Not_Available
=>
7959 end Expand_N_Op_Expon
;
7961 --------------------
7962 -- Expand_N_Op_Ge --
7963 --------------------
7965 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
7966 Typ
: constant Entity_Id
:= Etype
(N
);
7967 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7968 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7969 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7972 Binary_Op_Validity_Checks
(N
);
7974 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7975 -- means we no longer have a comparison operation, we are all done.
7977 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7979 if Nkind
(N
) /= N_Op_Ge
then
7985 if Is_Array_Type
(Typ1
) then
7986 Expand_Array_Comparison
(N
);
7990 -- Deal with boolean operands
7992 if Is_Boolean_Type
(Typ1
) then
7993 Adjust_Condition
(Op1
);
7994 Adjust_Condition
(Op2
);
7995 Set_Etype
(N
, Standard_Boolean
);
7996 Adjust_Result_Type
(N
, Typ
);
7999 Rewrite_Comparison
(N
);
8001 Optimize_Length_Comparison
(N
);
8004 --------------------
8005 -- Expand_N_Op_Gt --
8006 --------------------
8008 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
8009 Typ
: constant Entity_Id
:= Etype
(N
);
8010 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8011 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8012 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8015 Binary_Op_Validity_Checks
(N
);
8017 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8018 -- means we no longer have a comparison operation, we are all done.
8020 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8022 if Nkind
(N
) /= N_Op_Gt
then
8026 -- Deal with array type operands
8028 if Is_Array_Type
(Typ1
) then
8029 Expand_Array_Comparison
(N
);
8033 -- Deal with boolean type operands
8035 if Is_Boolean_Type
(Typ1
) then
8036 Adjust_Condition
(Op1
);
8037 Adjust_Condition
(Op2
);
8038 Set_Etype
(N
, Standard_Boolean
);
8039 Adjust_Result_Type
(N
, Typ
);
8042 Rewrite_Comparison
(N
);
8044 Optimize_Length_Comparison
(N
);
8047 --------------------
8048 -- Expand_N_Op_Le --
8049 --------------------
8051 procedure Expand_N_Op_Le
(N
: Node_Id
) is
8052 Typ
: constant Entity_Id
:= Etype
(N
);
8053 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8054 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8055 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8058 Binary_Op_Validity_Checks
(N
);
8060 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8061 -- means we no longer have a comparison operation, we are all done.
8063 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8065 if Nkind
(N
) /= N_Op_Le
then
8069 -- Deal with array type operands
8071 if Is_Array_Type
(Typ1
) then
8072 Expand_Array_Comparison
(N
);
8076 -- Deal with Boolean type operands
8078 if Is_Boolean_Type
(Typ1
) then
8079 Adjust_Condition
(Op1
);
8080 Adjust_Condition
(Op2
);
8081 Set_Etype
(N
, Standard_Boolean
);
8082 Adjust_Result_Type
(N
, Typ
);
8085 Rewrite_Comparison
(N
);
8087 Optimize_Length_Comparison
(N
);
8090 --------------------
8091 -- Expand_N_Op_Lt --
8092 --------------------
8094 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
8095 Typ
: constant Entity_Id
:= Etype
(N
);
8096 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8097 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8098 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8101 Binary_Op_Validity_Checks
(N
);
8103 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8104 -- means we no longer have a comparison operation, we are all done.
8106 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8108 if Nkind
(N
) /= N_Op_Lt
then
8112 -- Deal with array type operands
8114 if Is_Array_Type
(Typ1
) then
8115 Expand_Array_Comparison
(N
);
8119 -- Deal with Boolean type operands
8121 if Is_Boolean_Type
(Typ1
) then
8122 Adjust_Condition
(Op1
);
8123 Adjust_Condition
(Op2
);
8124 Set_Etype
(N
, Standard_Boolean
);
8125 Adjust_Result_Type
(N
, Typ
);
8128 Rewrite_Comparison
(N
);
8130 Optimize_Length_Comparison
(N
);
8133 -----------------------
8134 -- Expand_N_Op_Minus --
8135 -----------------------
8137 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
8138 Loc
: constant Source_Ptr
:= Sloc
(N
);
8139 Typ
: constant Entity_Id
:= Etype
(N
);
8142 Unary_Op_Validity_Checks
(N
);
8144 -- Check for MINIMIZED/ELIMINATED overflow mode
8146 if Minimized_Eliminated_Overflow_Check
(N
) then
8147 Apply_Arithmetic_Overflow_Check
(N
);
8151 if not Backend_Overflow_Checks_On_Target
8152 and then Is_Signed_Integer_Type
(Etype
(N
))
8153 and then Do_Overflow_Check
(N
)
8155 -- Software overflow checking expands -expr into (0 - expr)
8158 Make_Op_Subtract
(Loc
,
8159 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
8160 Right_Opnd
=> Right_Opnd
(N
)));
8162 Analyze_And_Resolve
(N
, Typ
);
8164 end Expand_N_Op_Minus
;
8166 ---------------------
8167 -- Expand_N_Op_Mod --
8168 ---------------------
8170 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
8171 Loc
: constant Source_Ptr
:= Sloc
(N
);
8172 Typ
: constant Entity_Id
:= Etype
(N
);
8173 DDC
: constant Boolean := Do_Division_Check
(N
);
8186 pragma Warnings
(Off
, Lhi
);
8189 Binary_Op_Validity_Checks
(N
);
8191 -- Check for MINIMIZED/ELIMINATED overflow mode
8193 if Minimized_Eliminated_Overflow_Check
(N
) then
8194 Apply_Arithmetic_Overflow_Check
(N
);
8198 if Is_Integer_Type
(Etype
(N
)) then
8199 Apply_Divide_Checks
(N
);
8201 -- All done if we don't have a MOD any more, which can happen as a
8202 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8204 if Nkind
(N
) /= N_Op_Mod
then
8209 -- Proceed with expansion of mod operator
8211 Left
:= Left_Opnd
(N
);
8212 Right
:= Right_Opnd
(N
);
8214 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
8215 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
8217 -- Convert mod to rem if operands are both known to be non-negative, or
8218 -- both known to be non-positive (these are the cases in which rem and
8219 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8220 -- likely that this will improve the quality of code, (the operation now
8221 -- corresponds to the hardware remainder), and it does not seem likely
8222 -- that it could be harmful. It also avoids some cases of the elaborate
8223 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8226 and then ((Llo
>= 0 and then Rlo
>= 0)
8228 (Lhi
<= 0 and then Rhi
<= 0))
8231 Make_Op_Rem
(Sloc
(N
),
8232 Left_Opnd
=> Left_Opnd
(N
),
8233 Right_Opnd
=> Right_Opnd
(N
)));
8235 -- Instead of reanalyzing the node we do the analysis manually. This
8236 -- avoids anomalies when the replacement is done in an instance and
8237 -- is epsilon more efficient.
8239 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
8241 Set_Do_Division_Check
(N
, DDC
);
8242 Expand_N_Op_Rem
(N
);
8246 -- Otherwise, normal mod processing
8249 -- Apply optimization x mod 1 = 0. We don't really need that with
8250 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
8251 -- certainly harmless.
8253 if Is_Integer_Type
(Etype
(N
))
8254 and then Compile_Time_Known_Value
(Right
)
8255 and then Expr_Value
(Right
) = Uint_1
8257 -- Call Remove_Side_Effects to ensure that any side effects in
8258 -- the ignored left operand (in particular function calls to
8259 -- user defined functions) are properly executed.
8261 Remove_Side_Effects
(Left
);
8263 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8264 Analyze_And_Resolve
(N
, Typ
);
8268 -- If we still have a mod operator and we are in Modify_Tree_For_C
8269 -- mode, and we have a signed integer type, then here is where we do
8270 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8271 -- for the special handling of the annoying case of largest negative
8272 -- number mod minus one.
8274 if Nkind
(N
) = N_Op_Mod
8275 and then Is_Signed_Integer_Type
(Typ
)
8276 and then Modify_Tree_For_C
8278 -- In the general case, we expand A mod B as
8280 -- Tnn : constant typ := A rem B;
8282 -- (if (A >= 0) = (B >= 0) then Tnn
8283 -- elsif Tnn = 0 then 0
8286 -- The comparison can be written simply as A >= 0 if we know that
8287 -- B >= 0 which is a very common case.
8289 -- An important optimization is when B is known at compile time
8290 -- to be 2**K for some constant. In this case we can simply AND
8291 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8292 -- and that works for both the positive and negative cases.
8295 P2
: constant Nat
:= Power_Of_Two
(Right
);
8300 Unchecked_Convert_To
(Typ
,
8303 Unchecked_Convert_To
8304 (Corresponding_Unsigned_Type
(Typ
), Left
),
8306 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
8307 Analyze_And_Resolve
(N
, Typ
);
8312 -- Here for the full rewrite
8315 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
8321 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
8322 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
8324 if not LOK
or else Rlo
< 0 then
8330 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
8331 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
8335 Make_Object_Declaration
(Loc
,
8336 Defining_Identifier
=> Tnn
,
8337 Constant_Present
=> True,
8338 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8342 Right_Opnd
=> Right
)));
8345 Make_If_Expression
(Loc
,
8346 Expressions
=> New_List
(
8348 New_Occurrence_Of
(Tnn
, Loc
),
8349 Make_If_Expression
(Loc
,
8351 Expressions
=> New_List
(
8353 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8354 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
8355 Make_Integer_Literal
(Loc
, 0),
8357 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8359 Duplicate_Subexpr_No_Checks
(Right
)))))));
8361 Analyze_And_Resolve
(N
, Typ
);
8366 -- Deal with annoying case of largest negative number mod minus one.
8367 -- Gigi may not handle this case correctly, because on some targets,
8368 -- the mod value is computed using a divide instruction which gives
8369 -- an overflow trap for this case.
8371 -- It would be a bit more efficient to figure out which targets
8372 -- this is really needed for, but in practice it is reasonable
8373 -- to do the following special check in all cases, since it means
8374 -- we get a clearer message, and also the overhead is minimal given
8375 -- that division is expensive in any case.
8377 -- In fact the check is quite easy, if the right operand is -1, then
8378 -- the mod value is always 0, and we can just ignore the left operand
8379 -- completely in this case.
8381 -- This only applies if we still have a mod operator. Skip if we
8382 -- have already rewritten this (e.g. in the case of eliminated
8383 -- overflow checks which have driven us into bignum mode).
8385 if Nkind
(N
) = N_Op_Mod
then
8387 -- The operand type may be private (e.g. in the expansion of an
8388 -- intrinsic operation) so we must use the underlying type to get
8389 -- the bounds, and convert the literals explicitly.
8393 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
8395 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
8396 and then ((not LOK
) or else (Llo
= LLB
))
8399 Make_If_Expression
(Loc
,
8400 Expressions
=> New_List
(
8402 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8404 Unchecked_Convert_To
(Typ
,
8405 Make_Integer_Literal
(Loc
, -1))),
8406 Unchecked_Convert_To
(Typ
,
8407 Make_Integer_Literal
(Loc
, Uint_0
)),
8408 Relocate_Node
(N
))));
8410 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8411 Analyze_And_Resolve
(N
, Typ
);
8415 end Expand_N_Op_Mod
;
8417 --------------------------
8418 -- Expand_N_Op_Multiply --
8419 --------------------------
8421 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
8422 Loc
: constant Source_Ptr
:= Sloc
(N
);
8423 Lop
: constant Node_Id
:= Left_Opnd
(N
);
8424 Rop
: constant Node_Id
:= Right_Opnd
(N
);
8426 Lp2
: constant Boolean :=
8427 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
8428 Rp2
: constant Boolean :=
8429 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
8431 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
8432 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
8433 Typ
: Entity_Id
:= Etype
(N
);
8436 Binary_Op_Validity_Checks
(N
);
8438 -- Check for MINIMIZED/ELIMINATED overflow mode
8440 if Minimized_Eliminated_Overflow_Check
(N
) then
8441 Apply_Arithmetic_Overflow_Check
(N
);
8445 -- Special optimizations for integer types
8447 if Is_Integer_Type
(Typ
) then
8449 -- N * 0 = 0 for integer types
8451 if Compile_Time_Known_Value
(Rop
)
8452 and then Expr_Value
(Rop
) = Uint_0
8454 -- Call Remove_Side_Effects to ensure that any side effects in
8455 -- the ignored left operand (in particular function calls to
8456 -- user defined functions) are properly executed.
8458 Remove_Side_Effects
(Lop
);
8460 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8461 Analyze_And_Resolve
(N
, Typ
);
8465 -- Similar handling for 0 * N = 0
8467 if Compile_Time_Known_Value
(Lop
)
8468 and then Expr_Value
(Lop
) = Uint_0
8470 Remove_Side_Effects
(Rop
);
8471 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8472 Analyze_And_Resolve
(N
, Typ
);
8476 -- N * 1 = 1 * N = N for integer types
8478 -- This optimisation is not done if we are going to
8479 -- rewrite the product 1 * 2 ** N to a shift.
8481 if Compile_Time_Known_Value
(Rop
)
8482 and then Expr_Value
(Rop
) = Uint_1
8488 elsif Compile_Time_Known_Value
(Lop
)
8489 and then Expr_Value
(Lop
) = Uint_1
8497 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8498 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8499 -- operand is an integer, as required for this to work.
8504 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8508 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
8511 Left_Opnd
=> Right_Opnd
(Lop
),
8512 Right_Opnd
=> Right_Opnd
(Rop
))));
8513 Analyze_And_Resolve
(N
, Typ
);
8517 -- If the result is modular, perform the reduction of the result
8520 if Is_Modular_Integer_Type
(Typ
)
8521 and then not Non_Binary_Modulus
(Typ
)
8526 Make_Op_Shift_Left
(Loc
,
8529 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
8531 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8535 Make_Op_Shift_Left
(Loc
,
8538 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
8541 Analyze_And_Resolve
(N
, Typ
);
8545 -- Same processing for the operands the other way round
8548 if Is_Modular_Integer_Type
(Typ
)
8549 and then not Non_Binary_Modulus
(Typ
)
8554 Make_Op_Shift_Left
(Loc
,
8557 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
8559 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8563 Make_Op_Shift_Left
(Loc
,
8566 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
8569 Analyze_And_Resolve
(N
, Typ
);
8573 -- Do required fixup of universal fixed operation
8575 if Typ
= Universal_Fixed
then
8576 Fixup_Universal_Fixed_Operation
(N
);
8580 -- Multiplications with fixed-point results
8582 if Is_Fixed_Point_Type
(Typ
) then
8584 -- No special processing if Treat_Fixed_As_Integer is set, since from
8585 -- a semantic point of view such operations are simply integer
8586 -- operations and will be treated that way.
8588 if not Treat_Fixed_As_Integer
(N
) then
8590 -- Case of fixed * integer => fixed
8592 if Is_Integer_Type
(Rtyp
) then
8593 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
8595 -- Case of integer * fixed => fixed
8597 elsif Is_Integer_Type
(Ltyp
) then
8598 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
8600 -- Case of fixed * fixed => fixed
8603 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
8607 -- Other cases of multiplication of fixed-point operands. Again we
8608 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8610 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
8611 and then not Treat_Fixed_As_Integer
(N
)
8613 if Is_Integer_Type
(Typ
) then
8614 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
8616 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8617 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
8620 -- Mixed-mode operations can appear in a non-static universal context,
8621 -- in which case the integer argument must be converted explicitly.
8623 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
8624 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
8625 Analyze_And_Resolve
(Rop
, Universal_Real
);
8627 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
8628 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
8629 Analyze_And_Resolve
(Lop
, Universal_Real
);
8631 -- Non-fixed point cases, check software overflow checking required
8633 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
8634 Apply_Arithmetic_Overflow_Check
(N
);
8637 -- Overflow checks for floating-point if -gnateF mode active
8639 Check_Float_Op_Overflow
(N
);
8640 end Expand_N_Op_Multiply
;
8642 --------------------
8643 -- Expand_N_Op_Ne --
8644 --------------------
8646 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
8647 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
8650 -- Case of elementary type with standard operator
8652 if Is_Elementary_Type
(Typ
)
8653 and then Sloc
(Entity
(N
)) = Standard_Location
8655 Binary_Op_Validity_Checks
(N
);
8657 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8658 -- means we no longer have a /= operation, we are all done.
8660 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8662 if Nkind
(N
) /= N_Op_Ne
then
8666 -- Boolean types (requiring handling of non-standard case)
8668 if Is_Boolean_Type
(Typ
) then
8669 Adjust_Condition
(Left_Opnd
(N
));
8670 Adjust_Condition
(Right_Opnd
(N
));
8671 Set_Etype
(N
, Standard_Boolean
);
8672 Adjust_Result_Type
(N
, Typ
);
8675 Rewrite_Comparison
(N
);
8677 -- For all cases other than elementary types, we rewrite node as the
8678 -- negation of an equality operation, and reanalyze. The equality to be
8679 -- used is defined in the same scope and has the same signature. This
8680 -- signature must be set explicitly since in an instance it may not have
8681 -- the same visibility as in the generic unit. This avoids duplicating
8682 -- or factoring the complex code for record/array equality tests etc.
8686 Loc
: constant Source_Ptr
:= Sloc
(N
);
8688 Ne
: constant Entity_Id
:= Entity
(N
);
8691 Binary_Op_Validity_Checks
(N
);
8697 Left_Opnd
=> Left_Opnd
(N
),
8698 Right_Opnd
=> Right_Opnd
(N
)));
8699 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
8701 if Scope
(Ne
) /= Standard_Standard
then
8702 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
8705 -- For navigation purposes, we want to treat the inequality as an
8706 -- implicit reference to the corresponding equality. Preserve the
8707 -- Comes_From_ source flag to generate proper Xref entries.
8709 Preserve_Comes_From_Source
(Neg
, N
);
8710 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
8712 Analyze_And_Resolve
(N
, Standard_Boolean
);
8716 Optimize_Length_Comparison
(N
);
8719 ---------------------
8720 -- Expand_N_Op_Not --
8721 ---------------------
8723 -- If the argument is other than a Boolean array type, there is no special
8724 -- expansion required, except for dealing with validity checks, and non-
8725 -- standard boolean representations.
8727 -- For the packed array case, we call the special routine in Exp_Pakd,
8728 -- except that if the component size is greater than one, we use the
8729 -- standard routine generating a gruesome loop (it is so peculiar to have
8730 -- packed arrays with non-standard Boolean representations anyway, so it
8731 -- does not matter that we do not handle this case efficiently).
8733 -- For the unpacked array case (and for the special packed case where we
8734 -- have non standard Booleans, as discussed above), we generate and insert
8735 -- into the tree the following function definition:
8737 -- function Nnnn (A : arr) is
8740 -- for J in a'range loop
8741 -- B (J) := not A (J);
8746 -- Here arr is the actual subtype of the parameter (and hence always
8747 -- constrained). Then we replace the not with a call to this function.
8749 procedure Expand_N_Op_Not
(N
: Node_Id
) is
8750 Loc
: constant Source_Ptr
:= Sloc
(N
);
8751 Typ
: constant Entity_Id
:= Etype
(N
);
8760 Func_Name
: Entity_Id
;
8761 Loop_Statement
: Node_Id
;
8764 Unary_Op_Validity_Checks
(N
);
8766 -- For boolean operand, deal with non-standard booleans
8768 if Is_Boolean_Type
(Typ
) then
8769 Adjust_Condition
(Right_Opnd
(N
));
8770 Set_Etype
(N
, Standard_Boolean
);
8771 Adjust_Result_Type
(N
, Typ
);
8775 -- Only array types need any other processing
8777 if not Is_Array_Type
(Typ
) then
8781 -- Case of array operand. If bit packed with a component size of 1,
8782 -- handle it in Exp_Pakd if the operand is known to be aligned.
8784 if Is_Bit_Packed_Array
(Typ
)
8785 and then Component_Size
(Typ
) = 1
8786 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
8788 Expand_Packed_Not
(N
);
8792 -- Case of array operand which is not bit-packed. If the context is
8793 -- a safe assignment, call in-place operation, If context is a larger
8794 -- boolean expression in the context of a safe assignment, expansion is
8795 -- done by enclosing operation.
8797 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
8798 Convert_To_Actual_Subtype
(Opnd
);
8799 Arr
:= Etype
(Opnd
);
8800 Ensure_Defined
(Arr
, N
);
8801 Silly_Boolean_Array_Not_Test
(N
, Arr
);
8803 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
8804 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
8805 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8808 -- Special case the negation of a binary operation
8810 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
8811 and then Safe_In_Place_Array_Op
8812 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
8814 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8818 elsif Nkind
(Parent
(N
)) in N_Binary_Op
8819 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
8822 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
8823 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
8824 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
8827 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
8829 -- (not A) op (not B) can be reduced to a single call
8831 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
8834 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
8837 -- A xor (not B) can also be special-cased
8839 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
8846 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
8847 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8848 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
8851 Make_Indexed_Component
(Loc
,
8852 Prefix
=> New_Occurrence_Of
(A
, Loc
),
8853 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8856 Make_Indexed_Component
(Loc
,
8857 Prefix
=> New_Occurrence_Of
(B
, Loc
),
8858 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8861 Make_Implicit_Loop_Statement
(N
,
8862 Identifier
=> Empty
,
8865 Make_Iteration_Scheme
(Loc
,
8866 Loop_Parameter_Specification
=>
8867 Make_Loop_Parameter_Specification
(Loc
,
8868 Defining_Identifier
=> J
,
8869 Discrete_Subtype_Definition
=>
8870 Make_Attribute_Reference
(Loc
,
8871 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
8872 Attribute_Name
=> Name_Range
))),
8874 Statements
=> New_List
(
8875 Make_Assignment_Statement
(Loc
,
8877 Expression
=> Make_Op_Not
(Loc
, A_J
))));
8879 Func_Name
:= Make_Temporary
(Loc
, 'N');
8880 Set_Is_Inlined
(Func_Name
);
8883 Make_Subprogram_Body
(Loc
,
8885 Make_Function_Specification
(Loc
,
8886 Defining_Unit_Name
=> Func_Name
,
8887 Parameter_Specifications
=> New_List
(
8888 Make_Parameter_Specification
(Loc
,
8889 Defining_Identifier
=> A
,
8890 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
8891 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8893 Declarations
=> New_List
(
8894 Make_Object_Declaration
(Loc
,
8895 Defining_Identifier
=> B
,
8896 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
8898 Handled_Statement_Sequence
=>
8899 Make_Handled_Sequence_Of_Statements
(Loc
,
8900 Statements
=> New_List
(
8902 Make_Simple_Return_Statement
(Loc
,
8903 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
8906 Make_Function_Call
(Loc
,
8907 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
8908 Parameter_Associations
=> New_List
(Opnd
)));
8910 Analyze_And_Resolve
(N
, Typ
);
8911 end Expand_N_Op_Not
;
8913 --------------------
8914 -- Expand_N_Op_Or --
8915 --------------------
8917 procedure Expand_N_Op_Or
(N
: Node_Id
) is
8918 Typ
: constant Entity_Id
:= Etype
(N
);
8921 Binary_Op_Validity_Checks
(N
);
8923 if Is_Array_Type
(Etype
(N
)) then
8924 Expand_Boolean_Operator
(N
);
8926 elsif Is_Boolean_Type
(Etype
(N
)) then
8927 Adjust_Condition
(Left_Opnd
(N
));
8928 Adjust_Condition
(Right_Opnd
(N
));
8929 Set_Etype
(N
, Standard_Boolean
);
8930 Adjust_Result_Type
(N
, Typ
);
8932 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8933 Expand_Intrinsic_Call
(N
, Entity
(N
));
8938 ----------------------
8939 -- Expand_N_Op_Plus --
8940 ----------------------
8942 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
8944 Unary_Op_Validity_Checks
(N
);
8946 -- Check for MINIMIZED/ELIMINATED overflow mode
8948 if Minimized_Eliminated_Overflow_Check
(N
) then
8949 Apply_Arithmetic_Overflow_Check
(N
);
8952 end Expand_N_Op_Plus
;
8954 ---------------------
8955 -- Expand_N_Op_Rem --
8956 ---------------------
8958 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
8959 Loc
: constant Source_Ptr
:= Sloc
(N
);
8960 Typ
: constant Entity_Id
:= Etype
(N
);
8971 -- Set if corresponding operand can be negative
8973 pragma Unreferenced
(Hi
);
8976 Binary_Op_Validity_Checks
(N
);
8978 -- Check for MINIMIZED/ELIMINATED overflow mode
8980 if Minimized_Eliminated_Overflow_Check
(N
) then
8981 Apply_Arithmetic_Overflow_Check
(N
);
8985 if Is_Integer_Type
(Etype
(N
)) then
8986 Apply_Divide_Checks
(N
);
8988 -- All done if we don't have a REM any more, which can happen as a
8989 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8991 if Nkind
(N
) /= N_Op_Rem
then
8996 -- Proceed with expansion of REM
8998 Left
:= Left_Opnd
(N
);
8999 Right
:= Right_Opnd
(N
);
9001 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9002 -- but it is useful with other back ends (e.g. AAMP), and is certainly
9005 if Is_Integer_Type
(Etype
(N
))
9006 and then Compile_Time_Known_Value
(Right
)
9007 and then Expr_Value
(Right
) = Uint_1
9009 -- Call Remove_Side_Effects to ensure that any side effects in the
9010 -- ignored left operand (in particular function calls to user defined
9011 -- functions) are properly executed.
9013 Remove_Side_Effects
(Left
);
9015 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9016 Analyze_And_Resolve
(N
, Typ
);
9020 -- Deal with annoying case of largest negative number remainder minus
9021 -- one. Gigi may not handle this case correctly, because on some
9022 -- targets, the mod value is computed using a divide instruction
9023 -- which gives an overflow trap for this case.
9025 -- It would be a bit more efficient to figure out which targets this
9026 -- is really needed for, but in practice it is reasonable to do the
9027 -- following special check in all cases, since it means we get a clearer
9028 -- message, and also the overhead is minimal given that division is
9029 -- expensive in any case.
9031 -- In fact the check is quite easy, if the right operand is -1, then
9032 -- the remainder is always 0, and we can just ignore the left operand
9033 -- completely in this case.
9035 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9036 Lneg
:= (not OK
) or else Lo
< 0;
9038 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9039 Rneg
:= (not OK
) or else Lo
< 0;
9041 -- We won't mess with trying to find out if the left operand can really
9042 -- be the largest negative number (that's a pain in the case of private
9043 -- types and this is really marginal). We will just assume that we need
9044 -- the test if the left operand can be negative at all.
9046 if Lneg
and Rneg
then
9048 Make_If_Expression
(Loc
,
9049 Expressions
=> New_List
(
9051 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9053 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
9055 Unchecked_Convert_To
(Typ
,
9056 Make_Integer_Literal
(Loc
, Uint_0
)),
9058 Relocate_Node
(N
))));
9060 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9061 Analyze_And_Resolve
(N
, Typ
);
9063 end Expand_N_Op_Rem
;
9065 -----------------------------
9066 -- Expand_N_Op_Rotate_Left --
9067 -----------------------------
9069 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
9071 Binary_Op_Validity_Checks
(N
);
9073 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9074 -- so we rewrite in terms of logical shifts
9076 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9078 -- where Bits is the shift count mod Esize (the mod operation here
9079 -- deals with ludicrous large shift counts, which are apparently OK).
9081 -- What about non-binary modulus ???
9084 Loc
: constant Source_Ptr
:= Sloc
(N
);
9085 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9086 Typ
: constant Entity_Id
:= Etype
(N
);
9089 if Modify_Tree_For_C
then
9090 Rewrite
(Right_Opnd
(N
),
9092 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9093 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9095 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9100 Make_Op_Shift_Left
(Loc
,
9101 Left_Opnd
=> Left_Opnd
(N
),
9102 Right_Opnd
=> Right_Opnd
(N
)),
9105 Make_Op_Shift_Right
(Loc
,
9106 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9108 Make_Op_Subtract
(Loc
,
9109 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9111 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9113 Analyze_And_Resolve
(N
, Typ
);
9116 end Expand_N_Op_Rotate_Left
;
9118 ------------------------------
9119 -- Expand_N_Op_Rotate_Right --
9120 ------------------------------
9122 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
9124 Binary_Op_Validity_Checks
(N
);
9126 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9127 -- so we rewrite in terms of logical shifts
9129 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9131 -- where Bits is the shift count mod Esize (the mod operation here
9132 -- deals with ludicrous large shift counts, which are apparently OK).
9134 -- What about non-binary modulus ???
9137 Loc
: constant Source_Ptr
:= Sloc
(N
);
9138 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9139 Typ
: constant Entity_Id
:= Etype
(N
);
9142 Rewrite
(Right_Opnd
(N
),
9144 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9145 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9147 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9149 if Modify_Tree_For_C
then
9153 Make_Op_Shift_Right
(Loc
,
9154 Left_Opnd
=> Left_Opnd
(N
),
9155 Right_Opnd
=> Right_Opnd
(N
)),
9158 Make_Op_Shift_Left
(Loc
,
9159 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9161 Make_Op_Subtract
(Loc
,
9162 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9164 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9166 Analyze_And_Resolve
(N
, Typ
);
9169 end Expand_N_Op_Rotate_Right
;
9171 ----------------------------
9172 -- Expand_N_Op_Shift_Left --
9173 ----------------------------
9175 -- Note: nothing in this routine depends on left as opposed to right shifts
9176 -- so we share the routine for expanding shift right operations.
9178 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
9180 Binary_Op_Validity_Checks
(N
);
9182 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9183 -- operand is not greater than the word size (since that would not
9184 -- be defined properly by the corresponding C shift operator).
9186 if Modify_Tree_For_C
then
9188 Right
: constant Node_Id
:= Right_Opnd
(N
);
9189 Loc
: constant Source_Ptr
:= Sloc
(Right
);
9190 Typ
: constant Entity_Id
:= Etype
(N
);
9191 Siz
: constant Uint
:= Esize
(Typ
);
9198 if Compile_Time_Known_Value
(Right
) then
9199 if Expr_Value
(Right
) >= Siz
then
9200 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9201 Analyze_And_Resolve
(N
, Typ
);
9204 -- Not compile time known, find range
9207 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9209 -- Nothing to do if known to be OK range, otherwise expand
9211 if not OK
or else Hi
>= Siz
then
9213 -- Prevent recursion on copy of shift node
9215 Orig
:= Relocate_Node
(N
);
9216 Set_Analyzed
(Orig
);
9218 -- Now do the rewrite
9221 Make_If_Expression
(Loc
,
9222 Expressions
=> New_List
(
9224 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
9225 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
9226 Make_Integer_Literal
(Loc
, 0),
9228 Analyze_And_Resolve
(N
, Typ
);
9233 end Expand_N_Op_Shift_Left
;
9235 -----------------------------
9236 -- Expand_N_Op_Shift_Right --
9237 -----------------------------
9239 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
9241 -- Share shift left circuit
9243 Expand_N_Op_Shift_Left
(N
);
9244 end Expand_N_Op_Shift_Right
;
9246 ----------------------------------------
9247 -- Expand_N_Op_Shift_Right_Arithmetic --
9248 ----------------------------------------
9250 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
9252 Binary_Op_Validity_Checks
(N
);
9254 -- If we are in Modify_Tree_For_C mode, there is no shift right
9255 -- arithmetic in C, so we rewrite in terms of logical shifts.
9257 -- Shift_Right (Num, Bits) or
9259 -- then not (Shift_Right (Mask, bits))
9262 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9264 -- Note: in almost all C compilers it would work to just shift a
9265 -- signed integer right, but it's undefined and we cannot rely on it.
9267 -- Note: the above works fine for shift counts greater than or equal
9268 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9269 -- generates all 1'bits.
9271 -- What about non-binary modulus ???
9274 Loc
: constant Source_Ptr
:= Sloc
(N
);
9275 Typ
: constant Entity_Id
:= Etype
(N
);
9276 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
9277 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
9278 Left
: constant Node_Id
:= Left_Opnd
(N
);
9279 Right
: constant Node_Id
:= Right_Opnd
(N
);
9283 if Modify_Tree_For_C
then
9285 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9286 -- compile time as a single constant.
9288 if Compile_Time_Known_Value
(Right
) then
9290 Val
: constant Uint
:= Expr_Value
(Right
);
9293 if Val
>= Esize
(Typ
) then
9294 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
9298 Make_Integer_Literal
(Loc
,
9299 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
9307 Make_Op_Shift_Right
(Loc
,
9308 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
9309 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
9312 -- Now do the rewrite
9317 Make_Op_Shift_Right
(Loc
,
9319 Right_Opnd
=> Right
),
9321 Make_If_Expression
(Loc
,
9322 Expressions
=> New_List
(
9324 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9325 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
9327 Make_Integer_Literal
(Loc
, 0)))));
9328 Analyze_And_Resolve
(N
, Typ
);
9331 end Expand_N_Op_Shift_Right_Arithmetic
;
9333 --------------------------
9334 -- Expand_N_Op_Subtract --
9335 --------------------------
9337 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
9338 Typ
: constant Entity_Id
:= Etype
(N
);
9341 Binary_Op_Validity_Checks
(N
);
9343 -- Check for MINIMIZED/ELIMINATED overflow mode
9345 if Minimized_Eliminated_Overflow_Check
(N
) then
9346 Apply_Arithmetic_Overflow_Check
(N
);
9350 -- N - 0 = N for integer types
9352 if Is_Integer_Type
(Typ
)
9353 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
9354 and then Expr_Value
(Right_Opnd
(N
)) = 0
9356 Rewrite
(N
, Left_Opnd
(N
));
9360 -- Arithmetic overflow checks for signed integer/fixed point types
9362 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
9363 Apply_Arithmetic_Overflow_Check
(N
);
9366 -- Overflow checks for floating-point if -gnateF mode active
9368 Check_Float_Op_Overflow
(N
);
9369 end Expand_N_Op_Subtract
;
9371 ---------------------
9372 -- Expand_N_Op_Xor --
9373 ---------------------
9375 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
9376 Typ
: constant Entity_Id
:= Etype
(N
);
9379 Binary_Op_Validity_Checks
(N
);
9381 if Is_Array_Type
(Etype
(N
)) then
9382 Expand_Boolean_Operator
(N
);
9384 elsif Is_Boolean_Type
(Etype
(N
)) then
9385 Adjust_Condition
(Left_Opnd
(N
));
9386 Adjust_Condition
(Right_Opnd
(N
));
9387 Set_Etype
(N
, Standard_Boolean
);
9388 Adjust_Result_Type
(N
, Typ
);
9390 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9391 Expand_Intrinsic_Call
(N
, Entity
(N
));
9394 end Expand_N_Op_Xor
;
9396 ----------------------
9397 -- Expand_N_Or_Else --
9398 ----------------------
9400 procedure Expand_N_Or_Else
(N
: Node_Id
)
9401 renames Expand_Short_Circuit_Operator
;
9403 -----------------------------------
9404 -- Expand_N_Qualified_Expression --
9405 -----------------------------------
9407 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
9408 Operand
: constant Node_Id
:= Expression
(N
);
9409 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
9412 -- Do validity check if validity checking operands
9414 if Validity_Checks_On
and Validity_Check_Operands
then
9415 Ensure_Valid
(Operand
);
9418 -- Apply possible constraint check
9420 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
9422 if Do_Range_Check
(Operand
) then
9423 Set_Do_Range_Check
(Operand
, False);
9424 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
9426 end Expand_N_Qualified_Expression
;
9428 ------------------------------------
9429 -- Expand_N_Quantified_Expression --
9430 ------------------------------------
9434 -- for all X in range => Cond
9439 -- for X in range loop
9446 -- Similarly, an existentially quantified expression:
9448 -- for some X in range => Cond
9453 -- for X in range loop
9460 -- In both cases, the iteration may be over a container in which case it is
9461 -- given by an iterator specification, not a loop parameter specification.
9463 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
9464 Actions
: constant List_Id
:= New_List
;
9465 For_All
: constant Boolean := All_Present
(N
);
9466 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
9467 Loc
: constant Source_Ptr
:= Sloc
(N
);
9468 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
9475 -- Create the declaration of the flag which tracks the status of the
9476 -- quantified expression. Generate:
9478 -- Flag : Boolean := (True | False);
9480 Flag
:= Make_Temporary
(Loc
, 'T', N
);
9483 Make_Object_Declaration
(Loc
,
9484 Defining_Identifier
=> Flag
,
9485 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
9487 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
9489 -- Construct the circuitry which tracks the status of the quantified
9490 -- expression. Generate:
9492 -- if [not] Cond then
9493 -- Flag := (False | True);
9497 Cond
:= Relocate_Node
(Condition
(N
));
9500 Cond
:= Make_Op_Not
(Loc
, Cond
);
9504 Make_Implicit_If_Statement
(N
,
9506 Then_Statements
=> New_List
(
9507 Make_Assignment_Statement
(Loc
,
9508 Name
=> New_Occurrence_Of
(Flag
, Loc
),
9510 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
9511 Make_Exit_Statement
(Loc
))));
9513 -- Build the loop equivalent of the quantified expression
9515 if Present
(Iter_Spec
) then
9517 Make_Iteration_Scheme
(Loc
,
9518 Iterator_Specification
=> Iter_Spec
);
9521 Make_Iteration_Scheme
(Loc
,
9522 Loop_Parameter_Specification
=> Loop_Spec
);
9526 Make_Loop_Statement
(Loc
,
9527 Iteration_Scheme
=> Scheme
,
9528 Statements
=> Stmts
,
9529 End_Label
=> Empty
));
9531 -- Transform the quantified expression
9534 Make_Expression_With_Actions
(Loc
,
9535 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
9536 Actions
=> Actions
));
9537 Analyze_And_Resolve
(N
, Standard_Boolean
);
9538 end Expand_N_Quantified_Expression
;
9540 ---------------------------------
9541 -- Expand_N_Selected_Component --
9542 ---------------------------------
9544 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
9545 Loc
: constant Source_Ptr
:= Sloc
(N
);
9546 Par
: constant Node_Id
:= Parent
(N
);
9547 P
: constant Node_Id
:= Prefix
(N
);
9548 S
: constant Node_Id
:= Selector_Name
(N
);
9549 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
9555 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
9556 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9557 -- unless the context of an assignment can provide size information.
9558 -- Don't we have a general routine that does this???
9560 function Is_Subtype_Declaration
return Boolean;
9561 -- The replacement of a discriminant reference by its value is required
9562 -- if this is part of the initialization of an temporary generated by a
9563 -- change of representation. This shows up as the construction of a
9564 -- discriminant constraint for a subtype declared at the same point as
9565 -- the entity in the prefix of the selected component. We recognize this
9566 -- case when the context of the reference is:
9567 -- subtype ST is T(Obj.D);
9568 -- where the entity for Obj comes from source, and ST has the same sloc.
9570 -----------------------
9571 -- In_Left_Hand_Side --
9572 -----------------------
9574 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
9576 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
9577 and then Comp
= Name
(Parent
(Comp
)))
9578 or else (Present
(Parent
(Comp
))
9579 and then Nkind
(Parent
(Comp
)) in N_Subexpr
9580 and then In_Left_Hand_Side
(Parent
(Comp
)));
9581 end In_Left_Hand_Side
;
9583 -----------------------------
9584 -- Is_Subtype_Declaration --
9585 -----------------------------
9587 function Is_Subtype_Declaration
return Boolean is
9588 Par
: constant Node_Id
:= Parent
(N
);
9591 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
9592 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
9593 and then Comes_From_Source
(Entity
(Prefix
(N
)))
9594 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
9595 end Is_Subtype_Declaration
;
9597 -- Start of processing for Expand_N_Selected_Component
9600 -- Insert explicit dereference if required
9602 if Is_Access_Type
(Ptyp
) then
9604 -- First set prefix type to proper access type, in case it currently
9605 -- has a private (non-access) view of this type.
9607 Set_Etype
(P
, Ptyp
);
9609 Insert_Explicit_Dereference
(P
);
9610 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
9612 if Ekind
(Etype
(P
)) = E_Private_Subtype
9613 and then Is_For_Access_Subtype
(Etype
(P
))
9615 Set_Etype
(P
, Base_Type
(Etype
(P
)));
9621 -- Deal with discriminant check required
9623 if Do_Discriminant_Check
(N
) then
9624 if Present
(Discriminant_Checking_Func
9625 (Original_Record_Component
(Entity
(S
))))
9627 -- Present the discriminant checking function to the backend, so
9628 -- that it can inline the call to the function.
9631 (Discriminant_Checking_Func
9632 (Original_Record_Component
(Entity
(S
))),
9635 -- Now reset the flag and generate the call
9637 Set_Do_Discriminant_Check
(N
, False);
9638 Generate_Discriminant_Check
(N
);
9640 -- In the case of Unchecked_Union, no discriminant checking is
9641 -- actually performed.
9644 Set_Do_Discriminant_Check
(N
, False);
9648 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9649 -- function, then additional actuals must be passed.
9651 if Ada_Version
>= Ada_2005
9652 and then Is_Build_In_Place_Function_Call
(P
)
9654 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
9657 -- Gigi cannot handle unchecked conversions that are the prefix of a
9658 -- selected component with discriminants. This must be checked during
9659 -- expansion, because during analysis the type of the selector is not
9660 -- known at the point the prefix is analyzed. If the conversion is the
9661 -- target of an assignment, then we cannot force the evaluation.
9663 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
9664 and then Has_Discriminants
(Etype
(N
))
9665 and then not In_Left_Hand_Side
(N
)
9667 Force_Evaluation
(Prefix
(N
));
9670 -- Remaining processing applies only if selector is a discriminant
9672 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
9674 -- If the selector is a discriminant of a constrained record type,
9675 -- we may be able to rewrite the expression with the actual value
9676 -- of the discriminant, a useful optimization in some cases.
9678 if Is_Record_Type
(Ptyp
)
9679 and then Has_Discriminants
(Ptyp
)
9680 and then Is_Constrained
(Ptyp
)
9682 -- Do this optimization for discrete types only, and not for
9683 -- access types (access discriminants get us into trouble).
9685 if not Is_Discrete_Type
(Etype
(N
)) then
9688 -- Don't do this on the left hand of an assignment statement.
9689 -- Normally one would think that references like this would not
9690 -- occur, but they do in generated code, and mean that we really
9691 -- do want to assign the discriminant.
9693 elsif Nkind
(Par
) = N_Assignment_Statement
9694 and then Name
(Par
) = N
9698 -- Don't do this optimization for the prefix of an attribute or
9699 -- the name of an object renaming declaration since these are
9700 -- contexts where we do not want the value anyway.
9702 elsif (Nkind
(Par
) = N_Attribute_Reference
9703 and then Prefix
(Par
) = N
)
9704 or else Is_Renamed_Object
(N
)
9708 -- Don't do this optimization if we are within the code for a
9709 -- discriminant check, since the whole point of such a check may
9710 -- be to verify the condition on which the code below depends.
9712 elsif Is_In_Discriminant_Check
(N
) then
9715 -- Green light to see if we can do the optimization. There is
9716 -- still one condition that inhibits the optimization below but
9717 -- now is the time to check the particular discriminant.
9720 -- Loop through discriminants to find the matching discriminant
9721 -- constraint to see if we can copy it.
9723 Disc
:= First_Discriminant
(Ptyp
);
9724 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
9725 Discr_Loop
: while Present
(Dcon
) loop
9726 Dval
:= Node
(Dcon
);
9728 -- Check if this is the matching discriminant and if the
9729 -- discriminant value is simple enough to make sense to
9730 -- copy. We don't want to copy complex expressions, and
9731 -- indeed to do so can cause trouble (before we put in
9732 -- this guard, a discriminant expression containing an
9733 -- AND THEN was copied, causing problems for coverage
9736 -- However, if the reference is part of the initialization
9737 -- code generated for an object declaration, we must use
9738 -- the discriminant value from the subtype constraint,
9739 -- because the selected component may be a reference to the
9740 -- object being initialized, whose discriminant is not yet
9741 -- set. This only happens in complex cases involving changes
9742 -- or representation.
9744 if Disc
= Entity
(Selector_Name
(N
))
9745 and then (Is_Entity_Name
(Dval
)
9746 or else Compile_Time_Known_Value
(Dval
)
9747 or else Is_Subtype_Declaration
)
9749 -- Here we have the matching discriminant. Check for
9750 -- the case of a discriminant of a component that is
9751 -- constrained by an outer discriminant, which cannot
9752 -- be optimized away.
9754 if Denotes_Discriminant
9755 (Dval
, Check_Concurrent
=> True)
9759 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
9761 Denotes_Discriminant
9762 (Selector_Name
(Original_Node
(Dval
)), True)
9766 -- Do not retrieve value if constraint is not static. It
9767 -- is generally not useful, and the constraint may be a
9768 -- rewritten outer discriminant in which case it is in
9771 elsif Is_Entity_Name
(Dval
)
9773 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
9774 and then Present
(Expression
(Parent
(Entity
(Dval
))))
9776 Is_OK_Static_Expression
9777 (Expression
(Parent
(Entity
(Dval
))))
9781 -- In the context of a case statement, the expression may
9782 -- have the base type of the discriminant, and we need to
9783 -- preserve the constraint to avoid spurious errors on
9786 elsif Nkind
(Parent
(N
)) = N_Case_Statement
9787 and then Etype
(Dval
) /= Etype
(Disc
)
9790 Make_Qualified_Expression
(Loc
,
9792 New_Occurrence_Of
(Etype
(Disc
), Loc
),
9794 New_Copy_Tree
(Dval
)));
9795 Analyze_And_Resolve
(N
, Etype
(Disc
));
9797 -- In case that comes out as a static expression,
9798 -- reset it (a selected component is never static).
9800 Set_Is_Static_Expression
(N
, False);
9803 -- Otherwise we can just copy the constraint, but the
9804 -- result is certainly not static. In some cases the
9805 -- discriminant constraint has been analyzed in the
9806 -- context of the original subtype indication, but for
9807 -- itypes the constraint might not have been analyzed
9808 -- yet, and this must be done now.
9811 Rewrite
(N
, New_Copy_Tree
(Dval
));
9812 Analyze_And_Resolve
(N
);
9813 Set_Is_Static_Expression
(N
, False);
9819 Next_Discriminant
(Disc
);
9820 end loop Discr_Loop
;
9822 -- Note: the above loop should always find a matching
9823 -- discriminant, but if it does not, we just missed an
9824 -- optimization due to some glitch (perhaps a previous
9825 -- error), so ignore.
9830 -- The only remaining processing is in the case of a discriminant of
9831 -- a concurrent object, where we rewrite the prefix to denote the
9832 -- corresponding record type. If the type is derived and has renamed
9833 -- discriminants, use corresponding discriminant, which is the one
9834 -- that appears in the corresponding record.
9836 if not Is_Concurrent_Type
(Ptyp
) then
9840 Disc
:= Entity
(Selector_Name
(N
));
9842 if Is_Derived_Type
(Ptyp
)
9843 and then Present
(Corresponding_Discriminant
(Disc
))
9845 Disc
:= Corresponding_Discriminant
(Disc
);
9849 Make_Selected_Component
(Loc
,
9851 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
9853 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
9859 -- Set Atomic_Sync_Required if necessary for atomic component
9861 if Nkind
(N
) = N_Selected_Component
then
9863 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
9867 -- If component is atomic, but type is not, setting depends on
9868 -- disable/enable state for the component.
9870 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
9871 Set
:= not Atomic_Synchronization_Disabled
(E
);
9873 -- If component is not atomic, but its type is atomic, setting
9874 -- depends on disable/enable state for the type.
9876 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9877 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
9879 -- If both component and type are atomic, we disable if either
9880 -- component or its type have sync disabled.
9882 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9883 Set
:= (not Atomic_Synchronization_Disabled
(E
))
9885 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
9891 -- Set flag if required
9894 Activate_Atomic_Synchronization
(N
);
9898 end Expand_N_Selected_Component
;
9900 --------------------
9901 -- Expand_N_Slice --
9902 --------------------
9904 procedure Expand_N_Slice
(N
: Node_Id
) is
9905 Loc
: constant Source_Ptr
:= Sloc
(N
);
9906 Typ
: constant Entity_Id
:= Etype
(N
);
9908 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
9909 -- Check whether the argument is an actual for a procedure call, in
9910 -- which case the expansion of a bit-packed slice is deferred until the
9911 -- call itself is expanded. The reason this is required is that we might
9912 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9913 -- that copy out would be missed if we created a temporary here in
9914 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9915 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9916 -- is harmless to defer expansion in the IN case, since the call
9917 -- processing will still generate the appropriate copy in operation,
9918 -- which will take care of the slice.
9920 procedure Make_Temporary_For_Slice
;
9921 -- Create a named variable for the value of the slice, in cases where
9922 -- the back-end cannot handle it properly, e.g. when packed types or
9923 -- unaligned slices are involved.
9925 -------------------------
9926 -- Is_Procedure_Actual --
9927 -------------------------
9929 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
9930 Par
: Node_Id
:= Parent
(N
);
9934 -- If our parent is a procedure call we can return
9936 if Nkind
(Par
) = N_Procedure_Call_Statement
then
9939 -- If our parent is a type conversion, keep climbing the tree,
9940 -- since a type conversion can be a procedure actual. Also keep
9941 -- climbing if parameter association or a qualified expression,
9942 -- since these are additional cases that do can appear on
9943 -- procedure actuals.
9945 elsif Nkind_In
(Par
, N_Type_Conversion
,
9946 N_Parameter_Association
,
9947 N_Qualified_Expression
)
9949 Par
:= Parent
(Par
);
9951 -- Any other case is not what we are looking for
9957 end Is_Procedure_Actual
;
9959 ------------------------------
9960 -- Make_Temporary_For_Slice --
9961 ------------------------------
9963 procedure Make_Temporary_For_Slice
is
9964 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
9969 Make_Object_Declaration
(Loc
,
9970 Defining_Identifier
=> Ent
,
9971 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
9973 Set_No_Initialization
(Decl
);
9975 Insert_Actions
(N
, New_List
(
9977 Make_Assignment_Statement
(Loc
,
9978 Name
=> New_Occurrence_Of
(Ent
, Loc
),
9979 Expression
=> Relocate_Node
(N
))));
9981 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
9982 Analyze_And_Resolve
(N
, Typ
);
9983 end Make_Temporary_For_Slice
;
9987 Pref
: constant Node_Id
:= Prefix
(N
);
9988 Pref_Typ
: Entity_Id
:= Etype
(Pref
);
9990 -- Start of processing for Expand_N_Slice
9993 -- Special handling for access types
9995 if Is_Access_Type
(Pref_Typ
) then
9996 Pref_Typ
:= Designated_Type
(Pref_Typ
);
9999 Make_Explicit_Dereference
(Sloc
(N
),
10000 Prefix
=> Relocate_Node
(Pref
)));
10002 Analyze_And_Resolve
(Pref
, Pref_Typ
);
10005 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10006 -- function, then additional actuals must be passed.
10008 if Ada_Version
>= Ada_2005
10009 and then Is_Build_In_Place_Function_Call
(Pref
)
10011 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
10014 -- The remaining case to be handled is packed slices. We can leave
10015 -- packed slices as they are in the following situations:
10017 -- 1. Right or left side of an assignment (we can handle this
10018 -- situation correctly in the assignment statement expansion).
10020 -- 2. Prefix of indexed component (the slide is optimized away in this
10021 -- case, see the start of Expand_N_Slice.)
10023 -- 3. Object renaming declaration, since we want the name of the
10024 -- slice, not the value.
10026 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10027 -- be required, and this is handled in the expansion of call
10030 -- 5. Prefix of an address attribute (this is an error which is caught
10031 -- elsewhere, and the expansion would interfere with generating the
10034 if not Is_Packed
(Typ
) then
10036 -- Apply transformation for actuals of a function call, where
10037 -- Expand_Actuals is not used.
10039 if Nkind
(Parent
(N
)) = N_Function_Call
10040 and then Is_Possibly_Unaligned_Slice
(N
)
10042 Make_Temporary_For_Slice
;
10045 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
10046 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
10047 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
10051 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
10052 or else Is_Renamed_Object
(N
)
10053 or else Is_Procedure_Actual
(N
)
10057 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
10058 and then Attribute_Name
(Parent
(N
)) = Name_Address
10063 Make_Temporary_For_Slice
;
10065 end Expand_N_Slice
;
10067 ------------------------------
10068 -- Expand_N_Type_Conversion --
10069 ------------------------------
10071 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
10072 Loc
: constant Source_Ptr
:= Sloc
(N
);
10073 Operand
: constant Node_Id
:= Expression
(N
);
10074 Target_Type
: constant Entity_Id
:= Etype
(N
);
10075 Operand_Type
: Entity_Id
:= Etype
(Operand
);
10077 procedure Handle_Changed_Representation
;
10078 -- This is called in the case of record and array type conversions to
10079 -- see if there is a change of representation to be handled. Change of
10080 -- representation is actually handled at the assignment statement level,
10081 -- and what this procedure does is rewrite node N conversion as an
10082 -- assignment to temporary. If there is no change of representation,
10083 -- then the conversion node is unchanged.
10085 procedure Raise_Accessibility_Error
;
10086 -- Called when we know that an accessibility check will fail. Rewrites
10087 -- node N to an appropriate raise statement and outputs warning msgs.
10088 -- The Etype of the raise node is set to Target_Type. Note that in this
10089 -- case the rest of the processing should be skipped (i.e. the call to
10090 -- this procedure will be followed by "goto Done").
10092 procedure Real_Range_Check
;
10093 -- Handles generation of range check for real target value
10095 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
10096 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
10097 -- evaluates to True.
10099 -----------------------------------
10100 -- Handle_Changed_Representation --
10101 -----------------------------------
10103 procedure Handle_Changed_Representation
is
10112 -- Nothing else to do if no change of representation
10114 if Same_Representation
(Operand_Type
, Target_Type
) then
10117 -- The real change of representation work is done by the assignment
10118 -- statement processing. So if this type conversion is appearing as
10119 -- the expression of an assignment statement, nothing needs to be
10120 -- done to the conversion.
10122 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
10125 -- Otherwise we need to generate a temporary variable, and do the
10126 -- change of representation assignment into that temporary variable.
10127 -- The conversion is then replaced by a reference to this variable.
10132 -- If type is unconstrained we have to add a constraint, copied
10133 -- from the actual value of the left hand side.
10135 if not Is_Constrained
(Target_Type
) then
10136 if Has_Discriminants
(Operand_Type
) then
10137 Disc
:= First_Discriminant
(Operand_Type
);
10139 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
10140 Disc
:= First_Stored_Discriminant
(Operand_Type
);
10144 while Present
(Disc
) loop
10146 Make_Selected_Component
(Loc
,
10148 Duplicate_Subexpr_Move_Checks
(Operand
),
10150 Make_Identifier
(Loc
, Chars
(Disc
))));
10151 Next_Discriminant
(Disc
);
10154 elsif Is_Array_Type
(Operand_Type
) then
10155 N_Ix
:= First_Index
(Target_Type
);
10158 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
10160 -- We convert the bounds explicitly. We use an unchecked
10161 -- conversion because bounds checks are done elsewhere.
10166 Unchecked_Convert_To
(Etype
(N_Ix
),
10167 Make_Attribute_Reference
(Loc
,
10169 Duplicate_Subexpr_No_Checks
10170 (Operand
, Name_Req
=> True),
10171 Attribute_Name
=> Name_First
,
10172 Expressions
=> New_List
(
10173 Make_Integer_Literal
(Loc
, J
)))),
10176 Unchecked_Convert_To
(Etype
(N_Ix
),
10177 Make_Attribute_Reference
(Loc
,
10179 Duplicate_Subexpr_No_Checks
10180 (Operand
, Name_Req
=> True),
10181 Attribute_Name
=> Name_Last
,
10182 Expressions
=> New_List
(
10183 Make_Integer_Literal
(Loc
, J
))))));
10190 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
10192 if Present
(Cons
) then
10194 Make_Subtype_Indication
(Loc
,
10195 Subtype_Mark
=> Odef
,
10197 Make_Index_Or_Discriminant_Constraint
(Loc
,
10198 Constraints
=> Cons
));
10201 Temp
:= Make_Temporary
(Loc
, 'C');
10203 Make_Object_Declaration
(Loc
,
10204 Defining_Identifier
=> Temp
,
10205 Object_Definition
=> Odef
);
10207 Set_No_Initialization
(Decl
, True);
10209 -- Insert required actions. It is essential to suppress checks
10210 -- since we have suppressed default initialization, which means
10211 -- that the variable we create may have no discriminants.
10216 Make_Assignment_Statement
(Loc
,
10217 Name
=> New_Occurrence_Of
(Temp
, Loc
),
10218 Expression
=> Relocate_Node
(N
))),
10219 Suppress
=> All_Checks
);
10221 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
10224 end Handle_Changed_Representation
;
10226 -------------------------------
10227 -- Raise_Accessibility_Error --
10228 -------------------------------
10230 procedure Raise_Accessibility_Error
is
10232 Error_Msg_Warn
:= SPARK_Mode
/= On
;
10234 Make_Raise_Program_Error
(Sloc
(N
),
10235 Reason
=> PE_Accessibility_Check_Failed
));
10236 Set_Etype
(N
, Target_Type
);
10238 Error_Msg_N
("<<accessibility check failure", N
);
10239 Error_Msg_NE
("\<<& [", N
, Standard_Program_Error
);
10240 end Raise_Accessibility_Error
;
10242 ----------------------
10243 -- Real_Range_Check --
10244 ----------------------
10246 -- Case of conversions to floating-point or fixed-point. If range checks
10247 -- are enabled and the target type has a range constraint, we convert:
10253 -- Tnn : typ'Base := typ'Base (x);
10254 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10257 -- This is necessary when there is a conversion of integer to float or
10258 -- to fixed-point to ensure that the correct checks are made. It is not
10259 -- necessary for float to float where it is enough to simply set the
10260 -- Do_Range_Check flag.
10262 procedure Real_Range_Check
is
10263 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
10264 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
10265 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
10266 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
10271 -- Nothing to do if conversion was rewritten
10273 if Nkind
(N
) /= N_Type_Conversion
then
10277 -- Nothing to do if range checks suppressed, or target has the same
10278 -- range as the base type (or is the base type).
10280 if Range_Checks_Suppressed
(Target_Type
)
10281 or else (Lo
= Type_Low_Bound
(Btyp
)
10283 Hi
= Type_High_Bound
(Btyp
))
10288 -- Nothing to do if expression is an entity on which checks have been
10291 if Is_Entity_Name
(Operand
)
10292 and then Range_Checks_Suppressed
(Entity
(Operand
))
10297 -- Nothing to do if bounds are all static and we can tell that the
10298 -- expression is within the bounds of the target. Note that if the
10299 -- operand is of an unconstrained floating-point type, then we do
10300 -- not trust it to be in range (might be infinite)
10303 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
10304 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
10307 if (not Is_Floating_Point_Type
(Xtyp
)
10308 or else Is_Constrained
(Xtyp
))
10309 and then Compile_Time_Known_Value
(S_Lo
)
10310 and then Compile_Time_Known_Value
(S_Hi
)
10311 and then Compile_Time_Known_Value
(Hi
)
10312 and then Compile_Time_Known_Value
(Lo
)
10315 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
10316 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
10321 if Is_Real_Type
(Xtyp
) then
10322 S_Lov
:= Expr_Value_R
(S_Lo
);
10323 S_Hiv
:= Expr_Value_R
(S_Hi
);
10325 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
10326 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
10330 and then S_Lov
>= D_Lov
10331 and then S_Hiv
<= D_Hiv
10333 -- Unset the range check flag on the current value of
10334 -- Expression (N), since the captured Operand may have
10335 -- been rewritten (such as for the case of a conversion
10336 -- to a fixed-point type).
10338 Set_Do_Range_Check
(Expression
(N
), False);
10346 -- For float to float conversions, we are done
10348 if Is_Floating_Point_Type
(Xtyp
)
10350 Is_Floating_Point_Type
(Btyp
)
10355 -- Otherwise rewrite the conversion as described above
10357 Conv
:= Relocate_Node
(N
);
10358 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
10359 Set_Etype
(Conv
, Btyp
);
10361 -- Enable overflow except for case of integer to float conversions,
10362 -- where it is never required, since we can never have overflow in
10365 if not Is_Integer_Type
(Etype
(Operand
)) then
10366 Enable_Overflow_Check
(Conv
);
10369 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
10371 Insert_Actions
(N
, New_List
(
10372 Make_Object_Declaration
(Loc
,
10373 Defining_Identifier
=> Tnn
,
10374 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
10375 Constant_Present
=> True,
10376 Expression
=> Conv
),
10378 Make_Raise_Constraint_Error
(Loc
,
10383 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10385 Make_Attribute_Reference
(Loc
,
10386 Attribute_Name
=> Name_First
,
10388 New_Occurrence_Of
(Target_Type
, Loc
))),
10392 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10394 Make_Attribute_Reference
(Loc
,
10395 Attribute_Name
=> Name_Last
,
10397 New_Occurrence_Of
(Target_Type
, Loc
)))),
10398 Reason
=> CE_Range_Check_Failed
)));
10400 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
10401 Analyze_And_Resolve
(N
, Btyp
);
10402 end Real_Range_Check
;
10404 -----------------------------
10405 -- Has_Extra_Accessibility --
10406 -----------------------------
10408 -- Returns true for a formal of an anonymous access type or for
10409 -- an Ada 2012-style stand-alone object of an anonymous access type.
10411 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
10413 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
10414 return Present
(Effective_Extra_Accessibility
(Id
));
10418 end Has_Extra_Accessibility
;
10420 -- Start of processing for Expand_N_Type_Conversion
10423 -- First remove check marks put by the semantic analysis on the type
10424 -- conversion between array types. We need these checks, and they will
10425 -- be generated by this expansion routine, but we do not depend on these
10426 -- flags being set, and since we do intend to expand the checks in the
10427 -- front end, we don't want them on the tree passed to the back end.
10429 if Is_Array_Type
(Target_Type
) then
10430 if Is_Constrained
(Target_Type
) then
10431 Set_Do_Length_Check
(N
, False);
10433 Set_Do_Range_Check
(Operand
, False);
10437 -- Nothing at all to do if conversion is to the identical type so remove
10438 -- the conversion completely, it is useless, except that it may carry
10439 -- an Assignment_OK attribute, which must be propagated to the operand.
10441 if Operand_Type
= Target_Type
then
10442 if Assignment_OK
(N
) then
10443 Set_Assignment_OK
(Operand
);
10446 Rewrite
(N
, Relocate_Node
(Operand
));
10450 -- Nothing to do if this is the second argument of read. This is a
10451 -- "backwards" conversion that will be handled by the specialized code
10452 -- in attribute processing.
10454 if Nkind
(Parent
(N
)) = N_Attribute_Reference
10455 and then Attribute_Name
(Parent
(N
)) = Name_Read
10456 and then Next
(First
(Expressions
(Parent
(N
)))) = N
10461 -- Check for case of converting to a type that has an invariant
10462 -- associated with it. This required an invariant check. We convert
10468 -- do invariant_check (typ (expr)) in typ (expr);
10470 -- using Duplicate_Subexpr to avoid multiple side effects
10472 -- Note: the Comes_From_Source check, and then the resetting of this
10473 -- flag prevents what would otherwise be an infinite recursion.
10475 if Has_Invariants
(Target_Type
)
10476 and then Present
(Invariant_Procedure
(Target_Type
))
10477 and then Comes_From_Source
(N
)
10479 Set_Comes_From_Source
(N
, False);
10481 Make_Expression_With_Actions
(Loc
,
10482 Actions
=> New_List
(
10483 Make_Invariant_Call
(Duplicate_Subexpr
(N
))),
10484 Expression
=> Duplicate_Subexpr_No_Checks
(N
)));
10485 Analyze_And_Resolve
(N
, Target_Type
);
10489 -- Here if we may need to expand conversion
10491 -- If the operand of the type conversion is an arithmetic operation on
10492 -- signed integers, and the based type of the signed integer type in
10493 -- question is smaller than Standard.Integer, we promote both of the
10494 -- operands to type Integer.
10496 -- For example, if we have
10498 -- target-type (opnd1 + opnd2)
10500 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10503 -- target-type (integer(opnd1) + integer(opnd2))
10505 -- We do this because we are always allowed to compute in a larger type
10506 -- if we do the right thing with the result, and in this case we are
10507 -- going to do a conversion which will do an appropriate check to make
10508 -- sure that things are in range of the target type in any case. This
10509 -- avoids some unnecessary intermediate overflows.
10511 -- We might consider a similar transformation in the case where the
10512 -- target is a real type or a 64-bit integer type, and the operand
10513 -- is an arithmetic operation using a 32-bit integer type. However,
10514 -- we do not bother with this case, because it could cause significant
10515 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10516 -- much cheaper, but we don't want different behavior on 32-bit and
10517 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10518 -- handles the configurable run-time cases where 64-bit arithmetic
10519 -- may simply be unavailable.
10521 -- Note: this circuit is partially redundant with respect to the circuit
10522 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10523 -- the processing here. Also we still need the Checks circuit, since we
10524 -- have to be sure not to generate junk overflow checks in the first
10525 -- place, since it would be trick to remove them here.
10527 if Integer_Promotion_Possible
(N
) then
10529 -- All conditions met, go ahead with transformation
10537 Make_Type_Conversion
(Loc
,
10538 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10539 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
10541 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
10542 Set_Right_Opnd
(Opnd
, R
);
10544 if Nkind
(Operand
) in N_Binary_Op
then
10546 Make_Type_Conversion
(Loc
,
10547 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10548 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
10550 Set_Left_Opnd
(Opnd
, L
);
10554 Make_Type_Conversion
(Loc
,
10555 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
10556 Expression
=> Opnd
));
10558 Analyze_And_Resolve
(N
, Target_Type
);
10563 -- Do validity check if validity checking operands
10565 if Validity_Checks_On
and Validity_Check_Operands
then
10566 Ensure_Valid
(Operand
);
10569 -- Special case of converting from non-standard boolean type
10571 if Is_Boolean_Type
(Operand_Type
)
10572 and then (Nonzero_Is_True
(Operand_Type
))
10574 Adjust_Condition
(Operand
);
10575 Set_Etype
(Operand
, Standard_Boolean
);
10576 Operand_Type
:= Standard_Boolean
;
10579 -- Case of converting to an access type
10581 if Is_Access_Type
(Target_Type
) then
10583 -- Apply an accessibility check when the conversion operand is an
10584 -- access parameter (or a renaming thereof), unless conversion was
10585 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10586 -- Note that other checks may still need to be applied below (such
10587 -- as tagged type checks).
10589 if Is_Entity_Name
(Operand
)
10590 and then Has_Extra_Accessibility
(Entity
(Operand
))
10591 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
10592 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
10593 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
10595 Apply_Accessibility_Check
10596 (Operand
, Target_Type
, Insert_Node
=> Operand
);
10598 -- If the level of the operand type is statically deeper than the
10599 -- level of the target type, then force Program_Error. Note that this
10600 -- can only occur for cases where the attribute is within the body of
10601 -- an instantiation, otherwise the conversion will already have been
10602 -- rejected as illegal.
10604 -- Note: warnings are issued by the analyzer for the instance cases
10606 elsif In_Instance_Body
10608 -- The case where the target type is an anonymous access type of
10609 -- a discriminant is excluded, because the level of such a type
10610 -- depends on the context and currently the level returned for such
10611 -- types is zero, resulting in warnings about about check failures
10612 -- in certain legal cases involving class-wide interfaces as the
10613 -- designated type (some cases, such as return statements, are
10614 -- checked at run time, but not clear if these are handled right
10615 -- in general, see 3.10.2(12/2-12.5/3) ???).
10618 not (Ekind
(Target_Type
) = E_Anonymous_Access_Type
10619 and then Present
(Associated_Node_For_Itype
(Target_Type
))
10620 and then Nkind
(Associated_Node_For_Itype
(Target_Type
)) =
10621 N_Discriminant_Specification
)
10623 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
10625 Raise_Accessibility_Error
;
10628 -- When the operand is a selected access discriminant the check needs
10629 -- to be made against the level of the object denoted by the prefix
10630 -- of the selected name. Force Program_Error for this case as well
10631 -- (this accessibility violation can only happen if within the body
10632 -- of an instantiation).
10634 elsif In_Instance_Body
10635 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
10636 and then Nkind
(Operand
) = N_Selected_Component
10637 and then Object_Access_Level
(Operand
) >
10638 Type_Access_Level
(Target_Type
)
10640 Raise_Accessibility_Error
;
10645 -- Case of conversions of tagged types and access to tagged types
10647 -- When needed, that is to say when the expression is class-wide, Add
10648 -- runtime a tag check for (strict) downward conversion by using the
10649 -- membership test, generating:
10651 -- [constraint_error when Operand not in Target_Type'Class]
10653 -- or in the access type case
10655 -- [constraint_error
10656 -- when Operand /= null
10657 -- and then Operand.all not in
10658 -- Designated_Type (Target_Type)'Class]
10660 if (Is_Access_Type
(Target_Type
)
10661 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
10662 or else Is_Tagged_Type
(Target_Type
)
10664 -- Do not do any expansion in the access type case if the parent is a
10665 -- renaming, since this is an error situation which will be caught by
10666 -- Sem_Ch8, and the expansion can interfere with this error check.
10668 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
10672 -- Otherwise, proceed with processing tagged conversion
10674 Tagged_Conversion
: declare
10675 Actual_Op_Typ
: Entity_Id
;
10676 Actual_Targ_Typ
: Entity_Id
;
10677 Make_Conversion
: Boolean := False;
10678 Root_Op_Typ
: Entity_Id
;
10680 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
10681 -- Create a membership check to test whether Operand is a member
10682 -- of Targ_Typ. If the original Target_Type is an access, include
10683 -- a test for null value. The check is inserted at N.
10685 --------------------
10686 -- Make_Tag_Check --
10687 --------------------
10689 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
10694 -- [Constraint_Error
10695 -- when Operand /= null
10696 -- and then Operand.all not in Targ_Typ]
10698 if Is_Access_Type
(Target_Type
) then
10700 Make_And_Then
(Loc
,
10703 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10704 Right_Opnd
=> Make_Null
(Loc
)),
10709 Make_Explicit_Dereference
(Loc
,
10710 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
10711 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
10714 -- [Constraint_Error when Operand not in Targ_Typ]
10719 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10720 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
10724 Make_Raise_Constraint_Error
(Loc
,
10726 Reason
=> CE_Tag_Check_Failed
));
10727 end Make_Tag_Check
;
10729 -- Start of processing for Tagged_Conversion
10732 -- Handle entities from the limited view
10734 if Is_Access_Type
(Operand_Type
) then
10736 Available_View
(Designated_Type
(Operand_Type
));
10738 Actual_Op_Typ
:= Operand_Type
;
10741 if Is_Access_Type
(Target_Type
) then
10743 Available_View
(Designated_Type
(Target_Type
));
10745 Actual_Targ_Typ
:= Target_Type
;
10748 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
10750 -- Ada 2005 (AI-251): Handle interface type conversion
10752 if Is_Interface
(Actual_Op_Typ
)
10754 Is_Interface
(Actual_Targ_Typ
)
10756 Expand_Interface_Conversion
(N
);
10760 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
10762 -- Create a runtime tag check for a downward class-wide type
10765 if Is_Class_Wide_Type
(Actual_Op_Typ
)
10766 and then Actual_Op_Typ
/= Actual_Targ_Typ
10767 and then Root_Op_Typ
/= Actual_Targ_Typ
10768 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
10769 Use_Full_View
=> True)
10771 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
10772 Make_Conversion
:= True;
10775 -- AI05-0073: If the result subtype of the function is defined
10776 -- by an access_definition designating a specific tagged type
10777 -- T, a check is made that the result value is null or the tag
10778 -- of the object designated by the result value identifies T.
10779 -- Constraint_Error is raised if this check fails.
10781 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
10784 Func_Typ
: Entity_Id
;
10787 -- Climb scope stack looking for the enclosing function
10789 Func
:= Current_Scope
;
10790 while Present
(Func
)
10791 and then Ekind
(Func
) /= E_Function
10793 Func
:= Scope
(Func
);
10796 -- The function's return subtype must be defined using
10797 -- an access definition.
10799 if Nkind
(Result_Definition
(Parent
(Func
))) =
10800 N_Access_Definition
10802 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
10804 -- The return subtype denotes a specific tagged type,
10805 -- in other words, a non class-wide type.
10807 if Is_Tagged_Type
(Func_Typ
)
10808 and then not Is_Class_Wide_Type
(Func_Typ
)
10810 Make_Tag_Check
(Actual_Targ_Typ
);
10811 Make_Conversion
:= True;
10817 -- We have generated a tag check for either a class-wide type
10818 -- conversion or for AI05-0073.
10820 if Make_Conversion
then
10825 Make_Unchecked_Type_Conversion
(Loc
,
10826 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
10827 Expression
=> Relocate_Node
(Expression
(N
)));
10829 Analyze_And_Resolve
(N
, Target_Type
);
10833 end Tagged_Conversion
;
10835 -- Case of other access type conversions
10837 elsif Is_Access_Type
(Target_Type
) then
10838 Apply_Constraint_Check
(Operand
, Target_Type
);
10840 -- Case of conversions from a fixed-point type
10842 -- These conversions require special expansion and processing, found in
10843 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10844 -- since from a semantic point of view, these are simple integer
10845 -- conversions, which do not need further processing.
10847 elsif Is_Fixed_Point_Type
(Operand_Type
)
10848 and then not Conversion_OK
(N
)
10850 -- We should never see universal fixed at this case, since the
10851 -- expansion of the constituent divide or multiply should have
10852 -- eliminated the explicit mention of universal fixed.
10854 pragma Assert
(Operand_Type
/= Universal_Fixed
);
10856 -- Check for special case of the conversion to universal real that
10857 -- occurs as a result of the use of a round attribute. In this case,
10858 -- the real type for the conversion is taken from the target type of
10859 -- the Round attribute and the result must be marked as rounded.
10861 if Target_Type
= Universal_Real
10862 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
10863 and then Attribute_Name
(Parent
(N
)) = Name_Round
10865 Set_Rounded_Result
(N
);
10866 Set_Etype
(N
, Etype
(Parent
(N
)));
10869 -- Otherwise do correct fixed-conversion, but skip these if the
10870 -- Conversion_OK flag is set, because from a semantic point of view
10871 -- these are simple integer conversions needing no further processing
10872 -- (the backend will simply treat them as integers).
10874 if not Conversion_OK
(N
) then
10875 if Is_Fixed_Point_Type
(Etype
(N
)) then
10876 Expand_Convert_Fixed_To_Fixed
(N
);
10879 elsif Is_Integer_Type
(Etype
(N
)) then
10880 Expand_Convert_Fixed_To_Integer
(N
);
10883 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
10884 Expand_Convert_Fixed_To_Float
(N
);
10889 -- Case of conversions to a fixed-point type
10891 -- These conversions require special expansion and processing, found in
10892 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10893 -- since from a semantic point of view, these are simple integer
10894 -- conversions, which do not need further processing.
10896 elsif Is_Fixed_Point_Type
(Target_Type
)
10897 and then not Conversion_OK
(N
)
10899 if Is_Integer_Type
(Operand_Type
) then
10900 Expand_Convert_Integer_To_Fixed
(N
);
10903 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
10904 Expand_Convert_Float_To_Fixed
(N
);
10908 -- Case of float-to-integer conversions
10910 -- We also handle float-to-fixed conversions with Conversion_OK set
10911 -- since semantically the fixed-point target is treated as though it
10912 -- were an integer in such cases.
10914 elsif Is_Floating_Point_Type
(Operand_Type
)
10916 (Is_Integer_Type
(Target_Type
)
10918 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
10920 -- One more check here, gcc is still not able to do conversions of
10921 -- this type with proper overflow checking, and so gigi is doing an
10922 -- approximation of what is required by doing floating-point compares
10923 -- with the end-point. But that can lose precision in some cases, and
10924 -- give a wrong result. Converting the operand to Universal_Real is
10925 -- helpful, but still does not catch all cases with 64-bit integers
10926 -- on targets with only 64-bit floats.
10928 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10929 -- Can this code be removed ???
10931 if Do_Range_Check
(Operand
) then
10933 Make_Type_Conversion
(Loc
,
10935 New_Occurrence_Of
(Universal_Real
, Loc
),
10937 Relocate_Node
(Operand
)));
10939 Set_Etype
(Operand
, Universal_Real
);
10940 Enable_Range_Check
(Operand
);
10941 Set_Do_Range_Check
(Expression
(Operand
), False);
10944 -- Case of array conversions
10946 -- Expansion of array conversions, add required length/range checks but
10947 -- only do this if there is no change of representation. For handling of
10948 -- this case, see Handle_Changed_Representation.
10950 elsif Is_Array_Type
(Target_Type
) then
10951 if Is_Constrained
(Target_Type
) then
10952 Apply_Length_Check
(Operand
, Target_Type
);
10954 Apply_Range_Check
(Operand
, Target_Type
);
10957 Handle_Changed_Representation
;
10959 -- Case of conversions of discriminated types
10961 -- Add required discriminant checks if target is constrained. Again this
10962 -- change is skipped if we have a change of representation.
10964 elsif Has_Discriminants
(Target_Type
)
10965 and then Is_Constrained
(Target_Type
)
10967 Apply_Discriminant_Check
(Operand
, Target_Type
);
10968 Handle_Changed_Representation
;
10970 -- Case of all other record conversions. The only processing required
10971 -- is to check for a change of representation requiring the special
10972 -- assignment processing.
10974 elsif Is_Record_Type
(Target_Type
) then
10976 -- Ada 2005 (AI-216): Program_Error is raised when converting from
10977 -- a derived Unchecked_Union type to an unconstrained type that is
10978 -- not Unchecked_Union if the operand lacks inferable discriminants.
10980 if Is_Derived_Type
(Operand_Type
)
10981 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
10982 and then not Is_Constrained
(Target_Type
)
10983 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
10984 and then not Has_Inferable_Discriminants
(Operand
)
10986 -- To prevent Gigi from generating illegal code, we generate a
10987 -- Program_Error node, but we give it the target type of the
10988 -- conversion (is this requirement documented somewhere ???)
10991 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
10992 Reason
=> PE_Unchecked_Union_Restriction
);
10995 Set_Etype
(PE
, Target_Type
);
11000 Handle_Changed_Representation
;
11003 -- Case of conversions of enumeration types
11005 elsif Is_Enumeration_Type
(Target_Type
) then
11007 -- Special processing is required if there is a change of
11008 -- representation (from enumeration representation clauses).
11010 if not Same_Representation
(Target_Type
, Operand_Type
) then
11012 -- Convert: x(y) to x'val (ytyp'val (y))
11015 Make_Attribute_Reference
(Loc
,
11016 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11017 Attribute_Name
=> Name_Val
,
11018 Expressions
=> New_List
(
11019 Make_Attribute_Reference
(Loc
,
11020 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
11021 Attribute_Name
=> Name_Pos
,
11022 Expressions
=> New_List
(Operand
)))));
11024 Analyze_And_Resolve
(N
, Target_Type
);
11027 -- Case of conversions to floating-point
11029 elsif Is_Floating_Point_Type
(Target_Type
) then
11033 -- At this stage, either the conversion node has been transformed into
11034 -- some other equivalent expression, or left as a conversion that can be
11035 -- handled by Gigi, in the following cases:
11037 -- Conversions with no change of representation or type
11039 -- Numeric conversions involving integer, floating- and fixed-point
11040 -- values. Fixed-point values are allowed only if Conversion_OK is
11041 -- set, i.e. if the fixed-point values are to be treated as integers.
11043 -- No other conversions should be passed to Gigi
11045 -- Check: are these rules stated in sinfo??? if so, why restate here???
11047 -- The only remaining step is to generate a range check if we still have
11048 -- a type conversion at this stage and Do_Range_Check is set. For now we
11049 -- do this only for conversions of discrete types and for float-to-float
11052 if Nkind
(N
) = N_Type_Conversion
then
11054 -- For now we only support floating-point cases where both source
11055 -- and target are floating-point types. Conversions where the source
11056 -- and target involve integer or fixed-point types are still TBD,
11057 -- though not clear whether those can even happen at this point, due
11058 -- to transformations above. ???
11060 if Is_Floating_Point_Type
(Etype
(N
))
11061 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
11063 if Do_Range_Check
(Expression
(N
))
11064 and then Is_Floating_Point_Type
(Target_Type
)
11066 Generate_Range_Check
11067 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
11070 -- Discrete-to-discrete conversions
11072 elsif Is_Discrete_Type
(Etype
(N
)) then
11074 Expr
: constant Node_Id
:= Expression
(N
);
11079 if Do_Range_Check
(Expr
)
11080 and then Is_Discrete_Type
(Etype
(Expr
))
11082 Set_Do_Range_Check
(Expr
, False);
11084 -- Before we do a range check, we have to deal with treating
11085 -- a fixed-point operand as an integer. The way we do this
11086 -- is simply to do an unchecked conversion to an appropriate
11087 -- integer type large enough to hold the result.
11089 -- This code is not active yet, because we are only dealing
11090 -- with discrete types so far ???
11092 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
11093 and then Treat_Fixed_As_Integer
(Expr
)
11095 Ftyp
:= Base_Type
(Etype
(Expr
));
11097 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
11098 Ityp
:= Standard_Long_Long_Integer
;
11100 Ityp
:= Standard_Integer
;
11103 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11106 -- Reset overflow flag, since the range check will include
11107 -- dealing with possible overflow, and generate the check.
11108 -- If Address is either a source type or target type,
11109 -- suppress range check to avoid typing anomalies when
11110 -- it is a visible integer type.
11112 Set_Do_Overflow_Check
(N
, False);
11114 if not Is_Descendent_Of_Address
(Etype
(Expr
))
11115 and then not Is_Descendent_Of_Address
(Target_Type
)
11117 Generate_Range_Check
11118 (Expr
, Target_Type
, CE_Range_Check_Failed
);
11125 -- Here at end of processing
11128 -- Apply predicate check if required. Note that we can't just call
11129 -- Apply_Predicate_Check here, because the type looks right after
11130 -- the conversion and it would omit the check. The Comes_From_Source
11131 -- guard is necessary to prevent infinite recursions when we generate
11132 -- internal conversions for the purpose of checking predicates.
11134 if Present
(Predicate_Function
(Target_Type
))
11135 and then Target_Type
/= Operand_Type
11136 and then Comes_From_Source
(N
)
11139 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
11142 -- Avoid infinite recursion on the subsequent expansion of
11143 -- of the copy of the original type conversion.
11145 Set_Comes_From_Source
(New_Expr
, False);
11146 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
11149 end Expand_N_Type_Conversion
;
11151 -----------------------------------
11152 -- Expand_N_Unchecked_Expression --
11153 -----------------------------------
11155 -- Remove the unchecked expression node from the tree. Its job was simply
11156 -- to make sure that its constituent expression was handled with checks
11157 -- off, and now that that is done, we can remove it from the tree, and
11158 -- indeed must, since Gigi does not expect to see these nodes.
11160 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
11161 Exp
: constant Node_Id
:= Expression
(N
);
11163 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
11165 end Expand_N_Unchecked_Expression
;
11167 ----------------------------------------
11168 -- Expand_N_Unchecked_Type_Conversion --
11169 ----------------------------------------
11171 -- If this cannot be handled by Gigi and we haven't already made a
11172 -- temporary for it, do it now.
11174 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
11175 Target_Type
: constant Entity_Id
:= Etype
(N
);
11176 Operand
: constant Node_Id
:= Expression
(N
);
11177 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11180 -- Nothing at all to do if conversion is to the identical type so remove
11181 -- the conversion completely, it is useless, except that it may carry
11182 -- an Assignment_OK indication which must be propagated to the operand.
11184 if Operand_Type
= Target_Type
then
11186 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
11188 if Assignment_OK
(N
) then
11189 Set_Assignment_OK
(Operand
);
11192 Rewrite
(N
, Relocate_Node
(Operand
));
11196 -- If we have a conversion of a compile time known value to a target
11197 -- type and the value is in range of the target type, then we can simply
11198 -- replace the construct by an integer literal of the correct type. We
11199 -- only apply this to integer types being converted. Possibly it may
11200 -- apply in other cases, but it is too much trouble to worry about.
11202 -- Note that we do not do this transformation if the Kill_Range_Check
11203 -- flag is set, since then the value may be outside the expected range.
11204 -- This happens in the Normalize_Scalars case.
11206 -- We also skip this if either the target or operand type is biased
11207 -- because in this case, the unchecked conversion is supposed to
11208 -- preserve the bit pattern, not the integer value.
11210 if Is_Integer_Type
(Target_Type
)
11211 and then not Has_Biased_Representation
(Target_Type
)
11212 and then Is_Integer_Type
(Operand_Type
)
11213 and then not Has_Biased_Representation
(Operand_Type
)
11214 and then Compile_Time_Known_Value
(Operand
)
11215 and then not Kill_Range_Check
(N
)
11218 Val
: constant Uint
:= Expr_Value
(Operand
);
11221 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
11223 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
11225 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
11227 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
11229 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
11231 -- If Address is the target type, just set the type to avoid a
11232 -- spurious type error on the literal when Address is a visible
11235 if Is_Descendent_Of_Address
(Target_Type
) then
11236 Set_Etype
(N
, Target_Type
);
11238 Analyze_And_Resolve
(N
, Target_Type
);
11246 -- Nothing to do if conversion is safe
11248 if Safe_Unchecked_Type_Conversion
(N
) then
11252 -- Otherwise force evaluation unless Assignment_OK flag is set (this
11253 -- flag indicates ??? More comments needed here)
11255 if Assignment_OK
(N
) then
11258 Force_Evaluation
(N
);
11260 end Expand_N_Unchecked_Type_Conversion
;
11262 ----------------------------
11263 -- Expand_Record_Equality --
11264 ----------------------------
11266 -- For non-variant records, Equality is expanded when needed into:
11268 -- and then Lhs.Discr1 = Rhs.Discr1
11270 -- and then Lhs.Discrn = Rhs.Discrn
11271 -- and then Lhs.Cmp1 = Rhs.Cmp1
11273 -- and then Lhs.Cmpn = Rhs.Cmpn
11275 -- The expression is folded by the back-end for adjacent fields. This
11276 -- function is called for tagged record in only one occasion: for imple-
11277 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11278 -- otherwise the primitive "=" is used directly.
11280 function Expand_Record_Equality
11285 Bodies
: List_Id
) return Node_Id
11287 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11292 First_Time
: Boolean := True;
11294 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
11295 -- Return the next discriminant or component to compare, starting with
11296 -- C, skipping inherited components.
11298 ------------------------
11299 -- Element_To_Compare --
11300 ------------------------
11302 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
11308 -- Exit loop when the next element to be compared is found, or
11309 -- there is no more such element.
11311 exit when No
(Comp
);
11313 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
11316 -- Skip inherited components
11318 -- Note: for a tagged type, we always generate the "=" primitive
11319 -- for the base type (not on the first subtype), so the test for
11320 -- Comp /= Original_Record_Component (Comp) is True for
11321 -- inherited components only.
11323 (Is_Tagged_Type
(Typ
)
11324 and then Comp
/= Original_Record_Component
(Comp
))
11328 or else Chars
(Comp
) = Name_uTag
11330 -- The .NET/JVM version of type Root_Controlled contains two
11331 -- fields which should not be considered part of the object. To
11332 -- achieve proper equiality between two controlled objects on
11333 -- .NET/JVM, skip _Parent whenever it has type Root_Controlled.
11335 or else (Chars
(Comp
) = Name_uParent
11336 and then VM_Target
/= No_VM
11337 and then Etype
(Comp
) = RTE
(RE_Root_Controlled
))
11339 -- Skip interface elements (secondary tags???)
11341 or else Is_Interface
(Etype
(Comp
)));
11343 Next_Entity
(Comp
);
11347 end Element_To_Compare
;
11349 -- Start of processing for Expand_Record_Equality
11352 -- Generates the following code: (assuming that Typ has one Discr and
11353 -- component C2 is also a record)
11356 -- and then Lhs.Discr1 = Rhs.Discr1
11357 -- and then Lhs.C1 = Rhs.C1
11358 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11360 -- and then Lhs.Cmpn = Rhs.Cmpn
11362 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
11363 C
:= Element_To_Compare
(First_Entity
(Typ
));
11364 while Present
(C
) loop
11372 First_Time
:= False;
11376 New_Lhs
:= New_Copy_Tree
(Lhs
);
11377 New_Rhs
:= New_Copy_Tree
(Rhs
);
11381 Expand_Composite_Equality
(Nod
, Etype
(C
),
11383 Make_Selected_Component
(Loc
,
11385 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11387 Make_Selected_Component
(Loc
,
11389 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11392 -- If some (sub)component is an unchecked_union, the whole
11393 -- operation will raise program error.
11395 if Nkind
(Check
) = N_Raise_Program_Error
then
11397 Set_Etype
(Result
, Standard_Boolean
);
11401 Make_And_Then
(Loc
,
11402 Left_Opnd
=> Result
,
11403 Right_Opnd
=> Check
);
11407 C
:= Element_To_Compare
(Next_Entity
(C
));
11411 end Expand_Record_Equality
;
11413 ---------------------------
11414 -- Expand_Set_Membership --
11415 ---------------------------
11417 procedure Expand_Set_Membership
(N
: Node_Id
) is
11418 Lop
: constant Node_Id
:= Left_Opnd
(N
);
11422 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
11423 -- If the alternative is a subtype mark, create a simple membership
11424 -- test. Otherwise create an equality test for it.
11430 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
11432 L
: constant Node_Id
:= New_Copy
(Lop
);
11433 R
: constant Node_Id
:= Relocate_Node
(Alt
);
11436 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
11437 or else Nkind
(Alt
) = N_Range
11440 Make_In
(Sloc
(Alt
),
11445 Make_Op_Eq
(Sloc
(Alt
),
11453 -- Start of processing for Expand_Set_Membership
11456 Remove_Side_Effects
(Lop
);
11458 Alt
:= Last
(Alternatives
(N
));
11459 Res
:= Make_Cond
(Alt
);
11462 while Present
(Alt
) loop
11464 Make_Or_Else
(Sloc
(Alt
),
11465 Left_Opnd
=> Make_Cond
(Alt
),
11466 Right_Opnd
=> Res
);
11471 Analyze_And_Resolve
(N
, Standard_Boolean
);
11472 end Expand_Set_Membership
;
11474 -----------------------------------
11475 -- Expand_Short_Circuit_Operator --
11476 -----------------------------------
11478 -- Deal with special expansion if actions are present for the right operand
11479 -- and deal with optimizing case of arguments being True or False. We also
11480 -- deal with the special case of non-standard boolean values.
11482 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
11483 Loc
: constant Source_Ptr
:= Sloc
(N
);
11484 Typ
: constant Entity_Id
:= Etype
(N
);
11485 Left
: constant Node_Id
:= Left_Opnd
(N
);
11486 Right
: constant Node_Id
:= Right_Opnd
(N
);
11487 LocR
: constant Source_Ptr
:= Sloc
(Right
);
11490 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
11491 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
11492 -- If Left = Shortcut_Value then Right need not be evaluated
11495 -- Deal with non-standard booleans
11497 if Is_Boolean_Type
(Typ
) then
11498 Adjust_Condition
(Left
);
11499 Adjust_Condition
(Right
);
11500 Set_Etype
(N
, Standard_Boolean
);
11503 -- Check for cases where left argument is known to be True or False
11505 if Compile_Time_Known_Value
(Left
) then
11507 -- Mark SCO for left condition as compile time known
11509 if Generate_SCO
and then Comes_From_Source
(Left
) then
11510 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
11513 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11514 -- Any actions associated with Right will be executed unconditionally
11515 -- and can thus be inserted into the tree unconditionally.
11517 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
11518 if Present
(Actions
(N
)) then
11519 Insert_Actions
(N
, Actions
(N
));
11522 Rewrite
(N
, Right
);
11524 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11525 -- In this case we can forget the actions associated with Right,
11526 -- since they will never be executed.
11529 Kill_Dead_Code
(Right
);
11530 Kill_Dead_Code
(Actions
(N
));
11531 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11534 Adjust_Result_Type
(N
, Typ
);
11538 -- If Actions are present for the right operand, we have to do some
11539 -- special processing. We can't just let these actions filter back into
11540 -- code preceding the short circuit (which is what would have happened
11541 -- if we had not trapped them in the short-circuit form), since they
11542 -- must only be executed if the right operand of the short circuit is
11543 -- executed and not otherwise.
11545 if Present
(Actions
(N
)) then
11546 Actlist
:= Actions
(N
);
11548 -- We now use an Expression_With_Actions node for the right operand
11549 -- of the short-circuit form. Note that this solves the traceability
11550 -- problems for coverage analysis.
11553 Make_Expression_With_Actions
(LocR
,
11554 Expression
=> Relocate_Node
(Right
),
11555 Actions
=> Actlist
));
11557 Set_Actions
(N
, No_List
);
11558 Analyze_And_Resolve
(Right
, Standard_Boolean
);
11560 Adjust_Result_Type
(N
, Typ
);
11564 -- No actions present, check for cases of right argument True/False
11566 if Compile_Time_Known_Value
(Right
) then
11568 -- Mark SCO for left condition as compile time known
11570 if Generate_SCO
and then Comes_From_Source
(Right
) then
11571 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
11574 -- Change (Left and then True), (Left or else False) to Left.
11575 -- Note that we know there are no actions associated with the right
11576 -- operand, since we just checked for this case above.
11578 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
11581 -- Change (Left and then False), (Left or else True) to Right,
11582 -- making sure to preserve any side effects associated with the Left
11586 Remove_Side_Effects
(Left
);
11587 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11591 Adjust_Result_Type
(N
, Typ
);
11592 end Expand_Short_Circuit_Operator
;
11594 -------------------------------------
11595 -- Fixup_Universal_Fixed_Operation --
11596 -------------------------------------
11598 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
11599 Conv
: constant Node_Id
:= Parent
(N
);
11602 -- We must have a type conversion immediately above us
11604 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
11606 -- Normally the type conversion gives our target type. The exception
11607 -- occurs in the case of the Round attribute, where the conversion
11608 -- will be to universal real, and our real type comes from the Round
11609 -- attribute (as well as an indication that we must round the result)
11611 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
11612 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
11614 Set_Etype
(N
, Etype
(Parent
(Conv
)));
11615 Set_Rounded_Result
(N
);
11617 -- Normal case where type comes from conversion above us
11620 Set_Etype
(N
, Etype
(Conv
));
11622 end Fixup_Universal_Fixed_Operation
;
11624 ---------------------------------
11625 -- Has_Inferable_Discriminants --
11626 ---------------------------------
11628 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
11630 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
11631 -- Determines whether the left-most prefix of a selected component is a
11632 -- formal parameter in a subprogram. Assumes N is a selected component.
11634 --------------------------------
11635 -- Prefix_Is_Formal_Parameter --
11636 --------------------------------
11638 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
11639 Sel_Comp
: Node_Id
;
11642 -- Move to the left-most prefix by climbing up the tree
11645 while Present
(Parent
(Sel_Comp
))
11646 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
11648 Sel_Comp
:= Parent
(Sel_Comp
);
11651 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
11652 end Prefix_Is_Formal_Parameter
;
11654 -- Start of processing for Has_Inferable_Discriminants
11657 -- For selected components, the subtype of the selector must be a
11658 -- constrained Unchecked_Union. If the component is subject to a
11659 -- per-object constraint, then the enclosing object must have inferable
11662 if Nkind
(N
) = N_Selected_Component
then
11663 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
11665 -- A small hack. If we have a per-object constrained selected
11666 -- component of a formal parameter, return True since we do not
11667 -- know the actual parameter association yet.
11669 if Prefix_Is_Formal_Parameter
(N
) then
11672 -- Otherwise, check the enclosing object and the selector
11675 return Has_Inferable_Discriminants
(Prefix
(N
))
11676 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
11679 -- The call to Has_Inferable_Discriminants will determine whether
11680 -- the selector has a constrained Unchecked_Union nominal type.
11683 return Has_Inferable_Discriminants
(Selector_Name
(N
));
11686 -- A qualified expression has inferable discriminants if its subtype
11687 -- mark is a constrained Unchecked_Union subtype.
11689 elsif Nkind
(N
) = N_Qualified_Expression
then
11690 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
11691 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
11693 -- For all other names, it is sufficient to have a constrained
11694 -- Unchecked_Union nominal subtype.
11697 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
11698 and then Is_Constrained
(Etype
(N
));
11700 end Has_Inferable_Discriminants
;
11702 -------------------------------
11703 -- Insert_Dereference_Action --
11704 -------------------------------
11706 procedure Insert_Dereference_Action
(N
: Node_Id
) is
11708 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
11709 -- Return true if type of P is derived from Checked_Pool;
11711 -----------------------------
11712 -- Is_Checked_Storage_Pool --
11713 -----------------------------
11715 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
11724 while T
/= Etype
(T
) loop
11725 if Is_RTE
(T
, RE_Checked_Pool
) then
11733 end Is_Checked_Storage_Pool
;
11737 Typ
: constant Entity_Id
:= Etype
(N
);
11738 Desig
: constant Entity_Id
:= Available_View
(Designated_Type
(Typ
));
11739 Loc
: constant Source_Ptr
:= Sloc
(N
);
11740 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
11741 Pnod
: constant Node_Id
:= Parent
(N
);
11747 Size_Bits
: Node_Id
;
11750 -- Start of processing for Insert_Dereference_Action
11753 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
11755 -- Do not re-expand a dereference which has already been processed by
11758 if Has_Dereference_Action
(Pnod
) then
11761 -- Do not perform this type of expansion for internally-generated
11764 elsif not Comes_From_Source
(Original_Node
(Pnod
)) then
11767 -- A dereference action is only applicable to objects which have been
11768 -- allocated on a checked pool.
11770 elsif not Is_Checked_Storage_Pool
(Pool
) then
11774 -- Extract the address of the dereferenced object. Generate:
11776 -- Addr : System.Address := <N>'Pool_Address;
11778 Addr
:= Make_Temporary
(Loc
, 'P');
11781 Make_Object_Declaration
(Loc
,
11782 Defining_Identifier
=> Addr
,
11783 Object_Definition
=>
11784 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
11786 Make_Attribute_Reference
(Loc
,
11787 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
11788 Attribute_Name
=> Name_Pool_Address
)));
11790 -- Calculate the size of the dereferenced object. Generate:
11792 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11795 Make_Explicit_Dereference
(Loc
,
11796 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11797 Set_Has_Dereference_Action
(Deref
);
11800 Make_Attribute_Reference
(Loc
,
11802 Attribute_Name
=> Name_Size
);
11804 -- Special case of an unconstrained array: need to add descriptor size
11806 if Is_Array_Type
(Desig
)
11807 and then not Is_Constrained
(First_Subtype
(Desig
))
11812 Make_Attribute_Reference
(Loc
,
11814 New_Occurrence_Of
(First_Subtype
(Desig
), Loc
),
11815 Attribute_Name
=> Name_Descriptor_Size
),
11816 Right_Opnd
=> Size_Bits
);
11819 Size
:= Make_Temporary
(Loc
, 'S');
11821 Make_Object_Declaration
(Loc
,
11822 Defining_Identifier
=> Size
,
11823 Object_Definition
=>
11824 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
11826 Make_Op_Divide
(Loc
,
11827 Left_Opnd
=> Size_Bits
,
11828 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
11830 -- Calculate the alignment of the dereferenced object. Generate:
11831 -- Alig : constant Storage_Count := <N>.all'Alignment;
11834 Make_Explicit_Dereference
(Loc
,
11835 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11836 Set_Has_Dereference_Action
(Deref
);
11838 Alig
:= Make_Temporary
(Loc
, 'A');
11840 Make_Object_Declaration
(Loc
,
11841 Defining_Identifier
=> Alig
,
11842 Object_Definition
=>
11843 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
11845 Make_Attribute_Reference
(Loc
,
11847 Attribute_Name
=> Name_Alignment
)));
11849 -- A dereference of a controlled object requires special processing. The
11850 -- finalization machinery requests additional space from the underlying
11851 -- pool to allocate and hide two pointers. As a result, a checked pool
11852 -- may mark the wrong memory as valid. Since checked pools do not have
11853 -- knowledge of hidden pointers, we have to bring the two pointers back
11854 -- in view in order to restore the original state of the object.
11856 if Needs_Finalization
(Desig
) then
11858 -- Adjust the address and size of the dereferenced object. Generate:
11859 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11862 Make_Procedure_Call_Statement
(Loc
,
11864 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
11865 Parameter_Associations
=> New_List
(
11866 New_Occurrence_Of
(Addr
, Loc
),
11867 New_Occurrence_Of
(Size
, Loc
),
11868 New_Occurrence_Of
(Alig
, Loc
)));
11870 -- Class-wide types complicate things because we cannot determine
11871 -- statically whether the actual object is truly controlled. We must
11872 -- generate a runtime check to detect this property. Generate:
11874 -- if Needs_Finalization (<N>.all'Tag) then
11878 if Is_Class_Wide_Type
(Desig
) then
11880 Make_Explicit_Dereference
(Loc
,
11881 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11882 Set_Has_Dereference_Action
(Deref
);
11885 Make_Implicit_If_Statement
(N
,
11887 Make_Function_Call
(Loc
,
11889 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
11890 Parameter_Associations
=> New_List
(
11891 Make_Attribute_Reference
(Loc
,
11893 Attribute_Name
=> Name_Tag
))),
11894 Then_Statements
=> New_List
(Stmt
));
11897 Insert_Action
(N
, Stmt
);
11901 -- Dereference (Pool, Addr, Size, Alig);
11904 Make_Procedure_Call_Statement
(Loc
,
11907 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
11908 Parameter_Associations
=> New_List
(
11909 New_Occurrence_Of
(Pool
, Loc
),
11910 New_Occurrence_Of
(Addr
, Loc
),
11911 New_Occurrence_Of
(Size
, Loc
),
11912 New_Occurrence_Of
(Alig
, Loc
))));
11914 -- Mark the explicit dereference as processed to avoid potential
11915 -- infinite expansion.
11917 Set_Has_Dereference_Action
(Pnod
);
11920 when RE_Not_Available
=>
11922 end Insert_Dereference_Action
;
11924 --------------------------------
11925 -- Integer_Promotion_Possible --
11926 --------------------------------
11928 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
11929 Operand
: constant Node_Id
:= Expression
(N
);
11930 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11931 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
11934 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
11938 -- We only do the transformation for source constructs. We assume
11939 -- that the expander knows what it is doing when it generates code.
11941 Comes_From_Source
(N
)
11943 -- If the operand type is Short_Integer or Short_Short_Integer,
11944 -- then we will promote to Integer, which is available on all
11945 -- targets, and is sufficient to ensure no intermediate overflow.
11946 -- Furthermore it is likely to be as efficient or more efficient
11947 -- than using the smaller type for the computation so we do this
11948 -- unconditionally.
11951 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
11953 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
11955 -- Test for interesting operation, which includes addition,
11956 -- division, exponentiation, multiplication, subtraction, absolute
11957 -- value and unary negation. Unary "+" is omitted since it is a
11958 -- no-op and thus can't overflow.
11960 and then Nkind_In
(Operand
, N_Op_Abs
,
11967 end Integer_Promotion_Possible
;
11969 ------------------------------
11970 -- Make_Array_Comparison_Op --
11971 ------------------------------
11973 -- This is a hand-coded expansion of the following generic function:
11976 -- type elem is (<>);
11977 -- type index is (<>);
11978 -- type a is array (index range <>) of elem;
11980 -- function Gnnn (X : a; Y: a) return boolean is
11981 -- J : index := Y'first;
11984 -- if X'length = 0 then
11987 -- elsif Y'length = 0 then
11991 -- for I in X'range loop
11992 -- if X (I) = Y (J) then
11993 -- if J = Y'last then
11996 -- J := index'succ (J);
12000 -- return X (I) > Y (J);
12004 -- return X'length > Y'length;
12008 -- Note that since we are essentially doing this expansion by hand, we
12009 -- do not need to generate an actual or formal generic part, just the
12010 -- instantiated function itself.
12012 -- Perhaps we could have the actual generic available in the run-time,
12013 -- obtained by rtsfind, and actually expand a real instantiation ???
12015 function Make_Array_Comparison_Op
12017 Nod
: Node_Id
) return Node_Id
12019 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12021 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
12022 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
12023 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
12024 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12026 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
12028 Loop_Statement
: Node_Id
;
12029 Loop_Body
: Node_Id
;
12031 Inner_If
: Node_Id
;
12032 Final_Expr
: Node_Id
;
12033 Func_Body
: Node_Id
;
12034 Func_Name
: Entity_Id
;
12040 -- if J = Y'last then
12043 -- J := index'succ (J);
12047 Make_Implicit_If_Statement
(Nod
,
12050 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
12052 Make_Attribute_Reference
(Loc
,
12053 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12054 Attribute_Name
=> Name_Last
)),
12056 Then_Statements
=> New_List
(
12057 Make_Exit_Statement
(Loc
)),
12061 Make_Assignment_Statement
(Loc
,
12062 Name
=> New_Occurrence_Of
(J
, Loc
),
12064 Make_Attribute_Reference
(Loc
,
12065 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
12066 Attribute_Name
=> Name_Succ
,
12067 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
12069 -- if X (I) = Y (J) then
12072 -- return X (I) > Y (J);
12076 Make_Implicit_If_Statement
(Nod
,
12080 Make_Indexed_Component
(Loc
,
12081 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12082 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
12085 Make_Indexed_Component
(Loc
,
12086 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12087 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
12089 Then_Statements
=> New_List
(Inner_If
),
12091 Else_Statements
=> New_List
(
12092 Make_Simple_Return_Statement
(Loc
,
12096 Make_Indexed_Component
(Loc
,
12097 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12098 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
12101 Make_Indexed_Component
(Loc
,
12102 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12103 Expressions
=> New_List
(
12104 New_Occurrence_Of
(J
, Loc
)))))));
12106 -- for I in X'range loop
12111 Make_Implicit_Loop_Statement
(Nod
,
12112 Identifier
=> Empty
,
12114 Iteration_Scheme
=>
12115 Make_Iteration_Scheme
(Loc
,
12116 Loop_Parameter_Specification
=>
12117 Make_Loop_Parameter_Specification
(Loc
,
12118 Defining_Identifier
=> I
,
12119 Discrete_Subtype_Definition
=>
12120 Make_Attribute_Reference
(Loc
,
12121 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12122 Attribute_Name
=> Name_Range
))),
12124 Statements
=> New_List
(Loop_Body
));
12126 -- if X'length = 0 then
12128 -- elsif Y'length = 0 then
12131 -- for ... loop ... end loop;
12132 -- return X'length > Y'length;
12136 Make_Attribute_Reference
(Loc
,
12137 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12138 Attribute_Name
=> Name_Length
);
12141 Make_Attribute_Reference
(Loc
,
12142 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12143 Attribute_Name
=> Name_Length
);
12147 Left_Opnd
=> Length1
,
12148 Right_Opnd
=> Length2
);
12151 Make_Implicit_If_Statement
(Nod
,
12155 Make_Attribute_Reference
(Loc
,
12156 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12157 Attribute_Name
=> Name_Length
),
12159 Make_Integer_Literal
(Loc
, 0)),
12163 Make_Simple_Return_Statement
(Loc
,
12164 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
12166 Elsif_Parts
=> New_List
(
12167 Make_Elsif_Part
(Loc
,
12171 Make_Attribute_Reference
(Loc
,
12172 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12173 Attribute_Name
=> Name_Length
),
12175 Make_Integer_Literal
(Loc
, 0)),
12179 Make_Simple_Return_Statement
(Loc
,
12180 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
12182 Else_Statements
=> New_List
(
12184 Make_Simple_Return_Statement
(Loc
,
12185 Expression
=> Final_Expr
)));
12189 Formals
:= New_List
(
12190 Make_Parameter_Specification
(Loc
,
12191 Defining_Identifier
=> X
,
12192 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12194 Make_Parameter_Specification
(Loc
,
12195 Defining_Identifier
=> Y
,
12196 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12198 -- function Gnnn (...) return boolean is
12199 -- J : index := Y'first;
12204 Func_Name
:= Make_Temporary
(Loc
, 'G');
12207 Make_Subprogram_Body
(Loc
,
12209 Make_Function_Specification
(Loc
,
12210 Defining_Unit_Name
=> Func_Name
,
12211 Parameter_Specifications
=> Formals
,
12212 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
12214 Declarations
=> New_List
(
12215 Make_Object_Declaration
(Loc
,
12216 Defining_Identifier
=> J
,
12217 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
12219 Make_Attribute_Reference
(Loc
,
12220 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12221 Attribute_Name
=> Name_First
))),
12223 Handled_Statement_Sequence
=>
12224 Make_Handled_Sequence_Of_Statements
(Loc
,
12225 Statements
=> New_List
(If_Stat
)));
12228 end Make_Array_Comparison_Op
;
12230 ---------------------------
12231 -- Make_Boolean_Array_Op --
12232 ---------------------------
12234 -- For logical operations on boolean arrays, expand in line the following,
12235 -- replacing 'and' with 'or' or 'xor' where needed:
12237 -- function Annn (A : typ; B: typ) return typ is
12240 -- for J in A'range loop
12241 -- C (J) := A (J) op B (J);
12246 -- Here typ is the boolean array type
12248 function Make_Boolean_Array_Op
12250 N
: Node_Id
) return Node_Id
12252 Loc
: constant Source_Ptr
:= Sloc
(N
);
12254 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
12255 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12256 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
12257 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12265 Func_Name
: Entity_Id
;
12266 Func_Body
: Node_Id
;
12267 Loop_Statement
: Node_Id
;
12271 Make_Indexed_Component
(Loc
,
12272 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12273 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12276 Make_Indexed_Component
(Loc
,
12277 Prefix
=> New_Occurrence_Of
(B
, Loc
),
12278 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12281 Make_Indexed_Component
(Loc
,
12282 Prefix
=> New_Occurrence_Of
(C
, Loc
),
12283 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12285 if Nkind
(N
) = N_Op_And
then
12289 Right_Opnd
=> B_J
);
12291 elsif Nkind
(N
) = N_Op_Or
then
12295 Right_Opnd
=> B_J
);
12301 Right_Opnd
=> B_J
);
12305 Make_Implicit_Loop_Statement
(N
,
12306 Identifier
=> Empty
,
12308 Iteration_Scheme
=>
12309 Make_Iteration_Scheme
(Loc
,
12310 Loop_Parameter_Specification
=>
12311 Make_Loop_Parameter_Specification
(Loc
,
12312 Defining_Identifier
=> J
,
12313 Discrete_Subtype_Definition
=>
12314 Make_Attribute_Reference
(Loc
,
12315 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12316 Attribute_Name
=> Name_Range
))),
12318 Statements
=> New_List
(
12319 Make_Assignment_Statement
(Loc
,
12321 Expression
=> Op
)));
12323 Formals
:= New_List
(
12324 Make_Parameter_Specification
(Loc
,
12325 Defining_Identifier
=> A
,
12326 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12328 Make_Parameter_Specification
(Loc
,
12329 Defining_Identifier
=> B
,
12330 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12332 Func_Name
:= Make_Temporary
(Loc
, 'A');
12333 Set_Is_Inlined
(Func_Name
);
12336 Make_Subprogram_Body
(Loc
,
12338 Make_Function_Specification
(Loc
,
12339 Defining_Unit_Name
=> Func_Name
,
12340 Parameter_Specifications
=> Formals
,
12341 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
12343 Declarations
=> New_List
(
12344 Make_Object_Declaration
(Loc
,
12345 Defining_Identifier
=> C
,
12346 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
12348 Handled_Statement_Sequence
=>
12349 Make_Handled_Sequence_Of_Statements
(Loc
,
12350 Statements
=> New_List
(
12352 Make_Simple_Return_Statement
(Loc
,
12353 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
12356 end Make_Boolean_Array_Op
;
12358 -----------------------------------------
12359 -- Minimized_Eliminated_Overflow_Check --
12360 -----------------------------------------
12362 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
12365 Is_Signed_Integer_Type
(Etype
(N
))
12366 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
12367 end Minimized_Eliminated_Overflow_Check
;
12369 --------------------------------
12370 -- Optimize_Length_Comparison --
12371 --------------------------------
12373 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
12374 Loc
: constant Source_Ptr
:= Sloc
(N
);
12375 Typ
: constant Entity_Id
:= Etype
(N
);
12380 -- First and Last attribute reference nodes, which end up as left and
12381 -- right operands of the optimized result.
12384 -- True for comparison operand of zero
12387 -- Comparison operand, set only if Is_Zero is false
12390 -- Entity whose length is being compared
12393 -- Integer_Literal node for length attribute expression, or Empty
12394 -- if there is no such expression present.
12397 -- Type of array index to which 'Length is applied
12399 Op
: Node_Kind
:= Nkind
(N
);
12400 -- Kind of comparison operator, gets flipped if operands backwards
12402 function Is_Optimizable
(N
: Node_Id
) return Boolean;
12403 -- Tests N to see if it is an optimizable comparison value (defined as
12404 -- constant zero or one, or something else where the value is known to
12405 -- be positive and in the range of 32-bits, and where the corresponding
12406 -- Length value is also known to be 32-bits. If result is true, sets
12407 -- Is_Zero, Ityp, and Comp accordingly.
12409 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
12410 -- Tests if N is a length attribute applied to a simple entity. If so,
12411 -- returns True, and sets Ent to the entity, and Index to the integer
12412 -- literal provided as an attribute expression, or to Empty if none.
12413 -- Also returns True if the expression is a generated type conversion
12414 -- whose expression is of the desired form. This latter case arises
12415 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12416 -- to check for being in range, which is not needed in this context.
12417 -- Returns False if neither condition holds.
12419 function Prepare_64
(N
: Node_Id
) return Node_Id
;
12420 -- Given a discrete expression, returns a Long_Long_Integer typed
12421 -- expression representing the underlying value of the expression.
12422 -- This is done with an unchecked conversion to the result type. We
12423 -- use unchecked conversion to handle the enumeration type case.
12425 ----------------------
12426 -- Is_Entity_Length --
12427 ----------------------
12429 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
12431 if Nkind
(N
) = N_Attribute_Reference
12432 and then Attribute_Name
(N
) = Name_Length
12433 and then Is_Entity_Name
(Prefix
(N
))
12435 Ent
:= Entity
(Prefix
(N
));
12437 if Present
(Expressions
(N
)) then
12438 Index
:= First
(Expressions
(N
));
12445 elsif Nkind
(N
) = N_Type_Conversion
12446 and then not Comes_From_Source
(N
)
12448 return Is_Entity_Length
(Expression
(N
));
12453 end Is_Entity_Length
;
12455 --------------------
12456 -- Is_Optimizable --
12457 --------------------
12459 function Is_Optimizable
(N
: Node_Id
) return Boolean is
12467 if Compile_Time_Known_Value
(N
) then
12468 Val
:= Expr_Value
(N
);
12470 if Val
= Uint_0
then
12475 elsif Val
= Uint_1
then
12482 -- Here we have to make sure of being within 32-bits
12484 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12487 or else Lo
< Uint_1
12488 or else Hi
> UI_From_Int
(Int
'Last)
12493 -- Comparison value was within range, so now we must check the index
12494 -- value to make sure it is also within 32-bits.
12496 Indx
:= First_Index
(Etype
(Ent
));
12498 if Present
(Index
) then
12499 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
12504 Ityp
:= Etype
(Indx
);
12506 if Esize
(Ityp
) > 32 then
12513 end Is_Optimizable
;
12519 function Prepare_64
(N
: Node_Id
) return Node_Id
is
12521 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
12524 -- Start of processing for Optimize_Length_Comparison
12527 -- Nothing to do if not a comparison
12529 if Op
not in N_Op_Compare
then
12533 -- Nothing to do if special -gnatd.P debug flag set
12535 if Debug_Flag_Dot_PP
then
12539 -- Ent'Length op 0/1
12541 if Is_Entity_Length
(Left_Opnd
(N
))
12542 and then Is_Optimizable
(Right_Opnd
(N
))
12546 -- 0/1 op Ent'Length
12548 elsif Is_Entity_Length
(Right_Opnd
(N
))
12549 and then Is_Optimizable
(Left_Opnd
(N
))
12551 -- Flip comparison to opposite sense
12554 when N_Op_Lt
=> Op
:= N_Op_Gt
;
12555 when N_Op_Le
=> Op
:= N_Op_Ge
;
12556 when N_Op_Gt
=> Op
:= N_Op_Lt
;
12557 when N_Op_Ge
=> Op
:= N_Op_Le
;
12558 when others => null;
12561 -- Else optimization not possible
12567 -- Fall through if we will do the optimization
12569 -- Cases to handle:
12571 -- X'Length = 0 => X'First > X'Last
12572 -- X'Length = 1 => X'First = X'Last
12573 -- X'Length = n => X'First + (n - 1) = X'Last
12575 -- X'Length /= 0 => X'First <= X'Last
12576 -- X'Length /= 1 => X'First /= X'Last
12577 -- X'Length /= n => X'First + (n - 1) /= X'Last
12579 -- X'Length >= 0 => always true, warn
12580 -- X'Length >= 1 => X'First <= X'Last
12581 -- X'Length >= n => X'First + (n - 1) <= X'Last
12583 -- X'Length > 0 => X'First <= X'Last
12584 -- X'Length > 1 => X'First < X'Last
12585 -- X'Length > n => X'First + (n - 1) < X'Last
12587 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12588 -- X'Length <= 1 => X'First >= X'Last
12589 -- X'Length <= n => X'First + (n - 1) >= X'Last
12591 -- X'Length < 0 => always false (warn)
12592 -- X'Length < 1 => X'First > X'Last
12593 -- X'Length < n => X'First + (n - 1) > X'Last
12595 -- Note: for the cases of n (not constant 0,1), we require that the
12596 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12597 -- and the same for the comparison value. Then we do the comparison
12598 -- using 64-bit arithmetic (actually long long integer), so that we
12599 -- cannot have overflow intefering with the result.
12601 -- First deal with warning cases
12610 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
12611 Analyze_And_Resolve
(N
, Typ
);
12612 Warn_On_Known_Condition
(N
);
12619 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
12620 Analyze_And_Resolve
(N
, Typ
);
12621 Warn_On_Known_Condition
(N
);
12625 if Constant_Condition_Warnings
12626 and then Comes_From_Source
(Original_Node
(N
))
12628 Error_Msg_N
("could replace by ""'=""?c?", N
);
12638 -- Build the First reference we will use
12641 Make_Attribute_Reference
(Loc
,
12642 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12643 Attribute_Name
=> Name_First
);
12645 if Present
(Index
) then
12646 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
12649 -- If general value case, then do the addition of (n - 1), and
12650 -- also add the needed conversions to type Long_Long_Integer.
12652 if Present
(Comp
) then
12655 Left_Opnd
=> Prepare_64
(Left
),
12657 Make_Op_Subtract
(Loc
,
12658 Left_Opnd
=> Prepare_64
(Comp
),
12659 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
12662 -- Build the Last reference we will use
12665 Make_Attribute_Reference
(Loc
,
12666 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12667 Attribute_Name
=> Name_Last
);
12669 if Present
(Index
) then
12670 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
12673 -- If general operand, convert Last reference to Long_Long_Integer
12675 if Present
(Comp
) then
12676 Right
:= Prepare_64
(Right
);
12679 -- Check for cases to optimize
12681 -- X'Length = 0 => X'First > X'Last
12682 -- X'Length < 1 => X'First > X'Last
12683 -- X'Length < n => X'First + (n - 1) > X'Last
12685 if (Is_Zero
and then Op
= N_Op_Eq
)
12686 or else (not Is_Zero
and then Op
= N_Op_Lt
)
12691 Right_Opnd
=> Right
);
12693 -- X'Length = 1 => X'First = X'Last
12694 -- X'Length = n => X'First + (n - 1) = X'Last
12696 elsif not Is_Zero
and then Op
= N_Op_Eq
then
12700 Right_Opnd
=> Right
);
12702 -- X'Length /= 0 => X'First <= X'Last
12703 -- X'Length > 0 => X'First <= X'Last
12705 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
12709 Right_Opnd
=> Right
);
12711 -- X'Length /= 1 => X'First /= X'Last
12712 -- X'Length /= n => X'First + (n - 1) /= X'Last
12714 elsif not Is_Zero
and then Op
= N_Op_Ne
then
12718 Right_Opnd
=> Right
);
12720 -- X'Length >= 1 => X'First <= X'Last
12721 -- X'Length >= n => X'First + (n - 1) <= X'Last
12723 elsif not Is_Zero
and then Op
= N_Op_Ge
then
12727 Right_Opnd
=> Right
);
12729 -- X'Length > 1 => X'First < X'Last
12730 -- X'Length > n => X'First + (n = 1) < X'Last
12732 elsif not Is_Zero
and then Op
= N_Op_Gt
then
12736 Right_Opnd
=> Right
);
12738 -- X'Length <= 1 => X'First >= X'Last
12739 -- X'Length <= n => X'First + (n - 1) >= X'Last
12741 elsif not Is_Zero
and then Op
= N_Op_Le
then
12745 Right_Opnd
=> Right
);
12747 -- Should not happen at this stage
12750 raise Program_Error
;
12753 -- Rewrite and finish up
12755 Rewrite
(N
, Result
);
12756 Analyze_And_Resolve
(N
, Typ
);
12758 end Optimize_Length_Comparison
;
12760 ------------------------------
12761 -- Process_Transient_Object --
12762 ------------------------------
12764 procedure Process_Transient_Object
12766 Rel_Node
: Node_Id
)
12768 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
12769 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
12770 Obj_Typ
: constant Node_Id
:= Etype
(Obj_Id
);
12771 Desig_Typ
: Entity_Id
;
12773 Hook_Id
: Entity_Id
;
12774 Hook_Insert
: Node_Id
;
12775 Ptr_Id
: Entity_Id
;
12777 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Rel_Node
);
12778 -- The node on which to insert the hook as an action. This is usually
12779 -- the innermost enclosing non-transient construct.
12781 Fin_Context
: Node_Id
;
12782 -- The node after which to insert the finalization actions of the
12783 -- transient controlled object.
12786 if Is_Boolean_Type
(Etype
(Rel_Node
)) then
12787 Fin_Context
:= Last
(Actions
(Rel_Node
));
12789 Fin_Context
:= Hook_Context
;
12792 -- Step 1: Create the access type which provides a reference to the
12793 -- transient controlled object.
12795 if Is_Access_Type
(Obj_Typ
) then
12796 Desig_Typ
:= Directly_Designated_Type
(Obj_Typ
);
12798 Desig_Typ
:= Obj_Typ
;
12801 Desig_Typ
:= Base_Type
(Desig_Typ
);
12804 -- Ann : access [all] <Desig_Typ>;
12806 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
12808 Insert_Action
(Hook_Context
,
12809 Make_Full_Type_Declaration
(Loc
,
12810 Defining_Identifier
=> Ptr_Id
,
12812 Make_Access_To_Object_Definition
(Loc
,
12813 All_Present
=> Ekind
(Obj_Typ
) = E_General_Access_Type
,
12814 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))));
12816 -- Step 2: Create a temporary which acts as a hook to the transient
12817 -- controlled object. Generate:
12819 -- Hook : Ptr_Id := null;
12821 Hook_Id
:= Make_Temporary
(Loc
, 'T');
12823 Insert_Action
(Hook_Context
,
12824 Make_Object_Declaration
(Loc
,
12825 Defining_Identifier
=> Hook_Id
,
12826 Object_Definition
=> New_Occurrence_Of
(Ptr_Id
, Loc
)));
12828 -- Mark the hook as created for the purposes of exporting the transient
12829 -- controlled object out of the expression_with_action or if expression.
12830 -- This signals the machinery in Build_Finalizer to treat this case in
12831 -- a special manner.
12833 Set_Status_Flag_Or_Transient_Decl
(Hook_Id
, Decl
);
12835 -- Step 3: Associate the transient object to the hook
12837 -- This must be inserted right after the object declaration, so that
12838 -- the assignment is executed if, and only if, the object is actually
12839 -- created (whereas the declaration of the hook pointer, and the
12840 -- finalization call, may be inserted at an outer level, and may
12841 -- remain unused for some executions, if the actual creation of
12842 -- the object is conditional).
12844 -- The use of unchecked conversion / unrestricted access is needed to
12845 -- avoid an accessibility violation. Note that the finalization code is
12846 -- structured in such a way that the "hook" is processed only when it
12847 -- points to an existing object.
12849 if Is_Access_Type
(Obj_Typ
) then
12851 Unchecked_Convert_To
12853 Expr
=> New_Occurrence_Of
(Obj_Id
, Loc
));
12856 Make_Attribute_Reference
(Loc
,
12857 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
12858 Attribute_Name
=> Name_Unrestricted_Access
);
12862 -- Hook := Ptr_Id (Obj_Id);
12864 -- Hook := Obj_Id'Unrestricted_Access;
12866 -- When the transient object is initialized by an aggregate, the hook
12867 -- must capture the object after the last component assignment takes
12868 -- place. Only then is the object fully initialized.
12870 if Ekind
(Obj_Id
) = E_Variable
12871 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
12873 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
12875 -- Otherwise the hook seizes the related object immediately
12878 Hook_Insert
:= Decl
;
12881 Insert_After_And_Analyze
(Hook_Insert
,
12882 Make_Assignment_Statement
(Loc
,
12883 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
12884 Expression
=> Expr
));
12886 -- Step 4: Finalize the hook after the context has been evaluated or
12887 -- elaborated. Generate:
12889 -- if Hook /= null then
12890 -- [Deep_]Finalize (Hook.all);
12894 -- When the node is part of a return statement, there is no need to
12895 -- insert a finalization call, as the general finalization mechanism
12896 -- (see Build_Finalizer) would take care of the transient controlled
12897 -- object on subprogram exit. Note that it would also be impossible to
12898 -- insert the finalization code after the return statement as this will
12899 -- render it unreachable.
12901 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
12904 -- Otherwise finalize the hook
12907 Insert_Action_After
(Fin_Context
,
12908 Make_Implicit_If_Statement
(Decl
,
12911 Left_Opnd
=> New_Occurrence_Of
(Hook_Id
, Loc
),
12912 Right_Opnd
=> Make_Null
(Loc
)),
12914 Then_Statements
=> New_List
(
12917 Make_Explicit_Dereference
(Loc
,
12918 Prefix
=> New_Occurrence_Of
(Hook_Id
, Loc
)),
12921 Make_Assignment_Statement
(Loc
,
12922 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
12923 Expression
=> Make_Null
(Loc
)))));
12925 end Process_Transient_Object
;
12927 ------------------------
12928 -- Rewrite_Comparison --
12929 ------------------------
12931 procedure Rewrite_Comparison
(N
: Node_Id
) is
12932 Warning_Generated
: Boolean := False;
12933 -- Set to True if first pass with Assume_Valid generates a warning in
12934 -- which case we skip the second pass to avoid warning overloaded.
12937 -- Set to Standard_True or Standard_False
12940 if Nkind
(N
) = N_Type_Conversion
then
12941 Rewrite_Comparison
(Expression
(N
));
12944 elsif Nkind
(N
) not in N_Op_Compare
then
12948 -- Now start looking at the comparison in detail. We potentially go
12949 -- through this loop twice. The first time, Assume_Valid is set False
12950 -- in the call to Compile_Time_Compare. If this call results in a
12951 -- clear result of always True or Always False, that's decisive and
12952 -- we are done. Otherwise we repeat the processing with Assume_Valid
12953 -- set to True to generate additional warnings. We can skip that step
12954 -- if Constant_Condition_Warnings is False.
12956 for AV
in False .. True loop
12958 Typ
: constant Entity_Id
:= Etype
(N
);
12959 Op1
: constant Node_Id
:= Left_Opnd
(N
);
12960 Op2
: constant Node_Id
:= Right_Opnd
(N
);
12962 Res
: constant Compare_Result
:=
12963 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
12964 -- Res indicates if compare outcome can be compile time determined
12966 True_Result
: Boolean;
12967 False_Result
: Boolean;
12970 case N_Op_Compare
(Nkind
(N
)) is
12972 True_Result
:= Res
= EQ
;
12973 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
12976 True_Result
:= Res
in Compare_GE
;
12977 False_Result
:= Res
= LT
;
12980 and then Constant_Condition_Warnings
12981 and then Comes_From_Source
(Original_Node
(N
))
12982 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
12983 and then not In_Instance
12984 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12985 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12988 ("can never be greater than, could replace by ""'=""?c?",
12990 Warning_Generated
:= True;
12994 True_Result
:= Res
= GT
;
12995 False_Result
:= Res
in Compare_LE
;
12998 True_Result
:= Res
= LT
;
12999 False_Result
:= Res
in Compare_GE
;
13002 True_Result
:= Res
in Compare_LE
;
13003 False_Result
:= Res
= GT
;
13006 and then Constant_Condition_Warnings
13007 and then Comes_From_Source
(Original_Node
(N
))
13008 and then Nkind
(Original_Node
(N
)) = N_Op_Le
13009 and then not In_Instance
13010 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
13011 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
13014 ("can never be less than, could replace by ""'=""?c?", N
);
13015 Warning_Generated
:= True;
13019 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
13020 False_Result
:= Res
= EQ
;
13023 -- If this is the first iteration, then we actually convert the
13024 -- comparison into True or False, if the result is certain.
13027 if True_Result
or False_Result
then
13028 Result
:= Boolean_Literals
(True_Result
);
13031 New_Occurrence_Of
(Result
, Sloc
(N
))));
13032 Analyze_And_Resolve
(N
, Typ
);
13033 Warn_On_Known_Condition
(N
);
13037 -- If this is the second iteration (AV = True), and the original
13038 -- node comes from source and we are not in an instance, then give
13039 -- a warning if we know result would be True or False. Note: we
13040 -- know Constant_Condition_Warnings is set if we get here.
13042 elsif Comes_From_Source
(Original_Node
(N
))
13043 and then not In_Instance
13045 if True_Result
then
13047 ("condition can only be False if invalid values present??",
13049 elsif False_Result
then
13051 ("condition can only be True if invalid values present??",
13057 -- Skip second iteration if not warning on constant conditions or
13058 -- if the first iteration already generated a warning of some kind or
13059 -- if we are in any case assuming all values are valid (so that the
13060 -- first iteration took care of the valid case).
13062 exit when not Constant_Condition_Warnings
;
13063 exit when Warning_Generated
;
13064 exit when Assume_No_Invalid_Values
;
13066 end Rewrite_Comparison
;
13068 ----------------------------
13069 -- Safe_In_Place_Array_Op --
13070 ----------------------------
13072 function Safe_In_Place_Array_Op
13075 Op2
: Node_Id
) return Boolean
13077 Target
: Entity_Id
;
13079 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
13080 -- Operand is safe if it cannot overlap part of the target of the
13081 -- operation. If the operand and the target are identical, the operand
13082 -- is safe. The operand can be empty in the case of negation.
13084 function Is_Unaliased
(N
: Node_Id
) return Boolean;
13085 -- Check that N is a stand-alone entity
13091 function Is_Unaliased
(N
: Node_Id
) return Boolean is
13095 and then No
(Address_Clause
(Entity
(N
)))
13096 and then No
(Renamed_Object
(Entity
(N
)));
13099 ---------------------
13100 -- Is_Safe_Operand --
13101 ---------------------
13103 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
13108 elsif Is_Entity_Name
(Op
) then
13109 return Is_Unaliased
(Op
);
13111 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
13112 return Is_Unaliased
(Prefix
(Op
));
13114 elsif Nkind
(Op
) = N_Slice
then
13116 Is_Unaliased
(Prefix
(Op
))
13117 and then Entity
(Prefix
(Op
)) /= Target
;
13119 elsif Nkind
(Op
) = N_Op_Not
then
13120 return Is_Safe_Operand
(Right_Opnd
(Op
));
13125 end Is_Safe_Operand
;
13127 -- Start of processing for Safe_In_Place_Array_Op
13130 -- Skip this processing if the component size is different from system
13131 -- storage unit (since at least for NOT this would cause problems).
13133 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
13136 -- Cannot do in place stuff on VM_Target since cannot pass addresses
13138 elsif VM_Target
/= No_VM
then
13141 -- Cannot do in place stuff if non-standard Boolean representation
13143 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
13146 elsif not Is_Unaliased
(Lhs
) then
13150 Target
:= Entity
(Lhs
);
13151 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
13153 end Safe_In_Place_Array_Op
;
13155 -----------------------
13156 -- Tagged_Membership --
13157 -----------------------
13159 -- There are two different cases to consider depending on whether the right
13160 -- operand is a class-wide type or not. If not we just compare the actual
13161 -- tag of the left expr to the target type tag:
13163 -- Left_Expr.Tag = Right_Type'Tag;
13165 -- If it is a class-wide type we use the RT function CW_Membership which is
13166 -- usually implemented by looking in the ancestor tables contained in the
13167 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13169 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13170 -- function IW_Membership which is usually implemented by looking in the
13171 -- table of abstract interface types plus the ancestor table contained in
13172 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13174 procedure Tagged_Membership
13176 SCIL_Node
: out Node_Id
;
13177 Result
: out Node_Id
)
13179 Left
: constant Node_Id
:= Left_Opnd
(N
);
13180 Right
: constant Node_Id
:= Right_Opnd
(N
);
13181 Loc
: constant Source_Ptr
:= Sloc
(N
);
13183 Full_R_Typ
: Entity_Id
;
13184 Left_Type
: Entity_Id
;
13185 New_Node
: Node_Id
;
13186 Right_Type
: Entity_Id
;
13190 SCIL_Node
:= Empty
;
13192 -- Handle entities from the limited view
13194 Left_Type
:= Available_View
(Etype
(Left
));
13195 Right_Type
:= Available_View
(Etype
(Right
));
13197 -- In the case where the type is an access type, the test is applied
13198 -- using the designated types (needed in Ada 2012 for implicit anonymous
13199 -- access conversions, for AI05-0149).
13201 if Is_Access_Type
(Right_Type
) then
13202 Left_Type
:= Designated_Type
(Left_Type
);
13203 Right_Type
:= Designated_Type
(Right_Type
);
13206 if Is_Class_Wide_Type
(Left_Type
) then
13207 Left_Type
:= Root_Type
(Left_Type
);
13210 if Is_Class_Wide_Type
(Right_Type
) then
13211 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
13213 Full_R_Typ
:= Underlying_Type
(Right_Type
);
13217 Make_Selected_Component
(Loc
,
13218 Prefix
=> Relocate_Node
(Left
),
13220 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
13222 if Is_Class_Wide_Type
(Right_Type
) then
13224 -- No need to issue a run-time check if we statically know that the
13225 -- result of this membership test is always true. For example,
13226 -- considering the following declarations:
13228 -- type Iface is interface;
13229 -- type T is tagged null record;
13230 -- type DT is new T and Iface with null record;
13235 -- These membership tests are always true:
13238 -- Obj2 in T'Class;
13239 -- Obj2 in Iface'Class;
13241 -- We do not need to handle cases where the membership is illegal.
13244 -- Obj1 in DT'Class; -- Compile time error
13245 -- Obj1 in Iface'Class; -- Compile time error
13247 if not Is_Class_Wide_Type
(Left_Type
)
13248 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
13249 Use_Full_View
=> True)
13250 or else (Is_Interface
(Etype
(Right_Type
))
13251 and then Interface_Present_In_Ancestor
13253 Iface
=> Etype
(Right_Type
))))
13255 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
13259 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13261 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
13263 -- Support to: "Iface_CW_Typ in Typ'Class"
13265 or else Is_Interface
(Left_Type
)
13267 -- Issue error if IW_Membership operation not available in a
13268 -- configurable run time setting.
13270 if not RTE_Available
(RE_IW_Membership
) then
13272 ("dynamic membership test on interface types", N
);
13278 Make_Function_Call
(Loc
,
13279 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
13280 Parameter_Associations
=> New_List
(
13281 Make_Attribute_Reference
(Loc
,
13283 Attribute_Name
=> Name_Address
),
13284 New_Occurrence_Of
(
13285 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
13288 -- Ada 95: Normal case
13291 Build_CW_Membership
(Loc
,
13292 Obj_Tag_Node
=> Obj_Tag
,
13294 New_Occurrence_Of
(
13295 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
13297 New_Node
=> New_Node
);
13299 -- Generate the SCIL node for this class-wide membership test.
13300 -- Done here because the previous call to Build_CW_Membership
13301 -- relocates Obj_Tag.
13303 if Generate_SCIL
then
13304 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
13305 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
13306 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
13309 Result
:= New_Node
;
13312 -- Right_Type is not a class-wide type
13315 -- No need to check the tag of the object if Right_Typ is abstract
13317 if Is_Abstract_Type
(Right_Type
) then
13318 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
13323 Left_Opnd
=> Obj_Tag
,
13326 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
13329 end Tagged_Membership
;
13331 ------------------------------
13332 -- Unary_Op_Validity_Checks --
13333 ------------------------------
13335 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
13337 if Validity_Checks_On
and Validity_Check_Operands
then
13338 Ensure_Valid
(Right_Opnd
(N
));
13340 end Unary_Op_Validity_Checks
;