1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Exp_VFpt
; use Exp_VFpt
;
46 with Freeze
; use Freeze
;
47 with Inline
; use Inline
;
49 with Namet
; use Namet
;
50 with Nlists
; use Nlists
;
51 with Nmake
; use Nmake
;
53 with Par_SCO
; use Par_SCO
;
54 with Restrict
; use Restrict
;
55 with Rident
; use Rident
;
56 with Rtsfind
; use Rtsfind
;
58 with Sem_Aux
; use Sem_Aux
;
59 with Sem_Cat
; use Sem_Cat
;
60 with Sem_Ch3
; use Sem_Ch3
;
61 with Sem_Ch8
; use Sem_Ch8
;
62 with Sem_Ch13
; use Sem_Ch13
;
63 with Sem_Eval
; use Sem_Eval
;
64 with Sem_Res
; use Sem_Res
;
65 with Sem_Type
; use Sem_Type
;
66 with Sem_Util
; use Sem_Util
;
67 with Sem_Warn
; use Sem_Warn
;
68 with Sinfo
; use Sinfo
;
69 with Snames
; use Snames
;
70 with Stand
; use Stand
;
71 with SCIL_LL
; use SCIL_LL
;
72 with Targparm
; use Targparm
;
73 with Tbuild
; use Tbuild
;
74 with Ttypes
; use Ttypes
;
75 with Uintp
; use Uintp
;
76 with Urealp
; use Urealp
;
77 with Validsw
; use Validsw
;
79 package body Exp_Ch4
is
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
86 pragma Inline
(Binary_Op_Validity_Checks
);
87 -- Performs validity checks for a binary operator
89 procedure Build_Boolean_Array_Proc_Call
93 -- If a boolean array assignment can be done in place, build call to
94 -- corresponding library procedure.
96 function Current_Anonymous_Master
return Entity_Id
;
97 -- Return the entity of the heterogeneous finalization master belonging to
98 -- the current unit (either function, package or procedure). This master
99 -- services all anonymous access-to-controlled types. If the current unit
100 -- does not have such master, create one.
102 procedure Displace_Allocator_Pointer
(N
: Node_Id
);
103 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
104 -- Expand_Allocator_Expression. Allocating class-wide interface objects
105 -- this routine displaces the pointer to the allocated object to reference
106 -- the component referencing the corresponding secondary dispatch table.
108 procedure Expand_Allocator_Expression
(N
: Node_Id
);
109 -- Subsidiary to Expand_N_Allocator, for the case when the expression
110 -- is a qualified expression or an aggregate.
112 procedure Expand_Array_Comparison
(N
: Node_Id
);
113 -- This routine handles expansion of the comparison operators (N_Op_Lt,
114 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
115 -- code for these operators is similar, differing only in the details of
116 -- the actual comparison call that is made. Special processing (call a
119 function Expand_Array_Equality
124 Typ
: Entity_Id
) return Node_Id
;
125 -- Expand an array equality into a call to a function implementing this
126 -- equality, and a call to it. Loc is the location for the generated nodes.
127 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
128 -- on which to attach bodies of local functions that are created in the
129 -- process. It is the responsibility of the caller to insert those bodies
130 -- at the right place. Nod provides the Sloc value for the generated code.
131 -- Normally the types used for the generated equality routine are taken
132 -- from Lhs and Rhs. However, in some situations of generated code, the
133 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
134 -- the type to be used for the formal parameters.
136 procedure Expand_Boolean_Operator
(N
: Node_Id
);
137 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
138 -- case of array type arguments.
140 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
);
141 -- Common expansion processing for short-circuit boolean operators
143 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
);
144 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
145 -- where we allow comparison of "out of range" values.
147 function Expand_Composite_Equality
152 Bodies
: List_Id
) return Node_Id
;
153 -- Local recursive function used to expand equality for nested composite
154 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
155 -- to attach bodies of local functions that are created in the process.
156 -- It is the responsibility of the caller to insert those bodies at the
157 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
158 -- are the left and right sides for the comparison, and Typ is the type of
159 -- the objects to compare.
161 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
162 -- Routine to expand concatenation of a sequence of two or more operands
163 -- (in the list Operands) and replace node Cnode with the result of the
164 -- concatenation. The operands can be of any appropriate type, and can
165 -- include both arrays and singleton elements.
167 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
);
168 -- N is an N_In membership test mode, with the overflow check mode set to
169 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
170 -- integer type. This is a case where top level processing is required to
171 -- handle overflow checks in subtrees.
173 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
174 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
175 -- fixed. We do not have such a type at runtime, so the purpose of this
176 -- routine is to find the real type by looking up the tree. We also
177 -- determine if the operation must be rounded.
179 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
180 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
181 -- discriminants if it has a constrained nominal type, unless the object
182 -- is a component of an enclosing Unchecked_Union object that is subject
183 -- to a per-object constraint and the enclosing object lacks inferable
186 -- An expression of an Unchecked_Union type has inferable discriminants
187 -- if it is either a name of an object with inferable discriminants or a
188 -- qualified expression whose subtype mark denotes a constrained subtype.
190 procedure Insert_Dereference_Action
(N
: Node_Id
);
191 -- N is an expression whose type is an access. When the type of the
192 -- associated storage pool is derived from Checked_Pool, generate a
193 -- call to the 'Dereference' primitive operation.
195 function Make_Array_Comparison_Op
197 Nod
: Node_Id
) return Node_Id
;
198 -- Comparisons between arrays are expanded in line. This function produces
199 -- the body of the implementation of (a > b), where a and b are one-
200 -- dimensional arrays of some discrete type. The original node is then
201 -- expanded into the appropriate call to this function. Nod provides the
202 -- Sloc value for the generated code.
204 function Make_Boolean_Array_Op
206 N
: Node_Id
) return Node_Id
;
207 -- Boolean operations on boolean arrays are expanded in line. This function
208 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
209 -- b). It is used only the normal case and not the packed case. The type
210 -- involved, Typ, is the Boolean array type, and the logical operations in
211 -- the body are simple boolean operations. Note that Typ is always a
212 -- constrained type (the caller has ensured this by using
213 -- Convert_To_Actual_Subtype if necessary).
215 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean;
216 -- For signed arithmetic operations when the current overflow mode is
217 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
218 -- as the first thing we do. We then return. We count on the recursive
219 -- apparatus for overflow checks to call us back with an equivalent
220 -- operation that is in CHECKED mode, avoiding a recursive entry into this
221 -- routine, and that is when we will proceed with the expansion of the
222 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
223 -- these optimizations without first making this check, since there may be
224 -- operands further down the tree that are relying on the recursive calls
225 -- triggered by the top level nodes to properly process overflow checking
226 -- and remaining expansion on these nodes. Note that this call back may be
227 -- skipped if the operation is done in Bignum mode but that's fine, since
228 -- the Bignum call takes care of everything.
230 procedure Optimize_Length_Comparison
(N
: Node_Id
);
231 -- Given an expression, if it is of the form X'Length op N (or the other
232 -- way round), where N is known at compile time to be 0 or 1, and X is a
233 -- simple entity, and op is a comparison operator, optimizes it into a
234 -- comparison of First and Last.
236 procedure Process_Transient_Object
239 -- Subsidiary routine to the expansion of expression_with_actions and if
240 -- expressions. Generate all the necessary code to finalize a transient
241 -- controlled object when the enclosing context is elaborated or evaluated.
242 -- Decl denotes the declaration of the transient controlled object which is
243 -- usually the result of a controlled function call. Rel_Node denotes the
244 -- context, either an expression_with_actions or an if expression.
246 procedure Rewrite_Comparison
(N
: Node_Id
);
247 -- If N is the node for a comparison whose outcome can be determined at
248 -- compile time, then the node N can be rewritten with True or False. If
249 -- the outcome cannot be determined at compile time, the call has no
250 -- effect. If N is a type conversion, then this processing is applied to
251 -- its expression. If N is neither comparison nor a type conversion, the
252 -- call has no effect.
254 procedure Tagged_Membership
256 SCIL_Node
: out Node_Id
;
257 Result
: out Node_Id
);
258 -- Construct the expression corresponding to the tagged membership test.
259 -- Deals with a second operand being (or not) a class-wide type.
261 function Safe_In_Place_Array_Op
264 Op2
: Node_Id
) return Boolean;
265 -- In the context of an assignment, where the right-hand side is a boolean
266 -- operation on arrays, check whether operation can be performed in place.
268 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
269 pragma Inline
(Unary_Op_Validity_Checks
);
270 -- Performs validity checks for a unary operator
272 -------------------------------
273 -- Binary_Op_Validity_Checks --
274 -------------------------------
276 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
278 if Validity_Checks_On
and Validity_Check_Operands
then
279 Ensure_Valid
(Left_Opnd
(N
));
280 Ensure_Valid
(Right_Opnd
(N
));
282 end Binary_Op_Validity_Checks
;
284 ------------------------------------
285 -- Build_Boolean_Array_Proc_Call --
286 ------------------------------------
288 procedure Build_Boolean_Array_Proc_Call
293 Loc
: constant Source_Ptr
:= Sloc
(N
);
294 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
295 Target
: constant Node_Id
:=
296 Make_Attribute_Reference
(Loc
,
298 Attribute_Name
=> Name_Address
);
300 Arg1
: Node_Id
:= Op1
;
301 Arg2
: Node_Id
:= Op2
;
303 Proc_Name
: Entity_Id
;
306 if Kind
= N_Op_Not
then
307 if Nkind
(Op1
) in N_Binary_Op
then
309 -- Use negated version of the binary operators
311 if Nkind
(Op1
) = N_Op_And
then
312 Proc_Name
:= RTE
(RE_Vector_Nand
);
314 elsif Nkind
(Op1
) = N_Op_Or
then
315 Proc_Name
:= RTE
(RE_Vector_Nor
);
317 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
318 Proc_Name
:= RTE
(RE_Vector_Xor
);
322 Make_Procedure_Call_Statement
(Loc
,
323 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
325 Parameter_Associations
=> New_List
(
327 Make_Attribute_Reference
(Loc
,
328 Prefix
=> Left_Opnd
(Op1
),
329 Attribute_Name
=> Name_Address
),
331 Make_Attribute_Reference
(Loc
,
332 Prefix
=> Right_Opnd
(Op1
),
333 Attribute_Name
=> Name_Address
),
335 Make_Attribute_Reference
(Loc
,
336 Prefix
=> Left_Opnd
(Op1
),
337 Attribute_Name
=> Name_Length
)));
340 Proc_Name
:= RTE
(RE_Vector_Not
);
343 Make_Procedure_Call_Statement
(Loc
,
344 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
345 Parameter_Associations
=> New_List
(
348 Make_Attribute_Reference
(Loc
,
350 Attribute_Name
=> Name_Address
),
352 Make_Attribute_Reference
(Loc
,
354 Attribute_Name
=> Name_Length
)));
358 -- We use the following equivalences:
360 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
361 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
362 -- (not X) xor (not Y) = X xor Y
363 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
365 if Nkind
(Op1
) = N_Op_Not
then
366 Arg1
:= Right_Opnd
(Op1
);
367 Arg2
:= Right_Opnd
(Op2
);
369 if Kind
= N_Op_And
then
370 Proc_Name
:= RTE
(RE_Vector_Nor
);
371 elsif Kind
= N_Op_Or
then
372 Proc_Name
:= RTE
(RE_Vector_Nand
);
374 Proc_Name
:= RTE
(RE_Vector_Xor
);
378 if Kind
= N_Op_And
then
379 Proc_Name
:= RTE
(RE_Vector_And
);
380 elsif Kind
= N_Op_Or
then
381 Proc_Name
:= RTE
(RE_Vector_Or
);
382 elsif Nkind
(Op2
) = N_Op_Not
then
383 Proc_Name
:= RTE
(RE_Vector_Nxor
);
384 Arg2
:= Right_Opnd
(Op2
);
386 Proc_Name
:= RTE
(RE_Vector_Xor
);
391 Make_Procedure_Call_Statement
(Loc
,
392 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
393 Parameter_Associations
=> New_List
(
395 Make_Attribute_Reference
(Loc
,
397 Attribute_Name
=> Name_Address
),
398 Make_Attribute_Reference
(Loc
,
400 Attribute_Name
=> Name_Address
),
401 Make_Attribute_Reference
(Loc
,
403 Attribute_Name
=> Name_Length
)));
406 Rewrite
(N
, Call_Node
);
410 when RE_Not_Available
=>
412 end Build_Boolean_Array_Proc_Call
;
414 ------------------------------
415 -- Current_Anonymous_Master --
416 ------------------------------
418 function Current_Anonymous_Master
return Entity_Id
is
426 Unit_Id
:= Cunit_Entity
(Current_Sem_Unit
);
428 -- Find the entity of the current unit
430 if Ekind
(Unit_Id
) = E_Subprogram_Body
then
432 -- When processing subprogram bodies, the proper scope is always that
435 Subp_Body
:= Unit_Id
;
436 while Present
(Subp_Body
)
437 and then Nkind
(Subp_Body
) /= N_Subprogram_Body
439 Subp_Body
:= Parent
(Subp_Body
);
442 Unit_Id
:= Corresponding_Spec
(Subp_Body
);
445 Loc
:= Sloc
(Unit_Id
);
446 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
448 -- Find the declarations list of the current unit
450 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
451 Unit_Decl
:= Specification
(Unit_Decl
);
452 Decls
:= Visible_Declarations
(Unit_Decl
);
455 Decls
:= New_List
(Make_Null_Statement
(Loc
));
456 Set_Visible_Declarations
(Unit_Decl
, Decls
);
458 elsif Is_Empty_List
(Decls
) then
459 Append_To
(Decls
, Make_Null_Statement
(Loc
));
463 Decls
:= Declarations
(Unit_Decl
);
466 Decls
:= New_List
(Make_Null_Statement
(Loc
));
467 Set_Declarations
(Unit_Decl
, Decls
);
469 elsif Is_Empty_List
(Decls
) then
470 Append_To
(Decls
, Make_Null_Statement
(Loc
));
474 -- The current unit has an existing anonymous master, traverse its
475 -- declarations and locate the entity.
477 if Has_Anonymous_Master
(Unit_Id
) then
480 Fin_Mas_Id
: Entity_Id
;
483 Decl
:= First
(Decls
);
484 while Present
(Decl
) loop
486 -- Look for the first variable in the declarations whole type
487 -- is Finalization_Master.
489 if Nkind
(Decl
) = N_Object_Declaration
then
490 Fin_Mas_Id
:= Defining_Identifier
(Decl
);
492 if Ekind
(Fin_Mas_Id
) = E_Variable
493 and then Etype
(Fin_Mas_Id
) = RTE
(RE_Finalization_Master
)
502 -- The master was not found even though the unit was labeled as
508 -- Create a new anonymous master
512 First_Decl
: constant Node_Id
:= First
(Decls
);
514 Fin_Mas_Id
: Entity_Id
;
517 -- Since the master and its associated initialization is inserted
518 -- at top level, use the scope of the unit when analyzing.
520 Push_Scope
(Unit_Id
);
522 -- Create the finalization master
525 Make_Defining_Identifier
(Loc
,
526 Chars
=> New_External_Name
(Chars
(Unit_Id
), "AM"));
529 -- <Fin_Mas_Id> : Finalization_Master;
532 Make_Object_Declaration
(Loc
,
533 Defining_Identifier
=> Fin_Mas_Id
,
535 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
537 Insert_Before_And_Analyze
(First_Decl
, Action
);
539 -- Mark the unit to prevent the generation of multiple masters
541 Set_Has_Anonymous_Master
(Unit_Id
);
543 -- Do not set the base pool and mode of operation on .NET/JVM
544 -- since those targets do not support pools and all VM masters
545 -- are heterogeneous by default.
547 if VM_Target
= No_VM
then
551 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
554 Make_Procedure_Call_Statement
(Loc
,
556 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
558 Parameter_Associations
=> New_List
(
559 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
560 Make_Attribute_Reference
(Loc
,
562 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
563 Attribute_Name
=> Name_Unrestricted_Access
)));
565 Insert_Before_And_Analyze
(First_Decl
, Action
);
568 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
571 Make_Procedure_Call_Statement
(Loc
,
573 New_Occurrence_Of
(RTE
(RE_Set_Is_Heterogeneous
), Loc
),
574 Parameter_Associations
=> New_List
(
575 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)));
577 Insert_Before_And_Analyze
(First_Decl
, Action
);
580 -- Restore the original state of the scope stack
587 end Current_Anonymous_Master
;
589 --------------------------------
590 -- Displace_Allocator_Pointer --
591 --------------------------------
593 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
594 Loc
: constant Source_Ptr
:= Sloc
(N
);
595 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
601 -- Do nothing in case of VM targets: the virtual machine will handle
602 -- interfaces directly.
604 if not Tagged_Type_Expansion
then
608 pragma Assert
(Nkind
(N
) = N_Identifier
609 and then Nkind
(Orig_Node
) = N_Allocator
);
611 PtrT
:= Etype
(Orig_Node
);
612 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
613 Etyp
:= Etype
(Expression
(Orig_Node
));
615 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
617 -- If the type of the allocator expression is not an interface type
618 -- we can generate code to reference the record component containing
619 -- the pointer to the secondary dispatch table.
621 if not Is_Interface
(Etyp
) then
623 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
626 -- 1) Get access to the allocated object
629 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
633 -- 2) Add the conversion to displace the pointer to reference
634 -- the secondary dispatch table.
636 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
637 Analyze_And_Resolve
(N
, Dtyp
);
639 -- 3) The 'access to the secondary dispatch table will be used
640 -- as the value returned by the allocator.
643 Make_Attribute_Reference
(Loc
,
644 Prefix
=> Relocate_Node
(N
),
645 Attribute_Name
=> Name_Access
));
646 Set_Etype
(N
, Saved_Typ
);
650 -- If the type of the allocator expression is an interface type we
651 -- generate a run-time call to displace "this" to reference the
652 -- component containing the pointer to the secondary dispatch table
653 -- or else raise Constraint_Error if the actual object does not
654 -- implement the target interface. This case corresponds to the
655 -- following example:
657 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
659 -- return new Iface_2'Class'(Obj);
664 Unchecked_Convert_To
(PtrT
,
665 Make_Function_Call
(Loc
,
666 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
667 Parameter_Associations
=> New_List
(
668 Unchecked_Convert_To
(RTE
(RE_Address
),
674 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
676 Analyze_And_Resolve
(N
, PtrT
);
679 end Displace_Allocator_Pointer
;
681 ---------------------------------
682 -- Expand_Allocator_Expression --
683 ---------------------------------
685 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
686 Loc
: constant Source_Ptr
:= Sloc
(N
);
687 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
688 PtrT
: constant Entity_Id
:= Etype
(N
);
689 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
691 procedure Apply_Accessibility_Check
693 Built_In_Place
: Boolean := False);
694 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
695 -- type, generate an accessibility check to verify that the level of the
696 -- type of the created object is not deeper than the level of the access
697 -- type. If the type of the qualified expression is class-wide, then
698 -- always generate the check (except in the case where it is known to be
699 -- unnecessary, see comment below). Otherwise, only generate the check
700 -- if the level of the qualified expression type is statically deeper
701 -- than the access type.
703 -- Although the static accessibility will generally have been performed
704 -- as a legality check, it won't have been done in cases where the
705 -- allocator appears in generic body, so a run-time check is needed in
706 -- general. One special case is when the access type is declared in the
707 -- same scope as the class-wide allocator, in which case the check can
708 -- never fail, so it need not be generated.
710 -- As an open issue, there seem to be cases where the static level
711 -- associated with the class-wide object's underlying type is not
712 -- sufficient to perform the proper accessibility check, such as for
713 -- allocators in nested subprograms or accept statements initialized by
714 -- class-wide formals when the actual originates outside at a deeper
715 -- static level. The nested subprogram case might require passing
716 -- accessibility levels along with class-wide parameters, and the task
717 -- case seems to be an actual gap in the language rules that needs to
718 -- be fixed by the ARG. ???
720 -------------------------------
721 -- Apply_Accessibility_Check --
722 -------------------------------
724 procedure Apply_Accessibility_Check
726 Built_In_Place
: Boolean := False)
728 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
736 if Ada_Version
>= Ada_2005
737 and then Is_Class_Wide_Type
(DesigT
)
738 and then (Tagged_Type_Expansion
or else VM_Target
/= No_VM
)
739 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
741 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
743 (Is_Class_Wide_Type
(Etype
(Exp
))
744 and then Scope
(PtrT
) /= Current_Scope
))
746 -- If the allocator was built in place, Ref is already a reference
747 -- to the access object initialized to the result of the allocator
748 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
749 -- Remove_Side_Effects for cases where the build-in-place call may
750 -- still be the prefix of the reference (to avoid generating
751 -- duplicate calls). Otherwise, it is the entity associated with
752 -- the object containing the address of the allocated object.
754 if Built_In_Place
then
755 Remove_Side_Effects
(Ref
);
756 Obj_Ref
:= New_Copy_Tree
(Ref
);
758 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
761 -- Step 1: Create the object clean up code
765 -- Deallocate the object if the accessibility check fails. This
766 -- is done only on targets or profiles that support deallocation.
770 if RTE_Available
(RE_Free
) then
771 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
772 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
774 Append_To
(Stmts
, Free_Stmt
);
776 -- The target or profile cannot deallocate objects
782 -- Finalize the object if applicable. Generate:
784 -- [Deep_]Finalize (Obj_Ref.all);
786 if Needs_Finalization
(DesigT
) then
790 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
793 -- When the target or profile supports deallocation, wrap the
794 -- finalization call in a block to ensure proper deallocation
795 -- even if finalization fails. Generate:
805 if Present
(Free_Stmt
) then
807 Make_Block_Statement
(Loc
,
808 Handled_Statement_Sequence
=>
809 Make_Handled_Sequence_Of_Statements
(Loc
,
810 Statements
=> New_List
(Fin_Call
),
812 Exception_Handlers
=> New_List
(
813 Make_Exception_Handler
(Loc
,
814 Exception_Choices
=> New_List
(
815 Make_Others_Choice
(Loc
)),
817 Statements
=> New_List
(
818 New_Copy_Tree
(Free_Stmt
),
819 Make_Raise_Statement
(Loc
))))));
822 Prepend_To
(Stmts
, Fin_Call
);
825 -- Signal the accessibility failure through a Program_Error
828 Make_Raise_Program_Error
(Loc
,
829 Condition
=> New_Occurrence_Of
(Standard_True
, Loc
),
830 Reason
=> PE_Accessibility_Check_Failed
));
832 -- Step 2: Create the accessibility comparison
838 Make_Attribute_Reference
(Loc
,
840 Attribute_Name
=> Name_Tag
);
842 -- For tagged types, determine the accessibility level by looking
843 -- at the type specific data of the dispatch table. Generate:
845 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
847 if Tagged_Type_Expansion
then
848 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
850 -- Use a runtime call to determine the accessibility level when
851 -- compiling on virtual machine targets. Generate:
853 -- Get_Access_Level (Ref'Tag)
857 Make_Function_Call
(Loc
,
859 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
860 Parameter_Associations
=> New_List
(Obj_Ref
));
867 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
869 -- Due to the complexity and side effects of the check, utilize an
870 -- if statement instead of the regular Program_Error circuitry.
873 Make_Implicit_If_Statement
(N
,
875 Then_Statements
=> Stmts
));
877 end Apply_Accessibility_Check
;
881 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
882 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
883 T
: constant Entity_Id
:= Entity
(Indic
);
885 Tag_Assign
: Node_Id
;
889 TagT
: Entity_Id
:= Empty
;
890 -- Type used as source for tag assignment
892 TagR
: Node_Id
:= Empty
;
893 -- Target reference for tag assignment
895 -- Start of processing for Expand_Allocator_Expression
898 -- Handle call to C++ constructor
900 if Is_CPP_Constructor_Call
(Exp
) then
901 Make_CPP_Constructor_Call_In_Allocator
903 Function_Call
=> Exp
);
907 -- In the case of an Ada 2012 allocator whose initial value comes from a
908 -- function call, pass "the accessibility level determined by the point
909 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
910 -- Expand_Call but it couldn't be done there (because the Etype of the
911 -- allocator wasn't set then) so we generate the parameter here. See
912 -- the Boolean variable Defer in (a block within) Expand_Call.
914 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
919 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
920 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
922 Subp
:= Entity
(Name
(Exp
));
925 Subp
:= Ultimate_Alias
(Subp
);
927 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
928 Add_Extra_Actual_To_Call
929 (Subprogram_Call
=> Exp
,
930 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
931 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
936 -- Case of tagged type or type requiring finalization
938 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
940 -- Ada 2005 (AI-318-02): If the initialization expression is a call
941 -- to a build-in-place function, then access to the allocated object
942 -- must be passed to the function. Currently we limit such functions
943 -- to those with constrained limited result subtypes, but eventually
944 -- we plan to expand the allowed forms of functions that are treated
945 -- as build-in-place.
947 if Ada_Version
>= Ada_2005
948 and then Is_Build_In_Place_Function_Call
(Exp
)
950 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
951 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
955 -- Actions inserted before:
956 -- Temp : constant ptr_T := new T'(Expression);
957 -- Temp._tag = T'tag; -- when not class-wide
958 -- [Deep_]Adjust (Temp.all);
960 -- We analyze by hand the new internal allocator to avoid any
961 -- recursion and inappropriate call to Initialize.
963 -- We don't want to remove side effects when the expression must be
964 -- built in place. In the case of a build-in-place function call,
965 -- that could lead to a duplication of the call, which was already
966 -- substituted for the allocator.
968 if not Aggr_In_Place
then
969 Remove_Side_Effects
(Exp
);
972 Temp
:= Make_Temporary
(Loc
, 'P', N
);
974 -- For a class wide allocation generate the following code:
976 -- type Equiv_Record is record ... end record;
977 -- implicit subtype CW is <Class_Wide_Subytpe>;
978 -- temp : PtrT := new CW'(CW!(expr));
980 if Is_Class_Wide_Type
(T
) then
981 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
983 -- Ada 2005 (AI-251): If the expression is a class-wide interface
984 -- object we generate code to move up "this" to reference the
985 -- base of the object before allocating the new object.
987 -- Note that Exp'Address is recursively expanded into a call
988 -- to Base_Address (Exp.Tag)
990 if Is_Class_Wide_Type
(Etype
(Exp
))
991 and then Is_Interface
(Etype
(Exp
))
992 and then Tagged_Type_Expansion
996 Unchecked_Convert_To
(Entity
(Indic
),
997 Make_Explicit_Dereference
(Loc
,
998 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
999 Make_Attribute_Reference
(Loc
,
1001 Attribute_Name
=> Name_Address
)))));
1005 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
1008 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
1011 -- Processing for allocators returning non-interface types
1013 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1014 if Aggr_In_Place
then
1016 Make_Object_Declaration
(Loc
,
1017 Defining_Identifier
=> Temp
,
1018 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1020 Make_Allocator
(Loc
,
1022 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1024 -- Copy the Comes_From_Source flag for the allocator we just
1025 -- built, since logically this allocator is a replacement of
1026 -- the original allocator node. This is for proper handling of
1027 -- restriction No_Implicit_Heap_Allocations.
1029 Set_Comes_From_Source
1030 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1032 Set_No_Initialization
(Expression
(Temp_Decl
));
1033 Insert_Action
(N
, Temp_Decl
);
1035 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1036 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1038 -- Attach the object to the associated finalization master.
1039 -- This is done manually on .NET/JVM since those compilers do
1040 -- no support pools and can't benefit from internally generated
1041 -- Allocate / Deallocate procedures.
1043 if VM_Target
/= No_VM
1044 and then Is_Controlled
(DesigT
)
1045 and then Present
(Finalization_Master
(PtrT
))
1049 Obj_Ref
=> New_Occurrence_Of
(Temp
, Loc
),
1054 Node
:= Relocate_Node
(N
);
1055 Set_Analyzed
(Node
);
1058 Make_Object_Declaration
(Loc
,
1059 Defining_Identifier
=> Temp
,
1060 Constant_Present
=> True,
1061 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1062 Expression
=> Node
);
1064 Insert_Action
(N
, Temp_Decl
);
1065 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1067 -- Attach the object to the associated finalization master.
1068 -- This is done manually on .NET/JVM since those compilers do
1069 -- no support pools and can't benefit from internally generated
1070 -- Allocate / Deallocate procedures.
1072 if VM_Target
/= No_VM
1073 and then Is_Controlled
(DesigT
)
1074 and then Present
(Finalization_Master
(PtrT
))
1079 New_Occurrence_Of
(Temp
, Loc
),
1084 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1085 -- interface type. In this case we use the type of the qualified
1086 -- expression to allocate the object.
1090 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1095 Make_Full_Type_Declaration
(Loc
,
1096 Defining_Identifier
=> Def_Id
,
1098 Make_Access_To_Object_Definition
(Loc
,
1099 All_Present
=> True,
1100 Null_Exclusion_Present
=> False,
1102 Is_Access_Constant
(Etype
(N
)),
1103 Subtype_Indication
=>
1104 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1106 Insert_Action
(N
, New_Decl
);
1108 -- Inherit the allocation-related attributes from the original
1111 Set_Finalization_Master
(Def_Id
, Finalization_Master
(PtrT
));
1113 Set_Associated_Storage_Pool
(Def_Id
,
1114 Associated_Storage_Pool
(PtrT
));
1116 -- Declare the object using the previous type declaration
1118 if Aggr_In_Place
then
1120 Make_Object_Declaration
(Loc
,
1121 Defining_Identifier
=> Temp
,
1122 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1124 Make_Allocator
(Loc
,
1125 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1127 -- Copy the Comes_From_Source flag for the allocator we just
1128 -- built, since logically this allocator is a replacement of
1129 -- the original allocator node. This is for proper handling
1130 -- of restriction No_Implicit_Heap_Allocations.
1132 Set_Comes_From_Source
1133 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1135 Set_No_Initialization
(Expression
(Temp_Decl
));
1136 Insert_Action
(N
, Temp_Decl
);
1138 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1139 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1142 Node
:= Relocate_Node
(N
);
1143 Set_Analyzed
(Node
);
1146 Make_Object_Declaration
(Loc
,
1147 Defining_Identifier
=> Temp
,
1148 Constant_Present
=> True,
1149 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
1150 Expression
=> Node
);
1152 Insert_Action
(N
, Temp_Decl
);
1153 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1156 -- Generate an additional object containing the address of the
1157 -- returned object. The type of this second object declaration
1158 -- is the correct type required for the common processing that
1159 -- is still performed by this subprogram. The displacement of
1160 -- this pointer to reference the component associated with the
1161 -- interface type will be done at the end of common processing.
1164 Make_Object_Declaration
(Loc
,
1165 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
1166 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1168 Unchecked_Convert_To
(PtrT
,
1169 New_Occurrence_Of
(Temp
, Loc
)));
1171 Insert_Action
(N
, New_Decl
);
1173 Temp_Decl
:= New_Decl
;
1174 Temp
:= Defining_Identifier
(New_Decl
);
1178 Apply_Accessibility_Check
(Temp
);
1180 -- Generate the tag assignment
1182 -- Suppress the tag assignment when VM_Target because VM tags are
1183 -- represented implicitly in objects.
1185 if not Tagged_Type_Expansion
then
1188 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1189 -- interface objects because in this case the tag does not change.
1191 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1192 pragma Assert
(Is_Class_Wide_Type
1193 (Directly_Designated_Type
(Etype
(N
))));
1196 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1198 TagR
:= New_Occurrence_Of
(Temp
, Loc
);
1200 elsif Is_Private_Type
(T
)
1201 and then Is_Tagged_Type
(Underlying_Type
(T
))
1203 TagT
:= Underlying_Type
(T
);
1205 Unchecked_Convert_To
(Underlying_Type
(T
),
1206 Make_Explicit_Dereference
(Loc
,
1207 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
1210 if Present
(TagT
) then
1212 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1216 Make_Assignment_Statement
(Loc
,
1218 Make_Selected_Component
(Loc
,
1222 (First_Tag_Component
(Full_T
), Loc
)),
1225 Unchecked_Convert_To
(RTE
(RE_Tag
),
1228 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1231 -- The previous assignment has to be done in any case
1233 Set_Assignment_OK
(Name
(Tag_Assign
));
1234 Insert_Action
(N
, Tag_Assign
);
1237 if Needs_Finalization
(DesigT
) and then Needs_Finalization
(T
) then
1239 -- Generate an Adjust call if the object will be moved. In Ada
1240 -- 2005, the object may be inherently limited, in which case
1241 -- there is no Adjust procedure, and the object is built in
1242 -- place. In Ada 95, the object can be limited but not
1243 -- inherently limited if this allocator came from a return
1244 -- statement (we're allocating the result on the secondary
1245 -- stack). In that case, the object will be moved, so we _do_
1248 if not Aggr_In_Place
1249 and then not Is_Limited_View
(T
)
1253 -- An unchecked conversion is needed in the classwide case
1254 -- because the designated type can be an ancestor of the
1255 -- subtype mark of the allocator.
1259 Unchecked_Convert_To
(T
,
1260 Make_Explicit_Dereference
(Loc
,
1261 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
1266 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1268 -- Do not generate this call in the following cases:
1270 -- * .NET/JVM - these targets do not support address arithmetic
1271 -- and unchecked conversion, key elements of Finalize_Address.
1273 -- * CodePeer mode - TSS primitive Finalize_Address is not
1274 -- created in this mode.
1276 if VM_Target
= No_VM
1277 and then not CodePeer_Mode
1278 and then Present
(Finalization_Master
(PtrT
))
1279 and then Present
(Temp_Decl
)
1280 and then Nkind
(Expression
(Temp_Decl
)) = N_Allocator
1283 Make_Set_Finalize_Address_Call
1290 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1291 Analyze_And_Resolve
(N
, PtrT
);
1293 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1294 -- component containing the secondary dispatch table of the interface
1297 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1298 Displace_Allocator_Pointer
(N
);
1301 elsif Aggr_In_Place
then
1302 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1304 Make_Object_Declaration
(Loc
,
1305 Defining_Identifier
=> Temp
,
1306 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1308 Make_Allocator
(Loc
,
1309 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1311 -- Copy the Comes_From_Source flag for the allocator we just built,
1312 -- since logically this allocator is a replacement of the original
1313 -- allocator node. This is for proper handling of restriction
1314 -- No_Implicit_Heap_Allocations.
1316 Set_Comes_From_Source
1317 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1319 Set_No_Initialization
(Expression
(Temp_Decl
));
1320 Insert_Action
(N
, Temp_Decl
);
1322 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1323 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1325 -- Attach the object to the associated finalization master. Thisis
1326 -- done manually on .NET/JVM since those compilers do no support
1327 -- pools and cannot benefit from internally generated Allocate and
1328 -- Deallocate procedures.
1330 if VM_Target
/= No_VM
1331 and then Is_Controlled
(DesigT
)
1332 and then Present
(Finalization_Master
(PtrT
))
1336 (Obj_Ref
=> New_Occurrence_Of
(Temp
, Loc
),
1340 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1341 Analyze_And_Resolve
(N
, PtrT
);
1343 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1344 Install_Null_Excluding_Check
(Exp
);
1346 elsif Is_Access_Type
(DesigT
)
1347 and then Nkind
(Exp
) = N_Allocator
1348 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1350 -- Apply constraint to designated subtype indication
1352 Apply_Constraint_Check
(Expression
(Exp
),
1353 Designated_Type
(DesigT
),
1354 No_Sliding
=> True);
1356 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1358 -- Propagate constraint_error to enclosing allocator
1360 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1364 Build_Allocate_Deallocate_Proc
(N
, True);
1367 -- type A is access T1;
1368 -- X : A := new T2'(...);
1369 -- T1 and T2 can be different subtypes, and we might need to check
1370 -- both constraints. First check against the type of the qualified
1373 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1375 if Do_Range_Check
(Exp
) then
1376 Set_Do_Range_Check
(Exp
, False);
1377 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1380 -- A check is also needed in cases where the designated subtype is
1381 -- constrained and differs from the subtype given in the qualified
1382 -- expression. Note that the check on the qualified expression does
1383 -- not allow sliding, but this check does (a relaxation from Ada 83).
1385 if Is_Constrained
(DesigT
)
1386 and then not Subtypes_Statically_Match
(T
, DesigT
)
1388 Apply_Constraint_Check
1389 (Exp
, DesigT
, No_Sliding
=> False);
1391 if Do_Range_Check
(Exp
) then
1392 Set_Do_Range_Check
(Exp
, False);
1393 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1397 -- For an access to unconstrained packed array, GIGI needs to see an
1398 -- expression with a constrained subtype in order to compute the
1399 -- proper size for the allocator.
1401 if Is_Array_Type
(T
)
1402 and then not Is_Constrained
(T
)
1403 and then Is_Packed
(T
)
1406 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1407 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1410 Make_Subtype_Declaration
(Loc
,
1411 Defining_Identifier
=> ConstrT
,
1412 Subtype_Indication
=>
1413 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1414 Freeze_Itype
(ConstrT
, Exp
);
1415 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1419 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1420 -- to a build-in-place function, then access to the allocated object
1421 -- must be passed to the function. Currently we limit such functions
1422 -- to those with constrained limited result subtypes, but eventually
1423 -- we plan to expand the allowed forms of functions that are treated
1424 -- as build-in-place.
1426 if Ada_Version
>= Ada_2005
1427 and then Is_Build_In_Place_Function_Call
(Exp
)
1429 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1434 when RE_Not_Available
=>
1436 end Expand_Allocator_Expression
;
1438 -----------------------------
1439 -- Expand_Array_Comparison --
1440 -----------------------------
1442 -- Expansion is only required in the case of array types. For the unpacked
1443 -- case, an appropriate runtime routine is called. For packed cases, and
1444 -- also in some other cases where a runtime routine cannot be called, the
1445 -- form of the expansion is:
1447 -- [body for greater_nn; boolean_expression]
1449 -- The body is built by Make_Array_Comparison_Op, and the form of the
1450 -- Boolean expression depends on the operator involved.
1452 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1453 Loc
: constant Source_Ptr
:= Sloc
(N
);
1454 Op1
: Node_Id
:= Left_Opnd
(N
);
1455 Op2
: Node_Id
:= Right_Opnd
(N
);
1456 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1457 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1460 Func_Body
: Node_Id
;
1461 Func_Name
: Entity_Id
;
1465 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1466 -- True for byte addressable target
1468 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1469 -- Returns True if the length of the given operand is known to be less
1470 -- than 4. Returns False if this length is known to be four or greater
1471 -- or is not known at compile time.
1473 ------------------------
1474 -- Length_Less_Than_4 --
1475 ------------------------
1477 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1478 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1481 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1482 return String_Literal_Length
(Otyp
) < 4;
1486 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1487 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1488 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1493 if Compile_Time_Known_Value
(Lo
) then
1494 Lov
:= Expr_Value
(Lo
);
1499 if Compile_Time_Known_Value
(Hi
) then
1500 Hiv
:= Expr_Value
(Hi
);
1505 return Hiv
< Lov
+ 3;
1508 end Length_Less_Than_4
;
1510 -- Start of processing for Expand_Array_Comparison
1513 -- Deal first with unpacked case, where we can call a runtime routine
1514 -- except that we avoid this for targets for which are not addressable
1515 -- by bytes, and for the JVM/CIL, since they do not support direct
1516 -- addressing of array components.
1518 if not Is_Bit_Packed_Array
(Typ1
)
1519 and then Byte_Addressable
1520 and then VM_Target
= No_VM
1522 -- The call we generate is:
1524 -- Compare_Array_xn[_Unaligned]
1525 -- (left'address, right'address, left'length, right'length) <op> 0
1527 -- x = U for unsigned, S for signed
1528 -- n = 8,16,32,64 for component size
1529 -- Add _Unaligned if length < 4 and component size is 8.
1530 -- <op> is the standard comparison operator
1532 if Component_Size
(Typ1
) = 8 then
1533 if Length_Less_Than_4
(Op1
)
1535 Length_Less_Than_4
(Op2
)
1537 if Is_Unsigned_Type
(Ctyp
) then
1538 Comp
:= RE_Compare_Array_U8_Unaligned
;
1540 Comp
:= RE_Compare_Array_S8_Unaligned
;
1544 if Is_Unsigned_Type
(Ctyp
) then
1545 Comp
:= RE_Compare_Array_U8
;
1547 Comp
:= RE_Compare_Array_S8
;
1551 elsif Component_Size
(Typ1
) = 16 then
1552 if Is_Unsigned_Type
(Ctyp
) then
1553 Comp
:= RE_Compare_Array_U16
;
1555 Comp
:= RE_Compare_Array_S16
;
1558 elsif Component_Size
(Typ1
) = 32 then
1559 if Is_Unsigned_Type
(Ctyp
) then
1560 Comp
:= RE_Compare_Array_U32
;
1562 Comp
:= RE_Compare_Array_S32
;
1565 else pragma Assert
(Component_Size
(Typ1
) = 64);
1566 if Is_Unsigned_Type
(Ctyp
) then
1567 Comp
:= RE_Compare_Array_U64
;
1569 Comp
:= RE_Compare_Array_S64
;
1573 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1574 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1577 Make_Function_Call
(Sloc
(Op1
),
1578 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1580 Parameter_Associations
=> New_List
(
1581 Make_Attribute_Reference
(Loc
,
1582 Prefix
=> Relocate_Node
(Op1
),
1583 Attribute_Name
=> Name_Address
),
1585 Make_Attribute_Reference
(Loc
,
1586 Prefix
=> Relocate_Node
(Op2
),
1587 Attribute_Name
=> Name_Address
),
1589 Make_Attribute_Reference
(Loc
,
1590 Prefix
=> Relocate_Node
(Op1
),
1591 Attribute_Name
=> Name_Length
),
1593 Make_Attribute_Reference
(Loc
,
1594 Prefix
=> Relocate_Node
(Op2
),
1595 Attribute_Name
=> Name_Length
))));
1598 Make_Integer_Literal
(Sloc
(Op2
),
1601 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1602 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1606 -- Cases where we cannot make runtime call
1608 -- For (a <= b) we convert to not (a > b)
1610 if Chars
(N
) = Name_Op_Le
then
1616 Right_Opnd
=> Op2
)));
1617 Analyze_And_Resolve
(N
, Standard_Boolean
);
1620 -- For < the Boolean expression is
1621 -- greater__nn (op2, op1)
1623 elsif Chars
(N
) = Name_Op_Lt
then
1624 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1628 Op1
:= Right_Opnd
(N
);
1629 Op2
:= Left_Opnd
(N
);
1631 -- For (a >= b) we convert to not (a < b)
1633 elsif Chars
(N
) = Name_Op_Ge
then
1639 Right_Opnd
=> Op2
)));
1640 Analyze_And_Resolve
(N
, Standard_Boolean
);
1643 -- For > the Boolean expression is
1644 -- greater__nn (op1, op2)
1647 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1648 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1651 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1653 Make_Function_Call
(Loc
,
1654 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1655 Parameter_Associations
=> New_List
(Op1
, Op2
));
1657 Insert_Action
(N
, Func_Body
);
1659 Analyze_And_Resolve
(N
, Standard_Boolean
);
1662 when RE_Not_Available
=>
1664 end Expand_Array_Comparison
;
1666 ---------------------------
1667 -- Expand_Array_Equality --
1668 ---------------------------
1670 -- Expand an equality function for multi-dimensional arrays. Here is an
1671 -- example of such a function for Nb_Dimension = 2
1673 -- function Enn (A : atyp; B : btyp) return boolean is
1675 -- if (A'length (1) = 0 or else A'length (2) = 0)
1677 -- (B'length (1) = 0 or else B'length (2) = 0)
1679 -- return True; -- RM 4.5.2(22)
1682 -- if A'length (1) /= B'length (1)
1684 -- A'length (2) /= B'length (2)
1686 -- return False; -- RM 4.5.2(23)
1690 -- A1 : Index_T1 := A'first (1);
1691 -- B1 : Index_T1 := B'first (1);
1695 -- A2 : Index_T2 := A'first (2);
1696 -- B2 : Index_T2 := B'first (2);
1699 -- if A (A1, A2) /= B (B1, B2) then
1703 -- exit when A2 = A'last (2);
1704 -- A2 := Index_T2'succ (A2);
1705 -- B2 := Index_T2'succ (B2);
1709 -- exit when A1 = A'last (1);
1710 -- A1 := Index_T1'succ (A1);
1711 -- B1 := Index_T1'succ (B1);
1718 -- Note on the formal types used (atyp and btyp). If either of the arrays
1719 -- is of a private type, we use the underlying type, and do an unchecked
1720 -- conversion of the actual. If either of the arrays has a bound depending
1721 -- on a discriminant, then we use the base type since otherwise we have an
1722 -- escaped discriminant in the function.
1724 -- If both arrays are constrained and have the same bounds, we can generate
1725 -- a loop with an explicit iteration scheme using a 'Range attribute over
1728 function Expand_Array_Equality
1733 Typ
: Entity_Id
) return Node_Id
1735 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1736 Decls
: constant List_Id
:= New_List
;
1737 Index_List1
: constant List_Id
:= New_List
;
1738 Index_List2
: constant List_Id
:= New_List
;
1742 Func_Name
: Entity_Id
;
1743 Func_Body
: Node_Id
;
1745 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1746 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1750 -- The parameter types to be used for the formals
1755 Num
: Int
) return Node_Id
;
1756 -- This builds the attribute reference Arr'Nam (Expr)
1758 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1759 -- Create one statement to compare corresponding components, designated
1760 -- by a full set of indexes.
1762 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1763 -- Given one of the arguments, computes the appropriate type to be used
1764 -- for that argument in the corresponding function formal
1766 function Handle_One_Dimension
1768 Index
: Node_Id
) return Node_Id
;
1769 -- This procedure returns the following code
1772 -- Bn : Index_T := B'First (N);
1776 -- exit when An = A'Last (N);
1777 -- An := Index_T'Succ (An)
1778 -- Bn := Index_T'Succ (Bn)
1782 -- If both indexes are constrained and identical, the procedure
1783 -- returns a simpler loop:
1785 -- for An in A'Range (N) loop
1789 -- N is the dimension for which we are generating a loop. Index is the
1790 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1791 -- xxx statement is either the loop or declare for the next dimension
1792 -- or if this is the last dimension the comparison of corresponding
1793 -- components of the arrays.
1795 -- The actual way the code works is to return the comparison of
1796 -- corresponding components for the N+1 call. That's neater.
1798 function Test_Empty_Arrays
return Node_Id
;
1799 -- This function constructs the test for both arrays being empty
1800 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1802 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1804 function Test_Lengths_Correspond
return Node_Id
;
1805 -- This function constructs the test for arrays having different lengths
1806 -- in at least one index position, in which case the resulting code is:
1808 -- A'length (1) /= B'length (1)
1810 -- A'length (2) /= B'length (2)
1821 Num
: Int
) return Node_Id
1825 Make_Attribute_Reference
(Loc
,
1826 Attribute_Name
=> Nam
,
1827 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1828 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1831 ------------------------
1832 -- Component_Equality --
1833 ------------------------
1835 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1840 -- if a(i1...) /= b(j1...) then return false; end if;
1843 Make_Indexed_Component
(Loc
,
1844 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1845 Expressions
=> Index_List1
);
1848 Make_Indexed_Component
(Loc
,
1849 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1850 Expressions
=> Index_List2
);
1852 Test
:= Expand_Composite_Equality
1853 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1855 -- If some (sub)component is an unchecked_union, the whole operation
1856 -- will raise program error.
1858 if Nkind
(Test
) = N_Raise_Program_Error
then
1860 -- This node is going to be inserted at a location where a
1861 -- statement is expected: clear its Etype so analysis will set
1862 -- it to the expected Standard_Void_Type.
1864 Set_Etype
(Test
, Empty
);
1869 Make_Implicit_If_Statement
(Nod
,
1870 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1871 Then_Statements
=> New_List
(
1872 Make_Simple_Return_Statement
(Loc
,
1873 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1875 end Component_Equality
;
1881 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1892 T
:= Underlying_Type
(T
);
1894 X
:= First_Index
(T
);
1895 while Present
(X
) loop
1896 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1898 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1911 --------------------------
1912 -- Handle_One_Dimension --
1913 ---------------------------
1915 function Handle_One_Dimension
1917 Index
: Node_Id
) return Node_Id
1919 Need_Separate_Indexes
: constant Boolean :=
1920 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1921 -- If the index types are identical, and we are working with
1922 -- constrained types, then we can use the same index for both
1925 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1928 Index_T
: Entity_Id
;
1933 if N
> Number_Dimensions
(Ltyp
) then
1934 return Component_Equality
(Ltyp
);
1937 -- Case where we generate a loop
1939 Index_T
:= Base_Type
(Etype
(Index
));
1941 if Need_Separate_Indexes
then
1942 Bn
:= Make_Temporary
(Loc
, 'B');
1947 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1948 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1950 Stm_List
:= New_List
(
1951 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1953 if Need_Separate_Indexes
then
1955 -- Generate guard for loop, followed by increments of indexes
1957 Append_To
(Stm_List
,
1958 Make_Exit_Statement
(Loc
,
1961 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1962 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1964 Append_To
(Stm_List
,
1965 Make_Assignment_Statement
(Loc
,
1966 Name
=> New_Occurrence_Of
(An
, 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
(An
, Loc
)))));
1974 Append_To
(Stm_List
,
1975 Make_Assignment_Statement
(Loc
,
1976 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1978 Make_Attribute_Reference
(Loc
,
1979 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1980 Attribute_Name
=> Name_Succ
,
1981 Expressions
=> New_List
(
1982 New_Occurrence_Of
(Bn
, Loc
)))));
1985 -- If separate indexes, we need a declare block for An and Bn, and a
1986 -- loop without an iteration scheme.
1988 if Need_Separate_Indexes
then
1990 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1993 Make_Block_Statement
(Loc
,
1994 Declarations
=> New_List
(
1995 Make_Object_Declaration
(Loc
,
1996 Defining_Identifier
=> An
,
1997 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1998 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
2000 Make_Object_Declaration
(Loc
,
2001 Defining_Identifier
=> Bn
,
2002 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
2003 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
2005 Handled_Statement_Sequence
=>
2006 Make_Handled_Sequence_Of_Statements
(Loc
,
2007 Statements
=> New_List
(Loop_Stm
)));
2009 -- If no separate indexes, return loop statement with explicit
2010 -- iteration scheme on its own
2014 Make_Implicit_Loop_Statement
(Nod
,
2015 Statements
=> Stm_List
,
2017 Make_Iteration_Scheme
(Loc
,
2018 Loop_Parameter_Specification
=>
2019 Make_Loop_Parameter_Specification
(Loc
,
2020 Defining_Identifier
=> An
,
2021 Discrete_Subtype_Definition
=>
2022 Arr_Attr
(A
, Name_Range
, N
))));
2025 end Handle_One_Dimension
;
2027 -----------------------
2028 -- Test_Empty_Arrays --
2029 -----------------------
2031 function Test_Empty_Arrays
return Node_Id
is
2041 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2044 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2045 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2049 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
2050 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2059 Left_Opnd
=> Relocate_Node
(Alist
),
2060 Right_Opnd
=> Atest
);
2064 Left_Opnd
=> Relocate_Node
(Blist
),
2065 Right_Opnd
=> Btest
);
2072 Right_Opnd
=> Blist
);
2073 end Test_Empty_Arrays
;
2075 -----------------------------
2076 -- Test_Lengths_Correspond --
2077 -----------------------------
2079 function Test_Lengths_Correspond
return Node_Id
is
2085 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2088 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2089 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
2096 Left_Opnd
=> Relocate_Node
(Result
),
2097 Right_Opnd
=> Rtest
);
2102 end Test_Lengths_Correspond
;
2104 -- Start of processing for Expand_Array_Equality
2107 Ltyp
:= Get_Arg_Type
(Lhs
);
2108 Rtyp
:= Get_Arg_Type
(Rhs
);
2110 -- For now, if the argument types are not the same, go to the base type,
2111 -- since the code assumes that the formals have the same type. This is
2112 -- fixable in future ???
2114 if Ltyp
/= Rtyp
then
2115 Ltyp
:= Base_Type
(Ltyp
);
2116 Rtyp
:= Base_Type
(Rtyp
);
2117 pragma Assert
(Ltyp
= Rtyp
);
2120 -- Build list of formals for function
2122 Formals
:= New_List
(
2123 Make_Parameter_Specification
(Loc
,
2124 Defining_Identifier
=> A
,
2125 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
2127 Make_Parameter_Specification
(Loc
,
2128 Defining_Identifier
=> B
,
2129 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
2131 Func_Name
:= Make_Temporary
(Loc
, 'E');
2133 -- Build statement sequence for function
2136 Make_Subprogram_Body
(Loc
,
2138 Make_Function_Specification
(Loc
,
2139 Defining_Unit_Name
=> Func_Name
,
2140 Parameter_Specifications
=> Formals
,
2141 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2143 Declarations
=> Decls
,
2145 Handled_Statement_Sequence
=>
2146 Make_Handled_Sequence_Of_Statements
(Loc
,
2147 Statements
=> New_List
(
2149 Make_Implicit_If_Statement
(Nod
,
2150 Condition
=> Test_Empty_Arrays
,
2151 Then_Statements
=> New_List
(
2152 Make_Simple_Return_Statement
(Loc
,
2154 New_Occurrence_Of
(Standard_True
, Loc
)))),
2156 Make_Implicit_If_Statement
(Nod
,
2157 Condition
=> Test_Lengths_Correspond
,
2158 Then_Statements
=> New_List
(
2159 Make_Simple_Return_Statement
(Loc
,
2161 New_Occurrence_Of
(Standard_False
, Loc
)))),
2163 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
2165 Make_Simple_Return_Statement
(Loc
,
2166 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2168 Set_Has_Completion
(Func_Name
, True);
2169 Set_Is_Inlined
(Func_Name
);
2171 -- If the array type is distinct from the type of the arguments, it
2172 -- is the full view of a private type. Apply an unchecked conversion
2173 -- to insure that analysis of the call succeeds.
2183 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
2185 L
:= OK_Convert_To
(Ltyp
, Lhs
);
2189 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
2191 R
:= OK_Convert_To
(Rtyp
, Rhs
);
2194 Actuals
:= New_List
(L
, R
);
2197 Append_To
(Bodies
, Func_Body
);
2200 Make_Function_Call
(Loc
,
2201 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2202 Parameter_Associations
=> Actuals
);
2203 end Expand_Array_Equality
;
2205 -----------------------------
2206 -- Expand_Boolean_Operator --
2207 -----------------------------
2209 -- Note that we first get the actual subtypes of the operands, since we
2210 -- always want to deal with types that have bounds.
2212 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2213 Typ
: constant Entity_Id
:= Etype
(N
);
2216 -- Special case of bit packed array where both operands are known to be
2217 -- properly aligned. In this case we use an efficient run time routine
2218 -- to carry out the operation (see System.Bit_Ops).
2220 if Is_Bit_Packed_Array
(Typ
)
2221 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2222 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2224 Expand_Packed_Boolean_Operator
(N
);
2228 -- For the normal non-packed case, the general expansion is to build
2229 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2230 -- and then inserting it into the tree. The original operator node is
2231 -- then rewritten as a call to this function. We also use this in the
2232 -- packed case if either operand is a possibly unaligned object.
2235 Loc
: constant Source_Ptr
:= Sloc
(N
);
2236 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2237 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2238 Func_Body
: Node_Id
;
2239 Func_Name
: Entity_Id
;
2242 Convert_To_Actual_Subtype
(L
);
2243 Convert_To_Actual_Subtype
(R
);
2244 Ensure_Defined
(Etype
(L
), N
);
2245 Ensure_Defined
(Etype
(R
), N
);
2246 Apply_Length_Check
(R
, Etype
(L
));
2248 if Nkind
(N
) = N_Op_Xor
then
2249 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2252 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2253 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2255 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2257 elsif Nkind
(Parent
(N
)) = N_Op_Not
2258 and then Nkind
(N
) = N_Op_And
2260 Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2265 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2266 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2267 Insert_Action
(N
, Func_Body
);
2269 -- Now rewrite the expression with a call
2272 Make_Function_Call
(Loc
,
2273 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2274 Parameter_Associations
=>
2277 Make_Type_Conversion
2278 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2280 Analyze_And_Resolve
(N
, Typ
);
2283 end Expand_Boolean_Operator
;
2285 ------------------------------------------------
2286 -- Expand_Compare_Minimize_Eliminate_Overflow --
2287 ------------------------------------------------
2289 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2290 Loc
: constant Source_Ptr
:= Sloc
(N
);
2292 Result_Type
: constant Entity_Id
:= Etype
(N
);
2293 -- Capture result type (could be a derived boolean type)
2298 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2299 -- Entity for Long_Long_Integer'Base
2301 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2302 -- Current overflow checking mode
2305 procedure Set_False
;
2306 -- These procedures rewrite N with an occurrence of Standard_True or
2307 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2313 procedure Set_False
is
2315 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2316 Warn_On_Known_Condition
(N
);
2323 procedure Set_True
is
2325 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2326 Warn_On_Known_Condition
(N
);
2329 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2332 -- Nothing to do unless we have a comparison operator with operands
2333 -- that are signed integer types, and we are operating in either
2334 -- MINIMIZED or ELIMINATED overflow checking mode.
2336 if Nkind
(N
) not in N_Op_Compare
2337 or else Check
not in Minimized_Or_Eliminated
2338 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2343 -- OK, this is the case we are interested in. First step is to process
2344 -- our operands using the Minimize_Eliminate circuitry which applies
2345 -- this processing to the two operand subtrees.
2347 Minimize_Eliminate_Overflows
2348 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2349 Minimize_Eliminate_Overflows
2350 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2352 -- See if the range information decides the result of the comparison.
2353 -- We can only do this if we in fact have full range information (which
2354 -- won't be the case if either operand is bignum at this stage).
2356 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2357 case N_Op_Compare
(Nkind
(N
)) is
2359 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2361 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2368 elsif Lhi
< Rlo
then
2375 elsif Lhi
<= Rlo
then
2382 elsif Lhi
<= Rlo
then
2389 elsif Lhi
< Rlo
then
2394 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2396 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2401 -- All done if we did the rewrite
2403 if Nkind
(N
) not in N_Op_Compare
then
2408 -- Otherwise, time to do the comparison
2411 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2412 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2415 -- If the two operands have the same signed integer type we are
2416 -- all set, nothing more to do. This is the case where either
2417 -- both operands were unchanged, or we rewrote both of them to
2418 -- be Long_Long_Integer.
2420 -- Note: Entity for the comparison may be wrong, but it's not worth
2421 -- the effort to change it, since the back end does not use it.
2423 if Is_Signed_Integer_Type
(Ltype
)
2424 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2428 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2430 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2432 Left
: Node_Id
:= Left_Opnd
(N
);
2433 Right
: Node_Id
:= Right_Opnd
(N
);
2434 -- Bignum references for left and right operands
2437 if not Is_RTE
(Ltype
, RE_Bignum
) then
2438 Left
:= Convert_To_Bignum
(Left
);
2439 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2440 Right
:= Convert_To_Bignum
(Right
);
2443 -- We rewrite our node with:
2446 -- Bnn : Result_Type;
2448 -- M : Mark_Id := SS_Mark;
2450 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2458 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2459 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2463 case N_Op_Compare
(Nkind
(N
)) is
2464 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2465 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2466 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2467 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2468 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2469 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2472 -- Insert assignment to Bnn into the bignum block
2475 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2476 Make_Assignment_Statement
(Loc
,
2477 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2479 Make_Function_Call
(Loc
,
2481 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2482 Parameter_Associations
=> New_List
(Left
, Right
))));
2484 -- Now do the rewrite with expression actions
2487 Make_Expression_With_Actions
(Loc
,
2488 Actions
=> New_List
(
2489 Make_Object_Declaration
(Loc
,
2490 Defining_Identifier
=> Bnn
,
2491 Object_Definition
=>
2492 New_Occurrence_Of
(Result_Type
, Loc
)),
2494 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2495 Analyze_And_Resolve
(N
, Result_Type
);
2499 -- No bignums involved, but types are different, so we must have
2500 -- rewritten one of the operands as a Long_Long_Integer but not
2503 -- If left operand is Long_Long_Integer, convert right operand
2504 -- and we are done (with a comparison of two Long_Long_Integers).
2506 elsif Ltype
= LLIB
then
2507 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2508 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2511 -- If right operand is Long_Long_Integer, convert left operand
2512 -- and we are done (with a comparison of two Long_Long_Integers).
2514 -- This is the only remaining possibility
2516 else pragma Assert
(Rtype
= LLIB
);
2517 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2518 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2522 end Expand_Compare_Minimize_Eliminate_Overflow
;
2524 -------------------------------
2525 -- Expand_Composite_Equality --
2526 -------------------------------
2528 -- This function is only called for comparing internal fields of composite
2529 -- types when these fields are themselves composites. This is a special
2530 -- case because it is not possible to respect normal Ada visibility rules.
2532 function Expand_Composite_Equality
2537 Bodies
: List_Id
) return Node_Id
2539 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2540 Full_Type
: Entity_Id
;
2544 function Find_Primitive_Eq
return Node_Id
;
2545 -- AI05-0123: Locate primitive equality for type if it exists, and
2546 -- build the corresponding call. If operation is abstract, replace
2547 -- call with an explicit raise. Return Empty if there is no primitive.
2549 -----------------------
2550 -- Find_Primitive_Eq --
2551 -----------------------
2553 function Find_Primitive_Eq
return Node_Id
is
2558 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2559 while Present
(Prim_E
) loop
2560 Prim
:= Node
(Prim_E
);
2562 -- Locate primitive equality with the right signature
2564 if Chars
(Prim
) = Name_Op_Eq
2565 and then Etype
(First_Formal
(Prim
)) =
2566 Etype
(Next_Formal
(First_Formal
(Prim
)))
2567 and then Etype
(Prim
) = Standard_Boolean
2569 if Is_Abstract_Subprogram
(Prim
) then
2571 Make_Raise_Program_Error
(Loc
,
2572 Reason
=> PE_Explicit_Raise
);
2576 Make_Function_Call
(Loc
,
2577 Name
=> New_Occurrence_Of
(Prim
, Loc
),
2578 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2585 -- If not found, predefined operation will be used
2588 end Find_Primitive_Eq
;
2590 -- Start of processing for Expand_Composite_Equality
2593 if Is_Private_Type
(Typ
) then
2594 Full_Type
:= Underlying_Type
(Typ
);
2599 -- If the private type has no completion the context may be the
2600 -- expansion of a composite equality for a composite type with some
2601 -- still incomplete components. The expression will not be analyzed
2602 -- until the enclosing type is completed, at which point this will be
2603 -- properly expanded, unless there is a bona fide completion error.
2605 if No
(Full_Type
) then
2606 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2609 Full_Type
:= Base_Type
(Full_Type
);
2611 -- When the base type itself is private, use the full view to expand
2612 -- the composite equality.
2614 if Is_Private_Type
(Full_Type
) then
2615 Full_Type
:= Underlying_Type
(Full_Type
);
2618 -- Case of array types
2620 if Is_Array_Type
(Full_Type
) then
2622 -- If the operand is an elementary type other than a floating-point
2623 -- type, then we can simply use the built-in block bitwise equality,
2624 -- since the predefined equality operators always apply and bitwise
2625 -- equality is fine for all these cases.
2627 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2628 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2630 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2632 -- For composite component types, and floating-point types, use the
2633 -- expansion. This deals with tagged component types (where we use
2634 -- the applicable equality routine) and floating-point, (where we
2635 -- need to worry about negative zeroes), and also the case of any
2636 -- composite type recursively containing such fields.
2639 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2642 -- Case of tagged record types
2644 elsif Is_Tagged_Type
(Full_Type
) then
2646 -- Call the primitive operation "=" of this type
2648 if Is_Class_Wide_Type
(Full_Type
) then
2649 Full_Type
:= Root_Type
(Full_Type
);
2652 -- If this is derived from an untagged private type completed with a
2653 -- tagged type, it does not have a full view, so we use the primitive
2654 -- operations of the private type. This check should no longer be
2655 -- necessary when these types receive their full views ???
2657 if Is_Private_Type
(Typ
)
2658 and then not Is_Tagged_Type
(Typ
)
2659 and then not Is_Controlled
(Typ
)
2660 and then Is_Derived_Type
(Typ
)
2661 and then No
(Full_View
(Typ
))
2663 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2665 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2669 Eq_Op
:= Node
(Prim
);
2670 exit when Chars
(Eq_Op
) = Name_Op_Eq
2671 and then Etype
(First_Formal
(Eq_Op
)) =
2672 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2673 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2675 pragma Assert
(Present
(Prim
));
2678 Eq_Op
:= Node
(Prim
);
2681 Make_Function_Call
(Loc
,
2682 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2683 Parameter_Associations
=>
2685 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2686 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2688 -- Case of untagged record types
2690 elsif Is_Record_Type
(Full_Type
) then
2691 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2693 if Present
(Eq_Op
) then
2694 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2696 -- Inherited equality from parent type. Convert the actuals to
2697 -- match signature of operation.
2700 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2704 Make_Function_Call
(Loc
,
2705 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2706 Parameter_Associations
=> New_List
(
2707 OK_Convert_To
(T
, Lhs
),
2708 OK_Convert_To
(T
, Rhs
)));
2712 -- Comparison between Unchecked_Union components
2714 if Is_Unchecked_Union
(Full_Type
) then
2716 Lhs_Type
: Node_Id
:= Full_Type
;
2717 Rhs_Type
: Node_Id
:= Full_Type
;
2718 Lhs_Discr_Val
: Node_Id
;
2719 Rhs_Discr_Val
: Node_Id
;
2724 if Nkind
(Lhs
) = N_Selected_Component
then
2725 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2730 if Nkind
(Rhs
) = N_Selected_Component
then
2731 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2734 -- Lhs of the composite equality
2736 if Is_Constrained
(Lhs_Type
) then
2738 -- Since the enclosing record type can never be an
2739 -- Unchecked_Union (this code is executed for records
2740 -- that do not have variants), we may reference its
2743 if Nkind
(Lhs
) = N_Selected_Component
2744 and then Has_Per_Object_Constraint
2745 (Entity
(Selector_Name
(Lhs
)))
2748 Make_Selected_Component
(Loc
,
2749 Prefix
=> Prefix
(Lhs
),
2752 (Get_Discriminant_Value
2753 (First_Discriminant
(Lhs_Type
),
2755 Stored_Constraint
(Lhs_Type
))));
2760 (Get_Discriminant_Value
2761 (First_Discriminant
(Lhs_Type
),
2763 Stored_Constraint
(Lhs_Type
)));
2767 -- It is not possible to infer the discriminant since
2768 -- the subtype is not constrained.
2771 Make_Raise_Program_Error
(Loc
,
2772 Reason
=> PE_Unchecked_Union_Restriction
);
2775 -- Rhs of the composite equality
2777 if Is_Constrained
(Rhs_Type
) then
2778 if Nkind
(Rhs
) = N_Selected_Component
2779 and then Has_Per_Object_Constraint
2780 (Entity
(Selector_Name
(Rhs
)))
2783 Make_Selected_Component
(Loc
,
2784 Prefix
=> Prefix
(Rhs
),
2787 (Get_Discriminant_Value
2788 (First_Discriminant
(Rhs_Type
),
2790 Stored_Constraint
(Rhs_Type
))));
2795 (Get_Discriminant_Value
2796 (First_Discriminant
(Rhs_Type
),
2798 Stored_Constraint
(Rhs_Type
)));
2803 Make_Raise_Program_Error
(Loc
,
2804 Reason
=> PE_Unchecked_Union_Restriction
);
2807 -- Call the TSS equality function with the inferred
2808 -- discriminant values.
2811 Make_Function_Call
(Loc
,
2812 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2813 Parameter_Associations
=> New_List
(
2822 Make_Function_Call
(Loc
,
2823 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2824 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2828 -- Equality composes in Ada 2012 for untagged record types. It also
2829 -- composes for bounded strings, because they are part of the
2830 -- predefined environment. We could make it compose for bounded
2831 -- strings by making them tagged, or by making sure all subcomponents
2832 -- are set to the same value, even when not used. Instead, we have
2833 -- this special case in the compiler, because it's more efficient.
2835 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2837 -- If no TSS has been created for the type, check whether there is
2838 -- a primitive equality declared for it.
2841 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2844 -- Use user-defined primitive if it exists, otherwise use
2845 -- predefined equality.
2847 if Present
(Op
) then
2850 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2855 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2858 -- Non-composite types (always use predefined equality)
2861 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2863 end Expand_Composite_Equality
;
2865 ------------------------
2866 -- Expand_Concatenate --
2867 ------------------------
2869 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2870 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2872 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2873 -- Result type of concatenation
2875 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2876 -- Component type. Elements of this component type can appear as one
2877 -- of the operands of concatenation as well as arrays.
2879 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2882 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2883 -- Index type. This is the base type of the index subtype, and is used
2884 -- for all computed bounds (which may be out of range of Istyp in the
2885 -- case of null ranges).
2888 -- This is the type we use to do arithmetic to compute the bounds and
2889 -- lengths of operands. The choice of this type is a little subtle and
2890 -- is discussed in a separate section at the start of the body code.
2892 Concatenation_Error
: exception;
2893 -- Raised if concatenation is sure to raise a CE
2895 Result_May_Be_Null
: Boolean := True;
2896 -- Reset to False if at least one operand is encountered which is known
2897 -- at compile time to be non-null. Used for handling the special case
2898 -- of setting the high bound to the last operand high bound for a null
2899 -- result, thus ensuring a proper high bound in the super-flat case.
2901 N
: constant Nat
:= List_Length
(Opnds
);
2902 -- Number of concatenation operands including possibly null operands
2905 -- Number of operands excluding any known to be null, except that the
2906 -- last operand is always retained, in case it provides the bounds for
2910 -- Current operand being processed in the loop through operands. After
2911 -- this loop is complete, always contains the last operand (which is not
2912 -- the same as Operands (NN), since null operands are skipped).
2914 -- Arrays describing the operands, only the first NN entries of each
2915 -- array are set (NN < N when we exclude known null operands).
2917 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2918 -- True if length of corresponding operand known at compile time
2920 Operands
: array (1 .. N
) of Node_Id
;
2921 -- Set to the corresponding entry in the Opnds list (but note that null
2922 -- operands are excluded, so not all entries in the list are stored).
2924 Fixed_Length
: array (1 .. N
) of Uint
;
2925 -- Set to length of operand. Entries in this array are set only if the
2926 -- corresponding entry in Is_Fixed_Length is True.
2928 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2929 -- Set to lower bound of operand. Either an integer literal in the case
2930 -- where the bound is known at compile time, else actual lower bound.
2931 -- The operand low bound is of type Ityp.
2933 Var_Length
: array (1 .. N
) of Entity_Id
;
2934 -- Set to an entity of type Natural that contains the length of an
2935 -- operand whose length is not known at compile time. Entries in this
2936 -- array are set only if the corresponding entry in Is_Fixed_Length
2937 -- is False. The entity is of type Artyp.
2939 Aggr_Length
: array (0 .. N
) of Node_Id
;
2940 -- The J'th entry in an expression node that represents the total length
2941 -- of operands 1 through J. It is either an integer literal node, or a
2942 -- reference to a constant entity with the right value, so it is fine
2943 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2944 -- entry always is set to zero. The length is of type Artyp.
2946 Low_Bound
: Node_Id
;
2947 -- A tree node representing the low bound of the result (of type Ityp).
2948 -- This is either an integer literal node, or an identifier reference to
2949 -- a constant entity initialized to the appropriate value.
2951 Last_Opnd_Low_Bound
: Node_Id
;
2952 -- A tree node representing the low bound of the last operand. This
2953 -- need only be set if the result could be null. It is used for the
2954 -- special case of setting the right low bound for a null result.
2955 -- This is of type Ityp.
2957 Last_Opnd_High_Bound
: Node_Id
;
2958 -- A tree node representing the high bound of the last operand. This
2959 -- need only be set if the result could be null. It is used for the
2960 -- special case of setting the right high bound for a null result.
2961 -- This is of type Ityp.
2963 High_Bound
: Node_Id
;
2964 -- A tree node representing the high bound of the result (of type Ityp)
2967 -- Result of the concatenation (of type Ityp)
2969 Actions
: constant List_Id
:= New_List
;
2970 -- Collect actions to be inserted
2972 Known_Non_Null_Operand_Seen
: Boolean;
2973 -- Set True during generation of the assignments of operands into
2974 -- result once an operand known to be non-null has been seen.
2976 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2977 -- This function makes an N_Integer_Literal node that is returned in
2978 -- analyzed form with the type set to Artyp. Importantly this literal
2979 -- is not flagged as static, so that if we do computations with it that
2980 -- result in statically detected out of range conditions, we will not
2981 -- generate error messages but instead warning messages.
2983 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2984 -- Given a node of type Ityp, returns the corresponding value of type
2985 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2986 -- For enum types, the Pos of the value is returned.
2988 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2989 -- The inverse function (uses Val in the case of enumeration types)
2991 ------------------------
2992 -- Make_Artyp_Literal --
2993 ------------------------
2995 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2996 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2998 Set_Etype
(Result
, Artyp
);
2999 Set_Analyzed
(Result
, True);
3000 Set_Is_Static_Expression
(Result
, False);
3002 end Make_Artyp_Literal
;
3008 function To_Artyp
(X
: Node_Id
) return Node_Id
is
3010 if Ityp
= Base_Type
(Artyp
) then
3013 elsif Is_Enumeration_Type
(Ityp
) then
3015 Make_Attribute_Reference
(Loc
,
3016 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3017 Attribute_Name
=> Name_Pos
,
3018 Expressions
=> New_List
(X
));
3021 return Convert_To
(Artyp
, X
);
3029 function To_Ityp
(X
: Node_Id
) return Node_Id
is
3031 if Is_Enumeration_Type
(Ityp
) then
3033 Make_Attribute_Reference
(Loc
,
3034 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3035 Attribute_Name
=> Name_Val
,
3036 Expressions
=> New_List
(X
));
3038 -- Case where we will do a type conversion
3041 if Ityp
= Base_Type
(Artyp
) then
3044 return Convert_To
(Ityp
, X
);
3049 -- Local Declarations
3051 Lib_Level_Target
: constant Boolean :=
3052 Nkind
(Parent
(Cnode
)) = N_Object_Declaration
3054 Is_Library_Level_Entity
(Defining_Identifier
(Parent
(Cnode
)));
3056 -- If the concatenation declares a library level entity, we call the
3057 -- built-in concatenation routines to prevent code bloat, regardless
3058 -- of optimization level. This is space-efficient, and prevent linking
3059 -- problems when units are compiled with different optimizations.
3061 Opnd_Typ
: Entity_Id
;
3068 -- Start of processing for Expand_Concatenate
3071 -- Choose an appropriate computational type
3073 -- We will be doing calculations of lengths and bounds in this routine
3074 -- and computing one from the other in some cases, e.g. getting the high
3075 -- bound by adding the length-1 to the low bound.
3077 -- We can't just use the index type, or even its base type for this
3078 -- purpose for two reasons. First it might be an enumeration type which
3079 -- is not suitable for computations of any kind, and second it may
3080 -- simply not have enough range. For example if the index type is
3081 -- -128..+127 then lengths can be up to 256, which is out of range of
3084 -- For enumeration types, we can simply use Standard_Integer, this is
3085 -- sufficient since the actual number of enumeration literals cannot
3086 -- possibly exceed the range of integer (remember we will be doing the
3087 -- arithmetic with POS values, not representation values).
3089 if Is_Enumeration_Type
(Ityp
) then
3090 Artyp
:= Standard_Integer
;
3092 -- If index type is Positive, we use the standard unsigned type, to give
3093 -- more room on the top of the range, obviating the need for an overflow
3094 -- check when creating the upper bound. This is needed to avoid junk
3095 -- overflow checks in the common case of String types.
3097 -- ??? Disabled for now
3099 -- elsif Istyp = Standard_Positive then
3100 -- Artyp := Standard_Unsigned;
3102 -- For modular types, we use a 32-bit modular type for types whose size
3103 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3104 -- identity type, and for larger unsigned types we use 64-bits.
3106 elsif Is_Modular_Integer_Type
(Ityp
) then
3107 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
3108 Artyp
:= Standard_Unsigned
;
3109 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
3112 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
3115 -- Similar treatment for signed types
3118 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
3119 Artyp
:= Standard_Integer
;
3120 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
3123 Artyp
:= Standard_Long_Long_Integer
;
3127 -- Supply dummy entry at start of length array
3129 Aggr_Length
(0) := Make_Artyp_Literal
(0);
3131 -- Go through operands setting up the above arrays
3135 Opnd
:= Remove_Head
(Opnds
);
3136 Opnd_Typ
:= Etype
(Opnd
);
3138 -- The parent got messed up when we put the operands in a list,
3139 -- so now put back the proper parent for the saved operand, that
3140 -- is to say the concatenation node, to make sure that each operand
3141 -- is seen as a subexpression, e.g. if actions must be inserted.
3143 Set_Parent
(Opnd
, Cnode
);
3145 -- Set will be True when we have setup one entry in the array
3149 -- Singleton element (or character literal) case
3151 if Base_Type
(Opnd_Typ
) = Ctyp
then
3153 Operands
(NN
) := Opnd
;
3154 Is_Fixed_Length
(NN
) := True;
3155 Fixed_Length
(NN
) := Uint_1
;
3156 Result_May_Be_Null
:= False;
3158 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3159 -- since we know that the result cannot be null).
3161 Opnd_Low_Bound
(NN
) :=
3162 Make_Attribute_Reference
(Loc
,
3163 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
3164 Attribute_Name
=> Name_First
);
3168 -- String literal case (can only occur for strings of course)
3170 elsif Nkind
(Opnd
) = N_String_Literal
then
3171 Len
:= String_Literal_Length
(Opnd_Typ
);
3174 Result_May_Be_Null
:= False;
3177 -- Capture last operand low and high bound if result could be null
3179 if J
= N
and then Result_May_Be_Null
then
3180 Last_Opnd_Low_Bound
:=
3181 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3183 Last_Opnd_High_Bound
:=
3184 Make_Op_Subtract
(Loc
,
3186 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3187 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3190 -- Skip null string literal
3192 if J
< N
and then Len
= 0 then
3197 Operands
(NN
) := Opnd
;
3198 Is_Fixed_Length
(NN
) := True;
3200 -- Set length and bounds
3202 Fixed_Length
(NN
) := Len
;
3204 Opnd_Low_Bound
(NN
) :=
3205 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3212 -- Check constrained case with known bounds
3214 if Is_Constrained
(Opnd_Typ
) then
3216 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3217 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3218 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3219 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3222 -- Fixed length constrained array type with known at compile
3223 -- time bounds is last case of fixed length operand.
3225 if Compile_Time_Known_Value
(Lo
)
3227 Compile_Time_Known_Value
(Hi
)
3230 Loval
: constant Uint
:= Expr_Value
(Lo
);
3231 Hival
: constant Uint
:= Expr_Value
(Hi
);
3232 Len
: constant Uint
:=
3233 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3237 Result_May_Be_Null
:= False;
3240 -- Capture last operand bounds if result could be null
3242 if J
= N
and then Result_May_Be_Null
then
3243 Last_Opnd_Low_Bound
:=
3245 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3247 Last_Opnd_High_Bound
:=
3249 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3252 -- Exclude null length case unless last operand
3254 if J
< N
and then Len
= 0 then
3259 Operands
(NN
) := Opnd
;
3260 Is_Fixed_Length
(NN
) := True;
3261 Fixed_Length
(NN
) := Len
;
3263 Opnd_Low_Bound
(NN
) :=
3265 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3272 -- All cases where the length is not known at compile time, or the
3273 -- special case of an operand which is known to be null but has a
3274 -- lower bound other than 1 or is other than a string type.
3279 -- Capture operand bounds
3281 Opnd_Low_Bound
(NN
) :=
3282 Make_Attribute_Reference
(Loc
,
3284 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3285 Attribute_Name
=> Name_First
);
3287 -- Capture last operand bounds if result could be null
3289 if J
= N
and Result_May_Be_Null
then
3290 Last_Opnd_Low_Bound
:=
3292 Make_Attribute_Reference
(Loc
,
3294 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3295 Attribute_Name
=> Name_First
));
3297 Last_Opnd_High_Bound
:=
3299 Make_Attribute_Reference
(Loc
,
3301 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3302 Attribute_Name
=> Name_Last
));
3305 -- Capture length of operand in entity
3307 Operands
(NN
) := Opnd
;
3308 Is_Fixed_Length
(NN
) := False;
3310 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3313 Make_Object_Declaration
(Loc
,
3314 Defining_Identifier
=> Var_Length
(NN
),
3315 Constant_Present
=> True,
3316 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3318 Make_Attribute_Reference
(Loc
,
3320 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3321 Attribute_Name
=> Name_Length
)));
3325 -- Set next entry in aggregate length array
3327 -- For first entry, make either integer literal for fixed length
3328 -- or a reference to the saved length for variable length.
3331 if Is_Fixed_Length
(1) then
3332 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3334 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
3337 -- If entry is fixed length and only fixed lengths so far, make
3338 -- appropriate new integer literal adding new length.
3340 elsif Is_Fixed_Length
(NN
)
3341 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3344 Make_Integer_Literal
(Loc
,
3345 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3347 -- All other cases, construct an addition node for the length and
3348 -- create an entity initialized to this length.
3351 Ent
:= Make_Temporary
(Loc
, 'L');
3353 if Is_Fixed_Length
(NN
) then
3354 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3356 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3360 Make_Object_Declaration
(Loc
,
3361 Defining_Identifier
=> Ent
,
3362 Constant_Present
=> True,
3363 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3366 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
3367 Right_Opnd
=> Clen
)));
3369 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3376 -- If we have only skipped null operands, return the last operand
3383 -- If we have only one non-null operand, return it and we are done.
3384 -- There is one case in which this cannot be done, and that is when
3385 -- the sole operand is of the element type, in which case it must be
3386 -- converted to an array, and the easiest way of doing that is to go
3387 -- through the normal general circuit.
3389 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3390 Result
:= Operands
(1);
3394 -- Cases where we have a real concatenation
3396 -- Next step is to find the low bound for the result array that we
3397 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3399 -- If the ultimate ancestor of the index subtype is a constrained array
3400 -- definition, then the lower bound is that of the index subtype as
3401 -- specified by (RM 4.5.3(6)).
3403 -- The right test here is to go to the root type, and then the ultimate
3404 -- ancestor is the first subtype of this root type.
3406 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3408 Make_Attribute_Reference
(Loc
,
3410 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3411 Attribute_Name
=> Name_First
);
3413 -- If the first operand in the list has known length we know that
3414 -- the lower bound of the result is the lower bound of this operand.
3416 elsif Is_Fixed_Length
(1) then
3417 Low_Bound
:= Opnd_Low_Bound
(1);
3419 -- OK, we don't know the lower bound, we have to build a horrible
3420 -- if expression node of the form
3422 -- if Cond1'Length /= 0 then
3425 -- if Opnd2'Length /= 0 then
3430 -- The nesting ends either when we hit an operand whose length is known
3431 -- at compile time, or on reaching the last operand, whose low bound we
3432 -- take unconditionally whether or not it is null. It's easiest to do
3433 -- this with a recursive procedure:
3437 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3438 -- Returns the lower bound determined by operands J .. NN
3440 ---------------------
3441 -- Get_Known_Bound --
3442 ---------------------
3444 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3446 if Is_Fixed_Length
(J
) or else J
= NN
then
3447 return New_Copy
(Opnd_Low_Bound
(J
));
3451 Make_If_Expression
(Loc
,
3452 Expressions
=> New_List
(
3456 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3458 Make_Integer_Literal
(Loc
, 0)),
3460 New_Copy
(Opnd_Low_Bound
(J
)),
3461 Get_Known_Bound
(J
+ 1)));
3463 end Get_Known_Bound
;
3466 Ent
:= Make_Temporary
(Loc
, 'L');
3469 Make_Object_Declaration
(Loc
,
3470 Defining_Identifier
=> Ent
,
3471 Constant_Present
=> True,
3472 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3473 Expression
=> Get_Known_Bound
(1)));
3475 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3479 -- Now we can safely compute the upper bound, normally
3480 -- Low_Bound + Length - 1.
3485 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3487 Make_Op_Subtract
(Loc
,
3488 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3489 Right_Opnd
=> Make_Artyp_Literal
(1))));
3491 -- Note that calculation of the high bound may cause overflow in some
3492 -- very weird cases, so in the general case we need an overflow check on
3493 -- the high bound. We can avoid this for the common case of string types
3494 -- and other types whose index is Positive, since we chose a wider range
3495 -- for the arithmetic type.
3497 if Istyp
/= Standard_Positive
then
3498 Activate_Overflow_Check
(High_Bound
);
3501 -- Handle the exceptional case where the result is null, in which case
3502 -- case the bounds come from the last operand (so that we get the proper
3503 -- bounds if the last operand is super-flat).
3505 if Result_May_Be_Null
then
3507 Make_If_Expression
(Loc
,
3508 Expressions
=> New_List
(
3510 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3511 Right_Opnd
=> Make_Artyp_Literal
(0)),
3512 Last_Opnd_Low_Bound
,
3516 Make_If_Expression
(Loc
,
3517 Expressions
=> New_List
(
3519 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3520 Right_Opnd
=> Make_Artyp_Literal
(0)),
3521 Last_Opnd_High_Bound
,
3525 -- Here is where we insert the saved up actions
3527 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3529 -- Now we construct an array object with appropriate bounds. We mark
3530 -- the target as internal to prevent useless initialization when
3531 -- Initialize_Scalars is enabled. Also since this is the actual result
3532 -- entity, we make sure we have debug information for the result.
3534 Ent
:= Make_Temporary
(Loc
, 'S');
3535 Set_Is_Internal
(Ent
);
3536 Set_Needs_Debug_Info
(Ent
);
3538 -- If the bound is statically known to be out of range, we do not want
3539 -- to abort, we want a warning and a runtime constraint error. Note that
3540 -- we have arranged that the result will not be treated as a static
3541 -- constant, so we won't get an illegality during this insertion.
3543 Insert_Action
(Cnode
,
3544 Make_Object_Declaration
(Loc
,
3545 Defining_Identifier
=> Ent
,
3546 Object_Definition
=>
3547 Make_Subtype_Indication
(Loc
,
3548 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3550 Make_Index_Or_Discriminant_Constraint
(Loc
,
3551 Constraints
=> New_List
(
3553 Low_Bound
=> Low_Bound
,
3554 High_Bound
=> High_Bound
))))),
3555 Suppress
=> All_Checks
);
3557 -- If the result of the concatenation appears as the initializing
3558 -- expression of an object declaration, we can just rename the
3559 -- result, rather than copying it.
3561 Set_OK_To_Rename
(Ent
);
3563 -- Catch the static out of range case now
3565 if Raises_Constraint_Error
(High_Bound
) then
3566 raise Concatenation_Error
;
3569 -- Now we will generate the assignments to do the actual concatenation
3571 -- There is one case in which we will not do this, namely when all the
3572 -- following conditions are met:
3574 -- The result type is Standard.String
3576 -- There are nine or fewer retained (non-null) operands
3578 -- The optimization level is -O0
3580 -- The corresponding System.Concat_n.Str_Concat_n routine is
3581 -- available in the run time.
3583 -- The debug flag gnatd.c is not set
3585 -- If all these conditions are met then we generate a call to the
3586 -- relevant concatenation routine. The purpose of this is to avoid
3587 -- undesirable code bloat at -O0.
3589 if Atyp
= Standard_String
3590 and then NN
in 2 .. 9
3591 and then (Lib_Level_Target
3593 ((Opt
.Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3594 and then not Debug_Flag_Dot_C
))
3597 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3608 if RTE_Available
(RR
(NN
)) then
3610 Opnds
: constant List_Id
:=
3611 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3614 for J
in 1 .. NN
loop
3615 if Is_List_Member
(Operands
(J
)) then
3616 Remove
(Operands
(J
));
3619 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3621 Make_Aggregate
(Loc
,
3622 Component_Associations
=> New_List
(
3623 Make_Component_Association
(Loc
,
3624 Choices
=> New_List
(
3625 Make_Integer_Literal
(Loc
, 1)),
3626 Expression
=> Operands
(J
)))));
3629 Append_To
(Opnds
, Operands
(J
));
3633 Insert_Action
(Cnode
,
3634 Make_Procedure_Call_Statement
(Loc
,
3635 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3636 Parameter_Associations
=> Opnds
));
3638 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3645 -- Not special case so generate the assignments
3647 Known_Non_Null_Operand_Seen
:= False;
3649 for J
in 1 .. NN
loop
3651 Lo
: constant Node_Id
:=
3653 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3654 Right_Opnd
=> Aggr_Length
(J
- 1));
3656 Hi
: constant Node_Id
:=
3658 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3660 Make_Op_Subtract
(Loc
,
3661 Left_Opnd
=> Aggr_Length
(J
),
3662 Right_Opnd
=> Make_Artyp_Literal
(1)));
3665 -- Singleton case, simple assignment
3667 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3668 Known_Non_Null_Operand_Seen
:= True;
3669 Insert_Action
(Cnode
,
3670 Make_Assignment_Statement
(Loc
,
3672 Make_Indexed_Component
(Loc
,
3673 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3674 Expressions
=> New_List
(To_Ityp
(Lo
))),
3675 Expression
=> Operands
(J
)),
3676 Suppress
=> All_Checks
);
3678 -- Array case, slice assignment, skipped when argument is fixed
3679 -- length and known to be null.
3681 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3684 Make_Assignment_Statement
(Loc
,
3688 New_Occurrence_Of
(Ent
, Loc
),
3691 Low_Bound
=> To_Ityp
(Lo
),
3692 High_Bound
=> To_Ityp
(Hi
))),
3693 Expression
=> Operands
(J
));
3695 if Is_Fixed_Length
(J
) then
3696 Known_Non_Null_Operand_Seen
:= True;
3698 elsif not Known_Non_Null_Operand_Seen
then
3700 -- Here if operand length is not statically known and no
3701 -- operand known to be non-null has been processed yet.
3702 -- If operand length is 0, we do not need to perform the
3703 -- assignment, and we must avoid the evaluation of the
3704 -- high bound of the slice, since it may underflow if the
3705 -- low bound is Ityp'First.
3708 Make_Implicit_If_Statement
(Cnode
,
3712 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3713 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3714 Then_Statements
=> New_List
(Assign
));
3717 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3723 -- Finally we build the result, which is a reference to the array object
3725 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3728 Rewrite
(Cnode
, Result
);
3729 Analyze_And_Resolve
(Cnode
, Atyp
);
3732 when Concatenation_Error
=>
3734 -- Kill warning generated for the declaration of the static out of
3735 -- range high bound, and instead generate a Constraint_Error with
3736 -- an appropriate specific message.
3738 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3739 Apply_Compile_Time_Constraint_Error
3741 Msg
=> "concatenation result upper bound out of range??",
3742 Reason
=> CE_Range_Check_Failed
);
3743 end Expand_Concatenate
;
3745 ---------------------------------------------------
3746 -- Expand_Membership_Minimize_Eliminate_Overflow --
3747 ---------------------------------------------------
3749 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3750 pragma Assert
(Nkind
(N
) = N_In
);
3751 -- Despite the name, this routine applies only to N_In, not to
3752 -- N_Not_In. The latter is always rewritten as not (X in Y).
3754 Result_Type
: constant Entity_Id
:= Etype
(N
);
3755 -- Capture result type, may be a derived boolean type
3757 Loc
: constant Source_Ptr
:= Sloc
(N
);
3758 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3759 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3761 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3762 -- is thus tempting to capture these values, but due to the rewrites
3763 -- that occur as a result of overflow checking, these values change
3764 -- as we go along, and it is safe just to always use Etype explicitly.
3766 Restype
: constant Entity_Id
:= Etype
(N
);
3770 -- Bounds in Minimize calls, not used currently
3772 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3773 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3776 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3778 -- If right operand is a subtype name, and the subtype name has no
3779 -- predicate, then we can just replace the right operand with an
3780 -- explicit range T'First .. T'Last, and use the explicit range code.
3782 if Nkind
(Rop
) /= N_Range
3783 and then No
(Predicate_Function
(Etype
(Rop
)))
3786 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3791 Make_Attribute_Reference
(Loc
,
3792 Attribute_Name
=> Name_First
,
3793 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3795 Make_Attribute_Reference
(Loc
,
3796 Attribute_Name
=> Name_Last
,
3797 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3798 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3802 -- Here for the explicit range case. Note that the bounds of the range
3803 -- have not been processed for minimized or eliminated checks.
3805 if Nkind
(Rop
) = N_Range
then
3806 Minimize_Eliminate_Overflows
3807 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3808 Minimize_Eliminate_Overflows
3809 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3811 -- We have A in B .. C, treated as A >= B and then A <= C
3815 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3816 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3817 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3820 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3821 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3822 L
: constant Entity_Id
:=
3823 Make_Defining_Identifier
(Loc
, Name_uL
);
3824 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3825 Lbound
: constant Node_Id
:=
3826 Convert_To_Bignum
(Low_Bound
(Rop
));
3827 Hbound
: constant Node_Id
:=
3828 Convert_To_Bignum
(High_Bound
(Rop
));
3830 -- Now we rewrite the membership test node to look like
3833 -- Bnn : Result_Type;
3835 -- M : Mark_Id := SS_Mark;
3836 -- L : Bignum := Lopnd;
3838 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3846 -- Insert declaration of L into declarations of bignum block
3849 (Last
(Declarations
(Blk
)),
3850 Make_Object_Declaration
(Loc
,
3851 Defining_Identifier
=> L
,
3852 Object_Definition
=>
3853 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3854 Expression
=> Lopnd
));
3856 -- Insert assignment to Bnn into expressions of bignum block
3859 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3860 Make_Assignment_Statement
(Loc
,
3861 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3865 Make_Function_Call
(Loc
,
3867 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3868 Parameter_Associations
=> New_List
(
3869 New_Occurrence_Of
(L
, Loc
),
3872 Make_Function_Call
(Loc
,
3874 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3875 Parameter_Associations
=> New_List
(
3876 New_Occurrence_Of
(L
, Loc
),
3879 -- Now rewrite the node
3882 Make_Expression_With_Actions
(Loc
,
3883 Actions
=> New_List
(
3884 Make_Object_Declaration
(Loc
,
3885 Defining_Identifier
=> Bnn
,
3886 Object_Definition
=>
3887 New_Occurrence_Of
(Result_Type
, Loc
)),
3889 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3890 Analyze_And_Resolve
(N
, Result_Type
);
3894 -- Here if no bignums around
3897 -- Case where types are all the same
3899 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3901 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3905 -- If types are not all the same, it means that we have rewritten
3906 -- at least one of them to be of type Long_Long_Integer, and we
3907 -- will convert the other operands to Long_Long_Integer.
3910 Convert_To_And_Rewrite
(LLIB
, Lop
);
3911 Set_Analyzed
(Lop
, False);
3912 Analyze_And_Resolve
(Lop
, LLIB
);
3914 -- For the right operand, avoid unnecessary recursion into
3915 -- this routine, we know that overflow is not possible.
3917 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3918 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3919 Set_Analyzed
(Rop
, False);
3920 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3923 -- Now the three operands are of the same signed integer type,
3924 -- so we can use the normal expansion routine for membership,
3925 -- setting the flag to prevent recursion into this procedure.
3927 Set_No_Minimize_Eliminate
(N
);
3931 -- Right operand is a subtype name and the subtype has a predicate. We
3932 -- have to make sure the predicate is checked, and for that we need to
3933 -- use the standard N_In circuitry with appropriate types.
3936 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3938 -- If types are "right", just call Expand_N_In preventing recursion
3940 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3941 Set_No_Minimize_Eliminate
(N
);
3946 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3948 -- For X in T, we want to rewrite our node as
3951 -- Bnn : Result_Type;
3954 -- M : Mark_Id := SS_Mark;
3955 -- Lnn : Long_Long_Integer'Base
3961 -- if not Bignum_In_LLI_Range (Nnn) then
3964 -- Lnn := From_Bignum (Nnn);
3966 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3967 -- and then T'Base (Lnn) in T;
3976 -- A bit gruesome, but there doesn't seem to be a simpler way
3979 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3980 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3981 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3982 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3983 T
: constant Entity_Id
:= Etype
(Rop
);
3984 TB
: constant Entity_Id
:= Base_Type
(T
);
3988 -- Mark the last membership operation to prevent recursion
3992 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3993 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3994 Set_No_Minimize_Eliminate
(Nin
);
3996 -- Now decorate the block
3999 (Last
(Declarations
(Blk
)),
4000 Make_Object_Declaration
(Loc
,
4001 Defining_Identifier
=> Lnn
,
4002 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
4005 (Last
(Declarations
(Blk
)),
4006 Make_Object_Declaration
(Loc
,
4007 Defining_Identifier
=> Nnn
,
4008 Object_Definition
=>
4009 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
4012 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
4014 Make_Assignment_Statement
(Loc
,
4015 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
4016 Expression
=> Relocate_Node
(Lop
)),
4018 Make_Implicit_If_Statement
(N
,
4022 Make_Function_Call
(Loc
,
4025 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
4026 Parameter_Associations
=> New_List
(
4027 New_Occurrence_Of
(Nnn
, Loc
)))),
4029 Then_Statements
=> New_List
(
4030 Make_Assignment_Statement
(Loc
,
4031 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4033 New_Occurrence_Of
(Standard_False
, Loc
))),
4035 Else_Statements
=> New_List
(
4036 Make_Assignment_Statement
(Loc
,
4037 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
4039 Make_Function_Call
(Loc
,
4041 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4042 Parameter_Associations
=> New_List
(
4043 New_Occurrence_Of
(Nnn
, Loc
)))),
4045 Make_Assignment_Statement
(Loc
,
4046 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4051 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4056 Make_Attribute_Reference
(Loc
,
4057 Attribute_Name
=> Name_First
,
4059 New_Occurrence_Of
(TB
, Loc
))),
4063 Make_Attribute_Reference
(Loc
,
4064 Attribute_Name
=> Name_Last
,
4066 New_Occurrence_Of
(TB
, Loc
))))),
4068 Right_Opnd
=> Nin
))))));
4070 -- Now we can do the rewrite
4073 Make_Expression_With_Actions
(Loc
,
4074 Actions
=> New_List
(
4075 Make_Object_Declaration
(Loc
,
4076 Defining_Identifier
=> Bnn
,
4077 Object_Definition
=>
4078 New_Occurrence_Of
(Result_Type
, Loc
)),
4080 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
4081 Analyze_And_Resolve
(N
, Result_Type
);
4085 -- Not bignum case, but types don't match (this means we rewrote the
4086 -- left operand to be Long_Long_Integer).
4089 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
4091 -- We rewrite the membership test as (where T is the type with
4092 -- the predicate, i.e. the type of the right operand)
4094 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4095 -- and then T'Base (Lop) in T
4098 T
: constant Entity_Id
:= Etype
(Rop
);
4099 TB
: constant Entity_Id
:= Base_Type
(T
);
4103 -- The last membership test is marked to prevent recursion
4107 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
4108 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4109 Set_No_Minimize_Eliminate
(Nin
);
4111 -- Now do the rewrite
4122 Make_Attribute_Reference
(Loc
,
4123 Attribute_Name
=> Name_First
,
4124 Prefix
=> New_Occurrence_Of
(TB
, Loc
))),
4127 Make_Attribute_Reference
(Loc
,
4128 Attribute_Name
=> Name_Last
,
4129 Prefix
=> 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
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
(PtrT
,
4304 Associated_Storage_Pool
(Rel_Typ
));
4306 Set_Associated_Storage_Pool
(PtrT
,
4307 Get_Global_Pool_For_Access_Type
(PtrT
));
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.
4315 if Present
(Rel_Typ
) then
4316 Set_Finalization_Master
(PtrT
, Finalization_Master
(Rel_Typ
));
4318 Set_Finalization_Master
(PtrT
, Current_Anonymous_Master
);
4322 -- Set the storage pool and find the appropriate version of Allocate to
4323 -- call. Do not overwrite the storage pool if it is already set, which
4324 -- can happen for build-in-place function returns (see
4325 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4327 if No
(Storage_Pool
(N
)) then
4328 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4330 if Present
(Pool
) then
4331 Set_Storage_Pool
(N
, Pool
);
4333 if Is_RTE
(Pool
, RE_SS_Pool
) then
4334 if VM_Target
= No_VM
then
4335 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4338 -- In the case of an allocator for a simple storage pool, locate
4339 -- and save a reference to the pool type's Allocate routine.
4341 elsif Present
(Get_Rep_Pragma
4342 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4345 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4346 Alloc_Op
: Entity_Id
;
4348 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4349 while Present
(Alloc_Op
) loop
4350 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4351 and then Present
(First_Formal
(Alloc_Op
))
4352 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4354 Set_Procedure_To_Call
(N
, Alloc_Op
);
4357 Alloc_Op
:= Homonym
(Alloc_Op
);
4362 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4363 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4366 Set_Procedure_To_Call
(N
,
4367 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4372 -- Under certain circumstances we can replace an allocator by an access
4373 -- to statically allocated storage. The conditions, as noted in AARM
4374 -- 3.10 (10c) are as follows:
4376 -- Size and initial value is known at compile time
4377 -- Access type is access-to-constant
4379 -- The allocator is not part of a constraint on a record component,
4380 -- because in that case the inserted actions are delayed until the
4381 -- record declaration is fully analyzed, which is too late for the
4382 -- analysis of the rewritten allocator.
4384 if Is_Access_Constant
(PtrT
)
4385 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4386 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4387 and then Size_Known_At_Compile_Time
4388 (Etype
(Expression
(Expression
(N
))))
4389 and then not Is_Record_Type
(Current_Scope
)
4391 -- Here we can do the optimization. For the allocator
4395 -- We insert an object declaration
4397 -- Tnn : aliased x := y;
4399 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4400 -- marked as requiring static allocation.
4402 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4403 Desig
:= Subtype_Mark
(Expression
(N
));
4405 -- If context is constrained, use constrained subtype directly,
4406 -- so that the constant is not labelled as having a nominally
4407 -- unconstrained subtype.
4409 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4410 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4414 Make_Object_Declaration
(Loc
,
4415 Defining_Identifier
=> Temp
,
4416 Aliased_Present
=> True,
4417 Constant_Present
=> Is_Access_Constant
(PtrT
),
4418 Object_Definition
=> Desig
,
4419 Expression
=> Expression
(Expression
(N
))));
4422 Make_Attribute_Reference
(Loc
,
4423 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4424 Attribute_Name
=> Name_Unrestricted_Access
));
4426 Analyze_And_Resolve
(N
, PtrT
);
4428 -- We set the variable as statically allocated, since we don't want
4429 -- it going on the stack of the current procedure.
4431 Set_Is_Statically_Allocated
(Temp
);
4435 -- Same if the allocator is an access discriminant for a local object:
4436 -- instead of an allocator we create a local value and constrain the
4437 -- enclosing object with the corresponding access attribute.
4439 if Is_Static_Coextension
(N
) then
4440 Rewrite_Coextension
(N
);
4444 -- Check for size too large, we do this because the back end misses
4445 -- proper checks here and can generate rubbish allocation calls when
4446 -- we are near the limit. We only do this for the 32-bit address case
4447 -- since that is from a practical point of view where we see a problem.
4449 if System_Address_Size
= 32
4450 and then not Storage_Checks_Suppressed
(PtrT
)
4451 and then not Storage_Checks_Suppressed
(Dtyp
)
4452 and then not Storage_Checks_Suppressed
(Etyp
)
4454 -- The check we want to generate should look like
4456 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4457 -- raise Storage_Error;
4460 -- where 3.5 gigabytes is a constant large enough to accommodate any
4461 -- reasonable request for. But we can't do it this way because at
4462 -- least at the moment we don't compute this attribute right, and
4463 -- can silently give wrong results when the result gets large. Since
4464 -- this is all about large results, that's bad, so instead we only
4465 -- apply the check for constrained arrays, and manually compute the
4466 -- value of the attribute ???
4468 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4470 Make_Raise_Storage_Error
(Loc
,
4473 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4475 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4476 Reason
=> SE_Object_Too_Large
));
4480 -- Handle case of qualified expression (other than optimization above)
4481 -- First apply constraint checks, because the bounds or discriminants
4482 -- in the aggregate might not match the subtype mark in the allocator.
4484 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4485 Apply_Constraint_Check
4486 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
4488 Expand_Allocator_Expression
(N
);
4492 -- If the allocator is for a type which requires initialization, and
4493 -- there is no initial value (i.e. operand is a subtype indication
4494 -- rather than a qualified expression), then we must generate a call to
4495 -- the initialization routine using an expressions action node:
4497 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4499 -- Here ptr_T is the pointer type for the allocator, and T is the
4500 -- subtype of the allocator. A special case arises if the designated
4501 -- type of the access type is a task or contains tasks. In this case
4502 -- the call to Init (Temp.all ...) is replaced by code that ensures
4503 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4504 -- for details). In addition, if the type T is a task T, then the
4505 -- first argument to Init must be converted to the task record type.
4508 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4514 Init_Arg1
: Node_Id
;
4515 Temp_Decl
: Node_Id
;
4516 Temp_Type
: Entity_Id
;
4519 if No_Initialization
(N
) then
4521 -- Even though this might be a simple allocation, create a custom
4522 -- Allocate if the context requires it. Since .NET/JVM compilers
4523 -- do not support pools, this step is skipped.
4525 if VM_Target
= No_VM
4526 and then Present
(Finalization_Master
(PtrT
))
4528 Build_Allocate_Deallocate_Proc
4530 Is_Allocate
=> True);
4533 -- Case of no initialization procedure present
4535 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4537 -- Case of simple initialization required
4539 if Needs_Simple_Initialization
(T
) then
4540 Check_Restriction
(No_Default_Initialization
, N
);
4541 Rewrite
(Expression
(N
),
4542 Make_Qualified_Expression
(Loc
,
4543 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4544 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4546 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4547 Analyze_And_Resolve
(Expression
(N
), T
);
4548 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4549 Expand_N_Allocator
(N
);
4551 -- No initialization required
4557 -- Case of initialization procedure present, must be called
4560 Check_Restriction
(No_Default_Initialization
, N
);
4562 if not Restriction_Active
(No_Default_Initialization
) then
4563 Init
:= Base_Init_Proc
(T
);
4565 Temp
:= Make_Temporary
(Loc
, 'P');
4567 -- Construct argument list for the initialization routine call
4570 Make_Explicit_Dereference
(Loc
,
4572 New_Occurrence_Of
(Temp
, Loc
));
4574 Set_Assignment_OK
(Init_Arg1
);
4577 -- The initialization procedure expects a specific type. if the
4578 -- context is access to class wide, indicate that the object
4579 -- being allocated has the right specific type.
4581 if Is_Class_Wide_Type
(Dtyp
) then
4582 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4585 -- If designated type is a concurrent type or if it is private
4586 -- type whose definition is a concurrent type, the first
4587 -- argument in the Init routine has to be unchecked conversion
4588 -- to the corresponding record type. If the designated type is
4589 -- a derived type, also convert the argument to its root type.
4591 if Is_Concurrent_Type
(T
) then
4593 Unchecked_Convert_To
(
4594 Corresponding_Record_Type
(T
), Init_Arg1
);
4596 elsif Is_Private_Type
(T
)
4597 and then Present
(Full_View
(T
))
4598 and then Is_Concurrent_Type
(Full_View
(T
))
4601 Unchecked_Convert_To
4602 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4604 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4606 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4609 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4610 Set_Etype
(Init_Arg1
, Ftyp
);
4614 Args
:= New_List
(Init_Arg1
);
4616 -- For the task case, pass the Master_Id of the access type as
4617 -- the value of the _Master parameter, and _Chain as the value
4618 -- of the _Chain parameter (_Chain will be defined as part of
4619 -- the generated code for the allocator).
4621 -- In Ada 2005, the context may be a function that returns an
4622 -- anonymous access type. In that case the Master_Id has been
4623 -- created when expanding the function declaration.
4625 if Has_Task
(T
) then
4626 if No
(Master_Id
(Base_Type
(PtrT
))) then
4628 -- The designated type was an incomplete type, and the
4629 -- access type did not get expanded. Salvage it now.
4631 if not Restriction_Active
(No_Task_Hierarchy
) then
4632 if Present
(Parent
(Base_Type
(PtrT
))) then
4633 Expand_N_Full_Type_Declaration
4634 (Parent
(Base_Type
(PtrT
)));
4636 -- The only other possibility is an itype. For this
4637 -- case, the master must exist in the context. This is
4638 -- the case when the allocator initializes an access
4639 -- component in an init-proc.
4642 pragma Assert
(Is_Itype
(PtrT
));
4643 Build_Master_Renaming
(PtrT
, N
);
4648 -- If the context of the allocator is a declaration or an
4649 -- assignment, we can generate a meaningful image for it,
4650 -- even though subsequent assignments might remove the
4651 -- connection between task and entity. We build this image
4652 -- when the left-hand side is a simple variable, a simple
4653 -- indexed assignment or a simple selected component.
4655 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4657 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4660 if Is_Entity_Name
(Nam
) then
4662 Build_Task_Image_Decls
4665 (Entity
(Nam
), Sloc
(Nam
)), T
);
4667 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4668 N_Selected_Component
)
4669 and then Is_Entity_Name
(Prefix
(Nam
))
4672 Build_Task_Image_Decls
4673 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4675 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4679 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4681 Build_Task_Image_Decls
4682 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4685 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4688 if Restriction_Active
(No_Task_Hierarchy
) then
4690 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4694 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4697 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4699 Decl
:= Last
(Decls
);
4701 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4703 -- Has_Task is false, Decls not used
4709 -- Add discriminants if discriminated type
4712 Dis
: Boolean := False;
4716 if Has_Discriminants
(T
) then
4720 elsif Is_Private_Type
(T
)
4721 and then Present
(Full_View
(T
))
4722 and then Has_Discriminants
(Full_View
(T
))
4725 Typ
:= Full_View
(T
);
4730 -- If the allocated object will be constrained by the
4731 -- default values for discriminants, then build a subtype
4732 -- with those defaults, and change the allocated subtype
4733 -- to that. Note that this happens in fewer cases in Ada
4736 if not Is_Constrained
(Typ
)
4737 and then Present
(Discriminant_Default_Value
4738 (First_Discriminant
(Typ
)))
4739 and then (Ada_Version
< Ada_2005
4741 Object_Type_Has_Constrained_Partial_View
4742 (Typ
, Current_Scope
))
4744 Typ
:= Build_Default_Subtype
(Typ
, N
);
4745 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
4748 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4749 while Present
(Discr
) loop
4750 Nod
:= Node
(Discr
);
4751 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4753 -- AI-416: when the discriminant constraint is an
4754 -- anonymous access type make sure an accessibility
4755 -- check is inserted if necessary (3.10.2(22.q/2))
4757 if Ada_Version
>= Ada_2005
4759 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4761 Apply_Accessibility_Check
4762 (Nod
, Typ
, Insert_Node
=> Nod
);
4770 -- We set the allocator as analyzed so that when we analyze
4771 -- the if expression node, we do not get an unwanted recursive
4772 -- expansion of the allocator expression.
4774 Set_Analyzed
(N
, True);
4775 Nod
:= Relocate_Node
(N
);
4777 -- Here is the transformation:
4778 -- input: new Ctrl_Typ
4779 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4780 -- Ctrl_TypIP (Temp.all, ...);
4781 -- [Deep_]Initialize (Temp.all);
4783 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4784 -- is the subtype of the allocator.
4787 Make_Object_Declaration
(Loc
,
4788 Defining_Identifier
=> Temp
,
4789 Constant_Present
=> True,
4790 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
4793 Set_Assignment_OK
(Temp_Decl
);
4794 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4796 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
4798 -- If the designated type is a task type or contains tasks,
4799 -- create block to activate created tasks, and insert
4800 -- declaration for Task_Image variable ahead of call.
4802 if Has_Task
(T
) then
4804 L
: constant List_Id
:= New_List
;
4807 Build_Task_Allocate_Block
(L
, Nod
, Args
);
4809 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
4810 Insert_Actions
(N
, L
);
4815 Make_Procedure_Call_Statement
(Loc
,
4816 Name
=> New_Occurrence_Of
(Init
, Loc
),
4817 Parameter_Associations
=> Args
));
4820 if Needs_Finalization
(T
) then
4823 -- [Deep_]Initialize (Init_Arg1);
4827 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4830 if Present
(Finalization_Master
(PtrT
)) then
4832 -- Special processing for .NET/JVM, the allocated object
4833 -- is attached to the finalization master. Generate:
4835 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4837 -- Types derived from [Limited_]Controlled are the only
4838 -- ones considered since they have fields Prev and Next.
4840 if VM_Target
/= No_VM
then
4841 if Is_Controlled
(T
) then
4844 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4848 -- Default case, generate:
4850 -- Set_Finalize_Address
4851 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
4853 -- Do not generate this call in CodePeer mode, as TSS
4854 -- primitive Finalize_Address is not created in this
4857 elsif not CodePeer_Mode
then
4859 Make_Set_Finalize_Address_Call
4867 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4868 Analyze_And_Resolve
(N
, PtrT
);
4873 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4874 -- object that has been rewritten as a reference, we displace "this"
4875 -- to reference properly its secondary dispatch table.
4877 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
4878 Displace_Allocator_Pointer
(N
);
4882 when RE_Not_Available
=>
4884 end Expand_N_Allocator
;
4886 -----------------------
4887 -- Expand_N_And_Then --
4888 -----------------------
4890 procedure Expand_N_And_Then
(N
: Node_Id
)
4891 renames Expand_Short_Circuit_Operator
;
4893 ------------------------------
4894 -- Expand_N_Case_Expression --
4895 ------------------------------
4897 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4898 Loc
: constant Source_Ptr
:= Sloc
(N
);
4899 Typ
: constant Entity_Id
:= Etype
(N
);
4910 -- Check for MINIMIZED/ELIMINATED overflow mode
4912 if Minimized_Eliminated_Overflow_Check
(N
) then
4913 Apply_Arithmetic_Overflow_Check
(N
);
4919 -- case X is when A => AX, when B => BX ...
4934 -- However, this expansion is wrong for limited types, and also
4935 -- wrong for unconstrained types (since the bounds may not be the
4936 -- same in all branches). Furthermore it involves an extra copy
4937 -- for large objects. So we take care of this by using the following
4938 -- modified expansion for non-elementary types:
4941 -- type Pnn is access all typ;
4945 -- T := AX'Unrestricted_Access;
4947 -- T := BX'Unrestricted_Access;
4953 Make_Case_Statement
(Loc
,
4954 Expression
=> Expression
(N
),
4955 Alternatives
=> New_List
);
4957 Actions
:= New_List
;
4961 if Is_Elementary_Type
(Typ
) then
4965 Pnn
:= Make_Temporary
(Loc
, 'P');
4967 Make_Full_Type_Declaration
(Loc
,
4968 Defining_Identifier
=> Pnn
,
4970 Make_Access_To_Object_Definition
(Loc
,
4971 All_Present
=> True,
4972 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
4976 Tnn
:= Make_Temporary
(Loc
, 'T');
4978 -- Create declaration for target of expression, and indicate that it
4979 -- does not require initialization.
4982 Make_Object_Declaration
(Loc
,
4983 Defining_Identifier
=> Tnn
,
4984 Object_Definition
=> New_Occurrence_Of
(Ttyp
, Loc
));
4985 Set_No_Initialization
(Decl
);
4986 Append_To
(Actions
, Decl
);
4988 -- Now process the alternatives
4990 Alt
:= First
(Alternatives
(N
));
4991 while Present
(Alt
) loop
4993 Aexp
: Node_Id
:= Expression
(Alt
);
4994 Aloc
: constant Source_Ptr
:= Sloc
(Aexp
);
4998 -- As described above, take Unrestricted_Access for case of non-
4999 -- scalar types, to avoid big copies, and special cases.
5001 if not Is_Elementary_Type
(Typ
) then
5003 Make_Attribute_Reference
(Aloc
,
5004 Prefix
=> Relocate_Node
(Aexp
),
5005 Attribute_Name
=> Name_Unrestricted_Access
);
5009 Make_Assignment_Statement
(Aloc
,
5010 Name
=> New_Occurrence_Of
(Tnn
, Loc
),
5011 Expression
=> Aexp
));
5013 -- Propagate declarations inserted in the node by Insert_Actions
5014 -- (for example, temporaries generated to remove side effects).
5015 -- These actions must remain attached to the alternative, given
5016 -- that they are generated by the corresponding expression.
5018 if Present
(Sinfo
.Actions
(Alt
)) then
5019 Prepend_List
(Sinfo
.Actions
(Alt
), Stats
);
5023 (Alternatives
(Cstmt
),
5024 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5025 Discrete_Choices
=> Discrete_Choices
(Alt
),
5026 Statements
=> Stats
));
5032 Append_To
(Actions
, Cstmt
);
5034 -- Construct and return final expression with actions
5036 if Is_Elementary_Type
(Typ
) then
5037 Fexp
:= New_Occurrence_Of
(Tnn
, Loc
);
5040 Make_Explicit_Dereference
(Loc
,
5041 Prefix
=> New_Occurrence_Of
(Tnn
, Loc
));
5045 Make_Expression_With_Actions
(Loc
,
5047 Actions
=> Actions
));
5049 Analyze_And_Resolve
(N
, Typ
);
5050 end Expand_N_Case_Expression
;
5052 -----------------------------------
5053 -- Expand_N_Explicit_Dereference --
5054 -----------------------------------
5056 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5058 -- Insert explicit dereference call for the checked storage pool case
5060 Insert_Dereference_Action
(Prefix
(N
));
5062 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5063 -- we set the atomic sync flag.
5065 if Is_Atomic
(Etype
(N
))
5066 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5068 Activate_Atomic_Synchronization
(N
);
5070 end Expand_N_Explicit_Dereference
;
5072 --------------------------------------
5073 -- Expand_N_Expression_With_Actions --
5074 --------------------------------------
5076 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5078 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5079 -- Inspect and process a single action of an expression_with_actions for
5080 -- transient controlled objects. If such objects are found, the routine
5081 -- generates code to clean them up when the context of the expression is
5082 -- evaluated or elaborated.
5084 --------------------
5085 -- Process_Action --
5086 --------------------
5088 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5090 if Nkind
(Act
) = N_Object_Declaration
5091 and then Is_Finalizable_Transient
(Act
, N
)
5093 Process_Transient_Object
(Act
, N
);
5096 -- Avoid processing temporary function results multiple times when
5097 -- dealing with nested expression_with_actions.
5099 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5102 -- Do not process temporary function results in loops. This is done
5103 -- by Expand_N_Loop_Statement and Build_Finalizer.
5105 elsif Nkind
(Act
) = N_Loop_Statement
then
5112 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5118 -- Start of processing for Expand_N_Expression_With_Actions
5121 -- Process the actions as described above
5123 Act
:= First
(Actions
(N
));
5124 while Present
(Act
) loop
5125 Process_Single_Action
(Act
);
5129 -- Deal with case where there are no actions. In this case we simply
5130 -- rewrite the node with its expression since we don't need the actions
5131 -- and the specification of this node does not allow a null action list.
5133 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5134 -- the expanded tree and relying on being able to retrieve the original
5135 -- tree in cases like this. This raises a whole lot of issues of whether
5136 -- we have problems elsewhere, which will be addressed in the future???
5138 if Is_Empty_List
(Actions
(N
)) then
5139 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5141 end Expand_N_Expression_With_Actions
;
5143 ----------------------------
5144 -- Expand_N_If_Expression --
5145 ----------------------------
5147 -- Deal with limited types and condition actions
5149 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5150 procedure Process_Actions
(Actions
: List_Id
);
5151 -- Inspect and process a single action list of an if expression for
5152 -- transient controlled objects. If such objects are found, the routine
5153 -- generates code to clean them up when the context of the expression is
5154 -- evaluated or elaborated.
5156 ---------------------
5157 -- Process_Actions --
5158 ---------------------
5160 procedure Process_Actions
(Actions
: List_Id
) is
5164 Act
:= First
(Actions
);
5165 while Present
(Act
) loop
5166 if Nkind
(Act
) = N_Object_Declaration
5167 and then Is_Finalizable_Transient
(Act
, N
)
5169 Process_Transient_Object
(Act
, N
);
5174 end Process_Actions
;
5178 Loc
: constant Source_Ptr
:= Sloc
(N
);
5179 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5180 Thenx
: constant Node_Id
:= Next
(Cond
);
5181 Elsex
: constant Node_Id
:= Next
(Thenx
);
5182 Typ
: constant Entity_Id
:= Etype
(N
);
5190 Ptr_Typ
: Entity_Id
;
5192 -- Start of processing for Expand_N_If_Expression
5195 -- Check for MINIMIZED/ELIMINATED overflow mode
5197 if Minimized_Eliminated_Overflow_Check
(N
) then
5198 Apply_Arithmetic_Overflow_Check
(N
);
5202 -- Fold at compile time if condition known. We have already folded
5203 -- static if expressions, but it is possible to fold any case in which
5204 -- the condition is known at compile time, even though the result is
5207 -- Note that we don't do the fold of such cases in Sem_Elab because
5208 -- it can cause infinite loops with the expander adding a conditional
5209 -- expression, and Sem_Elab circuitry removing it repeatedly.
5211 if Compile_Time_Known_Value
(Cond
) then
5212 if Is_True
(Expr_Value
(Cond
)) then
5214 Actions
:= Then_Actions
(N
);
5217 Actions
:= Else_Actions
(N
);
5222 if Present
(Actions
) then
5224 Make_Expression_With_Actions
(Loc
,
5225 Expression
=> Relocate_Node
(Expr
),
5226 Actions
=> Actions
));
5227 Analyze_And_Resolve
(N
, Typ
);
5229 Rewrite
(N
, Relocate_Node
(Expr
));
5232 -- Note that the result is never static (legitimate cases of static
5233 -- if expressions were folded in Sem_Eval).
5235 Set_Is_Static_Expression
(N
, False);
5239 -- If the type is limited or unconstrained, we expand as follows to
5240 -- avoid any possibility of improper copies.
5242 -- Note: it may be possible to avoid this special processing if the
5243 -- back end uses its own mechanisms for handling by-reference types ???
5245 -- type Ptr is access all Typ;
5249 -- Cnn := then-expr'Unrestricted_Access;
5252 -- Cnn := else-expr'Unrestricted_Access;
5255 -- and replace the if expression by a reference to Cnn.all.
5257 -- This special case can be skipped if the back end handles limited
5258 -- types properly and ensures that no incorrect copies are made.
5260 if Is_By_Reference_Type
(Typ
)
5261 and then not Back_End_Handles_Limited_Types
5263 -- When the "then" or "else" expressions involve controlled function
5264 -- calls, generated temporaries are chained on the corresponding list
5265 -- of actions. These temporaries need to be finalized after the if
5266 -- expression is evaluated.
5268 Process_Actions
(Then_Actions
(N
));
5269 Process_Actions
(Else_Actions
(N
));
5272 -- type Ann is access all Typ;
5274 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5277 Make_Full_Type_Declaration
(Loc
,
5278 Defining_Identifier
=> Ptr_Typ
,
5280 Make_Access_To_Object_Definition
(Loc
,
5281 All_Present
=> True,
5282 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5287 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5290 Make_Object_Declaration
(Loc
,
5291 Defining_Identifier
=> Cnn
,
5292 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5296 -- Cnn := <Thenx>'Unrestricted_Access;
5298 -- Cnn := <Elsex>'Unrestricted_Access;
5302 Make_Implicit_If_Statement
(N
,
5303 Condition
=> Relocate_Node
(Cond
),
5304 Then_Statements
=> New_List
(
5305 Make_Assignment_Statement
(Sloc
(Thenx
),
5306 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5308 Make_Attribute_Reference
(Loc
,
5309 Prefix
=> Relocate_Node
(Thenx
),
5310 Attribute_Name
=> Name_Unrestricted_Access
))),
5312 Else_Statements
=> New_List
(
5313 Make_Assignment_Statement
(Sloc
(Elsex
),
5314 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5316 Make_Attribute_Reference
(Loc
,
5317 Prefix
=> Relocate_Node
(Elsex
),
5318 Attribute_Name
=> Name_Unrestricted_Access
))));
5321 Make_Explicit_Dereference
(Loc
,
5322 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5324 -- For other types, we only need to expand if there are other actions
5325 -- associated with either branch.
5327 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5329 -- We now wrap the actions into the appropriate expression
5331 if Present
(Then_Actions
(N
)) then
5333 Make_Expression_With_Actions
(Sloc
(Thenx
),
5334 Actions
=> Then_Actions
(N
),
5335 Expression
=> Relocate_Node
(Thenx
)));
5337 Set_Then_Actions
(N
, No_List
);
5338 Analyze_And_Resolve
(Thenx
, Typ
);
5341 if Present
(Else_Actions
(N
)) then
5343 Make_Expression_With_Actions
(Sloc
(Elsex
),
5344 Actions
=> Else_Actions
(N
),
5345 Expression
=> Relocate_Node
(Elsex
)));
5347 Set_Else_Actions
(N
, No_List
);
5348 Analyze_And_Resolve
(Elsex
, Typ
);
5353 -- If no actions then no expansion needed, gigi will handle it using the
5354 -- same approach as a C conditional expression.
5360 -- Fall through here for either the limited expansion, or the case of
5361 -- inserting actions for non-limited types. In both these cases, we must
5362 -- move the SLOC of the parent If statement to the newly created one and
5363 -- change it to the SLOC of the expression which, after expansion, will
5364 -- correspond to what is being evaluated.
5366 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
5367 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5368 Set_Sloc
(Parent
(N
), Loc
);
5371 -- Make sure Then_Actions and Else_Actions are appropriately moved
5372 -- to the new if statement.
5374 if Present
(Then_Actions
(N
)) then
5376 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5379 if Present
(Else_Actions
(N
)) then
5381 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5384 Insert_Action
(N
, Decl
);
5385 Insert_Action
(N
, New_If
);
5387 Analyze_And_Resolve
(N
, Typ
);
5388 end Expand_N_If_Expression
;
5394 procedure Expand_N_In
(N
: Node_Id
) is
5395 Loc
: constant Source_Ptr
:= Sloc
(N
);
5396 Restyp
: constant Entity_Id
:= Etype
(N
);
5397 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5398 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5399 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5404 procedure Substitute_Valid_Check
;
5405 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5406 -- test for the left operand being in range of its subtype.
5408 ----------------------------
5409 -- Substitute_Valid_Check --
5410 ----------------------------
5412 procedure Substitute_Valid_Check
is
5415 Make_Attribute_Reference
(Loc
,
5416 Prefix
=> Relocate_Node
(Lop
),
5417 Attribute_Name
=> Name_Valid
));
5419 Analyze_And_Resolve
(N
, Restyp
);
5421 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5422 -- in which case, this usage makes sense, and in any case, we have
5423 -- actually eliminated the danger of optimization above.
5425 if Overflow_Check_Mode
not in Minimized_Or_Eliminated
then
5427 ("??explicit membership test may be optimized away", N
);
5428 Error_Msg_N
-- CODEFIX
5429 ("\??use ''Valid attribute instead", N
);
5433 end Substitute_Valid_Check
;
5435 -- Start of processing for Expand_N_In
5438 -- If set membership case, expand with separate procedure
5440 if Present
(Alternatives
(N
)) then
5441 Expand_Set_Membership
(N
);
5445 -- Not set membership, proceed with expansion
5447 Ltyp
:= Etype
(Left_Opnd
(N
));
5448 Rtyp
:= Etype
(Right_Opnd
(N
));
5450 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5451 -- type, then expand with a separate procedure. Note the use of the
5452 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5454 if Overflow_Check_Mode
in Minimized_Or_Eliminated
5455 and then Is_Signed_Integer_Type
(Ltyp
)
5456 and then not No_Minimize_Eliminate
(N
)
5458 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
5462 -- Check case of explicit test for an expression in range of its
5463 -- subtype. This is suspicious usage and we replace it with a 'Valid
5464 -- test and give a warning for scalar types.
5466 if Is_Scalar_Type
(Ltyp
)
5468 -- Only relevant for source comparisons
5470 and then Comes_From_Source
(N
)
5472 -- In floating-point this is a standard way to check for finite values
5473 -- and using 'Valid would typically be a pessimization.
5475 and then not Is_Floating_Point_Type
(Ltyp
)
5477 -- Don't give the message unless right operand is a type entity and
5478 -- the type of the left operand matches this type. Note that this
5479 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5480 -- checks have changed the type of the left operand.
5482 and then Nkind
(Rop
) in N_Has_Entity
5483 and then Ltyp
= Entity
(Rop
)
5485 -- Skip in VM mode, where we have no sense of invalid values. The
5486 -- warning still seems relevant, but not important enough to worry.
5488 and then VM_Target
= No_VM
5490 -- Skip this for predicated types, where such expressions are a
5491 -- reasonable way of testing if something meets the predicate.
5493 and then not Present
(Predicate_Function
(Ltyp
))
5495 Substitute_Valid_Check
;
5499 -- Do validity check on operands
5501 if Validity_Checks_On
and Validity_Check_Operands
then
5502 Ensure_Valid
(Left_Opnd
(N
));
5503 Validity_Check_Range
(Right_Opnd
(N
));
5506 -- Case of explicit range
5508 if Nkind
(Rop
) = N_Range
then
5510 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
5511 Hi
: constant Node_Id
:= High_Bound
(Rop
);
5513 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
5514 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
5516 Lcheck
: Compare_Result
;
5517 Ucheck
: Compare_Result
;
5519 Warn1
: constant Boolean :=
5520 Constant_Condition_Warnings
5521 and then Comes_From_Source
(N
)
5522 and then not In_Instance
;
5523 -- This must be true for any of the optimization warnings, we
5524 -- clearly want to give them only for source with the flag on. We
5525 -- also skip these warnings in an instance since it may be the
5526 -- case that different instantiations have different ranges.
5528 Warn2
: constant Boolean :=
5530 and then Nkind
(Original_Node
(Rop
)) = N_Range
5531 and then Is_Integer_Type
(Etype
(Lo
));
5532 -- For the case where only one bound warning is elided, we also
5533 -- insist on an explicit range and an integer type. The reason is
5534 -- that the use of enumeration ranges including an end point is
5535 -- common, as is the use of a subtype name, one of whose bounds is
5536 -- the same as the type of the expression.
5539 -- If test is explicit x'First .. x'Last, replace by valid check
5541 -- Could use some individual comments for this complex test ???
5543 if Is_Scalar_Type
(Ltyp
)
5545 -- And left operand is X'First where X matches left operand
5546 -- type (this eliminates cases of type mismatch, including
5547 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5548 -- type of the left operand.
5550 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
5551 and then Attribute_Name
(Lo_Orig
) = Name_First
5552 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
5553 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
5555 -- Same tests for right operand
5557 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
5558 and then Attribute_Name
(Hi_Orig
) = Name_Last
5559 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
5560 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
5562 -- Relevant only for source cases
5564 and then Comes_From_Source
(N
)
5566 -- Omit for VM cases, where we don't have invalid values
5568 and then VM_Target
= No_VM
5570 Substitute_Valid_Check
;
5574 -- If bounds of type are known at compile time, and the end points
5575 -- are known at compile time and identical, this is another case
5576 -- for substituting a valid test. We only do this for discrete
5577 -- types, since it won't arise in practice for float types.
5579 if Comes_From_Source
(N
)
5580 and then Is_Discrete_Type
(Ltyp
)
5581 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
5582 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
5583 and then Compile_Time_Known_Value
(Lo
)
5584 and then Compile_Time_Known_Value
(Hi
)
5585 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
5586 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
5588 -- Kill warnings in instances, since they may be cases where we
5589 -- have a test in the generic that makes sense with some types
5590 -- and not with other types.
5592 and then not In_Instance
5594 Substitute_Valid_Check
;
5598 -- If we have an explicit range, do a bit of optimization based on
5599 -- range analysis (we may be able to kill one or both checks).
5601 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
5602 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
5604 -- If either check is known to fail, replace result by False since
5605 -- the other check does not matter. Preserve the static flag for
5606 -- legality checks, because we are constant-folding beyond RM 4.9.
5608 if Lcheck
= LT
or else Ucheck
= GT
then
5610 Error_Msg_N
("?c?range test optimized away", N
);
5611 Error_Msg_N
("\?c?value is known to be out of range", N
);
5614 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5615 Analyze_And_Resolve
(N
, Restyp
);
5616 Set_Is_Static_Expression
(N
, Static
);
5619 -- If both checks are known to succeed, replace result by True,
5620 -- since we know we are in range.
5622 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5624 Error_Msg_N
("?c?range test optimized away", N
);
5625 Error_Msg_N
("\?c?value is known to be in range", N
);
5628 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5629 Analyze_And_Resolve
(N
, Restyp
);
5630 Set_Is_Static_Expression
(N
, Static
);
5633 -- If lower bound check succeeds and upper bound check is not
5634 -- known to succeed or fail, then replace the range check with
5635 -- a comparison against the upper bound.
5637 elsif Lcheck
in Compare_GE
then
5638 if Warn2
and then not In_Instance
then
5639 Error_Msg_N
("??lower bound test optimized away", Lo
);
5640 Error_Msg_N
("\??value is known to be in range", Lo
);
5646 Right_Opnd
=> High_Bound
(Rop
)));
5647 Analyze_And_Resolve
(N
, Restyp
);
5650 -- If upper bound check succeeds and lower bound check is not
5651 -- known to succeed or fail, then replace the range check with
5652 -- a comparison against the lower bound.
5654 elsif Ucheck
in Compare_LE
then
5655 if Warn2
and then not In_Instance
then
5656 Error_Msg_N
("??upper bound test optimized away", Hi
);
5657 Error_Msg_N
("\??value is known to be in range", Hi
);
5663 Right_Opnd
=> Low_Bound
(Rop
)));
5664 Analyze_And_Resolve
(N
, Restyp
);
5668 -- We couldn't optimize away the range check, but there is one
5669 -- more issue. If we are checking constant conditionals, then we
5670 -- see if we can determine the outcome assuming everything is
5671 -- valid, and if so give an appropriate warning.
5673 if Warn1
and then not Assume_No_Invalid_Values
then
5674 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
5675 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
5677 -- Result is out of range for valid value
5679 if Lcheck
= LT
or else Ucheck
= GT
then
5681 ("?c?value can only be in range if it is invalid", N
);
5683 -- Result is in range for valid value
5685 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5687 ("?c?value can only be out of range if it is invalid", N
);
5689 -- Lower bound check succeeds if value is valid
5691 elsif Warn2
and then Lcheck
in Compare_GE
then
5693 ("?c?lower bound check only fails if it is invalid", Lo
);
5695 -- Upper bound check succeeds if value is valid
5697 elsif Warn2
and then Ucheck
in Compare_LE
then
5699 ("?c?upper bound check only fails for invalid values", Hi
);
5704 -- For all other cases of an explicit range, nothing to be done
5708 -- Here right operand is a subtype mark
5712 Typ
: Entity_Id
:= Etype
(Rop
);
5713 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
5714 Cond
: Node_Id
:= Empty
;
5716 Obj
: Node_Id
:= Lop
;
5717 SCIL_Node
: Node_Id
;
5720 Remove_Side_Effects
(Obj
);
5722 -- For tagged type, do tagged membership operation
5724 if Is_Tagged_Type
(Typ
) then
5726 -- No expansion will be performed when VM_Target, as the VM
5727 -- back-ends will handle the membership tests directly (tags
5728 -- are not explicitly represented in Java objects, so the
5729 -- normal tagged membership expansion is not what we want).
5731 if Tagged_Type_Expansion
then
5732 Tagged_Membership
(N
, SCIL_Node
, New_N
);
5734 Analyze_And_Resolve
(N
, Restyp
);
5736 -- Update decoration of relocated node referenced by the
5739 if Generate_SCIL
and then Present
(SCIL_Node
) then
5740 Set_SCIL_Node
(N
, SCIL_Node
);
5746 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5747 -- This reason we do this is that the bounds may have the wrong
5748 -- type if they come from the original type definition. Also this
5749 -- way we get all the processing above for an explicit range.
5751 -- Don't do this for predicated types, since in this case we
5752 -- want to check the predicate.
5754 elsif Is_Scalar_Type
(Typ
) then
5755 if No
(Predicate_Function
(Typ
)) then
5759 Make_Attribute_Reference
(Loc
,
5760 Attribute_Name
=> Name_First
,
5761 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
5764 Make_Attribute_Reference
(Loc
,
5765 Attribute_Name
=> Name_Last
,
5766 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
5767 Analyze_And_Resolve
(N
, Restyp
);
5772 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5773 -- a membership test if the subtype mark denotes a constrained
5774 -- Unchecked_Union subtype and the expression lacks inferable
5777 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
5778 and then Is_Constrained
(Typ
)
5779 and then not Has_Inferable_Discriminants
(Lop
)
5782 Make_Raise_Program_Error
(Loc
,
5783 Reason
=> PE_Unchecked_Union_Restriction
));
5785 -- Prevent Gigi from generating incorrect code by rewriting the
5786 -- test as False. What is this undocumented thing about ???
5788 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5792 -- Here we have a non-scalar type
5795 Typ
:= Designated_Type
(Typ
);
5798 if not Is_Constrained
(Typ
) then
5799 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5800 Analyze_And_Resolve
(N
, Restyp
);
5802 -- For the constrained array case, we have to check the subscripts
5803 -- for an exact match if the lengths are non-zero (the lengths
5804 -- must match in any case).
5806 elsif Is_Array_Type
(Typ
) then
5807 Check_Subscripts
: declare
5808 function Build_Attribute_Reference
5811 Dim
: Nat
) return Node_Id
;
5812 -- Build attribute reference E'Nam (Dim)
5814 -------------------------------
5815 -- Build_Attribute_Reference --
5816 -------------------------------
5818 function Build_Attribute_Reference
5821 Dim
: Nat
) return Node_Id
5825 Make_Attribute_Reference
(Loc
,
5827 Attribute_Name
=> Nam
,
5828 Expressions
=> New_List
(
5829 Make_Integer_Literal
(Loc
, Dim
)));
5830 end Build_Attribute_Reference
;
5832 -- Start of processing for Check_Subscripts
5835 for J
in 1 .. Number_Dimensions
(Typ
) loop
5836 Evolve_And_Then
(Cond
,
5839 Build_Attribute_Reference
5840 (Duplicate_Subexpr_No_Checks
(Obj
),
5843 Build_Attribute_Reference
5844 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
5846 Evolve_And_Then
(Cond
,
5849 Build_Attribute_Reference
5850 (Duplicate_Subexpr_No_Checks
(Obj
),
5853 Build_Attribute_Reference
5854 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
5863 Right_Opnd
=> Make_Null
(Loc
)),
5864 Right_Opnd
=> Cond
);
5868 Analyze_And_Resolve
(N
, Restyp
);
5869 end Check_Subscripts
;
5871 -- These are the cases where constraint checks may be required,
5872 -- e.g. records with possible discriminants
5875 -- Expand the test into a series of discriminant comparisons.
5876 -- The expression that is built is the negation of the one that
5877 -- is used for checking discriminant constraints.
5879 Obj
:= Relocate_Node
(Left_Opnd
(N
));
5881 if Has_Discriminants
(Typ
) then
5882 Cond
:= Make_Op_Not
(Loc
,
5883 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
5886 Cond
:= Make_Or_Else
(Loc
,
5890 Right_Opnd
=> Make_Null
(Loc
)),
5891 Right_Opnd
=> Cond
);
5895 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
5899 Analyze_And_Resolve
(N
, Restyp
);
5902 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5903 -- expression of an anonymous access type. This can involve an
5904 -- accessibility test and a tagged type membership test in the
5905 -- case of tagged designated types.
5907 if Ada_Version
>= Ada_2012
5909 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
5912 Expr_Entity
: Entity_Id
:= Empty
;
5914 Param_Level
: Node_Id
;
5915 Type_Level
: Node_Id
;
5918 if Is_Entity_Name
(Lop
) then
5919 Expr_Entity
:= Param_Entity
(Lop
);
5921 if not Present
(Expr_Entity
) then
5922 Expr_Entity
:= Entity
(Lop
);
5926 -- If a conversion of the anonymous access value to the
5927 -- tested type would be illegal, then the result is False.
5929 if not Valid_Conversion
5930 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
5932 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5933 Analyze_And_Resolve
(N
, Restyp
);
5935 -- Apply an accessibility check if the access object has an
5936 -- associated access level and when the level of the type is
5937 -- less deep than the level of the access parameter. This
5938 -- only occur for access parameters and stand-alone objects
5939 -- of an anonymous access type.
5942 if Present
(Expr_Entity
)
5945 (Effective_Extra_Accessibility
(Expr_Entity
))
5946 and then UI_Gt
(Object_Access_Level
(Lop
),
5947 Type_Access_Level
(Rtyp
))
5951 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
5954 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
5956 -- Return True only if the accessibility level of the
5957 -- expression entity is not deeper than the level of
5958 -- the tested access type.
5962 Left_Opnd
=> Relocate_Node
(N
),
5963 Right_Opnd
=> Make_Op_Le
(Loc
,
5964 Left_Opnd
=> Param_Level
,
5965 Right_Opnd
=> Type_Level
)));
5967 Analyze_And_Resolve
(N
);
5970 -- If the designated type is tagged, do tagged membership
5973 -- *** NOTE: we have to check not null before doing the
5974 -- tagged membership test (but maybe that can be done
5975 -- inside Tagged_Membership?).
5977 if Is_Tagged_Type
(Typ
) then
5980 Left_Opnd
=> Relocate_Node
(N
),
5984 Right_Opnd
=> Make_Null
(Loc
))));
5986 -- No expansion will be performed when VM_Target, as
5987 -- the VM back-ends will handle the membership tests
5988 -- directly (tags are not explicitly represented in
5989 -- Java objects, so the normal tagged membership
5990 -- expansion is not what we want).
5992 if Tagged_Type_Expansion
then
5994 -- Note that we have to pass Original_Node, because
5995 -- the membership test might already have been
5996 -- rewritten by earlier parts of membership test.
5999 (Original_Node
(N
), SCIL_Node
, New_N
);
6001 -- Update decoration of relocated node referenced
6002 -- by the SCIL node.
6004 if Generate_SCIL
and then Present
(SCIL_Node
) then
6005 Set_SCIL_Node
(New_N
, SCIL_Node
);
6010 Left_Opnd
=> Relocate_Node
(N
),
6011 Right_Opnd
=> New_N
));
6013 Analyze_And_Resolve
(N
, Restyp
);
6022 -- At this point, we have done the processing required for the basic
6023 -- membership test, but not yet dealt with the predicate.
6027 -- If a predicate is present, then we do the predicate test, but we
6028 -- most certainly want to omit this if we are within the predicate
6029 -- function itself, since otherwise we have an infinite recursion.
6030 -- The check should also not be emitted when testing against a range
6031 -- (the check is only done when the right operand is a subtype; see
6032 -- RM12-4.5.2 (28.1/3-30/3)).
6035 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6039 and then Current_Scope
/= PFunc
6040 and then Nkind
(Rop
) /= N_Range
6044 Left_Opnd
=> Relocate_Node
(N
),
6045 Right_Opnd
=> Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True)));
6047 -- Analyze new expression, mark left operand as analyzed to
6048 -- avoid infinite recursion adding predicate calls. Similarly,
6049 -- suppress further range checks on the call.
6051 Set_Analyzed
(Left_Opnd
(N
));
6052 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6054 -- All done, skip attempt at compile time determination of result
6061 --------------------------------
6062 -- Expand_N_Indexed_Component --
6063 --------------------------------
6065 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6066 Loc
: constant Source_Ptr
:= Sloc
(N
);
6067 Typ
: constant Entity_Id
:= Etype
(N
);
6068 P
: constant Node_Id
:= Prefix
(N
);
6069 T
: constant Entity_Id
:= Etype
(P
);
6073 -- A special optimization, if we have an indexed component that is
6074 -- selecting from a slice, then we can eliminate the slice, since, for
6075 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6076 -- the range check required by the slice. The range check for the slice
6077 -- itself has already been generated. The range check for the
6078 -- subscripting operation is ensured by converting the subject to
6079 -- the subtype of the slice.
6081 -- This optimization not only generates better code, avoiding slice
6082 -- messing especially in the packed case, but more importantly bypasses
6083 -- some problems in handling this peculiar case, for example, the issue
6084 -- of dealing specially with object renamings.
6086 if Nkind
(P
) = N_Slice
then
6088 Make_Indexed_Component
(Loc
,
6089 Prefix
=> Prefix
(P
),
6090 Expressions
=> New_List
(
6092 (Etype
(First_Index
(Etype
(P
))),
6093 First
(Expressions
(N
))))));
6094 Analyze_And_Resolve
(N
, Typ
);
6098 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6099 -- function, then additional actuals must be passed.
6101 if Ada_Version
>= Ada_2005
6102 and then Is_Build_In_Place_Function_Call
(P
)
6104 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6107 -- If the prefix is an access type, then we unconditionally rewrite if
6108 -- as an explicit dereference. This simplifies processing for several
6109 -- cases, including packed array cases and certain cases in which checks
6110 -- must be generated. We used to try to do this only when it was
6111 -- necessary, but it cleans up the code to do it all the time.
6113 if Is_Access_Type
(T
) then
6114 Insert_Explicit_Dereference
(P
);
6115 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6116 Atp
:= Designated_Type
(T
);
6121 -- Generate index and validity checks
6123 Generate_Index_Checks
(N
);
6125 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6126 Apply_Subscript_Validity_Checks
(N
);
6129 -- If selecting from an array with atomic components, and atomic sync
6130 -- is not suppressed for this array type, set atomic sync flag.
6132 if (Has_Atomic_Components
(Atp
)
6133 and then not Atomic_Synchronization_Disabled
(Atp
))
6134 or else (Is_Atomic
(Typ
)
6135 and then not Atomic_Synchronization_Disabled
(Typ
))
6137 Activate_Atomic_Synchronization
(N
);
6140 -- All done for the non-packed case
6142 if not Is_Packed
(Etype
(Prefix
(N
))) then
6146 -- For packed arrays that are not bit-packed (i.e. the case of an array
6147 -- with one or more index types with a non-contiguous enumeration type),
6148 -- we can always use the normal packed element get circuit.
6150 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6151 Expand_Packed_Element_Reference
(N
);
6155 -- For a reference to a component of a bit packed array, we have to
6156 -- convert it to a reference to the corresponding Packed_Array_Type.
6157 -- We only want to do this for simple references, and not for:
6159 -- Left side of assignment, or prefix of left side of assignment, or
6160 -- prefix of the prefix, to handle packed arrays of packed arrays,
6161 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6163 -- Renaming objects in renaming associations
6164 -- This case is handled when a use of the renamed variable occurs
6166 -- Actual parameters for a procedure call
6167 -- This case is handled in Exp_Ch6.Expand_Actuals
6169 -- The second expression in a 'Read attribute reference
6171 -- The prefix of an address or bit or size attribute reference
6173 -- The following circuit detects these exceptions
6176 Child
: Node_Id
:= N
;
6177 Parnt
: Node_Id
:= Parent
(N
);
6181 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6184 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6185 N_Procedure_Call_Statement
)
6186 or else (Nkind
(Parnt
) = N_Parameter_Association
6188 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6192 elsif Nkind
(Parnt
) = N_Attribute_Reference
6193 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
6196 and then Prefix
(Parnt
) = Child
6200 elsif Nkind
(Parnt
) = N_Assignment_Statement
6201 and then Name
(Parnt
) = Child
6205 -- If the expression is an index of an indexed component, it must
6206 -- be expanded regardless of context.
6208 elsif Nkind
(Parnt
) = N_Indexed_Component
6209 and then Child
/= Prefix
(Parnt
)
6211 Expand_Packed_Element_Reference
(N
);
6214 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6215 and then Name
(Parent
(Parnt
)) = Parnt
6219 elsif Nkind
(Parnt
) = N_Attribute_Reference
6220 and then Attribute_Name
(Parnt
) = Name_Read
6221 and then Next
(First
(Expressions
(Parnt
))) = Child
6225 elsif Nkind_In
(Parnt
, N_Indexed_Component
, N_Selected_Component
)
6226 and then Prefix
(Parnt
) = Child
6231 Expand_Packed_Element_Reference
(N
);
6235 -- Keep looking up tree for unchecked expression, or if we are the
6236 -- prefix of a possible assignment left side.
6239 Parnt
:= Parent
(Child
);
6242 end Expand_N_Indexed_Component
;
6244 ---------------------
6245 -- Expand_N_Not_In --
6246 ---------------------
6248 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6249 -- can be done. This avoids needing to duplicate this expansion code.
6251 procedure Expand_N_Not_In
(N
: Node_Id
) is
6252 Loc
: constant Source_Ptr
:= Sloc
(N
);
6253 Typ
: constant Entity_Id
:= Etype
(N
);
6254 Cfs
: constant Boolean := Comes_From_Source
(N
);
6261 Left_Opnd
=> Left_Opnd
(N
),
6262 Right_Opnd
=> Right_Opnd
(N
))));
6264 -- If this is a set membership, preserve list of alternatives
6266 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6268 -- We want this to appear as coming from source if original does (see
6269 -- transformations in Expand_N_In).
6271 Set_Comes_From_Source
(N
, Cfs
);
6272 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6274 -- Now analyze transformed node
6276 Analyze_And_Resolve
(N
, Typ
);
6277 end Expand_N_Not_In
;
6283 -- The only replacement required is for the case of a null of a type that
6284 -- is an access to protected subprogram, or a subtype thereof. We represent
6285 -- such access values as a record, and so we must replace the occurrence of
6286 -- null by the equivalent record (with a null address and a null pointer in
6287 -- it), so that the backend creates the proper value.
6289 procedure Expand_N_Null
(N
: Node_Id
) is
6290 Loc
: constant Source_Ptr
:= Sloc
(N
);
6291 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6295 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6297 Make_Aggregate
(Loc
,
6298 Expressions
=> New_List
(
6299 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6303 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6305 -- For subsequent semantic analysis, the node must retain its type.
6306 -- Gigi in any case replaces this type by the corresponding record
6307 -- type before processing the node.
6313 when RE_Not_Available
=>
6317 ---------------------
6318 -- Expand_N_Op_Abs --
6319 ---------------------
6321 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6322 Loc
: constant Source_Ptr
:= Sloc
(N
);
6323 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6326 Unary_Op_Validity_Checks
(N
);
6328 -- Check for MINIMIZED/ELIMINATED overflow mode
6330 if Minimized_Eliminated_Overflow_Check
(N
) then
6331 Apply_Arithmetic_Overflow_Check
(N
);
6335 -- Deal with software overflow checking
6337 if not Backend_Overflow_Checks_On_Target
6338 and then Is_Signed_Integer_Type
(Etype
(N
))
6339 and then Do_Overflow_Check
(N
)
6341 -- The only case to worry about is when the argument is equal to the
6342 -- largest negative number, so what we do is to insert the check:
6344 -- [constraint_error when Expr = typ'Base'First]
6346 -- with the usual Duplicate_Subexpr use coding for expr
6349 Make_Raise_Constraint_Error
(Loc
,
6352 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6354 Make_Attribute_Reference
(Loc
,
6356 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6357 Attribute_Name
=> Name_First
)),
6358 Reason
=> CE_Overflow_Check_Failed
));
6361 -- Vax floating-point types case
6363 if Vax_Float
(Etype
(N
)) then
6364 Expand_Vax_Arith
(N
);
6366 end Expand_N_Op_Abs
;
6368 ---------------------
6369 -- Expand_N_Op_Add --
6370 ---------------------
6372 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6373 Typ
: constant Entity_Id
:= Etype
(N
);
6376 Binary_Op_Validity_Checks
(N
);
6378 -- Check for MINIMIZED/ELIMINATED overflow mode
6380 if Minimized_Eliminated_Overflow_Check
(N
) then
6381 Apply_Arithmetic_Overflow_Check
(N
);
6385 -- N + 0 = 0 + N = N for integer types
6387 if Is_Integer_Type
(Typ
) then
6388 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6389 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6391 Rewrite
(N
, Left_Opnd
(N
));
6394 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6395 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
6397 Rewrite
(N
, Right_Opnd
(N
));
6402 -- Arithmetic overflow checks for signed integer/fixed point types
6404 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
6405 Apply_Arithmetic_Overflow_Check
(N
);
6408 -- Vax floating-point types case
6410 elsif Vax_Float
(Typ
) then
6411 Expand_Vax_Arith
(N
);
6413 end Expand_N_Op_Add
;
6415 ---------------------
6416 -- Expand_N_Op_And --
6417 ---------------------
6419 procedure Expand_N_Op_And
(N
: Node_Id
) is
6420 Typ
: constant Entity_Id
:= Etype
(N
);
6423 Binary_Op_Validity_Checks
(N
);
6425 if Is_Array_Type
(Etype
(N
)) then
6426 Expand_Boolean_Operator
(N
);
6428 elsif Is_Boolean_Type
(Etype
(N
)) then
6429 Adjust_Condition
(Left_Opnd
(N
));
6430 Adjust_Condition
(Right_Opnd
(N
));
6431 Set_Etype
(N
, Standard_Boolean
);
6432 Adjust_Result_Type
(N
, Typ
);
6434 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
6435 Expand_Intrinsic_Call
(N
, Entity
(N
));
6438 end Expand_N_Op_And
;
6440 ------------------------
6441 -- Expand_N_Op_Concat --
6442 ------------------------
6444 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
6446 -- List of operands to be concatenated
6449 -- Node which is to be replaced by the result of concatenating the nodes
6450 -- in the list Opnds.
6453 -- Ensure validity of both operands
6455 Binary_Op_Validity_Checks
(N
);
6457 -- If we are the left operand of a concatenation higher up the tree,
6458 -- then do nothing for now, since we want to deal with a series of
6459 -- concatenations as a unit.
6461 if Nkind
(Parent
(N
)) = N_Op_Concat
6462 and then N
= Left_Opnd
(Parent
(N
))
6467 -- We get here with a concatenation whose left operand may be a
6468 -- concatenation itself with a consistent type. We need to process
6469 -- these concatenation operands from left to right, which means
6470 -- from the deepest node in the tree to the highest node.
6473 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
6474 Cnode
:= Left_Opnd
(Cnode
);
6477 -- Now Cnode is the deepest concatenation, and its parents are the
6478 -- concatenation nodes above, so now we process bottom up, doing the
6481 -- The outer loop runs more than once if more than one concatenation
6482 -- type is involved.
6485 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
6486 Set_Parent
(Opnds
, N
);
6488 -- The inner loop gathers concatenation operands
6490 Inner
: while Cnode
/= N
6491 and then Base_Type
(Etype
(Cnode
)) =
6492 Base_Type
(Etype
(Parent
(Cnode
)))
6494 Cnode
:= Parent
(Cnode
);
6495 Append
(Right_Opnd
(Cnode
), Opnds
);
6498 Expand_Concatenate
(Cnode
, Opnds
);
6500 exit Outer
when Cnode
= N
;
6501 Cnode
:= Parent
(Cnode
);
6503 end Expand_N_Op_Concat
;
6505 ------------------------
6506 -- Expand_N_Op_Divide --
6507 ------------------------
6509 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
6510 Loc
: constant Source_Ptr
:= Sloc
(N
);
6511 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
6512 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
6513 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
6514 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
6515 Typ
: Entity_Id
:= Etype
(N
);
6516 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
6518 Compile_Time_Known_Value
(Ropnd
);
6522 Binary_Op_Validity_Checks
(N
);
6524 -- Check for MINIMIZED/ELIMINATED overflow mode
6526 if Minimized_Eliminated_Overflow_Check
(N
) then
6527 Apply_Arithmetic_Overflow_Check
(N
);
6531 -- Otherwise proceed with expansion of division
6534 Rval
:= Expr_Value
(Ropnd
);
6537 -- N / 1 = N for integer types
6539 if Rknow
and then Rval
= Uint_1
then
6544 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6545 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6546 -- operand is an unsigned integer, as required for this to work.
6548 if Nkind
(Ropnd
) = N_Op_Expon
6549 and then Is_Power_Of_2_For_Shift
(Ropnd
)
6551 -- We cannot do this transformation in configurable run time mode if we
6552 -- have 64-bit integers and long shifts are not available.
6554 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
6557 Make_Op_Shift_Right
(Loc
,
6560 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
6561 Analyze_And_Resolve
(N
, Typ
);
6565 -- Do required fixup of universal fixed operation
6567 if Typ
= Universal_Fixed
then
6568 Fixup_Universal_Fixed_Operation
(N
);
6572 -- Divisions with fixed-point results
6574 if Is_Fixed_Point_Type
(Typ
) then
6576 -- No special processing if Treat_Fixed_As_Integer is set, since
6577 -- from a semantic point of view such operations are simply integer
6578 -- operations and will be treated that way.
6580 if not Treat_Fixed_As_Integer
(N
) then
6581 if Is_Integer_Type
(Rtyp
) then
6582 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
6584 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
6588 -- Other cases of division of fixed-point operands. Again we exclude the
6589 -- case where Treat_Fixed_As_Integer is set.
6591 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
6592 and then not Treat_Fixed_As_Integer
(N
)
6594 if Is_Integer_Type
(Typ
) then
6595 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
6597 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6598 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
6601 -- Mixed-mode operations can appear in a non-static universal context,
6602 -- in which case the integer argument must be converted explicitly.
6604 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
6606 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
6608 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
6610 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
6612 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
6614 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
6616 -- Non-fixed point cases, do integer zero divide and overflow checks
6618 elsif Is_Integer_Type
(Typ
) then
6619 Apply_Divide_Checks
(N
);
6621 -- Deal with Vax_Float
6623 elsif Vax_Float
(Typ
) then
6624 Expand_Vax_Arith
(N
);
6627 end Expand_N_Op_Divide
;
6629 --------------------
6630 -- Expand_N_Op_Eq --
6631 --------------------
6633 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
6634 Loc
: constant Source_Ptr
:= Sloc
(N
);
6635 Typ
: constant Entity_Id
:= Etype
(N
);
6636 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
6637 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
6638 Bodies
: constant List_Id
:= New_List
;
6639 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
6641 Typl
: Entity_Id
:= A_Typ
;
6642 Op_Name
: Entity_Id
;
6645 procedure Build_Equality_Call
(Eq
: Entity_Id
);
6646 -- If a constructed equality exists for the type or for its parent,
6647 -- build and analyze call, adding conversions if the operation is
6650 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
6651 -- Determines whether a type has a subcomponent of an unconstrained
6652 -- Unchecked_Union subtype. Typ is a record type.
6654 -------------------------
6655 -- Build_Equality_Call --
6656 -------------------------
6658 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
6659 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
6660 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
6661 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
6664 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
6665 and then not Is_Class_Wide_Type
(A_Typ
)
6667 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
6668 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
6671 -- If we have an Unchecked_Union, we need to add the inferred
6672 -- discriminant values as actuals in the function call. At this
6673 -- point, the expansion has determined that both operands have
6674 -- inferable discriminants.
6676 if Is_Unchecked_Union
(Op_Type
) then
6678 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
6679 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
6681 Lhs_Discr_Vals
: Elist_Id
;
6682 -- List of inferred discriminant values for left operand.
6684 Rhs_Discr_Vals
: Elist_Id
;
6685 -- List of inferred discriminant values for right operand.
6690 Lhs_Discr_Vals
:= New_Elmt_List
;
6691 Rhs_Discr_Vals
:= New_Elmt_List
;
6693 -- Per-object constrained selected components require special
6694 -- attention. If the enclosing scope of the component is an
6695 -- Unchecked_Union, we cannot reference its discriminants
6696 -- directly. This is why we use the extra parameters of the
6697 -- equality function of the enclosing Unchecked_Union.
6699 -- type UU_Type (Discr : Integer := 0) is
6702 -- pragma Unchecked_Union (UU_Type);
6704 -- 1. Unchecked_Union enclosing record:
6706 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6708 -- Comp : UU_Type (Discr);
6710 -- end Enclosing_UU_Type;
6711 -- pragma Unchecked_Union (Enclosing_UU_Type);
6713 -- Obj1 : Enclosing_UU_Type;
6714 -- Obj2 : Enclosing_UU_Type (1);
6716 -- [. . .] Obj1 = Obj2 [. . .]
6720 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6722 -- A and B are the formal parameters of the equality function
6723 -- of Enclosing_UU_Type. The function always has two extra
6724 -- formals to capture the inferred discriminant values for
6725 -- each discriminant of the type.
6727 -- 2. Non-Unchecked_Union enclosing record:
6730 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6733 -- Comp : UU_Type (Discr);
6735 -- end Enclosing_Non_UU_Type;
6737 -- Obj1 : Enclosing_Non_UU_Type;
6738 -- Obj2 : Enclosing_Non_UU_Type (1);
6740 -- ... Obj1 = Obj2 ...
6744 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6745 -- obj1.discr, obj2.discr)) then
6747 -- In this case we can directly reference the discriminants of
6748 -- the enclosing record.
6750 -- Process left operand of equality
6752 if Nkind
(Lhs
) = N_Selected_Component
6754 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
6756 -- If enclosing record is an Unchecked_Union, use formals
6757 -- corresponding to each discriminant. The name of the
6758 -- formal is that of the discriminant, with added suffix,
6759 -- see Exp_Ch3.Build_Record_Equality for details.
6761 if Is_Unchecked_Union
6762 (Scope
(Entity
(Selector_Name
(Lhs
))))
6766 (Scope
(Entity
(Selector_Name
(Lhs
))));
6767 while Present
(Discr
) loop
6769 Make_Identifier
(Loc
,
6770 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
6771 To
=> Lhs_Discr_Vals
);
6772 Next_Discriminant
(Discr
);
6775 -- If enclosing record is of a non-Unchecked_Union type, it
6776 -- is possible to reference its discriminants directly.
6779 Discr
:= First_Discriminant
(Lhs_Type
);
6780 while Present
(Discr
) loop
6782 Make_Selected_Component
(Loc
,
6783 Prefix
=> Prefix
(Lhs
),
6786 (Get_Discriminant_Value
(Discr
,
6788 Stored_Constraint
(Lhs_Type
)))),
6789 To
=> Lhs_Discr_Vals
);
6790 Next_Discriminant
(Discr
);
6794 -- Otherwise operand is on object with a constrained type.
6795 -- Infer the discriminant values from the constraint.
6799 Discr
:= First_Discriminant
(Lhs_Type
);
6800 while Present
(Discr
) loop
6803 (Get_Discriminant_Value
(Discr
,
6805 Stored_Constraint
(Lhs_Type
))),
6806 To
=> Lhs_Discr_Vals
);
6807 Next_Discriminant
(Discr
);
6811 -- Similar processing for right operand of equality
6813 if Nkind
(Rhs
) = N_Selected_Component
6815 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
6817 if Is_Unchecked_Union
6818 (Scope
(Entity
(Selector_Name
(Rhs
))))
6822 (Scope
(Entity
(Selector_Name
(Rhs
))));
6823 while Present
(Discr
) loop
6825 Make_Identifier
(Loc
,
6826 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
6827 To
=> Rhs_Discr_Vals
);
6828 Next_Discriminant
(Discr
);
6832 Discr
:= First_Discriminant
(Rhs_Type
);
6833 while Present
(Discr
) loop
6835 Make_Selected_Component
(Loc
,
6836 Prefix
=> Prefix
(Rhs
),
6838 New_Copy
(Get_Discriminant_Value
6841 Stored_Constraint
(Rhs_Type
)))),
6842 To
=> Rhs_Discr_Vals
);
6843 Next_Discriminant
(Discr
);
6848 Discr
:= First_Discriminant
(Rhs_Type
);
6849 while Present
(Discr
) loop
6851 New_Copy
(Get_Discriminant_Value
6854 Stored_Constraint
(Rhs_Type
))),
6855 To
=> Rhs_Discr_Vals
);
6856 Next_Discriminant
(Discr
);
6860 -- Now merge the list of discriminant values so that values
6861 -- of corresponding discriminants are adjacent.
6869 Params
:= New_List
(L_Exp
, R_Exp
);
6870 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
6871 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
6872 while Present
(L_Elmt
) loop
6873 Append_To
(Params
, Node
(L_Elmt
));
6874 Append_To
(Params
, Node
(R_Elmt
));
6880 Make_Function_Call
(Loc
,
6881 Name
=> New_Occurrence_Of
(Eq
, Loc
),
6882 Parameter_Associations
=> Params
));
6886 -- Normal case, not an unchecked union
6890 Make_Function_Call
(Loc
,
6891 Name
=> New_Occurrence_Of
(Eq
, Loc
),
6892 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
6895 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6896 end Build_Equality_Call
;
6898 ------------------------------------
6899 -- Has_Unconstrained_UU_Component --
6900 ------------------------------------
6902 function Has_Unconstrained_UU_Component
6903 (Typ
: Node_Id
) return Boolean
6905 Tdef
: constant Node_Id
:=
6906 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
6910 function Component_Is_Unconstrained_UU
6911 (Comp
: Node_Id
) return Boolean;
6912 -- Determines whether the subtype of the component is an
6913 -- unconstrained Unchecked_Union.
6915 function Variant_Is_Unconstrained_UU
6916 (Variant
: Node_Id
) return Boolean;
6917 -- Determines whether a component of the variant has an unconstrained
6918 -- Unchecked_Union subtype.
6920 -----------------------------------
6921 -- Component_Is_Unconstrained_UU --
6922 -----------------------------------
6924 function Component_Is_Unconstrained_UU
6925 (Comp
: Node_Id
) return Boolean
6928 if Nkind
(Comp
) /= N_Component_Declaration
then
6933 Sindic
: constant Node_Id
:=
6934 Subtype_Indication
(Component_Definition
(Comp
));
6937 -- Unconstrained nominal type. In the case of a constraint
6938 -- present, the node kind would have been N_Subtype_Indication.
6940 if Nkind
(Sindic
) = N_Identifier
then
6941 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
6946 end Component_Is_Unconstrained_UU
;
6948 ---------------------------------
6949 -- Variant_Is_Unconstrained_UU --
6950 ---------------------------------
6952 function Variant_Is_Unconstrained_UU
6953 (Variant
: Node_Id
) return Boolean
6955 Clist
: constant Node_Id
:= Component_List
(Variant
);
6958 if Is_Empty_List
(Component_Items
(Clist
)) then
6962 -- We only need to test one component
6965 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
6968 while Present
(Comp
) loop
6969 if Component_Is_Unconstrained_UU
(Comp
) then
6977 -- None of the components withing the variant were of
6978 -- unconstrained Unchecked_Union type.
6981 end Variant_Is_Unconstrained_UU
;
6983 -- Start of processing for Has_Unconstrained_UU_Component
6986 if Null_Present
(Tdef
) then
6990 Clist
:= Component_List
(Tdef
);
6991 Vpart
:= Variant_Part
(Clist
);
6993 -- Inspect available components
6995 if Present
(Component_Items
(Clist
)) then
6997 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7000 while Present
(Comp
) loop
7002 -- One component is sufficient
7004 if Component_Is_Unconstrained_UU
(Comp
) then
7013 -- Inspect available components withing variants
7015 if Present
(Vpart
) then
7017 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7020 while Present
(Variant
) loop
7022 -- One component within a variant is sufficient
7024 if Variant_Is_Unconstrained_UU
(Variant
) then
7033 -- Neither the available components, nor the components inside the
7034 -- variant parts were of an unconstrained Unchecked_Union subtype.
7037 end Has_Unconstrained_UU_Component
;
7039 -- Start of processing for Expand_N_Op_Eq
7042 Binary_Op_Validity_Checks
(N
);
7044 -- Deal with private types
7046 if Ekind
(Typl
) = E_Private_Type
then
7047 Typl
:= Underlying_Type
(Typl
);
7048 elsif Ekind
(Typl
) = E_Private_Subtype
then
7049 Typl
:= Underlying_Type
(Base_Type
(Typl
));
7054 -- It may happen in error situations that the underlying type is not
7055 -- set. The error will be detected later, here we just defend the
7062 Typl
:= Base_Type
(Typl
);
7064 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7065 -- means we no longer have a comparison operation, we are all done.
7067 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7069 if Nkind
(N
) /= N_Op_Eq
then
7073 -- Boolean types (requiring handling of non-standard case)
7075 if Is_Boolean_Type
(Typl
) then
7076 Adjust_Condition
(Left_Opnd
(N
));
7077 Adjust_Condition
(Right_Opnd
(N
));
7078 Set_Etype
(N
, Standard_Boolean
);
7079 Adjust_Result_Type
(N
, Typ
);
7083 elsif Is_Array_Type
(Typl
) then
7085 -- If we are doing full validity checking, and it is possible for the
7086 -- array elements to be invalid then expand out array comparisons to
7087 -- make sure that we check the array elements.
7089 if Validity_Check_Operands
7090 and then not Is_Known_Valid
(Component_Type
(Typl
))
7093 Save_Force_Validity_Checks
: constant Boolean :=
7094 Force_Validity_Checks
;
7096 Force_Validity_Checks
:= True;
7098 Expand_Array_Equality
7100 Relocate_Node
(Lhs
),
7101 Relocate_Node
(Rhs
),
7104 Insert_Actions
(N
, Bodies
);
7105 Analyze_And_Resolve
(N
, Standard_Boolean
);
7106 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7109 -- Packed case where both operands are known aligned
7111 elsif Is_Bit_Packed_Array
(Typl
)
7112 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7113 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7115 Expand_Packed_Eq
(N
);
7117 -- Where the component type is elementary we can use a block bit
7118 -- comparison (if supported on the target) exception in the case
7119 -- of floating-point (negative zero issues require element by
7120 -- element comparison), and atomic types (where we must be sure
7121 -- to load elements independently) and possibly unaligned arrays.
7123 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7124 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7125 and then not Is_Atomic
(Component_Type
(Typl
))
7126 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7127 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7128 and then Support_Composite_Compare_On_Target
7132 -- For composite and floating-point cases, expand equality loop to
7133 -- make sure of using proper comparisons for tagged types, and
7134 -- correctly handling the floating-point case.
7138 Expand_Array_Equality
7140 Relocate_Node
(Lhs
),
7141 Relocate_Node
(Rhs
),
7144 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7145 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7150 elsif Is_Record_Type
(Typl
) then
7152 -- For tagged types, use the primitive "="
7154 if Is_Tagged_Type
(Typl
) then
7156 -- No need to do anything else compiling under restriction
7157 -- No_Dispatching_Calls. During the semantic analysis we
7158 -- already notified such violation.
7160 if Restriction_Active
(No_Dispatching_Calls
) then
7164 -- If this is derived from an untagged private type completed with
7165 -- a tagged type, it does not have a full view, so we use the
7166 -- primitive operations of the private type. This check should no
7167 -- longer be necessary when these types get their full views???
7169 if Is_Private_Type
(A_Typ
)
7170 and then not Is_Tagged_Type
(A_Typ
)
7171 and then Is_Derived_Type
(A_Typ
)
7172 and then No
(Full_View
(A_Typ
))
7174 -- Search for equality operation, checking that the operands
7175 -- have the same type. Note that we must find a matching entry,
7176 -- or something is very wrong.
7178 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7180 while Present
(Prim
) loop
7181 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7182 and then Etype
(First_Formal
(Node
(Prim
))) =
7183 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7185 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7190 pragma Assert
(Present
(Prim
));
7191 Op_Name
:= Node
(Prim
);
7193 -- Find the type's predefined equality or an overriding
7194 -- user- defined equality. The reason for not simply calling
7195 -- Find_Prim_Op here is that there may be a user-defined
7196 -- overloaded equality op that precedes the equality that we want,
7197 -- so we have to explicitly search (e.g., there could be an
7198 -- equality with two different parameter types).
7201 if Is_Class_Wide_Type
(Typl
) then
7202 Typl
:= Root_Type
(Typl
);
7205 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7206 while Present
(Prim
) loop
7207 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7208 and then Etype
(First_Formal
(Node
(Prim
))) =
7209 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7211 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7216 pragma Assert
(Present
(Prim
));
7217 Op_Name
:= Node
(Prim
);
7220 Build_Equality_Call
(Op_Name
);
7222 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7223 -- predefined equality operator for a type which has a subcomponent
7224 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7226 elsif Has_Unconstrained_UU_Component
(Typl
) then
7228 Make_Raise_Program_Error
(Loc
,
7229 Reason
=> PE_Unchecked_Union_Restriction
));
7231 -- Prevent Gigi from generating incorrect code by rewriting the
7232 -- equality as a standard False. (is this documented somewhere???)
7235 New_Occurrence_Of
(Standard_False
, Loc
));
7237 elsif Is_Unchecked_Union
(Typl
) then
7239 -- If we can infer the discriminants of the operands, we make a
7240 -- call to the TSS equality function.
7242 if Has_Inferable_Discriminants
(Lhs
)
7244 Has_Inferable_Discriminants
(Rhs
)
7247 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7250 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7251 -- the predefined equality operator for an Unchecked_Union type
7252 -- if either of the operands lack inferable discriminants.
7255 Make_Raise_Program_Error
(Loc
,
7256 Reason
=> PE_Unchecked_Union_Restriction
));
7258 -- Prevent Gigi from generating incorrect code by rewriting
7259 -- the equality as a standard False (documented where???).
7262 New_Occurrence_Of
(Standard_False
, Loc
));
7266 -- If a type support function is present (for complex cases), use it
7268 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7270 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7272 -- When comparing two Bounded_Strings, use the primitive equality of
7273 -- the root Super_String type.
7275 elsif Is_Bounded_String
(Typl
) then
7277 First_Elmt
(Collect_Primitive_Operations
(Root_Type
(Typl
)));
7279 while Present
(Prim
) loop
7280 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7281 and then Etype
(First_Formal
(Node
(Prim
))) =
7282 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7283 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7288 -- A Super_String type should always have a primitive equality
7290 pragma Assert
(Present
(Prim
));
7291 Build_Equality_Call
(Node
(Prim
));
7293 -- Otherwise expand the component by component equality. Note that
7294 -- we never use block-bit comparisons for records, because of the
7295 -- problems with gaps. The backend will often be able to recombine
7296 -- the separate comparisons that we generate here.
7299 Remove_Side_Effects
(Lhs
);
7300 Remove_Side_Effects
(Rhs
);
7302 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7304 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7305 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7309 -- Test if result is known at compile time
7311 Rewrite_Comparison
(N
);
7313 -- If we still have comparison for Vax_Float, process it
7315 if Vax_Float
(Typl
) and then Nkind
(N
) in N_Op_Compare
then
7316 Expand_Vax_Comparison
(N
);
7320 Optimize_Length_Comparison
(N
);
7323 -----------------------
7324 -- Expand_N_Op_Expon --
7325 -----------------------
7327 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
7328 Loc
: constant Source_Ptr
:= Sloc
(N
);
7329 Typ
: constant Entity_Id
:= Etype
(N
);
7330 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
7331 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
7332 Bastyp
: constant Node_Id
:= Etype
(Base
);
7333 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
7334 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
7335 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
7344 Binary_Op_Validity_Checks
(N
);
7346 -- CodePeer wants to see the unexpanded N_Op_Expon node
7348 if CodePeer_Mode
then
7352 -- If either operand is of a private type, then we have the use of an
7353 -- intrinsic operator, and we get rid of the privateness, by using root
7354 -- types of underlying types for the actual operation. Otherwise the
7355 -- private types will cause trouble if we expand multiplications or
7356 -- shifts etc. We also do this transformation if the result type is
7357 -- different from the base type.
7359 if Is_Private_Type
(Etype
(Base
))
7360 or else Is_Private_Type
(Typ
)
7361 or else Is_Private_Type
(Exptyp
)
7362 or else Rtyp
/= Root_Type
(Bastyp
)
7365 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
7366 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
7369 Unchecked_Convert_To
(Typ
,
7371 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
7372 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
7373 Analyze_And_Resolve
(N
, Typ
);
7378 -- Check for MINIMIZED/ELIMINATED overflow mode
7380 if Minimized_Eliminated_Overflow_Check
(N
) then
7381 Apply_Arithmetic_Overflow_Check
(N
);
7385 -- Test for case of known right argument where we can replace the
7386 -- exponentiation by an equivalent expression using multiplication.
7388 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7389 -- configurable run-time mode, we may not have the exponentiation
7390 -- routine available, and we don't want the legality of the program
7391 -- to depend on how clever the compiler is in knowing values.
7393 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
7394 Expv
:= Expr_Value
(Exp
);
7396 -- We only fold small non-negative exponents. You might think we
7397 -- could fold small negative exponents for the real case, but we
7398 -- can't because we are required to raise Constraint_Error for
7399 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7400 -- See ACVC test C4A012B.
7402 if Expv
>= 0 and then Expv
<= 4 then
7404 -- X ** 0 = 1 (or 1.0)
7408 -- Call Remove_Side_Effects to ensure that any side effects
7409 -- in the ignored left operand (in particular function calls
7410 -- to user defined functions) are properly executed.
7412 Remove_Side_Effects
(Base
);
7414 if Ekind
(Typ
) in Integer_Kind
then
7415 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
7417 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
7429 Make_Op_Multiply
(Loc
,
7430 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7431 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7433 -- X ** 3 = X * X * X
7437 Make_Op_Multiply
(Loc
,
7439 Make_Op_Multiply
(Loc
,
7440 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7441 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
7442 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7447 -- En : constant base'type := base * base;
7452 pragma Assert
(Expv
= 4);
7453 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
7456 Make_Expression_With_Actions
(Loc
,
7457 Actions
=> New_List
(
7458 Make_Object_Declaration
(Loc
,
7459 Defining_Identifier
=> Temp
,
7460 Constant_Present
=> True,
7461 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7463 Make_Op_Multiply
(Loc
,
7465 Duplicate_Subexpr
(Base
),
7467 Duplicate_Subexpr_No_Checks
(Base
)))),
7470 Make_Op_Multiply
(Loc
,
7471 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
7472 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
)));
7476 Analyze_And_Resolve
(N
, Typ
);
7481 -- Case of (2 ** expression) appearing as an argument of an integer
7482 -- multiplication, or as the right argument of a division of a non-
7483 -- negative integer. In such cases we leave the node untouched, setting
7484 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
7485 -- of the higher level node converts it into a shift.
7487 -- Another case is 2 ** N in any other context. We simply convert
7488 -- this to 1 * 2 ** N, and then the above transformation applies.
7490 -- Note: this transformation is not applicable for a modular type with
7491 -- a non-binary modulus in the multiplication case, since we get a wrong
7492 -- result if the shift causes an overflow before the modular reduction.
7494 -- Note: we used to check that Exptyp was an unsigned type. But that is
7495 -- an unnecessary check, since if Exp is negative, we have a run-time
7496 -- error that is either caught (so we get the right result) or we have
7497 -- suppressed the check, in which case the code is erroneous anyway.
7499 if Nkind
(Base
) = N_Integer_Literal
7500 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
7501 and then Expr_Value
(Base
) = Uint_2
7502 and then Is_Integer_Type
(Root_Type
(Exptyp
))
7503 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
7506 -- First the multiply and divide cases
7508 if Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
) then
7510 P
: constant Node_Id
:= Parent
(N
);
7511 L
: constant Node_Id
:= Left_Opnd
(P
);
7512 R
: constant Node_Id
:= Right_Opnd
(P
);
7515 if (Nkind
(P
) = N_Op_Multiply
7516 and then not Non_Binary_Modulus
(Typ
)
7518 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
7520 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
7521 and then not Do_Overflow_Check
(P
))
7523 (Nkind
(P
) = N_Op_Divide
7524 and then Is_Integer_Type
(Etype
(L
))
7525 and then Is_Unsigned_Type
(Etype
(L
))
7527 and then not Do_Overflow_Check
(P
))
7529 Set_Is_Power_Of_2_For_Shift
(N
);
7534 -- Now the other cases
7536 elsif not Non_Binary_Modulus
(Typ
) then
7538 Make_Op_Multiply
(Loc
,
7539 Left_Opnd
=> Make_Integer_Literal
(Loc
, 1),
7540 Right_Opnd
=> Relocate_Node
(N
)));
7541 Analyze_And_Resolve
(N
, Typ
);
7546 -- Fall through if exponentiation must be done using a runtime routine
7548 -- First deal with modular case
7550 if Is_Modular_Integer_Type
(Rtyp
) then
7552 -- Non-binary case, we call the special exponentiation routine for
7553 -- the non-binary case, converting the argument to Long_Long_Integer
7554 -- and passing the modulus value. Then the result is converted back
7555 -- to the base type.
7557 if Non_Binary_Modulus
(Rtyp
) then
7560 Make_Function_Call
(Loc
,
7561 Name
=> New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
7562 Parameter_Associations
=> New_List
(
7563 Convert_To
(Standard_Integer
, Base
),
7564 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
7567 -- Binary case, in this case, we call one of two routines, either the
7568 -- unsigned integer case, or the unsigned long long integer case,
7569 -- with a final "and" operation to do the required mod.
7572 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
7573 Ent
:= RTE
(RE_Exp_Unsigned
);
7575 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
7582 Make_Function_Call
(Loc
,
7583 Name
=> New_Occurrence_Of
(Ent
, Loc
),
7584 Parameter_Associations
=> New_List
(
7585 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
7588 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
7592 -- Common exit point for modular type case
7594 Analyze_And_Resolve
(N
, Typ
);
7597 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7598 -- It is not worth having routines for Short_[Short_]Integer, since for
7599 -- most machines it would not help, and it would generate more code that
7600 -- might need certification when a certified run time is required.
7602 -- In the integer cases, we have two routines, one for when overflow
7603 -- checks are required, and one when they are not required, since there
7604 -- is a real gain in omitting checks on many machines.
7606 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
7607 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
7609 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
7610 or else Rtyp
= Universal_Integer
7612 Etyp
:= Standard_Long_Long_Integer
;
7614 -- Overflow checking is the only choice on the AAMP target, where
7615 -- arithmetic instructions check overflow automatically, so only
7616 -- one version of the exponentiation unit is needed.
7618 if Ovflo
or AAMP_On_Target
then
7619 Rent
:= RE_Exp_Long_Long_Integer
;
7621 Rent
:= RE_Exn_Long_Long_Integer
;
7624 elsif Is_Signed_Integer_Type
(Rtyp
) then
7625 Etyp
:= Standard_Integer
;
7627 -- Overflow checking is the only choice on the AAMP target, where
7628 -- arithmetic instructions check overflow automatically, so only
7629 -- one version of the exponentiation unit is needed.
7631 if Ovflo
or AAMP_On_Target
then
7632 Rent
:= RE_Exp_Integer
;
7634 Rent
:= RE_Exn_Integer
;
7637 -- Floating-point cases, always done using Long_Long_Float. We do not
7638 -- need separate routines for the overflow case here, since in the case
7639 -- of floating-point, we generate infinities anyway as a rule (either
7640 -- that or we automatically trap overflow), and if there is an infinity
7641 -- generated and a range check is required, the check will fail anyway.
7644 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
7645 Etyp
:= Standard_Long_Long_Float
;
7646 Rent
:= RE_Exn_Long_Long_Float
;
7649 -- Common processing for integer cases and floating-point cases.
7650 -- If we are in the right type, we can call runtime routine directly
7653 and then Rtyp
/= Universal_Integer
7654 and then Rtyp
/= Universal_Real
7657 Make_Function_Call
(Loc
,
7658 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
7659 Parameter_Associations
=> New_List
(Base
, Exp
)));
7661 -- Otherwise we have to introduce conversions (conversions are also
7662 -- required in the universal cases, since the runtime routine is
7663 -- typed using one of the standard types).
7668 Make_Function_Call
(Loc
,
7669 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
7670 Parameter_Associations
=> New_List
(
7671 Convert_To
(Etyp
, Base
),
7675 Analyze_And_Resolve
(N
, Typ
);
7679 when RE_Not_Available
=>
7681 end Expand_N_Op_Expon
;
7683 --------------------
7684 -- Expand_N_Op_Ge --
7685 --------------------
7687 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
7688 Typ
: constant Entity_Id
:= Etype
(N
);
7689 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7690 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7691 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7694 Binary_Op_Validity_Checks
(N
);
7696 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7697 -- means we no longer have a comparison operation, we are all done.
7699 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7701 if Nkind
(N
) /= N_Op_Ge
then
7707 if Is_Array_Type
(Typ1
) then
7708 Expand_Array_Comparison
(N
);
7712 -- Deal with boolean operands
7714 if Is_Boolean_Type
(Typ1
) then
7715 Adjust_Condition
(Op1
);
7716 Adjust_Condition
(Op2
);
7717 Set_Etype
(N
, Standard_Boolean
);
7718 Adjust_Result_Type
(N
, Typ
);
7721 Rewrite_Comparison
(N
);
7723 -- If we still have comparison, and Vax_Float type, process it
7725 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7726 Expand_Vax_Comparison
(N
);
7730 Optimize_Length_Comparison
(N
);
7733 --------------------
7734 -- Expand_N_Op_Gt --
7735 --------------------
7737 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
7738 Typ
: constant Entity_Id
:= Etype
(N
);
7739 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7740 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7741 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7744 Binary_Op_Validity_Checks
(N
);
7746 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7747 -- means we no longer have a comparison operation, we are all done.
7749 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7751 if Nkind
(N
) /= N_Op_Gt
then
7755 -- Deal with array type operands
7757 if Is_Array_Type
(Typ1
) then
7758 Expand_Array_Comparison
(N
);
7762 -- Deal with boolean type operands
7764 if Is_Boolean_Type
(Typ1
) then
7765 Adjust_Condition
(Op1
);
7766 Adjust_Condition
(Op2
);
7767 Set_Etype
(N
, Standard_Boolean
);
7768 Adjust_Result_Type
(N
, Typ
);
7771 Rewrite_Comparison
(N
);
7773 -- If we still have comparison, and Vax_Float type, process it
7775 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7776 Expand_Vax_Comparison
(N
);
7780 Optimize_Length_Comparison
(N
);
7783 --------------------
7784 -- Expand_N_Op_Le --
7785 --------------------
7787 procedure Expand_N_Op_Le
(N
: Node_Id
) is
7788 Typ
: constant Entity_Id
:= Etype
(N
);
7789 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7790 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7791 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7794 Binary_Op_Validity_Checks
(N
);
7796 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7797 -- means we no longer have a comparison operation, we are all done.
7799 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7801 if Nkind
(N
) /= N_Op_Le
then
7805 -- Deal with array type operands
7807 if Is_Array_Type
(Typ1
) then
7808 Expand_Array_Comparison
(N
);
7812 -- Deal with Boolean type operands
7814 if Is_Boolean_Type
(Typ1
) then
7815 Adjust_Condition
(Op1
);
7816 Adjust_Condition
(Op2
);
7817 Set_Etype
(N
, Standard_Boolean
);
7818 Adjust_Result_Type
(N
, Typ
);
7821 Rewrite_Comparison
(N
);
7823 -- If we still have comparison, and Vax_Float type, process it
7825 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7826 Expand_Vax_Comparison
(N
);
7830 Optimize_Length_Comparison
(N
);
7833 --------------------
7834 -- Expand_N_Op_Lt --
7835 --------------------
7837 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
7838 Typ
: constant Entity_Id
:= Etype
(N
);
7839 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7840 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7841 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7844 Binary_Op_Validity_Checks
(N
);
7846 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7847 -- means we no longer have a comparison operation, we are all done.
7849 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7851 if Nkind
(N
) /= N_Op_Lt
then
7855 -- Deal with array type operands
7857 if Is_Array_Type
(Typ1
) then
7858 Expand_Array_Comparison
(N
);
7862 -- Deal with Boolean type operands
7864 if Is_Boolean_Type
(Typ1
) then
7865 Adjust_Condition
(Op1
);
7866 Adjust_Condition
(Op2
);
7867 Set_Etype
(N
, Standard_Boolean
);
7868 Adjust_Result_Type
(N
, Typ
);
7871 Rewrite_Comparison
(N
);
7873 -- If we still have comparison, and Vax_Float type, process it
7875 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7876 Expand_Vax_Comparison
(N
);
7880 Optimize_Length_Comparison
(N
);
7883 -----------------------
7884 -- Expand_N_Op_Minus --
7885 -----------------------
7887 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
7888 Loc
: constant Source_Ptr
:= Sloc
(N
);
7889 Typ
: constant Entity_Id
:= Etype
(N
);
7892 Unary_Op_Validity_Checks
(N
);
7894 -- Check for MINIMIZED/ELIMINATED overflow mode
7896 if Minimized_Eliminated_Overflow_Check
(N
) then
7897 Apply_Arithmetic_Overflow_Check
(N
);
7901 if not Backend_Overflow_Checks_On_Target
7902 and then Is_Signed_Integer_Type
(Etype
(N
))
7903 and then Do_Overflow_Check
(N
)
7905 -- Software overflow checking expands -expr into (0 - expr)
7908 Make_Op_Subtract
(Loc
,
7909 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
7910 Right_Opnd
=> Right_Opnd
(N
)));
7912 Analyze_And_Resolve
(N
, Typ
);
7914 -- Vax floating-point types case
7916 elsif Vax_Float
(Etype
(N
)) then
7917 Expand_Vax_Arith
(N
);
7919 end Expand_N_Op_Minus
;
7921 ---------------------
7922 -- Expand_N_Op_Mod --
7923 ---------------------
7925 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
7926 Loc
: constant Source_Ptr
:= Sloc
(N
);
7927 Typ
: constant Entity_Id
:= Etype
(N
);
7928 DDC
: constant Boolean := Do_Division_Check
(N
);
7941 pragma Warnings
(Off
, Lhi
);
7944 Binary_Op_Validity_Checks
(N
);
7946 -- Check for MINIMIZED/ELIMINATED overflow mode
7948 if Minimized_Eliminated_Overflow_Check
(N
) then
7949 Apply_Arithmetic_Overflow_Check
(N
);
7953 if Is_Integer_Type
(Etype
(N
)) then
7954 Apply_Divide_Checks
(N
);
7956 -- All done if we don't have a MOD any more, which can happen as a
7957 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
7959 if Nkind
(N
) /= N_Op_Mod
then
7964 -- Proceed with expansion of mod operator
7966 Left
:= Left_Opnd
(N
);
7967 Right
:= Right_Opnd
(N
);
7969 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
7970 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
7972 -- Convert mod to rem if operands are both known to be non-negative, or
7973 -- both known to be non-positive (these are the cases in which rem and
7974 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
7975 -- likely that this will improve the quality of code, (the operation now
7976 -- corresponds to the hardware remainder), and it does not seem likely
7977 -- that it could be harmful. It also avoids some cases of the elaborate
7978 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
7981 and then ((Llo
>= 0 and then Rlo
>= 0)
7983 (Lhi
<= 0 and then Rhi
<= 0))
7986 Make_Op_Rem
(Sloc
(N
),
7987 Left_Opnd
=> Left_Opnd
(N
),
7988 Right_Opnd
=> Right_Opnd
(N
)));
7990 -- Instead of reanalyzing the node we do the analysis manually. This
7991 -- avoids anomalies when the replacement is done in an instance and
7992 -- is epsilon more efficient.
7994 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
7996 Set_Do_Division_Check
(N
, DDC
);
7997 Expand_N_Op_Rem
(N
);
8001 -- Otherwise, normal mod processing
8004 -- Apply optimization x mod 1 = 0. We don't really need that with
8005 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
8006 -- certainly harmless.
8008 if Is_Integer_Type
(Etype
(N
))
8009 and then Compile_Time_Known_Value
(Right
)
8010 and then Expr_Value
(Right
) = Uint_1
8012 -- Call Remove_Side_Effects to ensure that any side effects in
8013 -- the ignored left operand (in particular function calls to
8014 -- user defined functions) are properly executed.
8016 Remove_Side_Effects
(Left
);
8018 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8019 Analyze_And_Resolve
(N
, Typ
);
8023 -- If we still have a mod operator and we are in Modify_Tree_For_C
8024 -- mode, and we have a signed integer type, then here is where we do
8025 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8026 -- for the special handling of the annoying case of largest negative
8027 -- number mod minus one.
8029 if Nkind
(N
) = N_Op_Mod
8030 and then Is_Signed_Integer_Type
(Typ
)
8031 and then Modify_Tree_For_C
8033 -- In the general case, we expand A mod B as
8035 -- Tnn : constant typ := A rem B;
8037 -- (if (A >= 0) = (B >= 0) then Tnn
8038 -- elsif Tnn = 0 then 0
8041 -- The comparison can be written simply as A >= 0 if we know that
8042 -- B >= 0 which is a very common case.
8044 -- An important optimization is when B is known at compile time
8045 -- to be 2**K for some constant. In this case we can simply AND
8046 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8047 -- and that works for both the positive and negative cases.
8050 P2
: constant Nat
:= Power_Of_Two
(Right
);
8055 Unchecked_Convert_To
(Typ
,
8058 Unchecked_Convert_To
8059 (Corresponding_Unsigned_Type
(Typ
), Left
),
8061 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
8062 Analyze_And_Resolve
(N
, Typ
);
8067 -- Here for the full rewrite
8070 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
8076 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
8077 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
8079 if not LOK
or else Rlo
< 0 then
8085 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
8086 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
8090 Make_Object_Declaration
(Loc
,
8091 Defining_Identifier
=> Tnn
,
8092 Constant_Present
=> True,
8093 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8097 Right_Opnd
=> Right
)));
8100 Make_If_Expression
(Loc
,
8101 Expressions
=> New_List
(
8103 New_Occurrence_Of
(Tnn
, Loc
),
8104 Make_If_Expression
(Loc
,
8106 Expressions
=> New_List
(
8108 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8109 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
8110 Make_Integer_Literal
(Loc
, 0),
8112 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8114 Duplicate_Subexpr_No_Checks
(Right
)))))));
8116 Analyze_And_Resolve
(N
, Typ
);
8121 -- Deal with annoying case of largest negative number mod minus one.
8122 -- Gigi may not handle this case correctly, because on some targets,
8123 -- the mod value is computed using a divide instruction which gives
8124 -- an overflow trap for this case.
8126 -- It would be a bit more efficient to figure out which targets
8127 -- this is really needed for, but in practice it is reasonable
8128 -- to do the following special check in all cases, since it means
8129 -- we get a clearer message, and also the overhead is minimal given
8130 -- that division is expensive in any case.
8132 -- In fact the check is quite easy, if the right operand is -1, then
8133 -- the mod value is always 0, and we can just ignore the left operand
8134 -- completely in this case.
8136 -- This only applies if we still have a mod operator. Skip if we
8137 -- have already rewritten this (e.g. in the case of eliminated
8138 -- overflow checks which have driven us into bignum mode).
8140 if Nkind
(N
) = N_Op_Mod
then
8142 -- The operand type may be private (e.g. in the expansion of an
8143 -- intrinsic operation) so we must use the underlying type to get
8144 -- the bounds, and convert the literals explicitly.
8148 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
8150 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
8151 and then ((not LOK
) or else (Llo
= LLB
))
8154 Make_If_Expression
(Loc
,
8155 Expressions
=> New_List
(
8157 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8159 Unchecked_Convert_To
(Typ
,
8160 Make_Integer_Literal
(Loc
, -1))),
8161 Unchecked_Convert_To
(Typ
,
8162 Make_Integer_Literal
(Loc
, Uint_0
)),
8163 Relocate_Node
(N
))));
8165 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8166 Analyze_And_Resolve
(N
, Typ
);
8170 end Expand_N_Op_Mod
;
8172 --------------------------
8173 -- Expand_N_Op_Multiply --
8174 --------------------------
8176 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
8177 Loc
: constant Source_Ptr
:= Sloc
(N
);
8178 Lop
: constant Node_Id
:= Left_Opnd
(N
);
8179 Rop
: constant Node_Id
:= Right_Opnd
(N
);
8181 Lp2
: constant Boolean :=
8182 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
8183 Rp2
: constant Boolean :=
8184 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
8186 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
8187 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
8188 Typ
: Entity_Id
:= Etype
(N
);
8191 Binary_Op_Validity_Checks
(N
);
8193 -- Check for MINIMIZED/ELIMINATED overflow mode
8195 if Minimized_Eliminated_Overflow_Check
(N
) then
8196 Apply_Arithmetic_Overflow_Check
(N
);
8200 -- Special optimizations for integer types
8202 if Is_Integer_Type
(Typ
) then
8204 -- N * 0 = 0 for integer types
8206 if Compile_Time_Known_Value
(Rop
)
8207 and then Expr_Value
(Rop
) = Uint_0
8209 -- Call Remove_Side_Effects to ensure that any side effects in
8210 -- the ignored left operand (in particular function calls to
8211 -- user defined functions) are properly executed.
8213 Remove_Side_Effects
(Lop
);
8215 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8216 Analyze_And_Resolve
(N
, Typ
);
8220 -- Similar handling for 0 * N = 0
8222 if Compile_Time_Known_Value
(Lop
)
8223 and then Expr_Value
(Lop
) = Uint_0
8225 Remove_Side_Effects
(Rop
);
8226 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8227 Analyze_And_Resolve
(N
, Typ
);
8231 -- N * 1 = 1 * N = N for integer types
8233 -- This optimisation is not done if we are going to
8234 -- rewrite the product 1 * 2 ** N to a shift.
8236 if Compile_Time_Known_Value
(Rop
)
8237 and then Expr_Value
(Rop
) = Uint_1
8243 elsif Compile_Time_Known_Value
(Lop
)
8244 and then Expr_Value
(Lop
) = Uint_1
8252 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8253 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8254 -- operand is an integer, as required for this to work.
8259 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8263 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
8266 Left_Opnd
=> Right_Opnd
(Lop
),
8267 Right_Opnd
=> Right_Opnd
(Rop
))));
8268 Analyze_And_Resolve
(N
, Typ
);
8272 -- If the result is modular, perform the reduction of the result
8275 if Is_Modular_Integer_Type
(Typ
)
8276 and then not Non_Binary_Modulus
(Typ
)
8281 Make_Op_Shift_Left
(Loc
,
8284 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
8286 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8290 Make_Op_Shift_Left
(Loc
,
8293 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
8296 Analyze_And_Resolve
(N
, Typ
);
8300 -- Same processing for the operands the other way round
8303 if Is_Modular_Integer_Type
(Typ
)
8304 and then not Non_Binary_Modulus
(Typ
)
8309 Make_Op_Shift_Left
(Loc
,
8312 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
8314 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8318 Make_Op_Shift_Left
(Loc
,
8321 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
8324 Analyze_And_Resolve
(N
, Typ
);
8328 -- Do required fixup of universal fixed operation
8330 if Typ
= Universal_Fixed
then
8331 Fixup_Universal_Fixed_Operation
(N
);
8335 -- Multiplications with fixed-point results
8337 if Is_Fixed_Point_Type
(Typ
) then
8339 -- No special processing if Treat_Fixed_As_Integer is set, since from
8340 -- a semantic point of view such operations are simply integer
8341 -- operations and will be treated that way.
8343 if not Treat_Fixed_As_Integer
(N
) then
8345 -- Case of fixed * integer => fixed
8347 if Is_Integer_Type
(Rtyp
) then
8348 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
8350 -- Case of integer * fixed => fixed
8352 elsif Is_Integer_Type
(Ltyp
) then
8353 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
8355 -- Case of fixed * fixed => fixed
8358 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
8362 -- Other cases of multiplication of fixed-point operands. Again we
8363 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8365 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
8366 and then not Treat_Fixed_As_Integer
(N
)
8368 if Is_Integer_Type
(Typ
) then
8369 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
8371 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8372 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
8375 -- Mixed-mode operations can appear in a non-static universal context,
8376 -- in which case the integer argument must be converted explicitly.
8378 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
8379 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
8380 Analyze_And_Resolve
(Rop
, Universal_Real
);
8382 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
8383 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
8384 Analyze_And_Resolve
(Lop
, Universal_Real
);
8386 -- Non-fixed point cases, check software overflow checking required
8388 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
8389 Apply_Arithmetic_Overflow_Check
(N
);
8391 -- Deal with VAX float case
8393 elsif Vax_Float
(Typ
) then
8394 Expand_Vax_Arith
(N
);
8397 end Expand_N_Op_Multiply
;
8399 --------------------
8400 -- Expand_N_Op_Ne --
8401 --------------------
8403 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
8404 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
8407 -- Case of elementary type with standard operator
8409 if Is_Elementary_Type
(Typ
)
8410 and then Sloc
(Entity
(N
)) = Standard_Location
8412 Binary_Op_Validity_Checks
(N
);
8414 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8415 -- means we no longer have a /= operation, we are all done.
8417 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8419 if Nkind
(N
) /= N_Op_Ne
then
8423 -- Boolean types (requiring handling of non-standard case)
8425 if Is_Boolean_Type
(Typ
) then
8426 Adjust_Condition
(Left_Opnd
(N
));
8427 Adjust_Condition
(Right_Opnd
(N
));
8428 Set_Etype
(N
, Standard_Boolean
);
8429 Adjust_Result_Type
(N
, Typ
);
8432 Rewrite_Comparison
(N
);
8434 -- If we still have comparison for Vax_Float, process it
8436 if Vax_Float
(Typ
) and then Nkind
(N
) in N_Op_Compare
then
8437 Expand_Vax_Comparison
(N
);
8441 -- For all cases other than elementary types, we rewrite node as the
8442 -- negation of an equality operation, and reanalyze. The equality to be
8443 -- used is defined in the same scope and has the same signature. This
8444 -- signature must be set explicitly since in an instance it may not have
8445 -- the same visibility as in the generic unit. This avoids duplicating
8446 -- or factoring the complex code for record/array equality tests etc.
8450 Loc
: constant Source_Ptr
:= Sloc
(N
);
8452 Ne
: constant Entity_Id
:= Entity
(N
);
8455 Binary_Op_Validity_Checks
(N
);
8461 Left_Opnd
=> Left_Opnd
(N
),
8462 Right_Opnd
=> Right_Opnd
(N
)));
8463 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
8465 if Scope
(Ne
) /= Standard_Standard
then
8466 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
8469 -- For navigation purposes, we want to treat the inequality as an
8470 -- implicit reference to the corresponding equality. Preserve the
8471 -- Comes_From_ source flag to generate proper Xref entries.
8473 Preserve_Comes_From_Source
(Neg
, N
);
8474 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
8476 Analyze_And_Resolve
(N
, Standard_Boolean
);
8480 Optimize_Length_Comparison
(N
);
8483 ---------------------
8484 -- Expand_N_Op_Not --
8485 ---------------------
8487 -- If the argument is other than a Boolean array type, there is no special
8488 -- expansion required, except for VMS operations on signed integers.
8490 -- For the packed case, we call the special routine in Exp_Pakd, except
8491 -- that if the component size is greater than one, we use the standard
8492 -- routine generating a gruesome loop (it is so peculiar to have packed
8493 -- arrays with non-standard Boolean representations anyway, so it does not
8494 -- matter that we do not handle this case efficiently).
8496 -- For the unpacked case (and for the special packed case where we have non
8497 -- standard Booleans, as discussed above), we generate and insert into the
8498 -- tree the following function definition:
8500 -- function Nnnn (A : arr) is
8503 -- for J in a'range loop
8504 -- B (J) := not A (J);
8509 -- Here arr is the actual subtype of the parameter (and hence always
8510 -- constrained). Then we replace the not with a call to this function.
8512 procedure Expand_N_Op_Not
(N
: Node_Id
) is
8513 Loc
: constant Source_Ptr
:= Sloc
(N
);
8514 Typ
: constant Entity_Id
:= Etype
(N
);
8523 Func_Name
: Entity_Id
;
8524 Loop_Statement
: Node_Id
;
8527 Unary_Op_Validity_Checks
(N
);
8529 -- For boolean operand, deal with non-standard booleans
8531 if Is_Boolean_Type
(Typ
) then
8532 Adjust_Condition
(Right_Opnd
(N
));
8533 Set_Etype
(N
, Standard_Boolean
);
8534 Adjust_Result_Type
(N
, Typ
);
8538 -- For the VMS "not" on signed integer types, use conversion to and from
8539 -- a predefined modular type.
8541 if Is_VMS_Operator
(Entity
(N
)) then
8547 -- If this is a derived type, retrieve original VMS type so that
8548 -- the proper sized type is used for intermediate values.
8550 if Is_Derived_Type
(Typ
) then
8551 Rtyp
:= First_Subtype
(Etype
(Typ
));
8556 -- The proper unsigned type must have a size compatible with the
8557 -- operand, to prevent misalignment.
8559 if RM_Size
(Rtyp
) <= 8 then
8560 Utyp
:= RTE
(RE_Unsigned_8
);
8562 elsif RM_Size
(Rtyp
) <= 16 then
8563 Utyp
:= RTE
(RE_Unsigned_16
);
8565 elsif RM_Size
(Rtyp
) = RM_Size
(Standard_Unsigned
) then
8566 Utyp
:= RTE
(RE_Unsigned_32
);
8569 Utyp
:= RTE
(RE_Long_Long_Unsigned
);
8573 Unchecked_Convert_To
(Typ
,
8575 Unchecked_Convert_To
(Utyp
, Right_Opnd
(N
)))));
8576 Analyze_And_Resolve
(N
, Typ
);
8581 -- Only array types need any other processing
8583 if not Is_Array_Type
(Typ
) then
8587 -- Case of array operand. If bit packed with a component size of 1,
8588 -- handle it in Exp_Pakd if the operand is known to be aligned.
8590 if Is_Bit_Packed_Array
(Typ
)
8591 and then Component_Size
(Typ
) = 1
8592 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
8594 Expand_Packed_Not
(N
);
8598 -- Case of array operand which is not bit-packed. If the context is
8599 -- a safe assignment, call in-place operation, If context is a larger
8600 -- boolean expression in the context of a safe assignment, expansion is
8601 -- done by enclosing operation.
8603 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
8604 Convert_To_Actual_Subtype
(Opnd
);
8605 Arr
:= Etype
(Opnd
);
8606 Ensure_Defined
(Arr
, N
);
8607 Silly_Boolean_Array_Not_Test
(N
, Arr
);
8609 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
8610 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
8611 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8614 -- Special case the negation of a binary operation
8616 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
8617 and then Safe_In_Place_Array_Op
8618 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
8620 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8624 elsif Nkind
(Parent
(N
)) in N_Binary_Op
8625 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
8628 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
8629 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
8630 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
8633 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
8635 -- (not A) op (not B) can be reduced to a single call
8637 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
8640 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
8643 -- A xor (not B) can also be special-cased
8645 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
8652 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
8653 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8654 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
8657 Make_Indexed_Component
(Loc
,
8658 Prefix
=> New_Occurrence_Of
(A
, Loc
),
8659 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8662 Make_Indexed_Component
(Loc
,
8663 Prefix
=> New_Occurrence_Of
(B
, Loc
),
8664 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8667 Make_Implicit_Loop_Statement
(N
,
8668 Identifier
=> Empty
,
8671 Make_Iteration_Scheme
(Loc
,
8672 Loop_Parameter_Specification
=>
8673 Make_Loop_Parameter_Specification
(Loc
,
8674 Defining_Identifier
=> J
,
8675 Discrete_Subtype_Definition
=>
8676 Make_Attribute_Reference
(Loc
,
8677 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
8678 Attribute_Name
=> Name_Range
))),
8680 Statements
=> New_List
(
8681 Make_Assignment_Statement
(Loc
,
8683 Expression
=> Make_Op_Not
(Loc
, A_J
))));
8685 Func_Name
:= Make_Temporary
(Loc
, 'N');
8686 Set_Is_Inlined
(Func_Name
);
8689 Make_Subprogram_Body
(Loc
,
8691 Make_Function_Specification
(Loc
,
8692 Defining_Unit_Name
=> Func_Name
,
8693 Parameter_Specifications
=> New_List
(
8694 Make_Parameter_Specification
(Loc
,
8695 Defining_Identifier
=> A
,
8696 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
8697 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8699 Declarations
=> New_List
(
8700 Make_Object_Declaration
(Loc
,
8701 Defining_Identifier
=> B
,
8702 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
8704 Handled_Statement_Sequence
=>
8705 Make_Handled_Sequence_Of_Statements
(Loc
,
8706 Statements
=> New_List
(
8708 Make_Simple_Return_Statement
(Loc
,
8709 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
8712 Make_Function_Call
(Loc
,
8713 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
8714 Parameter_Associations
=> New_List
(Opnd
)));
8716 Analyze_And_Resolve
(N
, Typ
);
8717 end Expand_N_Op_Not
;
8719 --------------------
8720 -- Expand_N_Op_Or --
8721 --------------------
8723 procedure Expand_N_Op_Or
(N
: Node_Id
) is
8724 Typ
: constant Entity_Id
:= Etype
(N
);
8727 Binary_Op_Validity_Checks
(N
);
8729 if Is_Array_Type
(Etype
(N
)) then
8730 Expand_Boolean_Operator
(N
);
8732 elsif Is_Boolean_Type
(Etype
(N
)) then
8733 Adjust_Condition
(Left_Opnd
(N
));
8734 Adjust_Condition
(Right_Opnd
(N
));
8735 Set_Etype
(N
, Standard_Boolean
);
8736 Adjust_Result_Type
(N
, Typ
);
8738 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8739 Expand_Intrinsic_Call
(N
, Entity
(N
));
8744 ----------------------
8745 -- Expand_N_Op_Plus --
8746 ----------------------
8748 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
8750 Unary_Op_Validity_Checks
(N
);
8752 -- Check for MINIMIZED/ELIMINATED overflow mode
8754 if Minimized_Eliminated_Overflow_Check
(N
) then
8755 Apply_Arithmetic_Overflow_Check
(N
);
8758 end Expand_N_Op_Plus
;
8760 ---------------------
8761 -- Expand_N_Op_Rem --
8762 ---------------------
8764 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
8765 Loc
: constant Source_Ptr
:= Sloc
(N
);
8766 Typ
: constant Entity_Id
:= Etype
(N
);
8777 -- Set if corresponding operand can be negative
8779 pragma Unreferenced
(Hi
);
8782 Binary_Op_Validity_Checks
(N
);
8784 -- Check for MINIMIZED/ELIMINATED overflow mode
8786 if Minimized_Eliminated_Overflow_Check
(N
) then
8787 Apply_Arithmetic_Overflow_Check
(N
);
8791 if Is_Integer_Type
(Etype
(N
)) then
8792 Apply_Divide_Checks
(N
);
8794 -- All done if we don't have a REM any more, which can happen as a
8795 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8797 if Nkind
(N
) /= N_Op_Rem
then
8802 -- Proceed with expansion of REM
8804 Left
:= Left_Opnd
(N
);
8805 Right
:= Right_Opnd
(N
);
8807 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
8808 -- but it is useful with other back ends (e.g. AAMP), and is certainly
8811 if Is_Integer_Type
(Etype
(N
))
8812 and then Compile_Time_Known_Value
(Right
)
8813 and then Expr_Value
(Right
) = Uint_1
8815 -- Call Remove_Side_Effects to ensure that any side effects in the
8816 -- ignored left operand (in particular function calls to user defined
8817 -- functions) are properly executed.
8819 Remove_Side_Effects
(Left
);
8821 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8822 Analyze_And_Resolve
(N
, Typ
);
8826 -- Deal with annoying case of largest negative number remainder minus
8827 -- one. Gigi may not handle this case correctly, because on some
8828 -- targets, the mod value is computed using a divide instruction
8829 -- which gives an overflow trap for this case.
8831 -- It would be a bit more efficient to figure out which targets this
8832 -- is really needed for, but in practice it is reasonable to do the
8833 -- following special check in all cases, since it means we get a clearer
8834 -- message, and also the overhead is minimal given that division is
8835 -- expensive in any case.
8837 -- In fact the check is quite easy, if the right operand is -1, then
8838 -- the remainder is always 0, and we can just ignore the left operand
8839 -- completely in this case.
8841 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8842 Lneg
:= (not OK
) or else Lo
< 0;
8844 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8845 Rneg
:= (not OK
) or else Lo
< 0;
8847 -- We won't mess with trying to find out if the left operand can really
8848 -- be the largest negative number (that's a pain in the case of private
8849 -- types and this is really marginal). We will just assume that we need
8850 -- the test if the left operand can be negative at all.
8852 if Lneg
and Rneg
then
8854 Make_If_Expression
(Loc
,
8855 Expressions
=> New_List
(
8857 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8859 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
8861 Unchecked_Convert_To
(Typ
,
8862 Make_Integer_Literal
(Loc
, Uint_0
)),
8864 Relocate_Node
(N
))));
8866 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8867 Analyze_And_Resolve
(N
, Typ
);
8869 end Expand_N_Op_Rem
;
8871 -----------------------------
8872 -- Expand_N_Op_Rotate_Left --
8873 -----------------------------
8875 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
8877 Binary_Op_Validity_Checks
(N
);
8879 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
8880 -- so we rewrite in terms of logical shifts
8882 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
8884 -- where Bits is the shift count mod Esize (the mod operation here
8885 -- deals with ludicrous large shift counts, which are apparently OK).
8887 -- What about non-binary modulus ???
8890 Loc
: constant Source_Ptr
:= Sloc
(N
);
8891 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
8892 Typ
: constant Entity_Id
:= Etype
(N
);
8895 if Modify_Tree_For_C
then
8896 Rewrite
(Right_Opnd
(N
),
8898 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
8899 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
8901 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
8906 Make_Op_Shift_Left
(Loc
,
8907 Left_Opnd
=> Left_Opnd
(N
),
8908 Right_Opnd
=> Right_Opnd
(N
)),
8911 Make_Op_Shift_Right
(Loc
,
8912 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
8914 Make_Op_Subtract
(Loc
,
8915 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
8917 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
8919 Analyze_And_Resolve
(N
, Typ
);
8922 end Expand_N_Op_Rotate_Left
;
8924 ------------------------------
8925 -- Expand_N_Op_Rotate_Right --
8926 ------------------------------
8928 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
8930 Binary_Op_Validity_Checks
(N
);
8932 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
8933 -- so we rewrite in terms of logical shifts
8935 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
8937 -- where Bits is the shift count mod Esize (the mod operation here
8938 -- deals with ludicrous large shift counts, which are apparently OK).
8940 -- What about non-binary modulus ???
8943 Loc
: constant Source_Ptr
:= Sloc
(N
);
8944 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
8945 Typ
: constant Entity_Id
:= Etype
(N
);
8948 Rewrite
(Right_Opnd
(N
),
8950 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
8951 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
8953 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
8955 if Modify_Tree_For_C
then
8959 Make_Op_Shift_Right
(Loc
,
8960 Left_Opnd
=> Left_Opnd
(N
),
8961 Right_Opnd
=> Right_Opnd
(N
)),
8964 Make_Op_Shift_Left
(Loc
,
8965 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
8967 Make_Op_Subtract
(Loc
,
8968 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
8970 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
8972 Analyze_And_Resolve
(N
, Typ
);
8975 end Expand_N_Op_Rotate_Right
;
8977 ----------------------------
8978 -- Expand_N_Op_Shift_Left --
8979 ----------------------------
8981 -- Note: nothing in this routine depends on left as opposed to right shifts
8982 -- so we share the routine for expanding shift right operations.
8984 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
8986 Binary_Op_Validity_Checks
(N
);
8988 -- If we are in Modify_Tree_For_C mode, then ensure that the right
8989 -- operand is not greater than the word size (since that would not
8990 -- be defined properly by the corresponding C shift operator).
8992 if Modify_Tree_For_C
then
8994 Right
: constant Node_Id
:= Right_Opnd
(N
);
8995 Loc
: constant Source_Ptr
:= Sloc
(Right
);
8996 Typ
: constant Entity_Id
:= Etype
(N
);
8997 Siz
: constant Uint
:= Esize
(Typ
);
9004 if Compile_Time_Known_Value
(Right
) then
9005 if Expr_Value
(Right
) >= Siz
then
9006 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9007 Analyze_And_Resolve
(N
, Typ
);
9010 -- Not compile time known, find range
9013 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9015 -- Nothing to do if known to be OK range, otherwise expand
9017 if not OK
or else Hi
>= Siz
then
9019 -- Prevent recursion on copy of shift node
9021 Orig
:= Relocate_Node
(N
);
9022 Set_Analyzed
(Orig
);
9024 -- Now do the rewrite
9027 Make_If_Expression
(Loc
,
9028 Expressions
=> New_List
(
9030 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
9031 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
9032 Make_Integer_Literal
(Loc
, 0),
9034 Analyze_And_Resolve
(N
, Typ
);
9039 end Expand_N_Op_Shift_Left
;
9041 -----------------------------
9042 -- Expand_N_Op_Shift_Right --
9043 -----------------------------
9045 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
9047 -- Share shift left circuit
9049 Expand_N_Op_Shift_Left
(N
);
9050 end Expand_N_Op_Shift_Right
;
9052 ----------------------------------------
9053 -- Expand_N_Op_Shift_Right_Arithmetic --
9054 ----------------------------------------
9056 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
9058 Binary_Op_Validity_Checks
(N
);
9060 -- If we are in Modify_Tree_For_C mode, there is no shift right
9061 -- arithmetic in C, so we rewrite in terms of logical shifts.
9063 -- Shift_Right (Num, Bits) or
9065 -- then not (Shift_Right (Mask, bits))
9068 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9070 -- Note: in almost all C compilers it would work to just shift a
9071 -- signed integer right, but it's undefined and we cannot rely on it.
9073 -- Note: the above works fine for shift counts greater than or equal
9074 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9075 -- generates all 1'bits.
9077 -- What about non-binary modulus ???
9080 Loc
: constant Source_Ptr
:= Sloc
(N
);
9081 Typ
: constant Entity_Id
:= Etype
(N
);
9082 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
9083 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
9084 Left
: constant Node_Id
:= Left_Opnd
(N
);
9085 Right
: constant Node_Id
:= Right_Opnd
(N
);
9089 if Modify_Tree_For_C
then
9091 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9092 -- compile time as a single constant.
9094 if Compile_Time_Known_Value
(Right
) then
9096 Val
: constant Uint
:= Expr_Value
(Right
);
9099 if Val
>= Esize
(Typ
) then
9100 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
9104 Make_Integer_Literal
(Loc
,
9105 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
9113 Make_Op_Shift_Right
(Loc
,
9114 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
9115 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
9118 -- Now do the rewrite
9123 Make_Op_Shift_Right
(Loc
,
9125 Right_Opnd
=> Right
),
9127 Make_If_Expression
(Loc
,
9128 Expressions
=> New_List
(
9130 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9131 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
9133 Make_Integer_Literal
(Loc
, 0)))));
9134 Analyze_And_Resolve
(N
, Typ
);
9137 end Expand_N_Op_Shift_Right_Arithmetic
;
9139 --------------------------
9140 -- Expand_N_Op_Subtract --
9141 --------------------------
9143 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
9144 Typ
: constant Entity_Id
:= Etype
(N
);
9147 Binary_Op_Validity_Checks
(N
);
9149 -- Check for MINIMIZED/ELIMINATED overflow mode
9151 if Minimized_Eliminated_Overflow_Check
(N
) then
9152 Apply_Arithmetic_Overflow_Check
(N
);
9156 -- N - 0 = N for integer types
9158 if Is_Integer_Type
(Typ
)
9159 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
9160 and then Expr_Value
(Right_Opnd
(N
)) = 0
9162 Rewrite
(N
, Left_Opnd
(N
));
9166 -- Arithmetic overflow checks for signed integer/fixed point types
9168 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
9169 Apply_Arithmetic_Overflow_Check
(N
);
9171 -- VAX floating-point types case
9173 elsif Vax_Float
(Typ
) then
9174 Expand_Vax_Arith
(N
);
9176 end Expand_N_Op_Subtract
;
9178 ---------------------
9179 -- Expand_N_Op_Xor --
9180 ---------------------
9182 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
9183 Typ
: constant Entity_Id
:= Etype
(N
);
9186 Binary_Op_Validity_Checks
(N
);
9188 if Is_Array_Type
(Etype
(N
)) then
9189 Expand_Boolean_Operator
(N
);
9191 elsif Is_Boolean_Type
(Etype
(N
)) then
9192 Adjust_Condition
(Left_Opnd
(N
));
9193 Adjust_Condition
(Right_Opnd
(N
));
9194 Set_Etype
(N
, Standard_Boolean
);
9195 Adjust_Result_Type
(N
, Typ
);
9197 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9198 Expand_Intrinsic_Call
(N
, Entity
(N
));
9201 end Expand_N_Op_Xor
;
9203 ----------------------
9204 -- Expand_N_Or_Else --
9205 ----------------------
9207 procedure Expand_N_Or_Else
(N
: Node_Id
)
9208 renames Expand_Short_Circuit_Operator
;
9210 -----------------------------------
9211 -- Expand_N_Qualified_Expression --
9212 -----------------------------------
9214 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
9215 Operand
: constant Node_Id
:= Expression
(N
);
9216 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
9219 -- Do validity check if validity checking operands
9221 if Validity_Checks_On
and Validity_Check_Operands
then
9222 Ensure_Valid
(Operand
);
9225 -- Apply possible constraint check
9227 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
9229 if Do_Range_Check
(Operand
) then
9230 Set_Do_Range_Check
(Operand
, False);
9231 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
9233 end Expand_N_Qualified_Expression
;
9235 ------------------------------------
9236 -- Expand_N_Quantified_Expression --
9237 ------------------------------------
9241 -- for all X in range => Cond
9246 -- for X in range loop
9253 -- Similarly, an existentially quantified expression:
9255 -- for some X in range => Cond
9260 -- for X in range loop
9267 -- In both cases, the iteration may be over a container in which case it is
9268 -- given by an iterator specification, not a loop parameter specification.
9270 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
9271 Actions
: constant List_Id
:= New_List
;
9272 For_All
: constant Boolean := All_Present
(N
);
9273 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
9274 Loc
: constant Source_Ptr
:= Sloc
(N
);
9275 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
9282 -- Create the declaration of the flag which tracks the status of the
9283 -- quantified expression. Generate:
9285 -- Flag : Boolean := (True | False);
9287 Flag
:= Make_Temporary
(Loc
, 'T', N
);
9290 Make_Object_Declaration
(Loc
,
9291 Defining_Identifier
=> Flag
,
9292 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
9294 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
9296 -- Construct the circuitry which tracks the status of the quantified
9297 -- expression. Generate:
9299 -- if [not] Cond then
9300 -- Flag := (False | True);
9304 Cond
:= Relocate_Node
(Condition
(N
));
9307 Cond
:= Make_Op_Not
(Loc
, Cond
);
9311 Make_Implicit_If_Statement
(N
,
9313 Then_Statements
=> New_List
(
9314 Make_Assignment_Statement
(Loc
,
9315 Name
=> New_Occurrence_Of
(Flag
, Loc
),
9317 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
9318 Make_Exit_Statement
(Loc
))));
9320 -- Build the loop equivalent of the quantified expression
9322 if Present
(Iter_Spec
) then
9324 Make_Iteration_Scheme
(Loc
,
9325 Iterator_Specification
=> Iter_Spec
);
9328 Make_Iteration_Scheme
(Loc
,
9329 Loop_Parameter_Specification
=> Loop_Spec
);
9333 Make_Loop_Statement
(Loc
,
9334 Iteration_Scheme
=> Scheme
,
9335 Statements
=> Stmts
,
9336 End_Label
=> Empty
));
9338 -- Transform the quantified expression
9341 Make_Expression_With_Actions
(Loc
,
9342 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
9343 Actions
=> Actions
));
9344 Analyze_And_Resolve
(N
, Standard_Boolean
);
9345 end Expand_N_Quantified_Expression
;
9347 ---------------------------------
9348 -- Expand_N_Selected_Component --
9349 ---------------------------------
9351 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
9352 Loc
: constant Source_Ptr
:= Sloc
(N
);
9353 Par
: constant Node_Id
:= Parent
(N
);
9354 P
: constant Node_Id
:= Prefix
(N
);
9355 S
: constant Node_Id
:= Selector_Name
(N
);
9356 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
9362 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
9363 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9364 -- unless the context of an assignment can provide size information.
9365 -- Don't we have a general routine that does this???
9367 function Is_Subtype_Declaration
return Boolean;
9368 -- The replacement of a discriminant reference by its value is required
9369 -- if this is part of the initialization of an temporary generated by a
9370 -- change of representation. This shows up as the construction of a
9371 -- discriminant constraint for a subtype declared at the same point as
9372 -- the entity in the prefix of the selected component. We recognize this
9373 -- case when the context of the reference is:
9374 -- subtype ST is T(Obj.D);
9375 -- where the entity for Obj comes from source, and ST has the same sloc.
9377 -----------------------
9378 -- In_Left_Hand_Side --
9379 -----------------------
9381 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
9383 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
9384 and then Comp
= Name
(Parent
(Comp
)))
9385 or else (Present
(Parent
(Comp
))
9386 and then Nkind
(Parent
(Comp
)) in N_Subexpr
9387 and then In_Left_Hand_Side
(Parent
(Comp
)));
9388 end In_Left_Hand_Side
;
9390 -----------------------------
9391 -- Is_Subtype_Declaration --
9392 -----------------------------
9394 function Is_Subtype_Declaration
return Boolean is
9395 Par
: constant Node_Id
:= Parent
(N
);
9398 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
9399 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
9400 and then Comes_From_Source
(Entity
(Prefix
(N
)))
9401 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
9402 end Is_Subtype_Declaration
;
9404 -- Start of processing for Expand_N_Selected_Component
9407 -- Insert explicit dereference if required
9409 if Is_Access_Type
(Ptyp
) then
9411 -- First set prefix type to proper access type, in case it currently
9412 -- has a private (non-access) view of this type.
9414 Set_Etype
(P
, Ptyp
);
9416 Insert_Explicit_Dereference
(P
);
9417 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
9419 if Ekind
(Etype
(P
)) = E_Private_Subtype
9420 and then Is_For_Access_Subtype
(Etype
(P
))
9422 Set_Etype
(P
, Base_Type
(Etype
(P
)));
9428 -- Deal with discriminant check required
9430 if Do_Discriminant_Check
(N
) then
9431 if Present
(Discriminant_Checking_Func
9432 (Original_Record_Component
(Entity
(S
))))
9434 -- Present the discriminant checking function to the backend, so
9435 -- that it can inline the call to the function.
9438 (Discriminant_Checking_Func
9439 (Original_Record_Component
(Entity
(S
))));
9441 -- Now reset the flag and generate the call
9443 Set_Do_Discriminant_Check
(N
, False);
9444 Generate_Discriminant_Check
(N
);
9446 -- In the case of Unchecked_Union, no discriminant checking is
9447 -- actually performed.
9450 Set_Do_Discriminant_Check
(N
, False);
9454 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9455 -- function, then additional actuals must be passed.
9457 if Ada_Version
>= Ada_2005
9458 and then Is_Build_In_Place_Function_Call
(P
)
9460 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
9463 -- Gigi cannot handle unchecked conversions that are the prefix of a
9464 -- selected component with discriminants. This must be checked during
9465 -- expansion, because during analysis the type of the selector is not
9466 -- known at the point the prefix is analyzed. If the conversion is the
9467 -- target of an assignment, then we cannot force the evaluation.
9469 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
9470 and then Has_Discriminants
(Etype
(N
))
9471 and then not In_Left_Hand_Side
(N
)
9473 Force_Evaluation
(Prefix
(N
));
9476 -- Remaining processing applies only if selector is a discriminant
9478 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
9480 -- If the selector is a discriminant of a constrained record type,
9481 -- we may be able to rewrite the expression with the actual value
9482 -- of the discriminant, a useful optimization in some cases.
9484 if Is_Record_Type
(Ptyp
)
9485 and then Has_Discriminants
(Ptyp
)
9486 and then Is_Constrained
(Ptyp
)
9488 -- Do this optimization for discrete types only, and not for
9489 -- access types (access discriminants get us into trouble).
9491 if not Is_Discrete_Type
(Etype
(N
)) then
9494 -- Don't do this on the left hand of an assignment statement.
9495 -- Normally one would think that references like this would not
9496 -- occur, but they do in generated code, and mean that we really
9497 -- do want to assign the discriminant.
9499 elsif Nkind
(Par
) = N_Assignment_Statement
9500 and then Name
(Par
) = N
9504 -- Don't do this optimization for the prefix of an attribute or
9505 -- the name of an object renaming declaration since these are
9506 -- contexts where we do not want the value anyway.
9508 elsif (Nkind
(Par
) = N_Attribute_Reference
9509 and then Prefix
(Par
) = N
)
9510 or else Is_Renamed_Object
(N
)
9514 -- Don't do this optimization if we are within the code for a
9515 -- discriminant check, since the whole point of such a check may
9516 -- be to verify the condition on which the code below depends.
9518 elsif Is_In_Discriminant_Check
(N
) then
9521 -- Green light to see if we can do the optimization. There is
9522 -- still one condition that inhibits the optimization below but
9523 -- now is the time to check the particular discriminant.
9526 -- Loop through discriminants to find the matching discriminant
9527 -- constraint to see if we can copy it.
9529 Disc
:= First_Discriminant
(Ptyp
);
9530 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
9531 Discr_Loop
: while Present
(Dcon
) loop
9532 Dval
:= Node
(Dcon
);
9534 -- Check if this is the matching discriminant and if the
9535 -- discriminant value is simple enough to make sense to
9536 -- copy. We don't want to copy complex expressions, and
9537 -- indeed to do so can cause trouble (before we put in
9538 -- this guard, a discriminant expression containing an
9539 -- AND THEN was copied, causing problems for coverage
9542 -- However, if the reference is part of the initialization
9543 -- code generated for an object declaration, we must use
9544 -- the discriminant value from the subtype constraint,
9545 -- because the selected component may be a reference to the
9546 -- object being initialized, whose discriminant is not yet
9547 -- set. This only happens in complex cases involving changes
9548 -- or representation.
9550 if Disc
= Entity
(Selector_Name
(N
))
9551 and then (Is_Entity_Name
(Dval
)
9552 or else Compile_Time_Known_Value
(Dval
)
9553 or else Is_Subtype_Declaration
)
9555 -- Here we have the matching discriminant. Check for
9556 -- the case of a discriminant of a component that is
9557 -- constrained by an outer discriminant, which cannot
9558 -- be optimized away.
9560 if Denotes_Discriminant
9561 (Dval
, Check_Concurrent
=> True)
9565 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
9567 Denotes_Discriminant
9568 (Selector_Name
(Original_Node
(Dval
)), True)
9572 -- Do not retrieve value if constraint is not static. It
9573 -- is generally not useful, and the constraint may be a
9574 -- rewritten outer discriminant in which case it is in
9577 elsif Is_Entity_Name
(Dval
)
9579 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
9580 and then Present
(Expression
(Parent
(Entity
(Dval
))))
9582 Is_Static_Expression
9583 (Expression
(Parent
(Entity
(Dval
))))
9587 -- In the context of a case statement, the expression may
9588 -- have the base type of the discriminant, and we need to
9589 -- preserve the constraint to avoid spurious errors on
9592 elsif Nkind
(Parent
(N
)) = N_Case_Statement
9593 and then Etype
(Dval
) /= Etype
(Disc
)
9596 Make_Qualified_Expression
(Loc
,
9598 New_Occurrence_Of
(Etype
(Disc
), Loc
),
9600 New_Copy_Tree
(Dval
)));
9601 Analyze_And_Resolve
(N
, Etype
(Disc
));
9603 -- In case that comes out as a static expression,
9604 -- reset it (a selected component is never static).
9606 Set_Is_Static_Expression
(N
, False);
9609 -- Otherwise we can just copy the constraint, but the
9610 -- result is certainly not static. In some cases the
9611 -- discriminant constraint has been analyzed in the
9612 -- context of the original subtype indication, but for
9613 -- itypes the constraint might not have been analyzed
9614 -- yet, and this must be done now.
9617 Rewrite
(N
, New_Copy_Tree
(Dval
));
9618 Analyze_And_Resolve
(N
);
9619 Set_Is_Static_Expression
(N
, False);
9625 Next_Discriminant
(Disc
);
9626 end loop Discr_Loop
;
9628 -- Note: the above loop should always find a matching
9629 -- discriminant, but if it does not, we just missed an
9630 -- optimization due to some glitch (perhaps a previous
9631 -- error), so ignore.
9636 -- The only remaining processing is in the case of a discriminant of
9637 -- a concurrent object, where we rewrite the prefix to denote the
9638 -- corresponding record type. If the type is derived and has renamed
9639 -- discriminants, use corresponding discriminant, which is the one
9640 -- that appears in the corresponding record.
9642 if not Is_Concurrent_Type
(Ptyp
) then
9646 Disc
:= Entity
(Selector_Name
(N
));
9648 if Is_Derived_Type
(Ptyp
)
9649 and then Present
(Corresponding_Discriminant
(Disc
))
9651 Disc
:= Corresponding_Discriminant
(Disc
);
9655 Make_Selected_Component
(Loc
,
9657 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
9659 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
9665 -- Set Atomic_Sync_Required if necessary for atomic component
9667 if Nkind
(N
) = N_Selected_Component
then
9669 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
9673 -- If component is atomic, but type is not, setting depends on
9674 -- disable/enable state for the component.
9676 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
9677 Set
:= not Atomic_Synchronization_Disabled
(E
);
9679 -- If component is not atomic, but its type is atomic, setting
9680 -- depends on disable/enable state for the type.
9682 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9683 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
9685 -- If both component and type are atomic, we disable if either
9686 -- component or its type have sync disabled.
9688 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9689 Set
:= (not Atomic_Synchronization_Disabled
(E
))
9691 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
9697 -- Set flag if required
9700 Activate_Atomic_Synchronization
(N
);
9704 end Expand_N_Selected_Component
;
9706 --------------------
9707 -- Expand_N_Slice --
9708 --------------------
9710 procedure Expand_N_Slice
(N
: Node_Id
) is
9711 Loc
: constant Source_Ptr
:= Sloc
(N
);
9712 Typ
: constant Entity_Id
:= Etype
(N
);
9714 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
9715 -- Check whether the argument is an actual for a procedure call, in
9716 -- which case the expansion of a bit-packed slice is deferred until the
9717 -- call itself is expanded. The reason this is required is that we might
9718 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9719 -- that copy out would be missed if we created a temporary here in
9720 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9721 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9722 -- is harmless to defer expansion in the IN case, since the call
9723 -- processing will still generate the appropriate copy in operation,
9724 -- which will take care of the slice.
9726 procedure Make_Temporary_For_Slice
;
9727 -- Create a named variable for the value of the slice, in cases where
9728 -- the back-end cannot handle it properly, e.g. when packed types or
9729 -- unaligned slices are involved.
9731 -------------------------
9732 -- Is_Procedure_Actual --
9733 -------------------------
9735 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
9736 Par
: Node_Id
:= Parent
(N
);
9740 -- If our parent is a procedure call we can return
9742 if Nkind
(Par
) = N_Procedure_Call_Statement
then
9745 -- If our parent is a type conversion, keep climbing the tree,
9746 -- since a type conversion can be a procedure actual. Also keep
9747 -- climbing if parameter association or a qualified expression,
9748 -- since these are additional cases that do can appear on
9749 -- procedure actuals.
9751 elsif Nkind_In
(Par
, N_Type_Conversion
,
9752 N_Parameter_Association
,
9753 N_Qualified_Expression
)
9755 Par
:= Parent
(Par
);
9757 -- Any other case is not what we are looking for
9763 end Is_Procedure_Actual
;
9765 ------------------------------
9766 -- Make_Temporary_For_Slice --
9767 ------------------------------
9769 procedure Make_Temporary_For_Slice
is
9770 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
9775 Make_Object_Declaration
(Loc
,
9776 Defining_Identifier
=> Ent
,
9777 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
9779 Set_No_Initialization
(Decl
);
9781 Insert_Actions
(N
, New_List
(
9783 Make_Assignment_Statement
(Loc
,
9784 Name
=> New_Occurrence_Of
(Ent
, Loc
),
9785 Expression
=> Relocate_Node
(N
))));
9787 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
9788 Analyze_And_Resolve
(N
, Typ
);
9789 end Make_Temporary_For_Slice
;
9793 Pref
: constant Node_Id
:= Prefix
(N
);
9794 Pref_Typ
: Entity_Id
:= Etype
(Pref
);
9796 -- Start of processing for Expand_N_Slice
9799 -- Special handling for access types
9801 if Is_Access_Type
(Pref_Typ
) then
9802 Pref_Typ
:= Designated_Type
(Pref_Typ
);
9805 Make_Explicit_Dereference
(Sloc
(N
),
9806 Prefix
=> Relocate_Node
(Pref
)));
9808 Analyze_And_Resolve
(Pref
, Pref_Typ
);
9811 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9812 -- function, then additional actuals must be passed.
9814 if Ada_Version
>= Ada_2005
9815 and then Is_Build_In_Place_Function_Call
(Pref
)
9817 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
9820 -- The remaining case to be handled is packed slices. We can leave
9821 -- packed slices as they are in the following situations:
9823 -- 1. Right or left side of an assignment (we can handle this
9824 -- situation correctly in the assignment statement expansion).
9826 -- 2. Prefix of indexed component (the slide is optimized away in this
9827 -- case, see the start of Expand_N_Slice.)
9829 -- 3. Object renaming declaration, since we want the name of the
9830 -- slice, not the value.
9832 -- 4. Argument to procedure call, since copy-in/copy-out handling may
9833 -- be required, and this is handled in the expansion of call
9836 -- 5. Prefix of an address attribute (this is an error which is caught
9837 -- elsewhere, and the expansion would interfere with generating the
9840 if not Is_Packed
(Typ
) then
9842 -- Apply transformation for actuals of a function call, where
9843 -- Expand_Actuals is not used.
9845 if Nkind
(Parent
(N
)) = N_Function_Call
9846 and then Is_Possibly_Unaligned_Slice
(N
)
9848 Make_Temporary_For_Slice
;
9851 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
9852 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9853 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
9857 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
9858 or else Is_Renamed_Object
(N
)
9859 or else Is_Procedure_Actual
(N
)
9863 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
9864 and then Attribute_Name
(Parent
(N
)) = Name_Address
9869 Make_Temporary_For_Slice
;
9873 ------------------------------
9874 -- Expand_N_Type_Conversion --
9875 ------------------------------
9877 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
9878 Loc
: constant Source_Ptr
:= Sloc
(N
);
9879 Operand
: constant Node_Id
:= Expression
(N
);
9880 Target_Type
: constant Entity_Id
:= Etype
(N
);
9881 Operand_Type
: Entity_Id
:= Etype
(Operand
);
9883 procedure Handle_Changed_Representation
;
9884 -- This is called in the case of record and array type conversions to
9885 -- see if there is a change of representation to be handled. Change of
9886 -- representation is actually handled at the assignment statement level,
9887 -- and what this procedure does is rewrite node N conversion as an
9888 -- assignment to temporary. If there is no change of representation,
9889 -- then the conversion node is unchanged.
9891 procedure Raise_Accessibility_Error
;
9892 -- Called when we know that an accessibility check will fail. Rewrites
9893 -- node N to an appropriate raise statement and outputs warning msgs.
9894 -- The Etype of the raise node is set to Target_Type.
9896 procedure Real_Range_Check
;
9897 -- Handles generation of range check for real target value
9899 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
9900 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
9901 -- evaluates to True.
9903 -----------------------------------
9904 -- Handle_Changed_Representation --
9905 -----------------------------------
9907 procedure Handle_Changed_Representation
is
9916 -- Nothing else to do if no change of representation
9918 if Same_Representation
(Operand_Type
, Target_Type
) then
9921 -- The real change of representation work is done by the assignment
9922 -- statement processing. So if this type conversion is appearing as
9923 -- the expression of an assignment statement, nothing needs to be
9924 -- done to the conversion.
9926 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9929 -- Otherwise we need to generate a temporary variable, and do the
9930 -- change of representation assignment into that temporary variable.
9931 -- The conversion is then replaced by a reference to this variable.
9936 -- If type is unconstrained we have to add a constraint, copied
9937 -- from the actual value of the left hand side.
9939 if not Is_Constrained
(Target_Type
) then
9940 if Has_Discriminants
(Operand_Type
) then
9941 Disc
:= First_Discriminant
(Operand_Type
);
9943 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
9944 Disc
:= First_Stored_Discriminant
(Operand_Type
);
9948 while Present
(Disc
) loop
9950 Make_Selected_Component
(Loc
,
9952 Duplicate_Subexpr_Move_Checks
(Operand
),
9954 Make_Identifier
(Loc
, Chars
(Disc
))));
9955 Next_Discriminant
(Disc
);
9958 elsif Is_Array_Type
(Operand_Type
) then
9959 N_Ix
:= First_Index
(Target_Type
);
9962 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
9964 -- We convert the bounds explicitly. We use an unchecked
9965 -- conversion because bounds checks are done elsewhere.
9970 Unchecked_Convert_To
(Etype
(N_Ix
),
9971 Make_Attribute_Reference
(Loc
,
9973 Duplicate_Subexpr_No_Checks
9974 (Operand
, Name_Req
=> True),
9975 Attribute_Name
=> Name_First
,
9976 Expressions
=> New_List
(
9977 Make_Integer_Literal
(Loc
, J
)))),
9980 Unchecked_Convert_To
(Etype
(N_Ix
),
9981 Make_Attribute_Reference
(Loc
,
9983 Duplicate_Subexpr_No_Checks
9984 (Operand
, Name_Req
=> True),
9985 Attribute_Name
=> Name_Last
,
9986 Expressions
=> New_List
(
9987 Make_Integer_Literal
(Loc
, J
))))));
9994 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
9996 if Present
(Cons
) then
9998 Make_Subtype_Indication
(Loc
,
9999 Subtype_Mark
=> Odef
,
10001 Make_Index_Or_Discriminant_Constraint
(Loc
,
10002 Constraints
=> Cons
));
10005 Temp
:= Make_Temporary
(Loc
, 'C');
10007 Make_Object_Declaration
(Loc
,
10008 Defining_Identifier
=> Temp
,
10009 Object_Definition
=> Odef
);
10011 Set_No_Initialization
(Decl
, True);
10013 -- Insert required actions. It is essential to suppress checks
10014 -- since we have suppressed default initialization, which means
10015 -- that the variable we create may have no discriminants.
10020 Make_Assignment_Statement
(Loc
,
10021 Name
=> New_Occurrence_Of
(Temp
, Loc
),
10022 Expression
=> Relocate_Node
(N
))),
10023 Suppress
=> All_Checks
);
10025 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
10028 end Handle_Changed_Representation
;
10030 -------------------------------
10031 -- Raise_Accessibility_Error --
10032 -------------------------------
10034 procedure Raise_Accessibility_Error
is
10036 Error_Msg_Warn
:= SPARK_Mode
/= On
;
10038 Make_Raise_Program_Error
(Sloc
(N
),
10039 Reason
=> PE_Accessibility_Check_Failed
));
10040 Set_Etype
(N
, Target_Type
);
10042 Error_Msg_N
("<<accessibility check failure", N
);
10043 Error_Msg_NE
("\<<& [", N
, Standard_Program_Error
);
10044 end Raise_Accessibility_Error
;
10046 ----------------------
10047 -- Real_Range_Check --
10048 ----------------------
10050 -- Case of conversions to floating-point or fixed-point. If range checks
10051 -- are enabled and the target type has a range constraint, we convert:
10057 -- Tnn : typ'Base := typ'Base (x);
10058 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10061 -- This is necessary when there is a conversion of integer to float or
10062 -- to fixed-point to ensure that the correct checks are made. It is not
10063 -- necessary for float to float where it is enough to simply set the
10064 -- Do_Range_Check flag.
10066 procedure Real_Range_Check
is
10067 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
10068 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
10069 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
10070 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
10075 -- Nothing to do if conversion was rewritten
10077 if Nkind
(N
) /= N_Type_Conversion
then
10081 -- Nothing to do if range checks suppressed, or target has the same
10082 -- range as the base type (or is the base type).
10084 if Range_Checks_Suppressed
(Target_Type
)
10085 or else (Lo
= Type_Low_Bound
(Btyp
)
10087 Hi
= Type_High_Bound
(Btyp
))
10092 -- Nothing to do if expression is an entity on which checks have been
10095 if Is_Entity_Name
(Operand
)
10096 and then Range_Checks_Suppressed
(Entity
(Operand
))
10101 -- Nothing to do if bounds are all static and we can tell that the
10102 -- expression is within the bounds of the target. Note that if the
10103 -- operand is of an unconstrained floating-point type, then we do
10104 -- not trust it to be in range (might be infinite)
10107 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
10108 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
10111 if (not Is_Floating_Point_Type
(Xtyp
)
10112 or else Is_Constrained
(Xtyp
))
10113 and then Compile_Time_Known_Value
(S_Lo
)
10114 and then Compile_Time_Known_Value
(S_Hi
)
10115 and then Compile_Time_Known_Value
(Hi
)
10116 and then Compile_Time_Known_Value
(Lo
)
10119 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
10120 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
10125 if Is_Real_Type
(Xtyp
) then
10126 S_Lov
:= Expr_Value_R
(S_Lo
);
10127 S_Hiv
:= Expr_Value_R
(S_Hi
);
10129 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
10130 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
10134 and then S_Lov
>= D_Lov
10135 and then S_Hiv
<= D_Hiv
10137 Set_Do_Range_Check
(Operand
, False);
10144 -- For float to float conversions, we are done
10146 if Is_Floating_Point_Type
(Xtyp
)
10148 Is_Floating_Point_Type
(Btyp
)
10153 -- Otherwise rewrite the conversion as described above
10155 Conv
:= Relocate_Node
(N
);
10156 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
10157 Set_Etype
(Conv
, Btyp
);
10159 -- Enable overflow except for case of integer to float conversions,
10160 -- where it is never required, since we can never have overflow in
10163 if not Is_Integer_Type
(Etype
(Operand
)) then
10164 Enable_Overflow_Check
(Conv
);
10167 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
10169 Insert_Actions
(N
, New_List
(
10170 Make_Object_Declaration
(Loc
,
10171 Defining_Identifier
=> Tnn
,
10172 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
10173 Constant_Present
=> True,
10174 Expression
=> Conv
),
10176 Make_Raise_Constraint_Error
(Loc
,
10181 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10183 Make_Attribute_Reference
(Loc
,
10184 Attribute_Name
=> Name_First
,
10186 New_Occurrence_Of
(Target_Type
, Loc
))),
10190 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10192 Make_Attribute_Reference
(Loc
,
10193 Attribute_Name
=> Name_Last
,
10195 New_Occurrence_Of
(Target_Type
, Loc
)))),
10196 Reason
=> CE_Range_Check_Failed
)));
10198 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
10199 Analyze_And_Resolve
(N
, Btyp
);
10200 end Real_Range_Check
;
10202 -----------------------------
10203 -- Has_Extra_Accessibility --
10204 -----------------------------
10206 -- Returns true for a formal of an anonymous access type or for
10207 -- an Ada 2012-style stand-alone object of an anonymous access type.
10209 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
10211 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
10212 return Present
(Effective_Extra_Accessibility
(Id
));
10216 end Has_Extra_Accessibility
;
10218 -- Start of processing for Expand_N_Type_Conversion
10221 -- First remove check marks put by the semantic analysis on the type
10222 -- conversion between array types. We need these checks, and they will
10223 -- be generated by this expansion routine, but we do not depend on these
10224 -- flags being set, and since we do intend to expand the checks in the
10225 -- front end, we don't want them on the tree passed to the back end.
10227 if Is_Array_Type
(Target_Type
) then
10228 if Is_Constrained
(Target_Type
) then
10229 Set_Do_Length_Check
(N
, False);
10231 Set_Do_Range_Check
(Operand
, False);
10235 -- Nothing at all to do if conversion is to the identical type so remove
10236 -- the conversion completely, it is useless, except that it may carry
10237 -- an Assignment_OK attribute, which must be propagated to the operand.
10239 if Operand_Type
= Target_Type
then
10240 if Assignment_OK
(N
) then
10241 Set_Assignment_OK
(Operand
);
10244 Rewrite
(N
, Relocate_Node
(Operand
));
10248 -- Nothing to do if this is the second argument of read. This is a
10249 -- "backwards" conversion that will be handled by the specialized code
10250 -- in attribute processing.
10252 if Nkind
(Parent
(N
)) = N_Attribute_Reference
10253 and then Attribute_Name
(Parent
(N
)) = Name_Read
10254 and then Next
(First
(Expressions
(Parent
(N
)))) = N
10259 -- Check for case of converting to a type that has an invariant
10260 -- associated with it. This required an invariant check. We convert
10266 -- do invariant_check (typ (expr)) in typ (expr);
10268 -- using Duplicate_Subexpr to avoid multiple side effects
10270 -- Note: the Comes_From_Source check, and then the resetting of this
10271 -- flag prevents what would otherwise be an infinite recursion.
10273 if Has_Invariants
(Target_Type
)
10274 and then Present
(Invariant_Procedure
(Target_Type
))
10275 and then Comes_From_Source
(N
)
10277 Set_Comes_From_Source
(N
, False);
10279 Make_Expression_With_Actions
(Loc
,
10280 Actions
=> New_List
(
10281 Make_Invariant_Call
(Duplicate_Subexpr
(N
))),
10282 Expression
=> Duplicate_Subexpr_No_Checks
(N
)));
10283 Analyze_And_Resolve
(N
, Target_Type
);
10287 -- Here if we may need to expand conversion
10289 -- If the operand of the type conversion is an arithmetic operation on
10290 -- signed integers, and the based type of the signed integer type in
10291 -- question is smaller than Standard.Integer, we promote both of the
10292 -- operands to type Integer.
10294 -- For example, if we have
10296 -- target-type (opnd1 + opnd2)
10298 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10301 -- target-type (integer(opnd1) + integer(opnd2))
10303 -- We do this because we are always allowed to compute in a larger type
10304 -- if we do the right thing with the result, and in this case we are
10305 -- going to do a conversion which will do an appropriate check to make
10306 -- sure that things are in range of the target type in any case. This
10307 -- avoids some unnecessary intermediate overflows.
10309 -- We might consider a similar transformation in the case where the
10310 -- target is a real type or a 64-bit integer type, and the operand
10311 -- is an arithmetic operation using a 32-bit integer type. However,
10312 -- we do not bother with this case, because it could cause significant
10313 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10314 -- much cheaper, but we don't want different behavior on 32-bit and
10315 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10316 -- handles the configurable run-time cases where 64-bit arithmetic
10317 -- may simply be unavailable.
10319 -- Note: this circuit is partially redundant with respect to the circuit
10320 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10321 -- the processing here. Also we still need the Checks circuit, since we
10322 -- have to be sure not to generate junk overflow checks in the first
10323 -- place, since it would be trick to remove them here.
10325 if Integer_Promotion_Possible
(N
) then
10327 -- All conditions met, go ahead with transformation
10335 Make_Type_Conversion
(Loc
,
10336 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10337 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
10339 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
10340 Set_Right_Opnd
(Opnd
, R
);
10342 if Nkind
(Operand
) in N_Binary_Op
then
10344 Make_Type_Conversion
(Loc
,
10345 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10346 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
10348 Set_Left_Opnd
(Opnd
, L
);
10352 Make_Type_Conversion
(Loc
,
10353 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
10354 Expression
=> Opnd
));
10356 Analyze_And_Resolve
(N
, Target_Type
);
10361 -- Do validity check if validity checking operands
10363 if Validity_Checks_On
and Validity_Check_Operands
then
10364 Ensure_Valid
(Operand
);
10367 -- Special case of converting from non-standard boolean type
10369 if Is_Boolean_Type
(Operand_Type
)
10370 and then (Nonzero_Is_True
(Operand_Type
))
10372 Adjust_Condition
(Operand
);
10373 Set_Etype
(Operand
, Standard_Boolean
);
10374 Operand_Type
:= Standard_Boolean
;
10377 -- Case of converting to an access type
10379 if Is_Access_Type
(Target_Type
) then
10381 -- Apply an accessibility check when the conversion operand is an
10382 -- access parameter (or a renaming thereof), unless conversion was
10383 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10384 -- Note that other checks may still need to be applied below (such
10385 -- as tagged type checks).
10387 if Is_Entity_Name
(Operand
)
10388 and then Has_Extra_Accessibility
(Entity
(Operand
))
10389 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
10390 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
10391 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
10393 Apply_Accessibility_Check
10394 (Operand
, Target_Type
, Insert_Node
=> Operand
);
10396 -- If the level of the operand type is statically deeper than the
10397 -- level of the target type, then force Program_Error. Note that this
10398 -- can only occur for cases where the attribute is within the body of
10399 -- an instantiation (otherwise the conversion will already have been
10400 -- rejected as illegal). Note: warnings are issued by the analyzer
10401 -- for the instance cases.
10403 elsif In_Instance_Body
10404 and then Type_Access_Level
(Operand_Type
) >
10405 Type_Access_Level
(Target_Type
)
10407 Raise_Accessibility_Error
;
10409 -- When the operand is a selected access discriminant the check needs
10410 -- to be made against the level of the object denoted by the prefix
10411 -- of the selected name. Force Program_Error for this case as well
10412 -- (this accessibility violation can only happen if within the body
10413 -- of an instantiation).
10415 elsif In_Instance_Body
10416 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
10417 and then Nkind
(Operand
) = N_Selected_Component
10418 and then Object_Access_Level
(Operand
) >
10419 Type_Access_Level
(Target_Type
)
10421 Raise_Accessibility_Error
;
10426 -- Case of conversions of tagged types and access to tagged types
10428 -- When needed, that is to say when the expression is class-wide, Add
10429 -- runtime a tag check for (strict) downward conversion by using the
10430 -- membership test, generating:
10432 -- [constraint_error when Operand not in Target_Type'Class]
10434 -- or in the access type case
10436 -- [constraint_error
10437 -- when Operand /= null
10438 -- and then Operand.all not in
10439 -- Designated_Type (Target_Type)'Class]
10441 if (Is_Access_Type
(Target_Type
)
10442 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
10443 or else Is_Tagged_Type
(Target_Type
)
10445 -- Do not do any expansion in the access type case if the parent is a
10446 -- renaming, since this is an error situation which will be caught by
10447 -- Sem_Ch8, and the expansion can interfere with this error check.
10449 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
10453 -- Otherwise, proceed with processing tagged conversion
10455 Tagged_Conversion
: declare
10456 Actual_Op_Typ
: Entity_Id
;
10457 Actual_Targ_Typ
: Entity_Id
;
10458 Make_Conversion
: Boolean := False;
10459 Root_Op_Typ
: Entity_Id
;
10461 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
10462 -- Create a membership check to test whether Operand is a member
10463 -- of Targ_Typ. If the original Target_Type is an access, include
10464 -- a test for null value. The check is inserted at N.
10466 --------------------
10467 -- Make_Tag_Check --
10468 --------------------
10470 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
10475 -- [Constraint_Error
10476 -- when Operand /= null
10477 -- and then Operand.all not in Targ_Typ]
10479 if Is_Access_Type
(Target_Type
) then
10481 Make_And_Then
(Loc
,
10484 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10485 Right_Opnd
=> Make_Null
(Loc
)),
10490 Make_Explicit_Dereference
(Loc
,
10491 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
10492 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
10495 -- [Constraint_Error when Operand not in Targ_Typ]
10500 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10501 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
10505 Make_Raise_Constraint_Error
(Loc
,
10507 Reason
=> CE_Tag_Check_Failed
));
10508 end Make_Tag_Check
;
10510 -- Start of processing for Tagged_Conversion
10513 -- Handle entities from the limited view
10515 if Is_Access_Type
(Operand_Type
) then
10517 Available_View
(Designated_Type
(Operand_Type
));
10519 Actual_Op_Typ
:= Operand_Type
;
10522 if Is_Access_Type
(Target_Type
) then
10524 Available_View
(Designated_Type
(Target_Type
));
10526 Actual_Targ_Typ
:= Target_Type
;
10529 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
10531 -- Ada 2005 (AI-251): Handle interface type conversion
10533 if Is_Interface
(Actual_Op_Typ
) then
10534 Expand_Interface_Conversion
(N
);
10538 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
10540 -- Create a runtime tag check for a downward class-wide type
10543 if Is_Class_Wide_Type
(Actual_Op_Typ
)
10544 and then Actual_Op_Typ
/= Actual_Targ_Typ
10545 and then Root_Op_Typ
/= Actual_Targ_Typ
10546 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
10547 Use_Full_View
=> True)
10549 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
10550 Make_Conversion
:= True;
10553 -- AI05-0073: If the result subtype of the function is defined
10554 -- by an access_definition designating a specific tagged type
10555 -- T, a check is made that the result value is null or the tag
10556 -- of the object designated by the result value identifies T.
10557 -- Constraint_Error is raised if this check fails.
10559 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
10562 Func_Typ
: Entity_Id
;
10565 -- Climb scope stack looking for the enclosing function
10567 Func
:= Current_Scope
;
10568 while Present
(Func
)
10569 and then Ekind
(Func
) /= E_Function
10571 Func
:= Scope
(Func
);
10574 -- The function's return subtype must be defined using
10575 -- an access definition.
10577 if Nkind
(Result_Definition
(Parent
(Func
))) =
10578 N_Access_Definition
10580 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
10582 -- The return subtype denotes a specific tagged type,
10583 -- in other words, a non class-wide type.
10585 if Is_Tagged_Type
(Func_Typ
)
10586 and then not Is_Class_Wide_Type
(Func_Typ
)
10588 Make_Tag_Check
(Actual_Targ_Typ
);
10589 Make_Conversion
:= True;
10595 -- We have generated a tag check for either a class-wide type
10596 -- conversion or for AI05-0073.
10598 if Make_Conversion
then
10603 Make_Unchecked_Type_Conversion
(Loc
,
10604 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
10605 Expression
=> Relocate_Node
(Expression
(N
)));
10607 Analyze_And_Resolve
(N
, Target_Type
);
10611 end Tagged_Conversion
;
10613 -- Case of other access type conversions
10615 elsif Is_Access_Type
(Target_Type
) then
10616 Apply_Constraint_Check
(Operand
, Target_Type
);
10618 -- Case of conversions from a fixed-point type
10620 -- These conversions require special expansion and processing, found in
10621 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10622 -- since from a semantic point of view, these are simple integer
10623 -- conversions, which do not need further processing.
10625 elsif Is_Fixed_Point_Type
(Operand_Type
)
10626 and then not Conversion_OK
(N
)
10628 -- We should never see universal fixed at this case, since the
10629 -- expansion of the constituent divide or multiply should have
10630 -- eliminated the explicit mention of universal fixed.
10632 pragma Assert
(Operand_Type
/= Universal_Fixed
);
10634 -- Check for special case of the conversion to universal real that
10635 -- occurs as a result of the use of a round attribute. In this case,
10636 -- the real type for the conversion is taken from the target type of
10637 -- the Round attribute and the result must be marked as rounded.
10639 if Target_Type
= Universal_Real
10640 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
10641 and then Attribute_Name
(Parent
(N
)) = Name_Round
10643 Set_Rounded_Result
(N
);
10644 Set_Etype
(N
, Etype
(Parent
(N
)));
10647 -- Otherwise do correct fixed-conversion, but skip these if the
10648 -- Conversion_OK flag is set, because from a semantic point of view
10649 -- these are simple integer conversions needing no further processing
10650 -- (the backend will simply treat them as integers).
10652 if not Conversion_OK
(N
) then
10653 if Is_Fixed_Point_Type
(Etype
(N
)) then
10654 Expand_Convert_Fixed_To_Fixed
(N
);
10657 elsif Is_Integer_Type
(Etype
(N
)) then
10658 Expand_Convert_Fixed_To_Integer
(N
);
10661 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
10662 Expand_Convert_Fixed_To_Float
(N
);
10667 -- Case of conversions to a fixed-point type
10669 -- These conversions require special expansion and processing, found in
10670 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10671 -- since from a semantic point of view, these are simple integer
10672 -- conversions, which do not need further processing.
10674 elsif Is_Fixed_Point_Type
(Target_Type
)
10675 and then not Conversion_OK
(N
)
10677 if Is_Integer_Type
(Operand_Type
) then
10678 Expand_Convert_Integer_To_Fixed
(N
);
10681 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
10682 Expand_Convert_Float_To_Fixed
(N
);
10686 -- Case of float-to-integer conversions
10688 -- We also handle float-to-fixed conversions with Conversion_OK set
10689 -- since semantically the fixed-point target is treated as though it
10690 -- were an integer in such cases.
10692 elsif Is_Floating_Point_Type
(Operand_Type
)
10694 (Is_Integer_Type
(Target_Type
)
10696 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
10698 -- One more check here, gcc is still not able to do conversions of
10699 -- this type with proper overflow checking, and so gigi is doing an
10700 -- approximation of what is required by doing floating-point compares
10701 -- with the end-point. But that can lose precision in some cases, and
10702 -- give a wrong result. Converting the operand to Universal_Real is
10703 -- helpful, but still does not catch all cases with 64-bit integers
10704 -- on targets with only 64-bit floats.
10706 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10707 -- Can this code be removed ???
10709 if Do_Range_Check
(Operand
) then
10711 Make_Type_Conversion
(Loc
,
10713 New_Occurrence_Of
(Universal_Real
, Loc
),
10715 Relocate_Node
(Operand
)));
10717 Set_Etype
(Operand
, Universal_Real
);
10718 Enable_Range_Check
(Operand
);
10719 Set_Do_Range_Check
(Expression
(Operand
), False);
10722 -- Case of array conversions
10724 -- Expansion of array conversions, add required length/range checks but
10725 -- only do this if there is no change of representation. For handling of
10726 -- this case, see Handle_Changed_Representation.
10728 elsif Is_Array_Type
(Target_Type
) then
10729 if Is_Constrained
(Target_Type
) then
10730 Apply_Length_Check
(Operand
, Target_Type
);
10732 Apply_Range_Check
(Operand
, Target_Type
);
10735 Handle_Changed_Representation
;
10737 -- Case of conversions of discriminated types
10739 -- Add required discriminant checks if target is constrained. Again this
10740 -- change is skipped if we have a change of representation.
10742 elsif Has_Discriminants
(Target_Type
)
10743 and then Is_Constrained
(Target_Type
)
10745 Apply_Discriminant_Check
(Operand
, Target_Type
);
10746 Handle_Changed_Representation
;
10748 -- Case of all other record conversions. The only processing required
10749 -- is to check for a change of representation requiring the special
10750 -- assignment processing.
10752 elsif Is_Record_Type
(Target_Type
) then
10754 -- Ada 2005 (AI-216): Program_Error is raised when converting from
10755 -- a derived Unchecked_Union type to an unconstrained type that is
10756 -- not Unchecked_Union if the operand lacks inferable discriminants.
10758 if Is_Derived_Type
(Operand_Type
)
10759 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
10760 and then not Is_Constrained
(Target_Type
)
10761 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
10762 and then not Has_Inferable_Discriminants
(Operand
)
10764 -- To prevent Gigi from generating illegal code, we generate a
10765 -- Program_Error node, but we give it the target type of the
10766 -- conversion (is this requirement documented somewhere ???)
10769 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
10770 Reason
=> PE_Unchecked_Union_Restriction
);
10773 Set_Etype
(PE
, Target_Type
);
10778 Handle_Changed_Representation
;
10781 -- Case of conversions of enumeration types
10783 elsif Is_Enumeration_Type
(Target_Type
) then
10785 -- Special processing is required if there is a change of
10786 -- representation (from enumeration representation clauses).
10788 if not Same_Representation
(Target_Type
, Operand_Type
) then
10790 -- Convert: x(y) to x'val (ytyp'val (y))
10793 Make_Attribute_Reference
(Loc
,
10794 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
10795 Attribute_Name
=> Name_Val
,
10796 Expressions
=> New_List
(
10797 Make_Attribute_Reference
(Loc
,
10798 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
10799 Attribute_Name
=> Name_Pos
,
10800 Expressions
=> New_List
(Operand
)))));
10802 Analyze_And_Resolve
(N
, Target_Type
);
10805 -- Case of conversions to floating-point
10807 elsif Is_Floating_Point_Type
(Target_Type
) then
10811 -- At this stage, either the conversion node has been transformed into
10812 -- some other equivalent expression, or left as a conversion that can be
10813 -- handled by Gigi, in the following cases:
10815 -- Conversions with no change of representation or type
10817 -- Numeric conversions involving integer, floating- and fixed-point
10818 -- values. Fixed-point values are allowed only if Conversion_OK is
10819 -- set, i.e. if the fixed-point values are to be treated as integers.
10821 -- No other conversions should be passed to Gigi
10823 -- Check: are these rules stated in sinfo??? if so, why restate here???
10825 -- The only remaining step is to generate a range check if we still have
10826 -- a type conversion at this stage and Do_Range_Check is set. For now we
10827 -- do this only for conversions of discrete types.
10829 if Nkind
(N
) = N_Type_Conversion
10830 and then Is_Discrete_Type
(Etype
(N
))
10833 Expr
: constant Node_Id
:= Expression
(N
);
10838 if Do_Range_Check
(Expr
)
10839 and then Is_Discrete_Type
(Etype
(Expr
))
10841 Set_Do_Range_Check
(Expr
, False);
10843 -- Before we do a range check, we have to deal with treating a
10844 -- fixed-point operand as an integer. The way we do this is
10845 -- simply to do an unchecked conversion to an appropriate
10846 -- integer type large enough to hold the result.
10848 -- This code is not active yet, because we are only dealing
10849 -- with discrete types so far ???
10851 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
10852 and then Treat_Fixed_As_Integer
(Expr
)
10854 Ftyp
:= Base_Type
(Etype
(Expr
));
10856 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
10857 Ityp
:= Standard_Long_Long_Integer
;
10859 Ityp
:= Standard_Integer
;
10862 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
10865 -- Reset overflow flag, since the range check will include
10866 -- dealing with possible overflow, and generate the check. If
10867 -- Address is either a source type or target type, suppress
10868 -- range check to avoid typing anomalies when it is a visible
10871 Set_Do_Overflow_Check
(N
, False);
10872 if not Is_Descendent_Of_Address
(Etype
(Expr
))
10873 and then not Is_Descendent_Of_Address
(Target_Type
)
10875 Generate_Range_Check
10876 (Expr
, Target_Type
, CE_Range_Check_Failed
);
10882 -- Final step, if the result is a type conversion involving Vax_Float
10883 -- types, then it is subject for further special processing.
10885 if Nkind
(N
) = N_Type_Conversion
10886 and then (Vax_Float
(Operand_Type
) or else Vax_Float
(Target_Type
))
10888 Expand_Vax_Conversion
(N
);
10892 -- Here at end of processing
10895 -- Apply predicate check if required. Note that we can't just call
10896 -- Apply_Predicate_Check here, because the type looks right after
10897 -- the conversion and it would omit the check. The Comes_From_Source
10898 -- guard is necessary to prevent infinite recursions when we generate
10899 -- internal conversions for the purpose of checking predicates.
10901 if Present
(Predicate_Function
(Target_Type
))
10902 and then Target_Type
/= Operand_Type
10903 and then Comes_From_Source
(N
)
10906 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
10909 -- Avoid infinite recursion on the subsequent expansion of
10910 -- of the copy of the original type conversion.
10912 Set_Comes_From_Source
(New_Expr
, False);
10913 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
10916 end Expand_N_Type_Conversion
;
10918 -----------------------------------
10919 -- Expand_N_Unchecked_Expression --
10920 -----------------------------------
10922 -- Remove the unchecked expression node from the tree. Its job was simply
10923 -- to make sure that its constituent expression was handled with checks
10924 -- off, and now that that is done, we can remove it from the tree, and
10925 -- indeed must, since Gigi does not expect to see these nodes.
10927 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
10928 Exp
: constant Node_Id
:= Expression
(N
);
10930 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
10932 end Expand_N_Unchecked_Expression
;
10934 ----------------------------------------
10935 -- Expand_N_Unchecked_Type_Conversion --
10936 ----------------------------------------
10938 -- If this cannot be handled by Gigi and we haven't already made a
10939 -- temporary for it, do it now.
10941 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
10942 Target_Type
: constant Entity_Id
:= Etype
(N
);
10943 Operand
: constant Node_Id
:= Expression
(N
);
10944 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
10947 -- Nothing at all to do if conversion is to the identical type so remove
10948 -- the conversion completely, it is useless, except that it may carry
10949 -- an Assignment_OK indication which must be propagated to the operand.
10951 if Operand_Type
= Target_Type
then
10953 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
10955 if Assignment_OK
(N
) then
10956 Set_Assignment_OK
(Operand
);
10959 Rewrite
(N
, Relocate_Node
(Operand
));
10963 -- If we have a conversion of a compile time known value to a target
10964 -- type and the value is in range of the target type, then we can simply
10965 -- replace the construct by an integer literal of the correct type. We
10966 -- only apply this to integer types being converted. Possibly it may
10967 -- apply in other cases, but it is too much trouble to worry about.
10969 -- Note that we do not do this transformation if the Kill_Range_Check
10970 -- flag is set, since then the value may be outside the expected range.
10971 -- This happens in the Normalize_Scalars case.
10973 -- We also skip this if either the target or operand type is biased
10974 -- because in this case, the unchecked conversion is supposed to
10975 -- preserve the bit pattern, not the integer value.
10977 if Is_Integer_Type
(Target_Type
)
10978 and then not Has_Biased_Representation
(Target_Type
)
10979 and then Is_Integer_Type
(Operand_Type
)
10980 and then not Has_Biased_Representation
(Operand_Type
)
10981 and then Compile_Time_Known_Value
(Operand
)
10982 and then not Kill_Range_Check
(N
)
10985 Val
: constant Uint
:= Expr_Value
(Operand
);
10988 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
10990 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
10992 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
10994 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
10996 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
10998 -- If Address is the target type, just set the type to avoid a
10999 -- spurious type error on the literal when Address is a visible
11002 if Is_Descendent_Of_Address
(Target_Type
) then
11003 Set_Etype
(N
, Target_Type
);
11005 Analyze_And_Resolve
(N
, Target_Type
);
11013 -- Nothing to do if conversion is safe
11015 if Safe_Unchecked_Type_Conversion
(N
) then
11019 -- Otherwise force evaluation unless Assignment_OK flag is set (this
11020 -- flag indicates ??? More comments needed here)
11022 if Assignment_OK
(N
) then
11025 Force_Evaluation
(N
);
11027 end Expand_N_Unchecked_Type_Conversion
;
11029 ----------------------------
11030 -- Expand_Record_Equality --
11031 ----------------------------
11033 -- For non-variant records, Equality is expanded when needed into:
11035 -- and then Lhs.Discr1 = Rhs.Discr1
11037 -- and then Lhs.Discrn = Rhs.Discrn
11038 -- and then Lhs.Cmp1 = Rhs.Cmp1
11040 -- and then Lhs.Cmpn = Rhs.Cmpn
11042 -- The expression is folded by the back-end for adjacent fields. This
11043 -- function is called for tagged record in only one occasion: for imple-
11044 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11045 -- otherwise the primitive "=" is used directly.
11047 function Expand_Record_Equality
11052 Bodies
: List_Id
) return Node_Id
11054 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11059 First_Time
: Boolean := True;
11061 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
11062 -- Return the next discriminant or component to compare, starting with
11063 -- C, skipping inherited components.
11065 ------------------------
11066 -- Element_To_Compare --
11067 ------------------------
11069 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
11075 -- Exit loop when the next element to be compared is found, or
11076 -- there is no more such element.
11078 exit when No
(Comp
);
11080 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
11083 -- Skip inherited components
11085 -- Note: for a tagged type, we always generate the "=" primitive
11086 -- for the base type (not on the first subtype), so the test for
11087 -- Comp /= Original_Record_Component (Comp) is True for
11088 -- inherited components only.
11090 (Is_Tagged_Type
(Typ
)
11091 and then Comp
/= Original_Record_Component
(Comp
))
11095 or else Chars
(Comp
) = Name_uTag
11097 -- The .NET/JVM version of type Root_Controlled contains two
11098 -- fields which should not be considered part of the object. To
11099 -- achieve proper equiality between two controlled objects on
11100 -- .NET/JVM, skip _Parent whenever it has type Root_Controlled.
11102 or else (Chars
(Comp
) = Name_uParent
11103 and then VM_Target
/= No_VM
11104 and then Etype
(Comp
) = RTE
(RE_Root_Controlled
))
11106 -- Skip interface elements (secondary tags???)
11108 or else Is_Interface
(Etype
(Comp
)));
11110 Next_Entity
(Comp
);
11114 end Element_To_Compare
;
11116 -- Start of processing for Expand_Record_Equality
11119 -- Generates the following code: (assuming that Typ has one Discr and
11120 -- component C2 is also a record)
11123 -- and then Lhs.Discr1 = Rhs.Discr1
11124 -- and then Lhs.C1 = Rhs.C1
11125 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11127 -- and then Lhs.Cmpn = Rhs.Cmpn
11129 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
11130 C
:= Element_To_Compare
(First_Entity
(Typ
));
11131 while Present
(C
) loop
11139 First_Time
:= False;
11143 New_Lhs
:= New_Copy_Tree
(Lhs
);
11144 New_Rhs
:= New_Copy_Tree
(Rhs
);
11148 Expand_Composite_Equality
(Nod
, Etype
(C
),
11150 Make_Selected_Component
(Loc
,
11152 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11154 Make_Selected_Component
(Loc
,
11156 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11159 -- If some (sub)component is an unchecked_union, the whole
11160 -- operation will raise program error.
11162 if Nkind
(Check
) = N_Raise_Program_Error
then
11164 Set_Etype
(Result
, Standard_Boolean
);
11168 Make_And_Then
(Loc
,
11169 Left_Opnd
=> Result
,
11170 Right_Opnd
=> Check
);
11174 C
:= Element_To_Compare
(Next_Entity
(C
));
11178 end Expand_Record_Equality
;
11180 ---------------------------
11181 -- Expand_Set_Membership --
11182 ---------------------------
11184 procedure Expand_Set_Membership
(N
: Node_Id
) is
11185 Lop
: constant Node_Id
:= Left_Opnd
(N
);
11189 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
11190 -- If the alternative is a subtype mark, create a simple membership
11191 -- test. Otherwise create an equality test for it.
11197 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
11199 L
: constant Node_Id
:= New_Copy
(Lop
);
11200 R
: constant Node_Id
:= Relocate_Node
(Alt
);
11203 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
11204 or else Nkind
(Alt
) = N_Range
11207 Make_In
(Sloc
(Alt
),
11212 Make_Op_Eq
(Sloc
(Alt
),
11220 -- Start of processing for Expand_Set_Membership
11223 Remove_Side_Effects
(Lop
);
11225 Alt
:= Last
(Alternatives
(N
));
11226 Res
:= Make_Cond
(Alt
);
11229 while Present
(Alt
) loop
11231 Make_Or_Else
(Sloc
(Alt
),
11232 Left_Opnd
=> Make_Cond
(Alt
),
11233 Right_Opnd
=> Res
);
11238 Analyze_And_Resolve
(N
, Standard_Boolean
);
11239 end Expand_Set_Membership
;
11241 -----------------------------------
11242 -- Expand_Short_Circuit_Operator --
11243 -----------------------------------
11245 -- Deal with special expansion if actions are present for the right operand
11246 -- and deal with optimizing case of arguments being True or False. We also
11247 -- deal with the special case of non-standard boolean values.
11249 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
11250 Loc
: constant Source_Ptr
:= Sloc
(N
);
11251 Typ
: constant Entity_Id
:= Etype
(N
);
11252 Left
: constant Node_Id
:= Left_Opnd
(N
);
11253 Right
: constant Node_Id
:= Right_Opnd
(N
);
11254 LocR
: constant Source_Ptr
:= Sloc
(Right
);
11257 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
11258 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
11259 -- If Left = Shortcut_Value then Right need not be evaluated
11262 -- Deal with non-standard booleans
11264 if Is_Boolean_Type
(Typ
) then
11265 Adjust_Condition
(Left
);
11266 Adjust_Condition
(Right
);
11267 Set_Etype
(N
, Standard_Boolean
);
11270 -- Check for cases where left argument is known to be True or False
11272 if Compile_Time_Known_Value
(Left
) then
11274 -- Mark SCO for left condition as compile time known
11276 if Generate_SCO
and then Comes_From_Source
(Left
) then
11277 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
11280 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11281 -- Any actions associated with Right will be executed unconditionally
11282 -- and can thus be inserted into the tree unconditionally.
11284 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
11285 if Present
(Actions
(N
)) then
11286 Insert_Actions
(N
, Actions
(N
));
11289 Rewrite
(N
, Right
);
11291 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11292 -- In this case we can forget the actions associated with Right,
11293 -- since they will never be executed.
11296 Kill_Dead_Code
(Right
);
11297 Kill_Dead_Code
(Actions
(N
));
11298 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11301 Adjust_Result_Type
(N
, Typ
);
11305 -- If Actions are present for the right operand, we have to do some
11306 -- special processing. We can't just let these actions filter back into
11307 -- code preceding the short circuit (which is what would have happened
11308 -- if we had not trapped them in the short-circuit form), since they
11309 -- must only be executed if the right operand of the short circuit is
11310 -- executed and not otherwise.
11312 if Present
(Actions
(N
)) then
11313 Actlist
:= Actions
(N
);
11315 -- We now use an Expression_With_Actions node for the right operand
11316 -- of the short-circuit form. Note that this solves the traceability
11317 -- problems for coverage analysis.
11320 Make_Expression_With_Actions
(LocR
,
11321 Expression
=> Relocate_Node
(Right
),
11322 Actions
=> Actlist
));
11323 Set_Actions
(N
, No_List
);
11324 Analyze_And_Resolve
(Right
, Standard_Boolean
);
11326 Adjust_Result_Type
(N
, Typ
);
11330 -- No actions present, check for cases of right argument True/False
11332 if Compile_Time_Known_Value
(Right
) then
11334 -- Mark SCO for left condition as compile time known
11336 if Generate_SCO
and then Comes_From_Source
(Right
) then
11337 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
11340 -- Change (Left and then True), (Left or else False) to Left.
11341 -- Note that we know there are no actions associated with the right
11342 -- operand, since we just checked for this case above.
11344 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
11347 -- Change (Left and then False), (Left or else True) to Right,
11348 -- making sure to preserve any side effects associated with the Left
11352 Remove_Side_Effects
(Left
);
11353 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11357 Adjust_Result_Type
(N
, Typ
);
11358 end Expand_Short_Circuit_Operator
;
11360 -------------------------------------
11361 -- Fixup_Universal_Fixed_Operation --
11362 -------------------------------------
11364 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
11365 Conv
: constant Node_Id
:= Parent
(N
);
11368 -- We must have a type conversion immediately above us
11370 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
11372 -- Normally the type conversion gives our target type. The exception
11373 -- occurs in the case of the Round attribute, where the conversion
11374 -- will be to universal real, and our real type comes from the Round
11375 -- attribute (as well as an indication that we must round the result)
11377 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
11378 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
11380 Set_Etype
(N
, Etype
(Parent
(Conv
)));
11381 Set_Rounded_Result
(N
);
11383 -- Normal case where type comes from conversion above us
11386 Set_Etype
(N
, Etype
(Conv
));
11388 end Fixup_Universal_Fixed_Operation
;
11390 ---------------------------------
11391 -- Has_Inferable_Discriminants --
11392 ---------------------------------
11394 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
11396 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
11397 -- Determines whether the left-most prefix of a selected component is a
11398 -- formal parameter in a subprogram. Assumes N is a selected component.
11400 --------------------------------
11401 -- Prefix_Is_Formal_Parameter --
11402 --------------------------------
11404 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
11405 Sel_Comp
: Node_Id
;
11408 -- Move to the left-most prefix by climbing up the tree
11411 while Present
(Parent
(Sel_Comp
))
11412 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
11414 Sel_Comp
:= Parent
(Sel_Comp
);
11417 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
11418 end Prefix_Is_Formal_Parameter
;
11420 -- Start of processing for Has_Inferable_Discriminants
11423 -- For selected components, the subtype of the selector must be a
11424 -- constrained Unchecked_Union. If the component is subject to a
11425 -- per-object constraint, then the enclosing object must have inferable
11428 if Nkind
(N
) = N_Selected_Component
then
11429 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
11431 -- A small hack. If we have a per-object constrained selected
11432 -- component of a formal parameter, return True since we do not
11433 -- know the actual parameter association yet.
11435 if Prefix_Is_Formal_Parameter
(N
) then
11438 -- Otherwise, check the enclosing object and the selector
11441 return Has_Inferable_Discriminants
(Prefix
(N
))
11442 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
11445 -- The call to Has_Inferable_Discriminants will determine whether
11446 -- the selector has a constrained Unchecked_Union nominal type.
11449 return Has_Inferable_Discriminants
(Selector_Name
(N
));
11452 -- A qualified expression has inferable discriminants if its subtype
11453 -- mark is a constrained Unchecked_Union subtype.
11455 elsif Nkind
(N
) = N_Qualified_Expression
then
11456 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
11457 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
11459 -- For all other names, it is sufficient to have a constrained
11460 -- Unchecked_Union nominal subtype.
11463 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
11464 and then Is_Constrained
(Etype
(N
));
11466 end Has_Inferable_Discriminants
;
11468 -------------------------------
11469 -- Insert_Dereference_Action --
11470 -------------------------------
11472 procedure Insert_Dereference_Action
(N
: Node_Id
) is
11474 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
11475 -- Return true if type of P is derived from Checked_Pool;
11477 -----------------------------
11478 -- Is_Checked_Storage_Pool --
11479 -----------------------------
11481 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
11490 while T
/= Etype
(T
) loop
11491 if Is_RTE
(T
, RE_Checked_Pool
) then
11499 end Is_Checked_Storage_Pool
;
11503 Typ
: constant Entity_Id
:= Etype
(N
);
11504 Desig
: constant Entity_Id
:= Available_View
(Designated_Type
(Typ
));
11505 Loc
: constant Source_Ptr
:= Sloc
(N
);
11506 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
11507 Pnod
: constant Node_Id
:= Parent
(N
);
11515 -- Start of processing for Insert_Dereference_Action
11518 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
11520 -- Do not re-expand a dereference which has already been processed by
11523 if Has_Dereference_Action
(Pnod
) then
11526 -- Do not perform this type of expansion for internally-generated
11529 elsif not Comes_From_Source
(Original_Node
(Pnod
)) then
11532 -- A dereference action is only applicable to objects which have been
11533 -- allocated on a checked pool.
11535 elsif not Is_Checked_Storage_Pool
(Pool
) then
11539 -- Extract the address of the dereferenced object. Generate:
11541 -- Addr : System.Address := <N>'Pool_Address;
11543 Addr
:= Make_Temporary
(Loc
, 'P');
11546 Make_Object_Declaration
(Loc
,
11547 Defining_Identifier
=> Addr
,
11548 Object_Definition
=>
11549 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
11551 Make_Attribute_Reference
(Loc
,
11552 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
11553 Attribute_Name
=> Name_Pool_Address
)));
11555 -- Calculate the size of the dereferenced object. Generate:
11557 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11560 Make_Explicit_Dereference
(Loc
,
11561 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11562 Set_Has_Dereference_Action
(Deref
);
11564 Size
:= Make_Temporary
(Loc
, 'S');
11567 Make_Object_Declaration
(Loc
,
11568 Defining_Identifier
=> Size
,
11570 Object_Definition
=>
11571 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
11574 Make_Op_Divide
(Loc
,
11576 Make_Attribute_Reference
(Loc
,
11578 Attribute_Name
=> Name_Size
),
11580 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
11582 -- Calculate the alignment of the dereferenced object. Generate:
11583 -- Alig : constant Storage_Count := <N>.all'Alignment;
11586 Make_Explicit_Dereference
(Loc
,
11587 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11588 Set_Has_Dereference_Action
(Deref
);
11590 Alig
:= Make_Temporary
(Loc
, 'A');
11593 Make_Object_Declaration
(Loc
,
11594 Defining_Identifier
=> Alig
,
11595 Object_Definition
=>
11596 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
11598 Make_Attribute_Reference
(Loc
,
11600 Attribute_Name
=> Name_Alignment
)));
11602 -- A dereference of a controlled object requires special processing. The
11603 -- finalization machinery requests additional space from the underlying
11604 -- pool to allocate and hide two pointers. As a result, a checked pool
11605 -- may mark the wrong memory as valid. Since checked pools do not have
11606 -- knowledge of hidden pointers, we have to bring the two pointers back
11607 -- in view in order to restore the original state of the object.
11609 if Needs_Finalization
(Desig
) then
11611 -- Adjust the address and size of the dereferenced object. Generate:
11612 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11615 Make_Procedure_Call_Statement
(Loc
,
11617 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
11618 Parameter_Associations
=> New_List
(
11619 New_Occurrence_Of
(Addr
, Loc
),
11620 New_Occurrence_Of
(Size
, Loc
),
11621 New_Occurrence_Of
(Alig
, Loc
)));
11623 -- Class-wide types complicate things because we cannot determine
11624 -- statically whether the actual object is truly controlled. We must
11625 -- generate a runtime check to detect this property. Generate:
11627 -- if Needs_Finalization (<N>.all'Tag) then
11631 if Is_Class_Wide_Type
(Desig
) then
11633 Make_Explicit_Dereference
(Loc
,
11634 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11635 Set_Has_Dereference_Action
(Deref
);
11638 Make_Implicit_If_Statement
(N
,
11640 Make_Function_Call
(Loc
,
11642 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
11643 Parameter_Associations
=> New_List
(
11644 Make_Attribute_Reference
(Loc
,
11646 Attribute_Name
=> Name_Tag
))),
11647 Then_Statements
=> New_List
(Stmt
));
11650 Insert_Action
(N
, Stmt
);
11654 -- Dereference (Pool, Addr, Size, Alig);
11657 Make_Procedure_Call_Statement
(Loc
,
11660 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
11661 Parameter_Associations
=> New_List
(
11662 New_Occurrence_Of
(Pool
, Loc
),
11663 New_Occurrence_Of
(Addr
, Loc
),
11664 New_Occurrence_Of
(Size
, Loc
),
11665 New_Occurrence_Of
(Alig
, Loc
))));
11667 -- Mark the explicit dereference as processed to avoid potential
11668 -- infinite expansion.
11670 Set_Has_Dereference_Action
(Pnod
);
11673 when RE_Not_Available
=>
11675 end Insert_Dereference_Action
;
11677 --------------------------------
11678 -- Integer_Promotion_Possible --
11679 --------------------------------
11681 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
11682 Operand
: constant Node_Id
:= Expression
(N
);
11683 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11684 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
11687 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
11691 -- We only do the transformation for source constructs. We assume
11692 -- that the expander knows what it is doing when it generates code.
11694 Comes_From_Source
(N
)
11696 -- If the operand type is Short_Integer or Short_Short_Integer,
11697 -- then we will promote to Integer, which is available on all
11698 -- targets, and is sufficient to ensure no intermediate overflow.
11699 -- Furthermore it is likely to be as efficient or more efficient
11700 -- than using the smaller type for the computation so we do this
11701 -- unconditionally.
11704 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
11706 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
11708 -- Test for interesting operation, which includes addition,
11709 -- division, exponentiation, multiplication, subtraction, absolute
11710 -- value and unary negation. Unary "+" is omitted since it is a
11711 -- no-op and thus can't overflow.
11713 and then Nkind_In
(Operand
, N_Op_Abs
,
11720 end Integer_Promotion_Possible
;
11722 ------------------------------
11723 -- Make_Array_Comparison_Op --
11724 ------------------------------
11726 -- This is a hand-coded expansion of the following generic function:
11729 -- type elem is (<>);
11730 -- type index is (<>);
11731 -- type a is array (index range <>) of elem;
11733 -- function Gnnn (X : a; Y: a) return boolean is
11734 -- J : index := Y'first;
11737 -- if X'length = 0 then
11740 -- elsif Y'length = 0 then
11744 -- for I in X'range loop
11745 -- if X (I) = Y (J) then
11746 -- if J = Y'last then
11749 -- J := index'succ (J);
11753 -- return X (I) > Y (J);
11757 -- return X'length > Y'length;
11761 -- Note that since we are essentially doing this expansion by hand, we
11762 -- do not need to generate an actual or formal generic part, just the
11763 -- instantiated function itself.
11765 function Make_Array_Comparison_Op
11767 Nod
: Node_Id
) return Node_Id
11769 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11771 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
11772 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
11773 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
11774 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
11776 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
11778 Loop_Statement
: Node_Id
;
11779 Loop_Body
: Node_Id
;
11781 Inner_If
: Node_Id
;
11782 Final_Expr
: Node_Id
;
11783 Func_Body
: Node_Id
;
11784 Func_Name
: Entity_Id
;
11790 -- if J = Y'last then
11793 -- J := index'succ (J);
11797 Make_Implicit_If_Statement
(Nod
,
11800 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
11802 Make_Attribute_Reference
(Loc
,
11803 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
11804 Attribute_Name
=> Name_Last
)),
11806 Then_Statements
=> New_List
(
11807 Make_Exit_Statement
(Loc
)),
11811 Make_Assignment_Statement
(Loc
,
11812 Name
=> New_Occurrence_Of
(J
, Loc
),
11814 Make_Attribute_Reference
(Loc
,
11815 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
11816 Attribute_Name
=> Name_Succ
,
11817 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
11819 -- if X (I) = Y (J) then
11822 -- return X (I) > Y (J);
11826 Make_Implicit_If_Statement
(Nod
,
11830 Make_Indexed_Component
(Loc
,
11831 Prefix
=> New_Occurrence_Of
(X
, Loc
),
11832 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
11835 Make_Indexed_Component
(Loc
,
11836 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
11837 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
11839 Then_Statements
=> New_List
(Inner_If
),
11841 Else_Statements
=> New_List
(
11842 Make_Simple_Return_Statement
(Loc
,
11846 Make_Indexed_Component
(Loc
,
11847 Prefix
=> New_Occurrence_Of
(X
, Loc
),
11848 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
11851 Make_Indexed_Component
(Loc
,
11852 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
11853 Expressions
=> New_List
(
11854 New_Occurrence_Of
(J
, Loc
)))))));
11856 -- for I in X'range loop
11861 Make_Implicit_Loop_Statement
(Nod
,
11862 Identifier
=> Empty
,
11864 Iteration_Scheme
=>
11865 Make_Iteration_Scheme
(Loc
,
11866 Loop_Parameter_Specification
=>
11867 Make_Loop_Parameter_Specification
(Loc
,
11868 Defining_Identifier
=> I
,
11869 Discrete_Subtype_Definition
=>
11870 Make_Attribute_Reference
(Loc
,
11871 Prefix
=> New_Occurrence_Of
(X
, Loc
),
11872 Attribute_Name
=> Name_Range
))),
11874 Statements
=> New_List
(Loop_Body
));
11876 -- if X'length = 0 then
11878 -- elsif Y'length = 0 then
11881 -- for ... loop ... end loop;
11882 -- return X'length > Y'length;
11886 Make_Attribute_Reference
(Loc
,
11887 Prefix
=> New_Occurrence_Of
(X
, Loc
),
11888 Attribute_Name
=> Name_Length
);
11891 Make_Attribute_Reference
(Loc
,
11892 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
11893 Attribute_Name
=> Name_Length
);
11897 Left_Opnd
=> Length1
,
11898 Right_Opnd
=> Length2
);
11901 Make_Implicit_If_Statement
(Nod
,
11905 Make_Attribute_Reference
(Loc
,
11906 Prefix
=> New_Occurrence_Of
(X
, Loc
),
11907 Attribute_Name
=> Name_Length
),
11909 Make_Integer_Literal
(Loc
, 0)),
11913 Make_Simple_Return_Statement
(Loc
,
11914 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
11916 Elsif_Parts
=> New_List
(
11917 Make_Elsif_Part
(Loc
,
11921 Make_Attribute_Reference
(Loc
,
11922 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
11923 Attribute_Name
=> Name_Length
),
11925 Make_Integer_Literal
(Loc
, 0)),
11929 Make_Simple_Return_Statement
(Loc
,
11930 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
11932 Else_Statements
=> New_List
(
11934 Make_Simple_Return_Statement
(Loc
,
11935 Expression
=> Final_Expr
)));
11939 Formals
:= New_List
(
11940 Make_Parameter_Specification
(Loc
,
11941 Defining_Identifier
=> X
,
11942 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
11944 Make_Parameter_Specification
(Loc
,
11945 Defining_Identifier
=> Y
,
11946 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
11948 -- function Gnnn (...) return boolean is
11949 -- J : index := Y'first;
11954 Func_Name
:= Make_Temporary
(Loc
, 'G');
11957 Make_Subprogram_Body
(Loc
,
11959 Make_Function_Specification
(Loc
,
11960 Defining_Unit_Name
=> Func_Name
,
11961 Parameter_Specifications
=> Formals
,
11962 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
11964 Declarations
=> New_List
(
11965 Make_Object_Declaration
(Loc
,
11966 Defining_Identifier
=> J
,
11967 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
11969 Make_Attribute_Reference
(Loc
,
11970 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
11971 Attribute_Name
=> Name_First
))),
11973 Handled_Statement_Sequence
=>
11974 Make_Handled_Sequence_Of_Statements
(Loc
,
11975 Statements
=> New_List
(If_Stat
)));
11978 end Make_Array_Comparison_Op
;
11980 ---------------------------
11981 -- Make_Boolean_Array_Op --
11982 ---------------------------
11984 -- For logical operations on boolean arrays, expand in line the following,
11985 -- replacing 'and' with 'or' or 'xor' where needed:
11987 -- function Annn (A : typ; B: typ) return typ is
11990 -- for J in A'range loop
11991 -- C (J) := A (J) op B (J);
11996 -- Here typ is the boolean array type
11998 function Make_Boolean_Array_Op
12000 N
: Node_Id
) return Node_Id
12002 Loc
: constant Source_Ptr
:= Sloc
(N
);
12004 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
12005 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12006 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
12007 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12015 Func_Name
: Entity_Id
;
12016 Func_Body
: Node_Id
;
12017 Loop_Statement
: Node_Id
;
12021 Make_Indexed_Component
(Loc
,
12022 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12023 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12026 Make_Indexed_Component
(Loc
,
12027 Prefix
=> New_Occurrence_Of
(B
, Loc
),
12028 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12031 Make_Indexed_Component
(Loc
,
12032 Prefix
=> New_Occurrence_Of
(C
, Loc
),
12033 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12035 if Nkind
(N
) = N_Op_And
then
12039 Right_Opnd
=> B_J
);
12041 elsif Nkind
(N
) = N_Op_Or
then
12045 Right_Opnd
=> B_J
);
12051 Right_Opnd
=> B_J
);
12055 Make_Implicit_Loop_Statement
(N
,
12056 Identifier
=> Empty
,
12058 Iteration_Scheme
=>
12059 Make_Iteration_Scheme
(Loc
,
12060 Loop_Parameter_Specification
=>
12061 Make_Loop_Parameter_Specification
(Loc
,
12062 Defining_Identifier
=> J
,
12063 Discrete_Subtype_Definition
=>
12064 Make_Attribute_Reference
(Loc
,
12065 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12066 Attribute_Name
=> Name_Range
))),
12068 Statements
=> New_List
(
12069 Make_Assignment_Statement
(Loc
,
12071 Expression
=> Op
)));
12073 Formals
:= New_List
(
12074 Make_Parameter_Specification
(Loc
,
12075 Defining_Identifier
=> A
,
12076 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12078 Make_Parameter_Specification
(Loc
,
12079 Defining_Identifier
=> B
,
12080 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12082 Func_Name
:= Make_Temporary
(Loc
, 'A');
12083 Set_Is_Inlined
(Func_Name
);
12086 Make_Subprogram_Body
(Loc
,
12088 Make_Function_Specification
(Loc
,
12089 Defining_Unit_Name
=> Func_Name
,
12090 Parameter_Specifications
=> Formals
,
12091 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
12093 Declarations
=> New_List
(
12094 Make_Object_Declaration
(Loc
,
12095 Defining_Identifier
=> C
,
12096 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
12098 Handled_Statement_Sequence
=>
12099 Make_Handled_Sequence_Of_Statements
(Loc
,
12100 Statements
=> New_List
(
12102 Make_Simple_Return_Statement
(Loc
,
12103 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
12106 end Make_Boolean_Array_Op
;
12108 -----------------------------------------
12109 -- Minimized_Eliminated_Overflow_Check --
12110 -----------------------------------------
12112 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
12115 Is_Signed_Integer_Type
(Etype
(N
))
12116 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
12117 end Minimized_Eliminated_Overflow_Check
;
12119 --------------------------------
12120 -- Optimize_Length_Comparison --
12121 --------------------------------
12123 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
12124 Loc
: constant Source_Ptr
:= Sloc
(N
);
12125 Typ
: constant Entity_Id
:= Etype
(N
);
12130 -- First and Last attribute reference nodes, which end up as left and
12131 -- right operands of the optimized result.
12134 -- True for comparison operand of zero
12137 -- Comparison operand, set only if Is_Zero is false
12140 -- Entity whose length is being compared
12143 -- Integer_Literal node for length attribute expression, or Empty
12144 -- if there is no such expression present.
12147 -- Type of array index to which 'Length is applied
12149 Op
: Node_Kind
:= Nkind
(N
);
12150 -- Kind of comparison operator, gets flipped if operands backwards
12152 function Is_Optimizable
(N
: Node_Id
) return Boolean;
12153 -- Tests N to see if it is an optimizable comparison value (defined as
12154 -- constant zero or one, or something else where the value is known to
12155 -- be positive and in the range of 32-bits, and where the corresponding
12156 -- Length value is also known to be 32-bits. If result is true, sets
12157 -- Is_Zero, Ityp, and Comp accordingly.
12159 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
12160 -- Tests if N is a length attribute applied to a simple entity. If so,
12161 -- returns True, and sets Ent to the entity, and Index to the integer
12162 -- literal provided as an attribute expression, or to Empty if none.
12163 -- Also returns True if the expression is a generated type conversion
12164 -- whose expression is of the desired form. This latter case arises
12165 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12166 -- to check for being in range, which is not needed in this context.
12167 -- Returns False if neither condition holds.
12169 function Prepare_64
(N
: Node_Id
) return Node_Id
;
12170 -- Given a discrete expression, returns a Long_Long_Integer typed
12171 -- expression representing the underlying value of the expression.
12172 -- This is done with an unchecked conversion to the result type. We
12173 -- use unchecked conversion to handle the enumeration type case.
12175 ----------------------
12176 -- Is_Entity_Length --
12177 ----------------------
12179 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
12181 if Nkind
(N
) = N_Attribute_Reference
12182 and then Attribute_Name
(N
) = Name_Length
12183 and then Is_Entity_Name
(Prefix
(N
))
12185 Ent
:= Entity
(Prefix
(N
));
12187 if Present
(Expressions
(N
)) then
12188 Index
:= First
(Expressions
(N
));
12195 elsif Nkind
(N
) = N_Type_Conversion
12196 and then not Comes_From_Source
(N
)
12198 return Is_Entity_Length
(Expression
(N
));
12203 end Is_Entity_Length
;
12205 --------------------
12206 -- Is_Optimizable --
12207 --------------------
12209 function Is_Optimizable
(N
: Node_Id
) return Boolean is
12217 if Compile_Time_Known_Value
(N
) then
12218 Val
:= Expr_Value
(N
);
12220 if Val
= Uint_0
then
12225 elsif Val
= Uint_1
then
12232 -- Here we have to make sure of being within 32-bits
12234 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12237 or else Lo
< Uint_1
12238 or else Hi
> UI_From_Int
(Int
'Last)
12243 -- Comparison value was within range, so now we must check the index
12244 -- value to make sure it is also within 32-bits.
12246 Indx
:= First_Index
(Etype
(Ent
));
12248 if Present
(Index
) then
12249 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
12254 Ityp
:= Etype
(Indx
);
12256 if Esize
(Ityp
) > 32 then
12263 end Is_Optimizable
;
12269 function Prepare_64
(N
: Node_Id
) return Node_Id
is
12271 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
12274 -- Start of processing for Optimize_Length_Comparison
12277 -- Nothing to do if not a comparison
12279 if Op
not in N_Op_Compare
then
12283 -- Nothing to do if special -gnatd.P debug flag set
12285 if Debug_Flag_Dot_PP
then
12289 -- Ent'Length op 0/1
12291 if Is_Entity_Length
(Left_Opnd
(N
))
12292 and then Is_Optimizable
(Right_Opnd
(N
))
12296 -- 0/1 op Ent'Length
12298 elsif Is_Entity_Length
(Right_Opnd
(N
))
12299 and then Is_Optimizable
(Left_Opnd
(N
))
12301 -- Flip comparison to opposite sense
12304 when N_Op_Lt
=> Op
:= N_Op_Gt
;
12305 when N_Op_Le
=> Op
:= N_Op_Ge
;
12306 when N_Op_Gt
=> Op
:= N_Op_Lt
;
12307 when N_Op_Ge
=> Op
:= N_Op_Le
;
12308 when others => null;
12311 -- Else optimization not possible
12317 -- Fall through if we will do the optimization
12319 -- Cases to handle:
12321 -- X'Length = 0 => X'First > X'Last
12322 -- X'Length = 1 => X'First = X'Last
12323 -- X'Length = n => X'First + (n - 1) = X'Last
12325 -- X'Length /= 0 => X'First <= X'Last
12326 -- X'Length /= 1 => X'First /= X'Last
12327 -- X'Length /= n => X'First + (n - 1) /= X'Last
12329 -- X'Length >= 0 => always true, warn
12330 -- X'Length >= 1 => X'First <= X'Last
12331 -- X'Length >= n => X'First + (n - 1) <= X'Last
12333 -- X'Length > 0 => X'First <= X'Last
12334 -- X'Length > 1 => X'First < X'Last
12335 -- X'Length > n => X'First + (n - 1) < X'Last
12337 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12338 -- X'Length <= 1 => X'First >= X'Last
12339 -- X'Length <= n => X'First + (n - 1) >= X'Last
12341 -- X'Length < 0 => always false (warn)
12342 -- X'Length < 1 => X'First > X'Last
12343 -- X'Length < n => X'First + (n - 1) > X'Last
12345 -- Note: for the cases of n (not constant 0,1), we require that the
12346 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12347 -- and the same for the comparison value. Then we do the comparison
12348 -- using 64-bit arithmetic (actually long long integer), so that we
12349 -- cannot have overflow intefering with the result.
12351 -- First deal with warning cases
12360 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
12361 Analyze_And_Resolve
(N
, Typ
);
12362 Warn_On_Known_Condition
(N
);
12369 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
12370 Analyze_And_Resolve
(N
, Typ
);
12371 Warn_On_Known_Condition
(N
);
12375 if Constant_Condition_Warnings
12376 and then Comes_From_Source
(Original_Node
(N
))
12378 Error_Msg_N
("could replace by ""'=""?c?", N
);
12388 -- Build the First reference we will use
12391 Make_Attribute_Reference
(Loc
,
12392 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12393 Attribute_Name
=> Name_First
);
12395 if Present
(Index
) then
12396 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
12399 -- If general value case, then do the addition of (n - 1), and
12400 -- also add the needed conversions to type Long_Long_Integer.
12402 if Present
(Comp
) then
12405 Left_Opnd
=> Prepare_64
(Left
),
12407 Make_Op_Subtract
(Loc
,
12408 Left_Opnd
=> Prepare_64
(Comp
),
12409 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
12412 -- Build the Last reference we will use
12415 Make_Attribute_Reference
(Loc
,
12416 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12417 Attribute_Name
=> Name_Last
);
12419 if Present
(Index
) then
12420 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
12423 -- If general operand, convert Last reference to Long_Long_Integer
12425 if Present
(Comp
) then
12426 Right
:= Prepare_64
(Right
);
12429 -- Check for cases to optimize
12431 -- X'Length = 0 => X'First > X'Last
12432 -- X'Length < 1 => X'First > X'Last
12433 -- X'Length < n => X'First + (n - 1) > X'Last
12435 if (Is_Zero
and then Op
= N_Op_Eq
)
12436 or else (not Is_Zero
and then Op
= N_Op_Lt
)
12441 Right_Opnd
=> Right
);
12443 -- X'Length = 1 => X'First = X'Last
12444 -- X'Length = n => X'First + (n - 1) = X'Last
12446 elsif not Is_Zero
and then Op
= N_Op_Eq
then
12450 Right_Opnd
=> Right
);
12452 -- X'Length /= 0 => X'First <= X'Last
12453 -- X'Length > 0 => X'First <= X'Last
12455 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
12459 Right_Opnd
=> Right
);
12461 -- X'Length /= 1 => X'First /= X'Last
12462 -- X'Length /= n => X'First + (n - 1) /= X'Last
12464 elsif not Is_Zero
and then Op
= N_Op_Ne
then
12468 Right_Opnd
=> Right
);
12470 -- X'Length >= 1 => X'First <= X'Last
12471 -- X'Length >= n => X'First + (n - 1) <= X'Last
12473 elsif not Is_Zero
and then Op
= N_Op_Ge
then
12477 Right_Opnd
=> Right
);
12479 -- X'Length > 1 => X'First < X'Last
12480 -- X'Length > n => X'First + (n = 1) < X'Last
12482 elsif not Is_Zero
and then Op
= N_Op_Gt
then
12486 Right_Opnd
=> Right
);
12488 -- X'Length <= 1 => X'First >= X'Last
12489 -- X'Length <= n => X'First + (n - 1) >= X'Last
12491 elsif not Is_Zero
and then Op
= N_Op_Le
then
12495 Right_Opnd
=> Right
);
12497 -- Should not happen at this stage
12500 raise Program_Error
;
12503 -- Rewrite and finish up
12505 Rewrite
(N
, Result
);
12506 Analyze_And_Resolve
(N
, Typ
);
12508 end Optimize_Length_Comparison
;
12510 ------------------------------
12511 -- Process_Transient_Object --
12512 ------------------------------
12514 procedure Process_Transient_Object
12516 Rel_Node
: Node_Id
)
12518 Hook_Context
: Node_Id
;
12519 -- Node on which to insert the hook pointer (as an action)
12521 Finalization_Context
: Node_Id
;
12522 -- Node after which to insert finalization actions
12524 Finalize_Always
: Boolean;
12525 -- If False, call to finalizer includes a test of whether the
12526 -- hook pointer is null.
12528 procedure Find_Enclosing_Contexts
(N
: Node_Id
);
12529 -- Find the logical context where N appears, and initializae
12530 -- Hook_Context and Finalization_Context accordingly. Also
12531 -- sets Finalize_Always.
12533 -----------------------------
12534 -- Find_Enclosing_Contexts --
12535 -----------------------------
12537 procedure Find_Enclosing_Contexts
(N
: Node_Id
) is
12541 Wrapped_Node
: Node_Id
;
12542 -- Note: if we are in a transient scope, we want to reuse it as
12543 -- the context for actions insertion, if possible. But if N is itself
12544 -- part of the stored actions for the current transient scope,
12545 -- then we need to insert at the appropriate (inner) location in
12546 -- the not as an action on Node_To_Be_Wrapped.
12548 In_Cond_Expr
: constant Boolean := Within_Case_Or_If_Expression
(N
);
12551 -- When the node is inside a case/if expression, the lifetime of any
12552 -- temporary controlled object is extended. Find a suitable insertion
12553 -- node by locating the topmost case or if expressions.
12555 if In_Cond_Expr
then
12558 while Present
(Par
) loop
12559 if Nkind_In
(Original_Node
(Par
), N_Case_Expression
,
12564 -- Prevent the search from going too far
12566 elsif Is_Body_Or_Package_Declaration
(Par
) then
12570 Par
:= Parent
(Par
);
12573 -- The topmost case or if expression is now recovered, but it may
12574 -- still not be the correct place to add generated code. Climb to
12575 -- find a parent that is part of a declarative or statement list,
12576 -- and is not a list of actuals in a call.
12579 while Present
(Par
) loop
12580 if Is_List_Member
(Par
)
12581 and then not Nkind_In
(Par
, N_Component_Association
,
12582 N_Discriminant_Association
,
12583 N_Parameter_Association
,
12584 N_Pragma_Argument_Association
)
12585 and then not Nkind_In
12586 (Parent
(Par
), N_Function_Call
,
12587 N_Procedure_Call_Statement
,
12588 N_Entry_Call_Statement
)
12591 Hook_Context
:= Par
;
12592 goto Hook_Context_Found
;
12594 -- Prevent the search from going too far
12596 elsif Is_Body_Or_Package_Declaration
(Par
) then
12600 Par
:= Parent
(Par
);
12603 Hook_Context
:= Par
;
12604 goto Hook_Context_Found
;
12608 while Present
(Par
) loop
12610 -- Keep climbing past various operators
12612 if Nkind
(Parent
(Par
)) in N_Op
12613 or else Nkind_In
(Parent
(Par
), N_And_Then
, N_Or_Else
)
12615 Par
:= Parent
(Par
);
12623 -- The node may be located in a pragma in which case return the
12626 -- pragma Precondition (... and then Ctrl_Func_Call ...);
12628 -- Similar case occurs when the node is related to an object
12629 -- declaration or assignment:
12631 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
12633 -- Another case to consider is when the node is part of a return
12636 -- return ... and then Ctrl_Func_Call ...;
12638 -- Another case is when the node acts as a formal in a procedure
12641 -- Proc (... and then Ctrl_Func_Call ...);
12643 if Scope_Is_Transient
then
12644 Wrapped_Node
:= Node_To_Be_Wrapped
;
12646 Wrapped_Node
:= Empty
;
12649 while Present
(Par
) loop
12650 if Par
= Wrapped_Node
12651 or else Nkind_In
(Par
, N_Assignment_Statement
,
12652 N_Object_Declaration
,
12654 N_Procedure_Call_Statement
,
12655 N_Simple_Return_Statement
)
12657 Hook_Context
:= Par
;
12658 goto Hook_Context_Found
;
12660 -- Prevent the search from going too far
12662 elsif Is_Body_Or_Package_Declaration
(Par
) then
12666 Par
:= Parent
(Par
);
12669 -- Return the topmost short circuit operator
12671 Hook_Context
:= Top
;
12674 <<Hook_Context_Found
>>
12676 -- Special case for Boolean EWAs: capture expression in a temporary,
12677 -- whose declaration will serve as the context around which to insert
12678 -- finalization code. The finalization thus remains local to the
12679 -- specific condition being evaluated.
12681 if Is_Boolean_Type
(Etype
(N
)) then
12683 -- In this case, the finalization context is chosen so that
12684 -- we know at finalization point that the hook pointer is
12685 -- never null, so no need for a test, we can call the finalizer
12686 -- unconditionally, except in the case where the object is
12687 -- created in a specific branch of a conditional expression.
12692 Nkind_In
(Original_Node
(N
), N_Case_Expression
,
12696 Loc
: constant Source_Ptr
:= Sloc
(N
);
12697 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
12700 Append_To
(Actions
(N
),
12701 Make_Object_Declaration
(Loc
,
12702 Defining_Identifier
=> Temp
,
12703 Constant_Present
=> True,
12704 Object_Definition
=>
12705 New_Occurrence_Of
(Etype
(N
), Loc
),
12706 Expression
=> Expression
(N
)));
12707 Finalization_Context
:= Last
(Actions
(N
));
12709 Analyze
(Last
(Actions
(N
)));
12711 Set_Expression
(N
, New_Occurrence_Of
(Temp
, Loc
));
12712 Analyze
(Expression
(N
));
12716 Finalize_Always
:= False;
12717 Finalization_Context
:= Hook_Context
;
12719 end Find_Enclosing_Contexts
;
12723 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
12724 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
12725 Obj_Typ
: constant Node_Id
:= Etype
(Obj_Id
);
12726 Desig_Typ
: Entity_Id
;
12728 Fin_Stmts
: List_Id
;
12729 Ptr_Id
: Entity_Id
;
12730 Temp_Id
: Entity_Id
;
12731 Temp_Ins
: Node_Id
;
12733 -- Start of processing for Process_Transient_Object
12736 Find_Enclosing_Contexts
(Rel_Node
);
12738 -- Step 1: Create the access type which provides a reference to the
12739 -- transient controlled object.
12741 if Is_Access_Type
(Obj_Typ
) then
12742 Desig_Typ
:= Directly_Designated_Type
(Obj_Typ
);
12744 Desig_Typ
:= Obj_Typ
;
12747 Desig_Typ
:= Base_Type
(Desig_Typ
);
12750 -- Ann : access [all] <Desig_Typ>;
12752 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
12754 Insert_Action
(Hook_Context
,
12755 Make_Full_Type_Declaration
(Loc
,
12756 Defining_Identifier
=> Ptr_Id
,
12758 Make_Access_To_Object_Definition
(Loc
,
12759 All_Present
=> Ekind
(Obj_Typ
) = E_General_Access_Type
,
12760 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))));
12762 -- Step 2: Create a temporary which acts as a hook to the transient
12763 -- controlled object. Generate:
12765 -- Temp : Ptr_Id := null;
12767 Temp_Id
:= Make_Temporary
(Loc
, 'T');
12769 Insert_Action
(Hook_Context
,
12770 Make_Object_Declaration
(Loc
,
12771 Defining_Identifier
=> Temp_Id
,
12772 Object_Definition
=> New_Occurrence_Of
(Ptr_Id
, Loc
)));
12774 -- Mark the temporary as created for the purposes of exporting the
12775 -- transient controlled object out of the expression_with_action or if
12776 -- expression. This signals the machinery in Build_Finalizer to treat
12777 -- this case specially.
12779 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Decl
);
12781 -- Step 3: Hook the transient object to the temporary
12783 -- This must be inserted right after the object declaration, so that
12784 -- the assignment is executed if, and only if, the object is actually
12785 -- created (whereas the declaration of the hook pointer, and the
12786 -- finalization call, may be inserted at an outer level, and may
12787 -- remain unused for some executions, if the actual creation of
12788 -- the object is conditional).
12790 -- The use of unchecked conversion / unrestricted access is needed to
12791 -- avoid an accessibility violation. Note that the finalization code is
12792 -- structured in such a way that the "hook" is processed only when it
12793 -- points to an existing object.
12795 if Is_Access_Type
(Obj_Typ
) then
12797 Unchecked_Convert_To
(Ptr_Id
, New_Occurrence_Of
(Obj_Id
, Loc
));
12800 Make_Attribute_Reference
(Loc
,
12801 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
12802 Attribute_Name
=> Name_Unrestricted_Access
);
12806 -- Temp := Ptr_Id (Obj_Id);
12808 -- Temp := Obj_Id'Unrestricted_Access;
12810 -- When the transient object is initialized by an aggregate, the hook
12811 -- must capture the object after the last component assignment takes
12812 -- place. Only then is the object fully initialized.
12814 if Ekind
(Obj_Id
) = E_Variable
12815 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
12817 Temp_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
12819 -- Otherwise the hook seizes the related object immediately
12825 Insert_After_And_Analyze
(Temp_Ins
,
12826 Make_Assignment_Statement
(Loc
,
12827 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
12828 Expression
=> Expr
));
12830 -- Step 4: Finalize the transient controlled object after the context
12831 -- has been evaluated/elaborated. Generate:
12833 -- if Temp /= null then
12834 -- [Deep_]Finalize (Temp.all);
12838 -- When the node is part of a return statement, there is no need to
12839 -- insert a finalization call, as the general finalization mechanism
12840 -- (see Build_Finalizer) would take care of the transient controlled
12841 -- object on subprogram exit. Note that it would also be impossible to
12842 -- insert the finalization code after the return statement as this will
12843 -- render it unreachable.
12845 if Nkind
(Finalization_Context
) /= N_Simple_Return_Statement
then
12846 Fin_Stmts
:= New_List
(
12849 Make_Explicit_Dereference
(Loc
,
12850 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
)),
12853 Make_Assignment_Statement
(Loc
,
12854 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
12855 Expression
=> Make_Null
(Loc
)));
12857 if not Finalize_Always
then
12858 Fin_Stmts
:= New_List
(
12859 Make_Implicit_If_Statement
(Decl
,
12862 Left_Opnd
=> New_Occurrence_Of
(Temp_Id
, Loc
),
12863 Right_Opnd
=> Make_Null
(Loc
)),
12864 Then_Statements
=> Fin_Stmts
));
12867 Insert_Actions_After
(Finalization_Context
, Fin_Stmts
);
12869 end Process_Transient_Object
;
12871 ------------------------
12872 -- Rewrite_Comparison --
12873 ------------------------
12875 procedure Rewrite_Comparison
(N
: Node_Id
) is
12876 Warning_Generated
: Boolean := False;
12877 -- Set to True if first pass with Assume_Valid generates a warning in
12878 -- which case we skip the second pass to avoid warning overloaded.
12881 -- Set to Standard_True or Standard_False
12884 if Nkind
(N
) = N_Type_Conversion
then
12885 Rewrite_Comparison
(Expression
(N
));
12888 elsif Nkind
(N
) not in N_Op_Compare
then
12892 -- Now start looking at the comparison in detail. We potentially go
12893 -- through this loop twice. The first time, Assume_Valid is set False
12894 -- in the call to Compile_Time_Compare. If this call results in a
12895 -- clear result of always True or Always False, that's decisive and
12896 -- we are done. Otherwise we repeat the processing with Assume_Valid
12897 -- set to True to generate additional warnings. We can skip that step
12898 -- if Constant_Condition_Warnings is False.
12900 for AV
in False .. True loop
12902 Typ
: constant Entity_Id
:= Etype
(N
);
12903 Op1
: constant Node_Id
:= Left_Opnd
(N
);
12904 Op2
: constant Node_Id
:= Right_Opnd
(N
);
12906 Res
: constant Compare_Result
:=
12907 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
12908 -- Res indicates if compare outcome can be compile time determined
12910 True_Result
: Boolean;
12911 False_Result
: Boolean;
12914 case N_Op_Compare
(Nkind
(N
)) is
12916 True_Result
:= Res
= EQ
;
12917 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
12920 True_Result
:= Res
in Compare_GE
;
12921 False_Result
:= Res
= LT
;
12924 and then Constant_Condition_Warnings
12925 and then Comes_From_Source
(Original_Node
(N
))
12926 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
12927 and then not In_Instance
12928 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12929 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12932 ("can never be greater than, could replace by ""'=""?c?",
12934 Warning_Generated
:= True;
12938 True_Result
:= Res
= GT
;
12939 False_Result
:= Res
in Compare_LE
;
12942 True_Result
:= Res
= LT
;
12943 False_Result
:= Res
in Compare_GE
;
12946 True_Result
:= Res
in Compare_LE
;
12947 False_Result
:= Res
= GT
;
12950 and then Constant_Condition_Warnings
12951 and then Comes_From_Source
(Original_Node
(N
))
12952 and then Nkind
(Original_Node
(N
)) = N_Op_Le
12953 and then not In_Instance
12954 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12955 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12958 ("can never be less than, could replace by ""'=""?c?", N
);
12959 Warning_Generated
:= True;
12963 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
12964 False_Result
:= Res
= EQ
;
12967 -- If this is the first iteration, then we actually convert the
12968 -- comparison into True or False, if the result is certain.
12971 if True_Result
or False_Result
then
12972 Result
:= Boolean_Literals
(True_Result
);
12975 New_Occurrence_Of
(Result
, Sloc
(N
))));
12976 Analyze_And_Resolve
(N
, Typ
);
12977 Warn_On_Known_Condition
(N
);
12981 -- If this is the second iteration (AV = True), and the original
12982 -- node comes from source and we are not in an instance, then give
12983 -- a warning if we know result would be True or False. Note: we
12984 -- know Constant_Condition_Warnings is set if we get here.
12986 elsif Comes_From_Source
(Original_Node
(N
))
12987 and then not In_Instance
12989 if True_Result
then
12991 ("condition can only be False if invalid values present??",
12993 elsif False_Result
then
12995 ("condition can only be True if invalid values present??",
13001 -- Skip second iteration if not warning on constant conditions or
13002 -- if the first iteration already generated a warning of some kind or
13003 -- if we are in any case assuming all values are valid (so that the
13004 -- first iteration took care of the valid case).
13006 exit when not Constant_Condition_Warnings
;
13007 exit when Warning_Generated
;
13008 exit when Assume_No_Invalid_Values
;
13010 end Rewrite_Comparison
;
13012 ----------------------------
13013 -- Safe_In_Place_Array_Op --
13014 ----------------------------
13016 function Safe_In_Place_Array_Op
13019 Op2
: Node_Id
) return Boolean
13021 Target
: Entity_Id
;
13023 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
13024 -- Operand is safe if it cannot overlap part of the target of the
13025 -- operation. If the operand and the target are identical, the operand
13026 -- is safe. The operand can be empty in the case of negation.
13028 function Is_Unaliased
(N
: Node_Id
) return Boolean;
13029 -- Check that N is a stand-alone entity
13035 function Is_Unaliased
(N
: Node_Id
) return Boolean is
13039 and then No
(Address_Clause
(Entity
(N
)))
13040 and then No
(Renamed_Object
(Entity
(N
)));
13043 ---------------------
13044 -- Is_Safe_Operand --
13045 ---------------------
13047 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
13052 elsif Is_Entity_Name
(Op
) then
13053 return Is_Unaliased
(Op
);
13055 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
13056 return Is_Unaliased
(Prefix
(Op
));
13058 elsif Nkind
(Op
) = N_Slice
then
13060 Is_Unaliased
(Prefix
(Op
))
13061 and then Entity
(Prefix
(Op
)) /= Target
;
13063 elsif Nkind
(Op
) = N_Op_Not
then
13064 return Is_Safe_Operand
(Right_Opnd
(Op
));
13069 end Is_Safe_Operand
;
13071 -- Start of processing for Safe_In_Place_Array_Op
13074 -- Skip this processing if the component size is different from system
13075 -- storage unit (since at least for NOT this would cause problems).
13077 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
13080 -- Cannot do in place stuff on VM_Target since cannot pass addresses
13082 elsif VM_Target
/= No_VM
then
13085 -- Cannot do in place stuff if non-standard Boolean representation
13087 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
13090 elsif not Is_Unaliased
(Lhs
) then
13094 Target
:= Entity
(Lhs
);
13095 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
13097 end Safe_In_Place_Array_Op
;
13099 -----------------------
13100 -- Tagged_Membership --
13101 -----------------------
13103 -- There are two different cases to consider depending on whether the right
13104 -- operand is a class-wide type or not. If not we just compare the actual
13105 -- tag of the left expr to the target type tag:
13107 -- Left_Expr.Tag = Right_Type'Tag;
13109 -- If it is a class-wide type we use the RT function CW_Membership which is
13110 -- usually implemented by looking in the ancestor tables contained in the
13111 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13113 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13114 -- function IW_Membership which is usually implemented by looking in the
13115 -- table of abstract interface types plus the ancestor table contained in
13116 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13118 procedure Tagged_Membership
13120 SCIL_Node
: out Node_Id
;
13121 Result
: out Node_Id
)
13123 Left
: constant Node_Id
:= Left_Opnd
(N
);
13124 Right
: constant Node_Id
:= Right_Opnd
(N
);
13125 Loc
: constant Source_Ptr
:= Sloc
(N
);
13127 Full_R_Typ
: Entity_Id
;
13128 Left_Type
: Entity_Id
;
13129 New_Node
: Node_Id
;
13130 Right_Type
: Entity_Id
;
13134 SCIL_Node
:= Empty
;
13136 -- Handle entities from the limited view
13138 Left_Type
:= Available_View
(Etype
(Left
));
13139 Right_Type
:= Available_View
(Etype
(Right
));
13141 -- In the case where the type is an access type, the test is applied
13142 -- using the designated types (needed in Ada 2012 for implicit anonymous
13143 -- access conversions, for AI05-0149).
13145 if Is_Access_Type
(Right_Type
) then
13146 Left_Type
:= Designated_Type
(Left_Type
);
13147 Right_Type
:= Designated_Type
(Right_Type
);
13150 if Is_Class_Wide_Type
(Left_Type
) then
13151 Left_Type
:= Root_Type
(Left_Type
);
13154 if Is_Class_Wide_Type
(Right_Type
) then
13155 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
13157 Full_R_Typ
:= Underlying_Type
(Right_Type
);
13161 Make_Selected_Component
(Loc
,
13162 Prefix
=> Relocate_Node
(Left
),
13164 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
13166 if Is_Class_Wide_Type
(Right_Type
) then
13168 -- No need to issue a run-time check if we statically know that the
13169 -- result of this membership test is always true. For example,
13170 -- considering the following declarations:
13172 -- type Iface is interface;
13173 -- type T is tagged null record;
13174 -- type DT is new T and Iface with null record;
13179 -- These membership tests are always true:
13182 -- Obj2 in T'Class;
13183 -- Obj2 in Iface'Class;
13185 -- We do not need to handle cases where the membership is illegal.
13188 -- Obj1 in DT'Class; -- Compile time error
13189 -- Obj1 in Iface'Class; -- Compile time error
13191 if not Is_Class_Wide_Type
(Left_Type
)
13192 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
13193 Use_Full_View
=> True)
13194 or else (Is_Interface
(Etype
(Right_Type
))
13195 and then Interface_Present_In_Ancestor
13197 Iface
=> Etype
(Right_Type
))))
13199 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
13203 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13205 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
13207 -- Support to: "Iface_CW_Typ in Typ'Class"
13209 or else Is_Interface
(Left_Type
)
13211 -- Issue error if IW_Membership operation not available in a
13212 -- configurable run time setting.
13214 if not RTE_Available
(RE_IW_Membership
) then
13216 ("dynamic membership test on interface types", N
);
13222 Make_Function_Call
(Loc
,
13223 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
13224 Parameter_Associations
=> New_List
(
13225 Make_Attribute_Reference
(Loc
,
13227 Attribute_Name
=> Name_Address
),
13228 New_Occurrence_Of
(
13229 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
13232 -- Ada 95: Normal case
13235 Build_CW_Membership
(Loc
,
13236 Obj_Tag_Node
=> Obj_Tag
,
13238 New_Occurrence_Of
(
13239 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
13241 New_Node
=> New_Node
);
13243 -- Generate the SCIL node for this class-wide membership test.
13244 -- Done here because the previous call to Build_CW_Membership
13245 -- relocates Obj_Tag.
13247 if Generate_SCIL
then
13248 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
13249 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
13250 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
13253 Result
:= New_Node
;
13256 -- Right_Type is not a class-wide type
13259 -- No need to check the tag of the object if Right_Typ is abstract
13261 if Is_Abstract_Type
(Right_Type
) then
13262 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
13267 Left_Opnd
=> Obj_Tag
,
13270 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
13273 end Tagged_Membership
;
13275 ------------------------------
13276 -- Unary_Op_Validity_Checks --
13277 ------------------------------
13279 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
13281 if Validity_Checks_On
and Validity_Check_Operands
then
13282 Ensure_Valid
(Right_Opnd
(N
));
13284 end Unary_Op_Validity_Checks
;