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 Rewrite_Comparison
(N
: Node_Id
);
237 -- If N is the node for a comparison whose outcome can be determined at
238 -- compile time, then the node N can be rewritten with True or False. If
239 -- the outcome cannot be determined at compile time, the call has no
240 -- effect. If N is a type conversion, then this processing is applied to
241 -- its expression. If N is neither comparison nor a type conversion, the
242 -- call has no effect.
244 procedure Tagged_Membership
246 SCIL_Node
: out Node_Id
;
247 Result
: out Node_Id
);
248 -- Construct the expression corresponding to the tagged membership test.
249 -- Deals with a second operand being (or not) a class-wide type.
251 function Safe_In_Place_Array_Op
254 Op2
: Node_Id
) return Boolean;
255 -- In the context of an assignment, where the right-hand side is a boolean
256 -- operation on arrays, check whether operation can be performed in place.
258 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
259 pragma Inline
(Unary_Op_Validity_Checks
);
260 -- Performs validity checks for a unary operator
262 -------------------------------
263 -- Binary_Op_Validity_Checks --
264 -------------------------------
266 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
268 if Validity_Checks_On
and Validity_Check_Operands
then
269 Ensure_Valid
(Left_Opnd
(N
));
270 Ensure_Valid
(Right_Opnd
(N
));
272 end Binary_Op_Validity_Checks
;
274 ------------------------------------
275 -- Build_Boolean_Array_Proc_Call --
276 ------------------------------------
278 procedure Build_Boolean_Array_Proc_Call
283 Loc
: constant Source_Ptr
:= Sloc
(N
);
284 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
285 Target
: constant Node_Id
:=
286 Make_Attribute_Reference
(Loc
,
288 Attribute_Name
=> Name_Address
);
290 Arg1
: Node_Id
:= Op1
;
291 Arg2
: Node_Id
:= Op2
;
293 Proc_Name
: Entity_Id
;
296 if Kind
= N_Op_Not
then
297 if Nkind
(Op1
) in N_Binary_Op
then
299 -- Use negated version of the binary operators
301 if Nkind
(Op1
) = N_Op_And
then
302 Proc_Name
:= RTE
(RE_Vector_Nand
);
304 elsif Nkind
(Op1
) = N_Op_Or
then
305 Proc_Name
:= RTE
(RE_Vector_Nor
);
307 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
308 Proc_Name
:= RTE
(RE_Vector_Xor
);
312 Make_Procedure_Call_Statement
(Loc
,
313 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
315 Parameter_Associations
=> New_List
(
317 Make_Attribute_Reference
(Loc
,
318 Prefix
=> Left_Opnd
(Op1
),
319 Attribute_Name
=> Name_Address
),
321 Make_Attribute_Reference
(Loc
,
322 Prefix
=> Right_Opnd
(Op1
),
323 Attribute_Name
=> Name_Address
),
325 Make_Attribute_Reference
(Loc
,
326 Prefix
=> Left_Opnd
(Op1
),
327 Attribute_Name
=> Name_Length
)));
330 Proc_Name
:= RTE
(RE_Vector_Not
);
333 Make_Procedure_Call_Statement
(Loc
,
334 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
335 Parameter_Associations
=> New_List
(
338 Make_Attribute_Reference
(Loc
,
340 Attribute_Name
=> Name_Address
),
342 Make_Attribute_Reference
(Loc
,
344 Attribute_Name
=> Name_Length
)));
348 -- We use the following equivalences:
350 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
351 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
352 -- (not X) xor (not Y) = X xor Y
353 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
355 if Nkind
(Op1
) = N_Op_Not
then
356 Arg1
:= Right_Opnd
(Op1
);
357 Arg2
:= Right_Opnd
(Op2
);
359 if Kind
= N_Op_And
then
360 Proc_Name
:= RTE
(RE_Vector_Nor
);
361 elsif Kind
= N_Op_Or
then
362 Proc_Name
:= RTE
(RE_Vector_Nand
);
364 Proc_Name
:= RTE
(RE_Vector_Xor
);
368 if Kind
= N_Op_And
then
369 Proc_Name
:= RTE
(RE_Vector_And
);
370 elsif Kind
= N_Op_Or
then
371 Proc_Name
:= RTE
(RE_Vector_Or
);
372 elsif Nkind
(Op2
) = N_Op_Not
then
373 Proc_Name
:= RTE
(RE_Vector_Nxor
);
374 Arg2
:= Right_Opnd
(Op2
);
376 Proc_Name
:= RTE
(RE_Vector_Xor
);
381 Make_Procedure_Call_Statement
(Loc
,
382 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
383 Parameter_Associations
=> New_List
(
385 Make_Attribute_Reference
(Loc
,
387 Attribute_Name
=> Name_Address
),
388 Make_Attribute_Reference
(Loc
,
390 Attribute_Name
=> Name_Address
),
391 Make_Attribute_Reference
(Loc
,
393 Attribute_Name
=> Name_Length
)));
396 Rewrite
(N
, Call_Node
);
400 when RE_Not_Available
=>
402 end Build_Boolean_Array_Proc_Call
;
404 ------------------------------
405 -- Current_Anonymous_Master --
406 ------------------------------
408 function Current_Anonymous_Master
return Entity_Id
is
416 Unit_Id
:= Cunit_Entity
(Current_Sem_Unit
);
418 -- Find the entity of the current unit
420 if Ekind
(Unit_Id
) = E_Subprogram_Body
then
422 -- When processing subprogram bodies, the proper scope is always that
425 Subp_Body
:= Unit_Id
;
426 while Present
(Subp_Body
)
427 and then Nkind
(Subp_Body
) /= N_Subprogram_Body
429 Subp_Body
:= Parent
(Subp_Body
);
432 Unit_Id
:= Corresponding_Spec
(Subp_Body
);
435 Loc
:= Sloc
(Unit_Id
);
436 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
438 -- Find the declarations list of the current unit
440 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
441 Unit_Decl
:= Specification
(Unit_Decl
);
442 Decls
:= Visible_Declarations
(Unit_Decl
);
445 Decls
:= New_List
(Make_Null_Statement
(Loc
));
446 Set_Visible_Declarations
(Unit_Decl
, Decls
);
448 elsif Is_Empty_List
(Decls
) then
449 Append_To
(Decls
, Make_Null_Statement
(Loc
));
453 Decls
:= Declarations
(Unit_Decl
);
456 Decls
:= New_List
(Make_Null_Statement
(Loc
));
457 Set_Declarations
(Unit_Decl
, Decls
);
459 elsif Is_Empty_List
(Decls
) then
460 Append_To
(Decls
, Make_Null_Statement
(Loc
));
464 -- The current unit has an existing anonymous master, traverse its
465 -- declarations and locate the entity.
467 if Has_Anonymous_Master
(Unit_Id
) then
470 Fin_Mas_Id
: Entity_Id
;
473 Decl
:= First
(Decls
);
474 while Present
(Decl
) loop
476 -- Look for the first variable in the declarations whole type
477 -- is Finalization_Master.
479 if Nkind
(Decl
) = N_Object_Declaration
then
480 Fin_Mas_Id
:= Defining_Identifier
(Decl
);
482 if Ekind
(Fin_Mas_Id
) = E_Variable
483 and then Etype
(Fin_Mas_Id
) = RTE
(RE_Finalization_Master
)
492 -- The master was not found even though the unit was labeled as
498 -- Create a new anonymous master
502 First_Decl
: constant Node_Id
:= First
(Decls
);
504 Fin_Mas_Id
: Entity_Id
;
507 -- Since the master and its associated initialization is inserted
508 -- at top level, use the scope of the unit when analyzing.
510 Push_Scope
(Unit_Id
);
512 -- Create the finalization master
515 Make_Defining_Identifier
(Loc
,
516 Chars
=> New_External_Name
(Chars
(Unit_Id
), "AM"));
519 -- <Fin_Mas_Id> : Finalization_Master;
522 Make_Object_Declaration
(Loc
,
523 Defining_Identifier
=> Fin_Mas_Id
,
525 New_Reference_To
(RTE
(RE_Finalization_Master
), Loc
));
527 Insert_Before_And_Analyze
(First_Decl
, Action
);
529 -- Mark the unit to prevent the generation of multiple masters
531 Set_Has_Anonymous_Master
(Unit_Id
);
533 -- Do not set the base pool and mode of operation on .NET/JVM
534 -- since those targets do not support pools and all VM masters
535 -- are heterogeneous by default.
537 if VM_Target
= No_VM
then
541 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
544 Make_Procedure_Call_Statement
(Loc
,
546 New_Reference_To
(RTE
(RE_Set_Base_Pool
), Loc
),
548 Parameter_Associations
=> New_List
(
549 New_Reference_To
(Fin_Mas_Id
, Loc
),
550 Make_Attribute_Reference
(Loc
,
552 New_Reference_To
(RTE
(RE_Global_Pool_Object
), Loc
),
553 Attribute_Name
=> Name_Unrestricted_Access
)));
555 Insert_Before_And_Analyze
(First_Decl
, Action
);
558 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
561 Make_Procedure_Call_Statement
(Loc
,
563 New_Reference_To
(RTE
(RE_Set_Is_Heterogeneous
), Loc
),
564 Parameter_Associations
=> New_List
(
565 New_Reference_To
(Fin_Mas_Id
, Loc
)));
567 Insert_Before_And_Analyze
(First_Decl
, Action
);
570 -- Restore the original state of the scope stack
577 end Current_Anonymous_Master
;
579 --------------------------------
580 -- Displace_Allocator_Pointer --
581 --------------------------------
583 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
584 Loc
: constant Source_Ptr
:= Sloc
(N
);
585 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
591 -- Do nothing in case of VM targets: the virtual machine will handle
592 -- interfaces directly.
594 if not Tagged_Type_Expansion
then
598 pragma Assert
(Nkind
(N
) = N_Identifier
599 and then Nkind
(Orig_Node
) = N_Allocator
);
601 PtrT
:= Etype
(Orig_Node
);
602 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
603 Etyp
:= Etype
(Expression
(Orig_Node
));
605 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
607 -- If the type of the allocator expression is not an interface type
608 -- we can generate code to reference the record component containing
609 -- the pointer to the secondary dispatch table.
611 if not Is_Interface
(Etyp
) then
613 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
616 -- 1) Get access to the allocated object
619 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
623 -- 2) Add the conversion to displace the pointer to reference
624 -- the secondary dispatch table.
626 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
627 Analyze_And_Resolve
(N
, Dtyp
);
629 -- 3) The 'access to the secondary dispatch table will be used
630 -- as the value returned by the allocator.
633 Make_Attribute_Reference
(Loc
,
634 Prefix
=> Relocate_Node
(N
),
635 Attribute_Name
=> Name_Access
));
636 Set_Etype
(N
, Saved_Typ
);
640 -- If the type of the allocator expression is an interface type we
641 -- generate a run-time call to displace "this" to reference the
642 -- component containing the pointer to the secondary dispatch table
643 -- or else raise Constraint_Error if the actual object does not
644 -- implement the target interface. This case corresponds to the
645 -- following example:
647 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
649 -- return new Iface_2'Class'(Obj);
654 Unchecked_Convert_To
(PtrT
,
655 Make_Function_Call
(Loc
,
656 Name
=> New_Reference_To
(RTE
(RE_Displace
), Loc
),
657 Parameter_Associations
=> New_List
(
658 Unchecked_Convert_To
(RTE
(RE_Address
),
664 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
666 Analyze_And_Resolve
(N
, PtrT
);
669 end Displace_Allocator_Pointer
;
671 ---------------------------------
672 -- Expand_Allocator_Expression --
673 ---------------------------------
675 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
676 Loc
: constant Source_Ptr
:= Sloc
(N
);
677 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
678 PtrT
: constant Entity_Id
:= Etype
(N
);
679 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
681 procedure Apply_Accessibility_Check
683 Built_In_Place
: Boolean := False);
684 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
685 -- type, generate an accessibility check to verify that the level of the
686 -- type of the created object is not deeper than the level of the access
687 -- type. If the type of the qualified expression is class-wide, then
688 -- always generate the check (except in the case where it is known to be
689 -- unnecessary, see comment below). Otherwise, only generate the check
690 -- if the level of the qualified expression type is statically deeper
691 -- than the access type.
693 -- Although the static accessibility will generally have been performed
694 -- as a legality check, it won't have been done in cases where the
695 -- allocator appears in generic body, so a run-time check is needed in
696 -- general. One special case is when the access type is declared in the
697 -- same scope as the class-wide allocator, in which case the check can
698 -- never fail, so it need not be generated.
700 -- As an open issue, there seem to be cases where the static level
701 -- associated with the class-wide object's underlying type is not
702 -- sufficient to perform the proper accessibility check, such as for
703 -- allocators in nested subprograms or accept statements initialized by
704 -- class-wide formals when the actual originates outside at a deeper
705 -- static level. The nested subprogram case might require passing
706 -- accessibility levels along with class-wide parameters, and the task
707 -- case seems to be an actual gap in the language rules that needs to
708 -- be fixed by the ARG. ???
710 -------------------------------
711 -- Apply_Accessibility_Check --
712 -------------------------------
714 procedure Apply_Accessibility_Check
716 Built_In_Place
: Boolean := False)
718 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
725 if Ada_Version
>= Ada_2005
726 and then Is_Class_Wide_Type
(DesigT
)
727 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
729 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
731 (Is_Class_Wide_Type
(Etype
(Exp
))
732 and then Scope
(PtrT
) /= Current_Scope
))
733 and then (Tagged_Type_Expansion
or else VM_Target
/= No_VM
)
735 -- If the allocator was built in place, Ref is already a reference
736 -- to the access object initialized to the result of the allocator
737 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
738 -- Remove_Side_Effects for cases where the build-in-place call may
739 -- still be the prefix of the reference (to avoid generating
740 -- duplicate calls). Otherwise, it is the entity associated with
741 -- the object containing the address of the allocated object.
743 if Built_In_Place
then
744 Remove_Side_Effects
(Ref
);
745 Obj_Ref
:= New_Copy
(Ref
);
747 Obj_Ref
:= New_Reference_To
(Ref
, Loc
);
750 -- Step 1: Create the object clean up code
754 -- Create an explicit free statement to clean up the allocated
755 -- object in case the accessibility check fails. Generate:
759 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy
(Obj_Ref
));
760 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
762 Append_To
(Stmts
, Free_Stmt
);
764 -- Finalize the object (if applicable), but wrap the call inside
765 -- a block to ensure that the object would still be deallocated in
766 -- case the finalization fails. Generate:
769 -- [Deep_]Finalize (Obj_Ref.all);
776 if Needs_Finalization
(DesigT
) then
778 Make_Block_Statement
(Loc
,
779 Handled_Statement_Sequence
=>
780 Make_Handled_Sequence_Of_Statements
(Loc
,
781 Statements
=> New_List
(
784 Make_Explicit_Dereference
(Loc
,
785 Prefix
=> New_Copy
(Obj_Ref
)),
788 Exception_Handlers
=> New_List
(
789 Make_Exception_Handler
(Loc
,
790 Exception_Choices
=> New_List
(
791 Make_Others_Choice
(Loc
)),
792 Statements
=> New_List
(
793 New_Copy_Tree
(Free_Stmt
),
794 Make_Raise_Statement
(Loc
)))))));
797 -- Signal the accessibility failure through a Program_Error
800 Make_Raise_Program_Error
(Loc
,
801 Condition
=> New_Reference_To
(Standard_True
, Loc
),
802 Reason
=> PE_Accessibility_Check_Failed
));
804 -- Step 2: Create the accessibility comparison
810 Make_Attribute_Reference
(Loc
,
812 Attribute_Name
=> Name_Tag
);
814 -- For tagged types, determine the accessibility level by looking
815 -- at the type specific data of the dispatch table. Generate:
817 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
819 if Tagged_Type_Expansion
then
820 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
822 -- Use a runtime call to determine the accessibility level when
823 -- compiling on virtual machine targets. Generate:
825 -- Get_Access_Level (Ref'Tag)
829 Make_Function_Call
(Loc
,
831 New_Reference_To
(RTE
(RE_Get_Access_Level
), Loc
),
832 Parameter_Associations
=> New_List
(Obj_Ref
));
839 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
841 -- Due to the complexity and side effects of the check, utilize an
842 -- if statement instead of the regular Program_Error circuitry.
845 Make_Implicit_If_Statement
(N
,
847 Then_Statements
=> Stmts
));
849 end Apply_Accessibility_Check
;
853 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
854 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
855 T
: constant Entity_Id
:= Entity
(Indic
);
857 Tag_Assign
: Node_Id
;
861 TagT
: Entity_Id
:= Empty
;
862 -- Type used as source for tag assignment
864 TagR
: Node_Id
:= Empty
;
865 -- Target reference for tag assignment
867 -- Start of processing for Expand_Allocator_Expression
870 -- Handle call to C++ constructor
872 if Is_CPP_Constructor_Call
(Exp
) then
873 Make_CPP_Constructor_Call_In_Allocator
875 Function_Call
=> Exp
);
879 -- In the case of an Ada 2012 allocator whose initial value comes from a
880 -- function call, pass "the accessibility level determined by the point
881 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
882 -- Expand_Call but it couldn't be done there (because the Etype of the
883 -- allocator wasn't set then) so we generate the parameter here. See
884 -- the Boolean variable Defer in (a block within) Expand_Call.
886 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
891 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
892 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
894 Subp
:= Entity
(Name
(Exp
));
897 Subp
:= Ultimate_Alias
(Subp
);
899 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
900 Add_Extra_Actual_To_Call
901 (Subprogram_Call
=> Exp
,
902 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
903 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
908 -- Case of tagged type or type requiring finalization
910 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
912 -- Ada 2005 (AI-318-02): If the initialization expression is a call
913 -- to a build-in-place function, then access to the allocated object
914 -- must be passed to the function. Currently we limit such functions
915 -- to those with constrained limited result subtypes, but eventually
916 -- we plan to expand the allowed forms of functions that are treated
917 -- as build-in-place.
919 if Ada_Version
>= Ada_2005
920 and then Is_Build_In_Place_Function_Call
(Exp
)
922 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
923 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
927 -- Actions inserted before:
928 -- Temp : constant ptr_T := new T'(Expression);
929 -- Temp._tag = T'tag; -- when not class-wide
930 -- [Deep_]Adjust (Temp.all);
932 -- We analyze by hand the new internal allocator to avoid any
933 -- recursion and inappropriate call to Initialize
935 -- We don't want to remove side effects when the expression must be
936 -- built in place. In the case of a build-in-place function call,
937 -- that could lead to a duplication of the call, which was already
938 -- substituted for the allocator.
940 if not Aggr_In_Place
then
941 Remove_Side_Effects
(Exp
);
944 Temp
:= Make_Temporary
(Loc
, 'P', N
);
946 -- For a class wide allocation generate the following code:
948 -- type Equiv_Record is record ... end record;
949 -- implicit subtype CW is <Class_Wide_Subytpe>;
950 -- temp : PtrT := new CW'(CW!(expr));
952 if Is_Class_Wide_Type
(T
) then
953 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
955 -- Ada 2005 (AI-251): If the expression is a class-wide interface
956 -- object we generate code to move up "this" to reference the
957 -- base of the object before allocating the new object.
959 -- Note that Exp'Address is recursively expanded into a call
960 -- to Base_Address (Exp.Tag)
962 if Is_Class_Wide_Type
(Etype
(Exp
))
963 and then Is_Interface
(Etype
(Exp
))
964 and then Tagged_Type_Expansion
968 Unchecked_Convert_To
(Entity
(Indic
),
969 Make_Explicit_Dereference
(Loc
,
970 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
971 Make_Attribute_Reference
(Loc
,
973 Attribute_Name
=> Name_Address
)))));
977 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
980 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
983 -- Processing for allocators returning non-interface types
985 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
986 if Aggr_In_Place
then
988 Make_Object_Declaration
(Loc
,
989 Defining_Identifier
=> Temp
,
990 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
994 New_Reference_To
(Etype
(Exp
), Loc
)));
996 -- Copy the Comes_From_Source flag for the allocator we just
997 -- built, since logically this allocator is a replacement of
998 -- the original allocator node. This is for proper handling of
999 -- restriction No_Implicit_Heap_Allocations.
1001 Set_Comes_From_Source
1002 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1004 Set_No_Initialization
(Expression
(Temp_Decl
));
1005 Insert_Action
(N
, Temp_Decl
);
1007 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1008 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1010 -- Attach the object to the associated finalization master.
1011 -- This is done manually on .NET/JVM since those compilers do
1012 -- no support pools and can't benefit from internally generated
1013 -- Allocate / Deallocate procedures.
1015 if VM_Target
/= No_VM
1016 and then Is_Controlled
(DesigT
)
1017 and then Present
(Finalization_Master
(PtrT
))
1022 New_Reference_To
(Temp
, Loc
),
1027 Node
:= Relocate_Node
(N
);
1028 Set_Analyzed
(Node
);
1031 Make_Object_Declaration
(Loc
,
1032 Defining_Identifier
=> Temp
,
1033 Constant_Present
=> True,
1034 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1035 Expression
=> Node
);
1037 Insert_Action
(N
, Temp_Decl
);
1038 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1040 -- Attach the object to the associated finalization master.
1041 -- This is done manually on .NET/JVM since those compilers do
1042 -- no support pools and can't benefit from internally generated
1043 -- Allocate / Deallocate procedures.
1045 if VM_Target
/= No_VM
1046 and then Is_Controlled
(DesigT
)
1047 and then Present
(Finalization_Master
(PtrT
))
1052 New_Reference_To
(Temp
, Loc
),
1057 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1058 -- interface type. In this case we use the type of the qualified
1059 -- expression to allocate the object.
1063 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1068 Make_Full_Type_Declaration
(Loc
,
1069 Defining_Identifier
=> Def_Id
,
1071 Make_Access_To_Object_Definition
(Loc
,
1072 All_Present
=> True,
1073 Null_Exclusion_Present
=> False,
1075 Is_Access_Constant
(Etype
(N
)),
1076 Subtype_Indication
=>
1077 New_Reference_To
(Etype
(Exp
), Loc
)));
1079 Insert_Action
(N
, New_Decl
);
1081 -- Inherit the allocation-related attributes from the original
1084 Set_Finalization_Master
(Def_Id
, Finalization_Master
(PtrT
));
1086 Set_Associated_Storage_Pool
(Def_Id
,
1087 Associated_Storage_Pool
(PtrT
));
1089 -- Declare the object using the previous type declaration
1091 if Aggr_In_Place
then
1093 Make_Object_Declaration
(Loc
,
1094 Defining_Identifier
=> Temp
,
1095 Object_Definition
=> New_Reference_To
(Def_Id
, Loc
),
1097 Make_Allocator
(Loc
,
1098 New_Reference_To
(Etype
(Exp
), Loc
)));
1100 -- Copy the Comes_From_Source flag for the allocator we just
1101 -- built, since logically this allocator is a replacement of
1102 -- the original allocator node. This is for proper handling
1103 -- of restriction No_Implicit_Heap_Allocations.
1105 Set_Comes_From_Source
1106 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1108 Set_No_Initialization
(Expression
(Temp_Decl
));
1109 Insert_Action
(N
, Temp_Decl
);
1111 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1112 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1115 Node
:= Relocate_Node
(N
);
1116 Set_Analyzed
(Node
);
1119 Make_Object_Declaration
(Loc
,
1120 Defining_Identifier
=> Temp
,
1121 Constant_Present
=> True,
1122 Object_Definition
=> New_Reference_To
(Def_Id
, Loc
),
1123 Expression
=> Node
);
1125 Insert_Action
(N
, Temp_Decl
);
1126 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1129 -- Generate an additional object containing the address of the
1130 -- returned object. The type of this second object declaration
1131 -- is the correct type required for the common processing that
1132 -- is still performed by this subprogram. The displacement of
1133 -- this pointer to reference the component associated with the
1134 -- interface type will be done at the end of common processing.
1137 Make_Object_Declaration
(Loc
,
1138 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
1139 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1141 Unchecked_Convert_To
(PtrT
,
1142 New_Reference_To
(Temp
, Loc
)));
1144 Insert_Action
(N
, New_Decl
);
1146 Temp_Decl
:= New_Decl
;
1147 Temp
:= Defining_Identifier
(New_Decl
);
1151 Apply_Accessibility_Check
(Temp
);
1153 -- Generate the tag assignment
1155 -- Suppress the tag assignment when VM_Target because VM tags are
1156 -- represented implicitly in objects.
1158 if not Tagged_Type_Expansion
then
1161 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1162 -- interface objects because in this case the tag does not change.
1164 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1165 pragma Assert
(Is_Class_Wide_Type
1166 (Directly_Designated_Type
(Etype
(N
))));
1169 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1171 TagR
:= New_Reference_To
(Temp
, Loc
);
1173 elsif Is_Private_Type
(T
)
1174 and then Is_Tagged_Type
(Underlying_Type
(T
))
1176 TagT
:= Underlying_Type
(T
);
1178 Unchecked_Convert_To
(Underlying_Type
(T
),
1179 Make_Explicit_Dereference
(Loc
,
1180 Prefix
=> New_Reference_To
(Temp
, Loc
)));
1183 if Present
(TagT
) then
1185 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1188 Make_Assignment_Statement
(Loc
,
1190 Make_Selected_Component
(Loc
,
1193 New_Reference_To
(First_Tag_Component
(Full_T
), Loc
)),
1195 Unchecked_Convert_To
(RTE
(RE_Tag
),
1198 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1201 -- The previous assignment has to be done in any case
1203 Set_Assignment_OK
(Name
(Tag_Assign
));
1204 Insert_Action
(N
, Tag_Assign
);
1207 if Needs_Finalization
(DesigT
) and then Needs_Finalization
(T
) then
1209 -- Generate an Adjust call if the object will be moved. In Ada
1210 -- 2005, the object may be inherently limited, in which case
1211 -- there is no Adjust procedure, and the object is built in
1212 -- place. In Ada 95, the object can be limited but not
1213 -- inherently limited if this allocator came from a return
1214 -- statement (we're allocating the result on the secondary
1215 -- stack). In that case, the object will be moved, so we _do_
1218 if not Aggr_In_Place
1219 and then not Is_Immutably_Limited_Type
(T
)
1223 -- An unchecked conversion is needed in the classwide case
1224 -- because the designated type can be an ancestor of the
1225 -- subtype mark of the allocator.
1229 Unchecked_Convert_To
(T
,
1230 Make_Explicit_Dereference
(Loc
,
1231 Prefix
=> New_Reference_To
(Temp
, Loc
))),
1236 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1238 -- Do not generate this call in the following cases:
1240 -- * .NET/JVM - these targets do not support address arithmetic
1241 -- and unchecked conversion, key elements of Finalize_Address.
1243 -- * SPARK mode - the call is useless and results in unwanted
1246 -- * CodePeer mode - TSS primitive Finalize_Address is not
1247 -- created in this mode.
1249 if VM_Target
= No_VM
1250 and then not SPARK_Mode
1251 and then not CodePeer_Mode
1252 and then Present
(Finalization_Master
(PtrT
))
1253 and then Present
(Temp_Decl
)
1254 and then Nkind
(Expression
(Temp_Decl
)) = N_Allocator
1257 Make_Set_Finalize_Address_Call
1264 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1265 Analyze_And_Resolve
(N
, PtrT
);
1267 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1268 -- component containing the secondary dispatch table of the interface
1271 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1272 Displace_Allocator_Pointer
(N
);
1275 elsif Aggr_In_Place
then
1276 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1278 Make_Object_Declaration
(Loc
,
1279 Defining_Identifier
=> Temp
,
1280 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1282 Make_Allocator
(Loc
,
1283 Expression
=> New_Reference_To
(Etype
(Exp
), Loc
)));
1285 -- Copy the Comes_From_Source flag for the allocator we just built,
1286 -- since logically this allocator is a replacement of the original
1287 -- allocator node. This is for proper handling of restriction
1288 -- No_Implicit_Heap_Allocations.
1290 Set_Comes_From_Source
1291 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1293 Set_No_Initialization
(Expression
(Temp_Decl
));
1294 Insert_Action
(N
, Temp_Decl
);
1296 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1297 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1299 -- Attach the object to the associated finalization master. Thisis
1300 -- done manually on .NET/JVM since those compilers do no support
1301 -- pools and cannot benefit from internally generated Allocate and
1302 -- Deallocate procedures.
1304 if VM_Target
/= No_VM
1305 and then Is_Controlled
(DesigT
)
1306 and then Present
(Finalization_Master
(PtrT
))
1310 (Obj_Ref
=> New_Reference_To
(Temp
, Loc
),
1314 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1315 Analyze_And_Resolve
(N
, PtrT
);
1317 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1318 Install_Null_Excluding_Check
(Exp
);
1320 elsif Is_Access_Type
(DesigT
)
1321 and then Nkind
(Exp
) = N_Allocator
1322 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1324 -- Apply constraint to designated subtype indication
1326 Apply_Constraint_Check
(Expression
(Exp
),
1327 Designated_Type
(DesigT
),
1328 No_Sliding
=> True);
1330 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1332 -- Propagate constraint_error to enclosing allocator
1334 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1338 Build_Allocate_Deallocate_Proc
(N
, True);
1341 -- type A is access T1;
1342 -- X : A := new T2'(...);
1343 -- T1 and T2 can be different subtypes, and we might need to check
1344 -- both constraints. First check against the type of the qualified
1347 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1349 if Do_Range_Check
(Exp
) then
1350 Set_Do_Range_Check
(Exp
, False);
1351 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1354 -- A check is also needed in cases where the designated subtype is
1355 -- constrained and differs from the subtype given in the qualified
1356 -- expression. Note that the check on the qualified expression does
1357 -- not allow sliding, but this check does (a relaxation from Ada 83).
1359 if Is_Constrained
(DesigT
)
1360 and then not Subtypes_Statically_Match
(T
, DesigT
)
1362 Apply_Constraint_Check
1363 (Exp
, DesigT
, No_Sliding
=> False);
1365 if Do_Range_Check
(Exp
) then
1366 Set_Do_Range_Check
(Exp
, False);
1367 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1371 -- For an access to unconstrained packed array, GIGI needs to see an
1372 -- expression with a constrained subtype in order to compute the
1373 -- proper size for the allocator.
1375 if Is_Array_Type
(T
)
1376 and then not Is_Constrained
(T
)
1377 and then Is_Packed
(T
)
1380 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1381 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1384 Make_Subtype_Declaration
(Loc
,
1385 Defining_Identifier
=> ConstrT
,
1386 Subtype_Indication
=>
1387 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1388 Freeze_Itype
(ConstrT
, Exp
);
1389 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1393 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1394 -- to a build-in-place function, then access to the allocated object
1395 -- must be passed to the function. Currently we limit such functions
1396 -- to those with constrained limited result subtypes, but eventually
1397 -- we plan to expand the allowed forms of functions that are treated
1398 -- as build-in-place.
1400 if Ada_Version
>= Ada_2005
1401 and then Is_Build_In_Place_Function_Call
(Exp
)
1403 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1408 when RE_Not_Available
=>
1410 end Expand_Allocator_Expression
;
1412 -----------------------------
1413 -- Expand_Array_Comparison --
1414 -----------------------------
1416 -- Expansion is only required in the case of array types. For the unpacked
1417 -- case, an appropriate runtime routine is called. For packed cases, and
1418 -- also in some other cases where a runtime routine cannot be called, the
1419 -- form of the expansion is:
1421 -- [body for greater_nn; boolean_expression]
1423 -- The body is built by Make_Array_Comparison_Op, and the form of the
1424 -- Boolean expression depends on the operator involved.
1426 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1427 Loc
: constant Source_Ptr
:= Sloc
(N
);
1428 Op1
: Node_Id
:= Left_Opnd
(N
);
1429 Op2
: Node_Id
:= Right_Opnd
(N
);
1430 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1431 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1434 Func_Body
: Node_Id
;
1435 Func_Name
: Entity_Id
;
1439 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1440 -- True for byte addressable target
1442 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1443 -- Returns True if the length of the given operand is known to be less
1444 -- than 4. Returns False if this length is known to be four or greater
1445 -- or is not known at compile time.
1447 ------------------------
1448 -- Length_Less_Than_4 --
1449 ------------------------
1451 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1452 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1455 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1456 return String_Literal_Length
(Otyp
) < 4;
1460 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1461 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1462 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1467 if Compile_Time_Known_Value
(Lo
) then
1468 Lov
:= Expr_Value
(Lo
);
1473 if Compile_Time_Known_Value
(Hi
) then
1474 Hiv
:= Expr_Value
(Hi
);
1479 return Hiv
< Lov
+ 3;
1482 end Length_Less_Than_4
;
1484 -- Start of processing for Expand_Array_Comparison
1487 -- Deal first with unpacked case, where we can call a runtime routine
1488 -- except that we avoid this for targets for which are not addressable
1489 -- by bytes, and for the JVM/CIL, since they do not support direct
1490 -- addressing of array components.
1492 if not Is_Bit_Packed_Array
(Typ1
)
1493 and then Byte_Addressable
1494 and then VM_Target
= No_VM
1496 -- The call we generate is:
1498 -- Compare_Array_xn[_Unaligned]
1499 -- (left'address, right'address, left'length, right'length) <op> 0
1501 -- x = U for unsigned, S for signed
1502 -- n = 8,16,32,64 for component size
1503 -- Add _Unaligned if length < 4 and component size is 8.
1504 -- <op> is the standard comparison operator
1506 if Component_Size
(Typ1
) = 8 then
1507 if Length_Less_Than_4
(Op1
)
1509 Length_Less_Than_4
(Op2
)
1511 if Is_Unsigned_Type
(Ctyp
) then
1512 Comp
:= RE_Compare_Array_U8_Unaligned
;
1514 Comp
:= RE_Compare_Array_S8_Unaligned
;
1518 if Is_Unsigned_Type
(Ctyp
) then
1519 Comp
:= RE_Compare_Array_U8
;
1521 Comp
:= RE_Compare_Array_S8
;
1525 elsif Component_Size
(Typ1
) = 16 then
1526 if Is_Unsigned_Type
(Ctyp
) then
1527 Comp
:= RE_Compare_Array_U16
;
1529 Comp
:= RE_Compare_Array_S16
;
1532 elsif Component_Size
(Typ1
) = 32 then
1533 if Is_Unsigned_Type
(Ctyp
) then
1534 Comp
:= RE_Compare_Array_U32
;
1536 Comp
:= RE_Compare_Array_S32
;
1539 else pragma Assert
(Component_Size
(Typ1
) = 64);
1540 if Is_Unsigned_Type
(Ctyp
) then
1541 Comp
:= RE_Compare_Array_U64
;
1543 Comp
:= RE_Compare_Array_S64
;
1547 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1548 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1551 Make_Function_Call
(Sloc
(Op1
),
1552 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1554 Parameter_Associations
=> New_List
(
1555 Make_Attribute_Reference
(Loc
,
1556 Prefix
=> Relocate_Node
(Op1
),
1557 Attribute_Name
=> Name_Address
),
1559 Make_Attribute_Reference
(Loc
,
1560 Prefix
=> Relocate_Node
(Op2
),
1561 Attribute_Name
=> Name_Address
),
1563 Make_Attribute_Reference
(Loc
,
1564 Prefix
=> Relocate_Node
(Op1
),
1565 Attribute_Name
=> Name_Length
),
1567 Make_Attribute_Reference
(Loc
,
1568 Prefix
=> Relocate_Node
(Op2
),
1569 Attribute_Name
=> Name_Length
))));
1572 Make_Integer_Literal
(Sloc
(Op2
),
1575 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1576 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1580 -- Cases where we cannot make runtime call
1582 -- For (a <= b) we convert to not (a > b)
1584 if Chars
(N
) = Name_Op_Le
then
1590 Right_Opnd
=> Op2
)));
1591 Analyze_And_Resolve
(N
, Standard_Boolean
);
1594 -- For < the Boolean expression is
1595 -- greater__nn (op2, op1)
1597 elsif Chars
(N
) = Name_Op_Lt
then
1598 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1602 Op1
:= Right_Opnd
(N
);
1603 Op2
:= Left_Opnd
(N
);
1605 -- For (a >= b) we convert to not (a < b)
1607 elsif Chars
(N
) = Name_Op_Ge
then
1613 Right_Opnd
=> Op2
)));
1614 Analyze_And_Resolve
(N
, Standard_Boolean
);
1617 -- For > the Boolean expression is
1618 -- greater__nn (op1, op2)
1621 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1622 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1625 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1627 Make_Function_Call
(Loc
,
1628 Name
=> New_Reference_To
(Func_Name
, Loc
),
1629 Parameter_Associations
=> New_List
(Op1
, Op2
));
1631 Insert_Action
(N
, Func_Body
);
1633 Analyze_And_Resolve
(N
, Standard_Boolean
);
1636 when RE_Not_Available
=>
1638 end Expand_Array_Comparison
;
1640 ---------------------------
1641 -- Expand_Array_Equality --
1642 ---------------------------
1644 -- Expand an equality function for multi-dimensional arrays. Here is an
1645 -- example of such a function for Nb_Dimension = 2
1647 -- function Enn (A : atyp; B : btyp) return boolean is
1649 -- if (A'length (1) = 0 or else A'length (2) = 0)
1651 -- (B'length (1) = 0 or else B'length (2) = 0)
1653 -- return True; -- RM 4.5.2(22)
1656 -- if A'length (1) /= B'length (1)
1658 -- A'length (2) /= B'length (2)
1660 -- return False; -- RM 4.5.2(23)
1664 -- A1 : Index_T1 := A'first (1);
1665 -- B1 : Index_T1 := B'first (1);
1669 -- A2 : Index_T2 := A'first (2);
1670 -- B2 : Index_T2 := B'first (2);
1673 -- if A (A1, A2) /= B (B1, B2) then
1677 -- exit when A2 = A'last (2);
1678 -- A2 := Index_T2'succ (A2);
1679 -- B2 := Index_T2'succ (B2);
1683 -- exit when A1 = A'last (1);
1684 -- A1 := Index_T1'succ (A1);
1685 -- B1 := Index_T1'succ (B1);
1692 -- Note on the formal types used (atyp and btyp). If either of the arrays
1693 -- is of a private type, we use the underlying type, and do an unchecked
1694 -- conversion of the actual. If either of the arrays has a bound depending
1695 -- on a discriminant, then we use the base type since otherwise we have an
1696 -- escaped discriminant in the function.
1698 -- If both arrays are constrained and have the same bounds, we can generate
1699 -- a loop with an explicit iteration scheme using a 'Range attribute over
1702 function Expand_Array_Equality
1707 Typ
: Entity_Id
) return Node_Id
1709 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1710 Decls
: constant List_Id
:= New_List
;
1711 Index_List1
: constant List_Id
:= New_List
;
1712 Index_List2
: constant List_Id
:= New_List
;
1716 Func_Name
: Entity_Id
;
1717 Func_Body
: Node_Id
;
1719 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1720 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1724 -- The parameter types to be used for the formals
1729 Num
: Int
) return Node_Id
;
1730 -- This builds the attribute reference Arr'Nam (Expr)
1732 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1733 -- Create one statement to compare corresponding components, designated
1734 -- by a full set of indexes.
1736 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1737 -- Given one of the arguments, computes the appropriate type to be used
1738 -- for that argument in the corresponding function formal
1740 function Handle_One_Dimension
1742 Index
: Node_Id
) return Node_Id
;
1743 -- This procedure returns the following code
1746 -- Bn : Index_T := B'First (N);
1750 -- exit when An = A'Last (N);
1751 -- An := Index_T'Succ (An)
1752 -- Bn := Index_T'Succ (Bn)
1756 -- If both indexes are constrained and identical, the procedure
1757 -- returns a simpler loop:
1759 -- for An in A'Range (N) loop
1763 -- N is the dimension for which we are generating a loop. Index is the
1764 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1765 -- xxx statement is either the loop or declare for the next dimension
1766 -- or if this is the last dimension the comparison of corresponding
1767 -- components of the arrays.
1769 -- The actual way the code works is to return the comparison of
1770 -- corresponding components for the N+1 call. That's neater!
1772 function Test_Empty_Arrays
return Node_Id
;
1773 -- This function constructs the test for both arrays being empty
1774 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1776 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1778 function Test_Lengths_Correspond
return Node_Id
;
1779 -- This function constructs the test for arrays having different lengths
1780 -- in at least one index position, in which case the resulting code is:
1782 -- A'length (1) /= B'length (1)
1784 -- A'length (2) /= B'length (2)
1795 Num
: Int
) return Node_Id
1799 Make_Attribute_Reference
(Loc
,
1800 Attribute_Name
=> Nam
,
1801 Prefix
=> New_Reference_To
(Arr
, Loc
),
1802 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1805 ------------------------
1806 -- Component_Equality --
1807 ------------------------
1809 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1814 -- if a(i1...) /= b(j1...) then return false; end if;
1817 Make_Indexed_Component
(Loc
,
1818 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1819 Expressions
=> Index_List1
);
1822 Make_Indexed_Component
(Loc
,
1823 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1824 Expressions
=> Index_List2
);
1826 Test
:= Expand_Composite_Equality
1827 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1829 -- If some (sub)component is an unchecked_union, the whole operation
1830 -- will raise program error.
1832 if Nkind
(Test
) = N_Raise_Program_Error
then
1834 -- This node is going to be inserted at a location where a
1835 -- statement is expected: clear its Etype so analysis will set
1836 -- it to the expected Standard_Void_Type.
1838 Set_Etype
(Test
, Empty
);
1843 Make_Implicit_If_Statement
(Nod
,
1844 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1845 Then_Statements
=> New_List
(
1846 Make_Simple_Return_Statement
(Loc
,
1847 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1849 end Component_Equality
;
1855 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1866 T
:= Underlying_Type
(T
);
1868 X
:= First_Index
(T
);
1869 while Present
(X
) loop
1870 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1872 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1885 --------------------------
1886 -- Handle_One_Dimension --
1887 ---------------------------
1889 function Handle_One_Dimension
1891 Index
: Node_Id
) return Node_Id
1893 Need_Separate_Indexes
: constant Boolean :=
1894 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1895 -- If the index types are identical, and we are working with
1896 -- constrained types, then we can use the same index for both
1899 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1902 Index_T
: Entity_Id
;
1907 if N
> Number_Dimensions
(Ltyp
) then
1908 return Component_Equality
(Ltyp
);
1911 -- Case where we generate a loop
1913 Index_T
:= Base_Type
(Etype
(Index
));
1915 if Need_Separate_Indexes
then
1916 Bn
:= Make_Temporary
(Loc
, 'B');
1921 Append
(New_Reference_To
(An
, Loc
), Index_List1
);
1922 Append
(New_Reference_To
(Bn
, Loc
), Index_List2
);
1924 Stm_List
:= New_List
(
1925 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1927 if Need_Separate_Indexes
then
1929 -- Generate guard for loop, followed by increments of indexes
1931 Append_To
(Stm_List
,
1932 Make_Exit_Statement
(Loc
,
1935 Left_Opnd
=> New_Reference_To
(An
, Loc
),
1936 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1938 Append_To
(Stm_List
,
1939 Make_Assignment_Statement
(Loc
,
1940 Name
=> New_Reference_To
(An
, Loc
),
1942 Make_Attribute_Reference
(Loc
,
1943 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1944 Attribute_Name
=> Name_Succ
,
1945 Expressions
=> New_List
(New_Reference_To
(An
, Loc
)))));
1947 Append_To
(Stm_List
,
1948 Make_Assignment_Statement
(Loc
,
1949 Name
=> New_Reference_To
(Bn
, Loc
),
1951 Make_Attribute_Reference
(Loc
,
1952 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1953 Attribute_Name
=> Name_Succ
,
1954 Expressions
=> New_List
(New_Reference_To
(Bn
, Loc
)))));
1957 -- If separate indexes, we need a declare block for An and Bn, and a
1958 -- loop without an iteration scheme.
1960 if Need_Separate_Indexes
then
1962 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1965 Make_Block_Statement
(Loc
,
1966 Declarations
=> New_List
(
1967 Make_Object_Declaration
(Loc
,
1968 Defining_Identifier
=> An
,
1969 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1970 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1972 Make_Object_Declaration
(Loc
,
1973 Defining_Identifier
=> Bn
,
1974 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1975 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1977 Handled_Statement_Sequence
=>
1978 Make_Handled_Sequence_Of_Statements
(Loc
,
1979 Statements
=> New_List
(Loop_Stm
)));
1981 -- If no separate indexes, return loop statement with explicit
1982 -- iteration scheme on its own
1986 Make_Implicit_Loop_Statement
(Nod
,
1987 Statements
=> Stm_List
,
1989 Make_Iteration_Scheme
(Loc
,
1990 Loop_Parameter_Specification
=>
1991 Make_Loop_Parameter_Specification
(Loc
,
1992 Defining_Identifier
=> An
,
1993 Discrete_Subtype_Definition
=>
1994 Arr_Attr
(A
, Name_Range
, N
))));
1997 end Handle_One_Dimension
;
1999 -----------------------
2000 -- Test_Empty_Arrays --
2001 -----------------------
2003 function Test_Empty_Arrays
return Node_Id
is
2013 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2016 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2017 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2021 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
2022 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2031 Left_Opnd
=> Relocate_Node
(Alist
),
2032 Right_Opnd
=> Atest
);
2036 Left_Opnd
=> Relocate_Node
(Blist
),
2037 Right_Opnd
=> Btest
);
2044 Right_Opnd
=> Blist
);
2045 end Test_Empty_Arrays
;
2047 -----------------------------
2048 -- Test_Lengths_Correspond --
2049 -----------------------------
2051 function Test_Lengths_Correspond
return Node_Id
is
2057 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2060 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2061 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
2068 Left_Opnd
=> Relocate_Node
(Result
),
2069 Right_Opnd
=> Rtest
);
2074 end Test_Lengths_Correspond
;
2076 -- Start of processing for Expand_Array_Equality
2079 Ltyp
:= Get_Arg_Type
(Lhs
);
2080 Rtyp
:= Get_Arg_Type
(Rhs
);
2082 -- For now, if the argument types are not the same, go to the base type,
2083 -- since the code assumes that the formals have the same type. This is
2084 -- fixable in future ???
2086 if Ltyp
/= Rtyp
then
2087 Ltyp
:= Base_Type
(Ltyp
);
2088 Rtyp
:= Base_Type
(Rtyp
);
2089 pragma Assert
(Ltyp
= Rtyp
);
2092 -- Build list of formals for function
2094 Formals
:= New_List
(
2095 Make_Parameter_Specification
(Loc
,
2096 Defining_Identifier
=> A
,
2097 Parameter_Type
=> New_Reference_To
(Ltyp
, Loc
)),
2099 Make_Parameter_Specification
(Loc
,
2100 Defining_Identifier
=> B
,
2101 Parameter_Type
=> New_Reference_To
(Rtyp
, Loc
)));
2103 Func_Name
:= Make_Temporary
(Loc
, 'E');
2105 -- Build statement sequence for function
2108 Make_Subprogram_Body
(Loc
,
2110 Make_Function_Specification
(Loc
,
2111 Defining_Unit_Name
=> Func_Name
,
2112 Parameter_Specifications
=> Formals
,
2113 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
2115 Declarations
=> Decls
,
2117 Handled_Statement_Sequence
=>
2118 Make_Handled_Sequence_Of_Statements
(Loc
,
2119 Statements
=> New_List
(
2121 Make_Implicit_If_Statement
(Nod
,
2122 Condition
=> Test_Empty_Arrays
,
2123 Then_Statements
=> New_List
(
2124 Make_Simple_Return_Statement
(Loc
,
2126 New_Occurrence_Of
(Standard_True
, Loc
)))),
2128 Make_Implicit_If_Statement
(Nod
,
2129 Condition
=> Test_Lengths_Correspond
,
2130 Then_Statements
=> New_List
(
2131 Make_Simple_Return_Statement
(Loc
,
2133 New_Occurrence_Of
(Standard_False
, Loc
)))),
2135 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
2137 Make_Simple_Return_Statement
(Loc
,
2138 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2140 Set_Has_Completion
(Func_Name
, True);
2141 Set_Is_Inlined
(Func_Name
);
2143 -- If the array type is distinct from the type of the arguments, it
2144 -- is the full view of a private type. Apply an unchecked conversion
2145 -- to insure that analysis of the call succeeds.
2155 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
2157 L
:= OK_Convert_To
(Ltyp
, Lhs
);
2161 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
2163 R
:= OK_Convert_To
(Rtyp
, Rhs
);
2166 Actuals
:= New_List
(L
, R
);
2169 Append_To
(Bodies
, Func_Body
);
2172 Make_Function_Call
(Loc
,
2173 Name
=> New_Reference_To
(Func_Name
, Loc
),
2174 Parameter_Associations
=> Actuals
);
2175 end Expand_Array_Equality
;
2177 -----------------------------
2178 -- Expand_Boolean_Operator --
2179 -----------------------------
2181 -- Note that we first get the actual subtypes of the operands, since we
2182 -- always want to deal with types that have bounds.
2184 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2185 Typ
: constant Entity_Id
:= Etype
(N
);
2188 -- Special case of bit packed array where both operands are known to be
2189 -- properly aligned. In this case we use an efficient run time routine
2190 -- to carry out the operation (see System.Bit_Ops).
2192 if Is_Bit_Packed_Array
(Typ
)
2193 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2194 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2196 Expand_Packed_Boolean_Operator
(N
);
2200 -- For the normal non-packed case, the general expansion is to build
2201 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2202 -- and then inserting it into the tree. The original operator node is
2203 -- then rewritten as a call to this function. We also use this in the
2204 -- packed case if either operand is a possibly unaligned object.
2207 Loc
: constant Source_Ptr
:= Sloc
(N
);
2208 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2209 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2210 Func_Body
: Node_Id
;
2211 Func_Name
: Entity_Id
;
2214 Convert_To_Actual_Subtype
(L
);
2215 Convert_To_Actual_Subtype
(R
);
2216 Ensure_Defined
(Etype
(L
), N
);
2217 Ensure_Defined
(Etype
(R
), N
);
2218 Apply_Length_Check
(R
, Etype
(L
));
2220 if Nkind
(N
) = N_Op_Xor
then
2221 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2224 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2225 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2227 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2229 elsif Nkind
(Parent
(N
)) = N_Op_Not
2230 and then Nkind
(N
) = N_Op_And
2232 Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2237 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2238 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2239 Insert_Action
(N
, Func_Body
);
2241 -- Now rewrite the expression with a call
2244 Make_Function_Call
(Loc
,
2245 Name
=> New_Reference_To
(Func_Name
, Loc
),
2246 Parameter_Associations
=>
2249 Make_Type_Conversion
2250 (Loc
, New_Reference_To
(Etype
(L
), Loc
), R
))));
2252 Analyze_And_Resolve
(N
, Typ
);
2255 end Expand_Boolean_Operator
;
2257 ------------------------------------------------
2258 -- Expand_Compare_Minimize_Eliminate_Overflow --
2259 ------------------------------------------------
2261 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2262 Loc
: constant Source_Ptr
:= Sloc
(N
);
2264 Result_Type
: constant Entity_Id
:= Etype
(N
);
2265 -- Capture result type (could be a derived boolean type)
2270 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2271 -- Entity for Long_Long_Integer'Base
2273 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2274 -- Current overflow checking mode
2277 procedure Set_False
;
2278 -- These procedures rewrite N with an occurrence of Standard_True or
2279 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2285 procedure Set_False
is
2287 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2288 Warn_On_Known_Condition
(N
);
2295 procedure Set_True
is
2297 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2298 Warn_On_Known_Condition
(N
);
2301 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2304 -- Nothing to do unless we have a comparison operator with operands
2305 -- that are signed integer types, and we are operating in either
2306 -- MINIMIZED or ELIMINATED overflow checking mode.
2308 if Nkind
(N
) not in N_Op_Compare
2309 or else Check
not in Minimized_Or_Eliminated
2310 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2315 -- OK, this is the case we are interested in. First step is to process
2316 -- our operands using the Minimize_Eliminate circuitry which applies
2317 -- this processing to the two operand subtrees.
2319 Minimize_Eliminate_Overflows
2320 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2321 Minimize_Eliminate_Overflows
2322 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2324 -- See if the range information decides the result of the comparison.
2325 -- We can only do this if we in fact have full range information (which
2326 -- won't be the case if either operand is bignum at this stage).
2328 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2329 case N_Op_Compare
(Nkind
(N
)) is
2331 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2333 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2340 elsif Lhi
< Rlo
then
2347 elsif Lhi
<= Rlo
then
2354 elsif Lhi
<= Rlo
then
2361 elsif Lhi
< Rlo
then
2366 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2368 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2373 -- All done if we did the rewrite
2375 if Nkind
(N
) not in N_Op_Compare
then
2380 -- Otherwise, time to do the comparison
2383 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2384 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2387 -- If the two operands have the same signed integer type we are
2388 -- all set, nothing more to do. This is the case where either
2389 -- both operands were unchanged, or we rewrote both of them to
2390 -- be Long_Long_Integer.
2392 -- Note: Entity for the comparison may be wrong, but it's not worth
2393 -- the effort to change it, since the back end does not use it.
2395 if Is_Signed_Integer_Type
(Ltype
)
2396 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2400 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2402 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2404 Left
: Node_Id
:= Left_Opnd
(N
);
2405 Right
: Node_Id
:= Right_Opnd
(N
);
2406 -- Bignum references for left and right operands
2409 if not Is_RTE
(Ltype
, RE_Bignum
) then
2410 Left
:= Convert_To_Bignum
(Left
);
2411 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2412 Right
:= Convert_To_Bignum
(Right
);
2415 -- We rewrite our node with:
2418 -- Bnn : Result_Type;
2420 -- M : Mark_Id := SS_Mark;
2422 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2430 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2431 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2435 case N_Op_Compare
(Nkind
(N
)) is
2436 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2437 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2438 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2439 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2440 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2441 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2444 -- Insert assignment to Bnn into the bignum block
2447 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2448 Make_Assignment_Statement
(Loc
,
2449 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2451 Make_Function_Call
(Loc
,
2453 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2454 Parameter_Associations
=> New_List
(Left
, Right
))));
2456 -- Now do the rewrite with expression actions
2459 Make_Expression_With_Actions
(Loc
,
2460 Actions
=> New_List
(
2461 Make_Object_Declaration
(Loc
,
2462 Defining_Identifier
=> Bnn
,
2463 Object_Definition
=>
2464 New_Occurrence_Of
(Result_Type
, Loc
)),
2466 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2467 Analyze_And_Resolve
(N
, Result_Type
);
2471 -- No bignums involved, but types are different, so we must have
2472 -- rewritten one of the operands as a Long_Long_Integer but not
2475 -- If left operand is Long_Long_Integer, convert right operand
2476 -- and we are done (with a comparison of two Long_Long_Integers).
2478 elsif Ltype
= LLIB
then
2479 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2480 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2483 -- If right operand is Long_Long_Integer, convert left operand
2484 -- and we are done (with a comparison of two Long_Long_Integers).
2486 -- This is the only remaining possibility
2488 else pragma Assert
(Rtype
= LLIB
);
2489 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2490 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2494 end Expand_Compare_Minimize_Eliminate_Overflow
;
2496 -------------------------------
2497 -- Expand_Composite_Equality --
2498 -------------------------------
2500 -- This function is only called for comparing internal fields of composite
2501 -- types when these fields are themselves composites. This is a special
2502 -- case because it is not possible to respect normal Ada visibility rules.
2504 function Expand_Composite_Equality
2509 Bodies
: List_Id
) return Node_Id
2511 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2512 Full_Type
: Entity_Id
;
2516 function Find_Primitive_Eq
return Node_Id
;
2517 -- AI05-0123: Locate primitive equality for type if it exists, and
2518 -- build the corresponding call. If operation is abstract, replace
2519 -- call with an explicit raise. Return Empty if there is no primitive.
2521 -----------------------
2522 -- Find_Primitive_Eq --
2523 -----------------------
2525 function Find_Primitive_Eq
return Node_Id
is
2530 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2531 while Present
(Prim_E
) loop
2532 Prim
:= Node
(Prim_E
);
2534 -- Locate primitive equality with the right signature
2536 if Chars
(Prim
) = Name_Op_Eq
2537 and then Etype
(First_Formal
(Prim
)) =
2538 Etype
(Next_Formal
(First_Formal
(Prim
)))
2539 and then Etype
(Prim
) = Standard_Boolean
2541 if Is_Abstract_Subprogram
(Prim
) then
2543 Make_Raise_Program_Error
(Loc
,
2544 Reason
=> PE_Explicit_Raise
);
2548 Make_Function_Call
(Loc
,
2549 Name
=> New_Reference_To
(Prim
, Loc
),
2550 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2557 -- If not found, predefined operation will be used
2560 end Find_Primitive_Eq
;
2562 -- Start of processing for Expand_Composite_Equality
2565 if Is_Private_Type
(Typ
) then
2566 Full_Type
:= Underlying_Type
(Typ
);
2571 -- If the private type has no completion the context may be the
2572 -- expansion of a composite equality for a composite type with some
2573 -- still incomplete components. The expression will not be analyzed
2574 -- until the enclosing type is completed, at which point this will be
2575 -- properly expanded, unless there is a bona fide completion error.
2577 if No
(Full_Type
) then
2578 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2581 Full_Type
:= Base_Type
(Full_Type
);
2583 if Is_Array_Type
(Full_Type
) then
2585 -- If the operand is an elementary type other than a floating-point
2586 -- type, then we can simply use the built-in block bitwise equality,
2587 -- since the predefined equality operators always apply and bitwise
2588 -- equality is fine for all these cases.
2590 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2591 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2593 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2595 -- For composite component types, and floating-point types, use the
2596 -- expansion. This deals with tagged component types (where we use
2597 -- the applicable equality routine) and floating-point, (where we
2598 -- need to worry about negative zeroes), and also the case of any
2599 -- composite type recursively containing such fields.
2602 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2605 elsif Is_Tagged_Type
(Full_Type
) then
2607 -- Call the primitive operation "=" of this type
2609 if Is_Class_Wide_Type
(Full_Type
) then
2610 Full_Type
:= Root_Type
(Full_Type
);
2613 -- If this is derived from an untagged private type completed with a
2614 -- tagged type, it does not have a full view, so we use the primitive
2615 -- operations of the private type. This check should no longer be
2616 -- necessary when these types receive their full views ???
2618 if Is_Private_Type
(Typ
)
2619 and then not Is_Tagged_Type
(Typ
)
2620 and then not Is_Controlled
(Typ
)
2621 and then Is_Derived_Type
(Typ
)
2622 and then No
(Full_View
(Typ
))
2624 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2626 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2630 Eq_Op
:= Node
(Prim
);
2631 exit when Chars
(Eq_Op
) = Name_Op_Eq
2632 and then Etype
(First_Formal
(Eq_Op
)) =
2633 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2634 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2636 pragma Assert
(Present
(Prim
));
2639 Eq_Op
:= Node
(Prim
);
2642 Make_Function_Call
(Loc
,
2643 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2644 Parameter_Associations
=>
2646 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2647 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2649 elsif Is_Record_Type
(Full_Type
) then
2650 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2652 if Present
(Eq_Op
) then
2653 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2655 -- Inherited equality from parent type. Convert the actuals to
2656 -- match signature of operation.
2659 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2663 Make_Function_Call
(Loc
,
2664 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2665 Parameter_Associations
=> New_List
(
2666 OK_Convert_To
(T
, Lhs
),
2667 OK_Convert_To
(T
, Rhs
)));
2671 -- Comparison between Unchecked_Union components
2673 if Is_Unchecked_Union
(Full_Type
) then
2675 Lhs_Type
: Node_Id
:= Full_Type
;
2676 Rhs_Type
: Node_Id
:= Full_Type
;
2677 Lhs_Discr_Val
: Node_Id
;
2678 Rhs_Discr_Val
: Node_Id
;
2683 if Nkind
(Lhs
) = N_Selected_Component
then
2684 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2689 if Nkind
(Rhs
) = N_Selected_Component
then
2690 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2693 -- Lhs of the composite equality
2695 if Is_Constrained
(Lhs_Type
) then
2697 -- Since the enclosing record type can never be an
2698 -- Unchecked_Union (this code is executed for records
2699 -- that do not have variants), we may reference its
2702 if Nkind
(Lhs
) = N_Selected_Component
2703 and then Has_Per_Object_Constraint
2704 (Entity
(Selector_Name
(Lhs
)))
2707 Make_Selected_Component
(Loc
,
2708 Prefix
=> Prefix
(Lhs
),
2711 (Get_Discriminant_Value
2712 (First_Discriminant
(Lhs_Type
),
2714 Stored_Constraint
(Lhs_Type
))));
2719 (Get_Discriminant_Value
2720 (First_Discriminant
(Lhs_Type
),
2722 Stored_Constraint
(Lhs_Type
)));
2726 -- It is not possible to infer the discriminant since
2727 -- the subtype is not constrained.
2730 Make_Raise_Program_Error
(Loc
,
2731 Reason
=> PE_Unchecked_Union_Restriction
);
2734 -- Rhs of the composite equality
2736 if Is_Constrained
(Rhs_Type
) then
2737 if Nkind
(Rhs
) = N_Selected_Component
2738 and then Has_Per_Object_Constraint
2739 (Entity
(Selector_Name
(Rhs
)))
2742 Make_Selected_Component
(Loc
,
2743 Prefix
=> Prefix
(Rhs
),
2746 (Get_Discriminant_Value
2747 (First_Discriminant
(Rhs_Type
),
2749 Stored_Constraint
(Rhs_Type
))));
2754 (Get_Discriminant_Value
2755 (First_Discriminant
(Rhs_Type
),
2757 Stored_Constraint
(Rhs_Type
)));
2762 Make_Raise_Program_Error
(Loc
,
2763 Reason
=> PE_Unchecked_Union_Restriction
);
2766 -- Call the TSS equality function with the inferred
2767 -- discriminant values.
2770 Make_Function_Call
(Loc
,
2771 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2772 Parameter_Associations
=> New_List
(
2781 Make_Function_Call
(Loc
,
2782 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2783 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2787 -- Equality composes in Ada 2012 for untagged record types. It also
2788 -- composes for bounded strings, because they are part of the
2789 -- predefined environment. We could make it compose for bounded
2790 -- strings by making them tagged, or by making sure all subcomponents
2791 -- are set to the same value, even when not used. Instead, we have
2792 -- this special case in the compiler, because it's more efficient.
2794 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2796 -- if no TSS has been created for the type, check whether there is
2797 -- a primitive equality declared for it.
2800 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2803 -- Use user-defined primitive if it exists, otherwise use
2804 -- predefined equality.
2806 if Present
(Op
) then
2809 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2814 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2818 -- If not array or record type, it is predefined equality.
2820 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2822 end Expand_Composite_Equality
;
2824 ------------------------
2825 -- Expand_Concatenate --
2826 ------------------------
2828 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2829 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2831 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2832 -- Result type of concatenation
2834 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2835 -- Component type. Elements of this component type can appear as one
2836 -- of the operands of concatenation as well as arrays.
2838 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2841 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2842 -- Index type. This is the base type of the index subtype, and is used
2843 -- for all computed bounds (which may be out of range of Istyp in the
2844 -- case of null ranges).
2847 -- This is the type we use to do arithmetic to compute the bounds and
2848 -- lengths of operands. The choice of this type is a little subtle and
2849 -- is discussed in a separate section at the start of the body code.
2851 Concatenation_Error
: exception;
2852 -- Raised if concatenation is sure to raise a CE
2854 Result_May_Be_Null
: Boolean := True;
2855 -- Reset to False if at least one operand is encountered which is known
2856 -- at compile time to be non-null. Used for handling the special case
2857 -- of setting the high bound to the last operand high bound for a null
2858 -- result, thus ensuring a proper high bound in the super-flat case.
2860 N
: constant Nat
:= List_Length
(Opnds
);
2861 -- Number of concatenation operands including possibly null operands
2864 -- Number of operands excluding any known to be null, except that the
2865 -- last operand is always retained, in case it provides the bounds for
2869 -- Current operand being processed in the loop through operands. After
2870 -- this loop is complete, always contains the last operand (which is not
2871 -- the same as Operands (NN), since null operands are skipped).
2873 -- Arrays describing the operands, only the first NN entries of each
2874 -- array are set (NN < N when we exclude known null operands).
2876 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2877 -- True if length of corresponding operand known at compile time
2879 Operands
: array (1 .. N
) of Node_Id
;
2880 -- Set to the corresponding entry in the Opnds list (but note that null
2881 -- operands are excluded, so not all entries in the list are stored).
2883 Fixed_Length
: array (1 .. N
) of Uint
;
2884 -- Set to length of operand. Entries in this array are set only if the
2885 -- corresponding entry in Is_Fixed_Length is True.
2887 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2888 -- Set to lower bound of operand. Either an integer literal in the case
2889 -- where the bound is known at compile time, else actual lower bound.
2890 -- The operand low bound is of type Ityp.
2892 Var_Length
: array (1 .. N
) of Entity_Id
;
2893 -- Set to an entity of type Natural that contains the length of an
2894 -- operand whose length is not known at compile time. Entries in this
2895 -- array are set only if the corresponding entry in Is_Fixed_Length
2896 -- is False. The entity is of type Artyp.
2898 Aggr_Length
: array (0 .. N
) of Node_Id
;
2899 -- The J'th entry in an expression node that represents the total length
2900 -- of operands 1 through J. It is either an integer literal node, or a
2901 -- reference to a constant entity with the right value, so it is fine
2902 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2903 -- entry always is set to zero. The length is of type Artyp.
2905 Low_Bound
: Node_Id
;
2906 -- A tree node representing the low bound of the result (of type Ityp).
2907 -- This is either an integer literal node, or an identifier reference to
2908 -- a constant entity initialized to the appropriate value.
2910 Last_Opnd_Low_Bound
: Node_Id
;
2911 -- A tree node representing the low bound of the last operand. This
2912 -- need only be set if the result could be null. It is used for the
2913 -- special case of setting the right low bound for a null result.
2914 -- This is of type Ityp.
2916 Last_Opnd_High_Bound
: Node_Id
;
2917 -- A tree node representing the high bound of the last operand. This
2918 -- need only be set if the result could be null. It is used for the
2919 -- special case of setting the right high bound for a null result.
2920 -- This is of type Ityp.
2922 High_Bound
: Node_Id
;
2923 -- A tree node representing the high bound of the result (of type Ityp)
2926 -- Result of the concatenation (of type Ityp)
2928 Actions
: constant List_Id
:= New_List
;
2929 -- Collect actions to be inserted
2931 Known_Non_Null_Operand_Seen
: Boolean;
2932 -- Set True during generation of the assignments of operands into
2933 -- result once an operand known to be non-null has been seen.
2935 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2936 -- This function makes an N_Integer_Literal node that is returned in
2937 -- analyzed form with the type set to Artyp. Importantly this literal
2938 -- is not flagged as static, so that if we do computations with it that
2939 -- result in statically detected out of range conditions, we will not
2940 -- generate error messages but instead warning messages.
2942 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2943 -- Given a node of type Ityp, returns the corresponding value of type
2944 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2945 -- For enum types, the Pos of the value is returned.
2947 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2948 -- The inverse function (uses Val in the case of enumeration types)
2950 ------------------------
2951 -- Make_Artyp_Literal --
2952 ------------------------
2954 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2955 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2957 Set_Etype
(Result
, Artyp
);
2958 Set_Analyzed
(Result
, True);
2959 Set_Is_Static_Expression
(Result
, False);
2961 end Make_Artyp_Literal
;
2967 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2969 if Ityp
= Base_Type
(Artyp
) then
2972 elsif Is_Enumeration_Type
(Ityp
) then
2974 Make_Attribute_Reference
(Loc
,
2975 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2976 Attribute_Name
=> Name_Pos
,
2977 Expressions
=> New_List
(X
));
2980 return Convert_To
(Artyp
, X
);
2988 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2990 if Is_Enumeration_Type
(Ityp
) then
2992 Make_Attribute_Reference
(Loc
,
2993 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2994 Attribute_Name
=> Name_Val
,
2995 Expressions
=> New_List
(X
));
2997 -- Case where we will do a type conversion
3000 if Ityp
= Base_Type
(Artyp
) then
3003 return Convert_To
(Ityp
, X
);
3008 -- Local Declarations
3010 Opnd_Typ
: Entity_Id
;
3017 -- Start of processing for Expand_Concatenate
3020 -- Choose an appropriate computational type
3022 -- We will be doing calculations of lengths and bounds in this routine
3023 -- and computing one from the other in some cases, e.g. getting the high
3024 -- bound by adding the length-1 to the low bound.
3026 -- We can't just use the index type, or even its base type for this
3027 -- purpose for two reasons. First it might be an enumeration type which
3028 -- is not suitable for computations of any kind, and second it may
3029 -- simply not have enough range. For example if the index type is
3030 -- -128..+127 then lengths can be up to 256, which is out of range of
3033 -- For enumeration types, we can simply use Standard_Integer, this is
3034 -- sufficient since the actual number of enumeration literals cannot
3035 -- possibly exceed the range of integer (remember we will be doing the
3036 -- arithmetic with POS values, not representation values).
3038 if Is_Enumeration_Type
(Ityp
) then
3039 Artyp
:= Standard_Integer
;
3041 -- If index type is Positive, we use the standard unsigned type, to give
3042 -- more room on the top of the range, obviating the need for an overflow
3043 -- check when creating the upper bound. This is needed to avoid junk
3044 -- overflow checks in the common case of String types.
3046 -- ??? Disabled for now
3048 -- elsif Istyp = Standard_Positive then
3049 -- Artyp := Standard_Unsigned;
3051 -- For modular types, we use a 32-bit modular type for types whose size
3052 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3053 -- identity type, and for larger unsigned types we use 64-bits.
3055 elsif Is_Modular_Integer_Type
(Ityp
) then
3056 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
3057 Artyp
:= Standard_Unsigned
;
3058 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
3061 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
3064 -- Similar treatment for signed types
3067 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
3068 Artyp
:= Standard_Integer
;
3069 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
3072 Artyp
:= Standard_Long_Long_Integer
;
3076 -- Supply dummy entry at start of length array
3078 Aggr_Length
(0) := Make_Artyp_Literal
(0);
3080 -- Go through operands setting up the above arrays
3084 Opnd
:= Remove_Head
(Opnds
);
3085 Opnd_Typ
:= Etype
(Opnd
);
3087 -- The parent got messed up when we put the operands in a list,
3088 -- so now put back the proper parent for the saved operand, that
3089 -- is to say the concatenation node, to make sure that each operand
3090 -- is seen as a subexpression, e.g. if actions must be inserted.
3092 Set_Parent
(Opnd
, Cnode
);
3094 -- Set will be True when we have setup one entry in the array
3098 -- Singleton element (or character literal) case
3100 if Base_Type
(Opnd_Typ
) = Ctyp
then
3102 Operands
(NN
) := Opnd
;
3103 Is_Fixed_Length
(NN
) := True;
3104 Fixed_Length
(NN
) := Uint_1
;
3105 Result_May_Be_Null
:= False;
3107 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3108 -- since we know that the result cannot be null).
3110 Opnd_Low_Bound
(NN
) :=
3111 Make_Attribute_Reference
(Loc
,
3112 Prefix
=> New_Reference_To
(Istyp
, Loc
),
3113 Attribute_Name
=> Name_First
);
3117 -- String literal case (can only occur for strings of course)
3119 elsif Nkind
(Opnd
) = N_String_Literal
then
3120 Len
:= String_Literal_Length
(Opnd_Typ
);
3123 Result_May_Be_Null
:= False;
3126 -- Capture last operand low and high bound if result could be null
3128 if J
= N
and then Result_May_Be_Null
then
3129 Last_Opnd_Low_Bound
:=
3130 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3132 Last_Opnd_High_Bound
:=
3133 Make_Op_Subtract
(Loc
,
3135 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3136 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3139 -- Skip null string literal
3141 if J
< N
and then Len
= 0 then
3146 Operands
(NN
) := Opnd
;
3147 Is_Fixed_Length
(NN
) := True;
3149 -- Set length and bounds
3151 Fixed_Length
(NN
) := Len
;
3153 Opnd_Low_Bound
(NN
) :=
3154 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3161 -- Check constrained case with known bounds
3163 if Is_Constrained
(Opnd_Typ
) then
3165 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3166 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3167 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3168 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3171 -- Fixed length constrained array type with known at compile
3172 -- time bounds is last case of fixed length operand.
3174 if Compile_Time_Known_Value
(Lo
)
3176 Compile_Time_Known_Value
(Hi
)
3179 Loval
: constant Uint
:= Expr_Value
(Lo
);
3180 Hival
: constant Uint
:= Expr_Value
(Hi
);
3181 Len
: constant Uint
:=
3182 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3186 Result_May_Be_Null
:= False;
3189 -- Capture last operand bounds if result could be null
3191 if J
= N
and then Result_May_Be_Null
then
3192 Last_Opnd_Low_Bound
:=
3194 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3196 Last_Opnd_High_Bound
:=
3198 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3201 -- Exclude null length case unless last operand
3203 if J
< N
and then Len
= 0 then
3208 Operands
(NN
) := Opnd
;
3209 Is_Fixed_Length
(NN
) := True;
3210 Fixed_Length
(NN
) := Len
;
3212 Opnd_Low_Bound
(NN
) :=
3214 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3221 -- All cases where the length is not known at compile time, or the
3222 -- special case of an operand which is known to be null but has a
3223 -- lower bound other than 1 or is other than a string type.
3228 -- Capture operand bounds
3230 Opnd_Low_Bound
(NN
) :=
3231 Make_Attribute_Reference
(Loc
,
3233 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3234 Attribute_Name
=> Name_First
);
3236 -- Capture last operand bounds if result could be null
3238 if J
= N
and Result_May_Be_Null
then
3239 Last_Opnd_Low_Bound
:=
3241 Make_Attribute_Reference
(Loc
,
3243 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3244 Attribute_Name
=> Name_First
));
3246 Last_Opnd_High_Bound
:=
3248 Make_Attribute_Reference
(Loc
,
3250 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3251 Attribute_Name
=> Name_Last
));
3254 -- Capture length of operand in entity
3256 Operands
(NN
) := Opnd
;
3257 Is_Fixed_Length
(NN
) := False;
3259 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3262 Make_Object_Declaration
(Loc
,
3263 Defining_Identifier
=> Var_Length
(NN
),
3264 Constant_Present
=> True,
3265 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3267 Make_Attribute_Reference
(Loc
,
3269 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3270 Attribute_Name
=> Name_Length
)));
3274 -- Set next entry in aggregate length array
3276 -- For first entry, make either integer literal for fixed length
3277 -- or a reference to the saved length for variable length.
3280 if Is_Fixed_Length
(1) then
3281 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3283 Aggr_Length
(1) := New_Reference_To
(Var_Length
(1), Loc
);
3286 -- If entry is fixed length and only fixed lengths so far, make
3287 -- appropriate new integer literal adding new length.
3289 elsif Is_Fixed_Length
(NN
)
3290 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3293 Make_Integer_Literal
(Loc
,
3294 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3296 -- All other cases, construct an addition node for the length and
3297 -- create an entity initialized to this length.
3300 Ent
:= Make_Temporary
(Loc
, 'L');
3302 if Is_Fixed_Length
(NN
) then
3303 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3305 Clen
:= New_Reference_To
(Var_Length
(NN
), Loc
);
3309 Make_Object_Declaration
(Loc
,
3310 Defining_Identifier
=> Ent
,
3311 Constant_Present
=> True,
3312 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3315 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
3316 Right_Opnd
=> Clen
)));
3318 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3325 -- If we have only skipped null operands, return the last operand
3332 -- If we have only one non-null operand, return it and we are done.
3333 -- There is one case in which this cannot be done, and that is when
3334 -- the sole operand is of the element type, in which case it must be
3335 -- converted to an array, and the easiest way of doing that is to go
3336 -- through the normal general circuit.
3338 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3339 Result
:= Operands
(1);
3343 -- Cases where we have a real concatenation
3345 -- Next step is to find the low bound for the result array that we
3346 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3348 -- If the ultimate ancestor of the index subtype is a constrained array
3349 -- definition, then the lower bound is that of the index subtype as
3350 -- specified by (RM 4.5.3(6)).
3352 -- The right test here is to go to the root type, and then the ultimate
3353 -- ancestor is the first subtype of this root type.
3355 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3357 Make_Attribute_Reference
(Loc
,
3359 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3360 Attribute_Name
=> Name_First
);
3362 -- If the first operand in the list has known length we know that
3363 -- the lower bound of the result is the lower bound of this operand.
3365 elsif Is_Fixed_Length
(1) then
3366 Low_Bound
:= Opnd_Low_Bound
(1);
3368 -- OK, we don't know the lower bound, we have to build a horrible
3369 -- if expression node of the form
3371 -- if Cond1'Length /= 0 then
3374 -- if Opnd2'Length /= 0 then
3379 -- The nesting ends either when we hit an operand whose length is known
3380 -- at compile time, or on reaching the last operand, whose low bound we
3381 -- take unconditionally whether or not it is null. It's easiest to do
3382 -- this with a recursive procedure:
3386 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3387 -- Returns the lower bound determined by operands J .. NN
3389 ---------------------
3390 -- Get_Known_Bound --
3391 ---------------------
3393 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3395 if Is_Fixed_Length
(J
) or else J
= NN
then
3396 return New_Copy
(Opnd_Low_Bound
(J
));
3400 Make_If_Expression
(Loc
,
3401 Expressions
=> New_List
(
3404 Left_Opnd
=> New_Reference_To
(Var_Length
(J
), Loc
),
3405 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3407 New_Copy
(Opnd_Low_Bound
(J
)),
3408 Get_Known_Bound
(J
+ 1)));
3410 end Get_Known_Bound
;
3413 Ent
:= Make_Temporary
(Loc
, 'L');
3416 Make_Object_Declaration
(Loc
,
3417 Defining_Identifier
=> Ent
,
3418 Constant_Present
=> True,
3419 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3420 Expression
=> Get_Known_Bound
(1)));
3422 Low_Bound
:= New_Reference_To
(Ent
, Loc
);
3426 -- Now we can safely compute the upper bound, normally
3427 -- Low_Bound + Length - 1.
3432 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3434 Make_Op_Subtract
(Loc
,
3435 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3436 Right_Opnd
=> Make_Artyp_Literal
(1))));
3438 -- Note that calculation of the high bound may cause overflow in some
3439 -- very weird cases, so in the general case we need an overflow check on
3440 -- the high bound. We can avoid this for the common case of string types
3441 -- and other types whose index is Positive, since we chose a wider range
3442 -- for the arithmetic type.
3444 if Istyp
/= Standard_Positive
then
3445 Activate_Overflow_Check
(High_Bound
);
3448 -- Handle the exceptional case where the result is null, in which case
3449 -- case the bounds come from the last operand (so that we get the proper
3450 -- bounds if the last operand is super-flat).
3452 if Result_May_Be_Null
then
3454 Make_If_Expression
(Loc
,
3455 Expressions
=> New_List
(
3457 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3458 Right_Opnd
=> Make_Artyp_Literal
(0)),
3459 Last_Opnd_Low_Bound
,
3463 Make_If_Expression
(Loc
,
3464 Expressions
=> New_List
(
3466 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3467 Right_Opnd
=> Make_Artyp_Literal
(0)),
3468 Last_Opnd_High_Bound
,
3472 -- Here is where we insert the saved up actions
3474 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3476 -- Now we construct an array object with appropriate bounds. We mark
3477 -- the target as internal to prevent useless initialization when
3478 -- Initialize_Scalars is enabled. Also since this is the actual result
3479 -- entity, we make sure we have debug information for the result.
3481 Ent
:= Make_Temporary
(Loc
, 'S');
3482 Set_Is_Internal
(Ent
);
3483 Set_Needs_Debug_Info
(Ent
);
3485 -- If the bound is statically known to be out of range, we do not want
3486 -- to abort, we want a warning and a runtime constraint error. Note that
3487 -- we have arranged that the result will not be treated as a static
3488 -- constant, so we won't get an illegality during this insertion.
3490 Insert_Action
(Cnode
,
3491 Make_Object_Declaration
(Loc
,
3492 Defining_Identifier
=> Ent
,
3493 Object_Definition
=>
3494 Make_Subtype_Indication
(Loc
,
3495 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3497 Make_Index_Or_Discriminant_Constraint
(Loc
,
3498 Constraints
=> New_List
(
3500 Low_Bound
=> Low_Bound
,
3501 High_Bound
=> High_Bound
))))),
3502 Suppress
=> All_Checks
);
3504 -- If the result of the concatenation appears as the initializing
3505 -- expression of an object declaration, we can just rename the
3506 -- result, rather than copying it.
3508 Set_OK_To_Rename
(Ent
);
3510 -- Catch the static out of range case now
3512 if Raises_Constraint_Error
(High_Bound
) then
3513 raise Concatenation_Error
;
3516 -- Now we will generate the assignments to do the actual concatenation
3518 -- There is one case in which we will not do this, namely when all the
3519 -- following conditions are met:
3521 -- The result type is Standard.String
3523 -- There are nine or fewer retained (non-null) operands
3525 -- The optimization level is -O0
3527 -- The corresponding System.Concat_n.Str_Concat_n routine is
3528 -- available in the run time.
3530 -- The debug flag gnatd.c is not set
3532 -- If all these conditions are met then we generate a call to the
3533 -- relevant concatenation routine. The purpose of this is to avoid
3534 -- undesirable code bloat at -O0.
3536 if Atyp
= Standard_String
3537 and then NN
in 2 .. 9
3538 and then (Opt
.Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3539 and then not Debug_Flag_Dot_C
3542 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3553 if RTE_Available
(RR
(NN
)) then
3555 Opnds
: constant List_Id
:=
3556 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3559 for J
in 1 .. NN
loop
3560 if Is_List_Member
(Operands
(J
)) then
3561 Remove
(Operands
(J
));
3564 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3566 Make_Aggregate
(Loc
,
3567 Component_Associations
=> New_List
(
3568 Make_Component_Association
(Loc
,
3569 Choices
=> New_List
(
3570 Make_Integer_Literal
(Loc
, 1)),
3571 Expression
=> Operands
(J
)))));
3574 Append_To
(Opnds
, Operands
(J
));
3578 Insert_Action
(Cnode
,
3579 Make_Procedure_Call_Statement
(Loc
,
3580 Name
=> New_Reference_To
(RTE
(RR
(NN
)), Loc
),
3581 Parameter_Associations
=> Opnds
));
3583 Result
:= New_Reference_To
(Ent
, Loc
);
3590 -- Not special case so generate the assignments
3592 Known_Non_Null_Operand_Seen
:= False;
3594 for J
in 1 .. NN
loop
3596 Lo
: constant Node_Id
:=
3598 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3599 Right_Opnd
=> Aggr_Length
(J
- 1));
3601 Hi
: constant Node_Id
:=
3603 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3605 Make_Op_Subtract
(Loc
,
3606 Left_Opnd
=> Aggr_Length
(J
),
3607 Right_Opnd
=> Make_Artyp_Literal
(1)));
3610 -- Singleton case, simple assignment
3612 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3613 Known_Non_Null_Operand_Seen
:= True;
3614 Insert_Action
(Cnode
,
3615 Make_Assignment_Statement
(Loc
,
3617 Make_Indexed_Component
(Loc
,
3618 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3619 Expressions
=> New_List
(To_Ityp
(Lo
))),
3620 Expression
=> Operands
(J
)),
3621 Suppress
=> All_Checks
);
3623 -- Array case, slice assignment, skipped when argument is fixed
3624 -- length and known to be null.
3626 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3629 Make_Assignment_Statement
(Loc
,
3633 New_Occurrence_Of
(Ent
, Loc
),
3636 Low_Bound
=> To_Ityp
(Lo
),
3637 High_Bound
=> To_Ityp
(Hi
))),
3638 Expression
=> Operands
(J
));
3640 if Is_Fixed_Length
(J
) then
3641 Known_Non_Null_Operand_Seen
:= True;
3643 elsif not Known_Non_Null_Operand_Seen
then
3645 -- Here if operand length is not statically known and no
3646 -- operand known to be non-null has been processed yet.
3647 -- If operand length is 0, we do not need to perform the
3648 -- assignment, and we must avoid the evaluation of the
3649 -- high bound of the slice, since it may underflow if the
3650 -- low bound is Ityp'First.
3653 Make_Implicit_If_Statement
(Cnode
,
3657 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3658 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3659 Then_Statements
=> New_List
(Assign
));
3662 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3668 -- Finally we build the result, which is a reference to the array object
3670 Result
:= New_Reference_To
(Ent
, Loc
);
3673 Rewrite
(Cnode
, Result
);
3674 Analyze_And_Resolve
(Cnode
, Atyp
);
3677 when Concatenation_Error
=>
3679 -- Kill warning generated for the declaration of the static out of
3680 -- range high bound, and instead generate a Constraint_Error with
3681 -- an appropriate specific message.
3683 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3684 Apply_Compile_Time_Constraint_Error
3686 Msg
=> "concatenation result upper bound out of range??",
3687 Reason
=> CE_Range_Check_Failed
);
3688 end Expand_Concatenate
;
3690 ---------------------------------------------------
3691 -- Expand_Membership_Minimize_Eliminate_Overflow --
3692 ---------------------------------------------------
3694 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3695 pragma Assert
(Nkind
(N
) = N_In
);
3696 -- Despite the name, this routine applies only to N_In, not to
3697 -- N_Not_In. The latter is always rewritten as not (X in Y).
3699 Result_Type
: constant Entity_Id
:= Etype
(N
);
3700 -- Capture result type, may be a derived boolean type
3702 Loc
: constant Source_Ptr
:= Sloc
(N
);
3703 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3704 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3706 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3707 -- is thus tempting to capture these values, but due to the rewrites
3708 -- that occur as a result of overflow checking, these values change
3709 -- as we go along, and it is safe just to always use Etype explicitly.
3711 Restype
: constant Entity_Id
:= Etype
(N
);
3715 -- Bounds in Minimize calls, not used currently
3717 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3718 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3721 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3723 -- If right operand is a subtype name, and the subtype name has no
3724 -- predicate, then we can just replace the right operand with an
3725 -- explicit range T'First .. T'Last, and use the explicit range code.
3727 if Nkind
(Rop
) /= N_Range
3728 and then No
(Predicate_Function
(Etype
(Rop
)))
3731 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3736 Make_Attribute_Reference
(Loc
,
3737 Attribute_Name
=> Name_First
,
3738 Prefix
=> New_Reference_To
(Rtyp
, Loc
)),
3740 Make_Attribute_Reference
(Loc
,
3741 Attribute_Name
=> Name_Last
,
3742 Prefix
=> New_Reference_To
(Rtyp
, Loc
))));
3743 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3747 -- Here for the explicit range case. Note that the bounds of the range
3748 -- have not been processed for minimized or eliminated checks.
3750 if Nkind
(Rop
) = N_Range
then
3751 Minimize_Eliminate_Overflows
3752 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3753 Minimize_Eliminate_Overflows
3754 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3756 -- We have A in B .. C, treated as A >= B and then A <= C
3760 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3761 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3762 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3765 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3766 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3767 L
: constant Entity_Id
:=
3768 Make_Defining_Identifier
(Loc
, Name_uL
);
3769 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3770 Lbound
: constant Node_Id
:=
3771 Convert_To_Bignum
(Low_Bound
(Rop
));
3772 Hbound
: constant Node_Id
:=
3773 Convert_To_Bignum
(High_Bound
(Rop
));
3775 -- Now we rewrite the membership test node to look like
3778 -- Bnn : Result_Type;
3780 -- M : Mark_Id := SS_Mark;
3781 -- L : Bignum := Lopnd;
3783 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3791 -- Insert declaration of L into declarations of bignum block
3794 (Last
(Declarations
(Blk
)),
3795 Make_Object_Declaration
(Loc
,
3796 Defining_Identifier
=> L
,
3797 Object_Definition
=>
3798 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3799 Expression
=> Lopnd
));
3801 -- Insert assignment to Bnn into expressions of bignum block
3804 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3805 Make_Assignment_Statement
(Loc
,
3806 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3810 Make_Function_Call
(Loc
,
3812 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3813 Parameter_Associations
=> New_List
(
3814 New_Occurrence_Of
(L
, Loc
),
3817 Make_Function_Call
(Loc
,
3819 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3820 Parameter_Associations
=> New_List
(
3821 New_Occurrence_Of
(L
, Loc
),
3824 -- Now rewrite the node
3827 Make_Expression_With_Actions
(Loc
,
3828 Actions
=> New_List
(
3829 Make_Object_Declaration
(Loc
,
3830 Defining_Identifier
=> Bnn
,
3831 Object_Definition
=>
3832 New_Occurrence_Of
(Result_Type
, Loc
)),
3834 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3835 Analyze_And_Resolve
(N
, Result_Type
);
3839 -- Here if no bignums around
3842 -- Case where types are all the same
3844 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3846 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3850 -- If types are not all the same, it means that we have rewritten
3851 -- at least one of them to be of type Long_Long_Integer, and we
3852 -- will convert the other operands to Long_Long_Integer.
3855 Convert_To_And_Rewrite
(LLIB
, Lop
);
3856 Set_Analyzed
(Lop
, False);
3857 Analyze_And_Resolve
(Lop
, LLIB
);
3859 -- For the right operand, avoid unnecessary recursion into
3860 -- this routine, we know that overflow is not possible.
3862 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3863 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3864 Set_Analyzed
(Rop
, False);
3865 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3868 -- Now the three operands are of the same signed integer type,
3869 -- so we can use the normal expansion routine for membership,
3870 -- setting the flag to prevent recursion into this procedure.
3872 Set_No_Minimize_Eliminate
(N
);
3876 -- Right operand is a subtype name and the subtype has a predicate. We
3877 -- have to make sure the predicate is checked, and for that we need to
3878 -- use the standard N_In circuitry with appropriate types.
3881 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3883 -- If types are "right", just call Expand_N_In preventing recursion
3885 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3886 Set_No_Minimize_Eliminate
(N
);
3891 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3893 -- For X in T, we want to rewrite our node as
3896 -- Bnn : Result_Type;
3899 -- M : Mark_Id := SS_Mark;
3900 -- Lnn : Long_Long_Integer'Base
3906 -- if not Bignum_In_LLI_Range (Nnn) then
3909 -- Lnn := From_Bignum (Nnn);
3911 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3912 -- and then T'Base (Lnn) in T;
3921 -- A bit gruesome, but there doesn't seem to be a simpler way
3924 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3925 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3926 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3927 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3928 T
: constant Entity_Id
:= Etype
(Rop
);
3929 TB
: constant Entity_Id
:= Base_Type
(T
);
3933 -- Mark the last membership operation to prevent recursion
3937 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3938 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3939 Set_No_Minimize_Eliminate
(Nin
);
3941 -- Now decorate the block
3944 (Last
(Declarations
(Blk
)),
3945 Make_Object_Declaration
(Loc
,
3946 Defining_Identifier
=> Lnn
,
3947 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3950 (Last
(Declarations
(Blk
)),
3951 Make_Object_Declaration
(Loc
,
3952 Defining_Identifier
=> Nnn
,
3953 Object_Definition
=>
3954 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3957 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3959 Make_Assignment_Statement
(Loc
,
3960 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3961 Expression
=> Relocate_Node
(Lop
)),
3963 Make_Implicit_If_Statement
(N
,
3967 Make_Function_Call
(Loc
,
3970 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3971 Parameter_Associations
=> New_List
(
3972 New_Occurrence_Of
(Nnn
, Loc
)))),
3974 Then_Statements
=> New_List
(
3975 Make_Assignment_Statement
(Loc
,
3976 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3978 New_Occurrence_Of
(Standard_False
, Loc
))),
3980 Else_Statements
=> New_List
(
3981 Make_Assignment_Statement
(Loc
,
3982 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3984 Make_Function_Call
(Loc
,
3986 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3987 Parameter_Associations
=> New_List
(
3988 New_Occurrence_Of
(Nnn
, Loc
)))),
3990 Make_Assignment_Statement
(Loc
,
3991 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3996 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4001 Make_Attribute_Reference
(Loc
,
4002 Attribute_Name
=> Name_First
,
4004 New_Occurrence_Of
(TB
, Loc
))),
4008 Make_Attribute_Reference
(Loc
,
4009 Attribute_Name
=> Name_Last
,
4011 New_Occurrence_Of
(TB
, Loc
))))),
4013 Right_Opnd
=> Nin
))))));
4015 -- Now we can do the rewrite
4018 Make_Expression_With_Actions
(Loc
,
4019 Actions
=> New_List
(
4020 Make_Object_Declaration
(Loc
,
4021 Defining_Identifier
=> Bnn
,
4022 Object_Definition
=>
4023 New_Occurrence_Of
(Result_Type
, Loc
)),
4025 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
4026 Analyze_And_Resolve
(N
, Result_Type
);
4030 -- Not bignum case, but types don't match (this means we rewrote the
4031 -- left operand to be Long_Long_Integer).
4034 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
4036 -- We rewrite the membership test as (where T is the type with
4037 -- the predicate, i.e. the type of the right operand)
4039 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4040 -- and then T'Base (Lop) in T
4043 T
: constant Entity_Id
:= Etype
(Rop
);
4044 TB
: constant Entity_Id
:= Base_Type
(T
);
4048 -- The last membership test is marked to prevent recursion
4052 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
4053 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4054 Set_No_Minimize_Eliminate
(Nin
);
4056 -- Now do the rewrite
4067 Make_Attribute_Reference
(Loc
,
4068 Attribute_Name
=> Name_First
,
4069 Prefix
=> New_Occurrence_Of
(TB
, Loc
))),
4072 Make_Attribute_Reference
(Loc
,
4073 Attribute_Name
=> Name_Last
,
4074 Prefix
=> New_Occurrence_Of
(TB
, Loc
))))),
4075 Right_Opnd
=> Nin
));
4076 Set_Analyzed
(N
, False);
4077 Analyze_And_Resolve
(N
, Restype
);
4081 end Expand_Membership_Minimize_Eliminate_Overflow
;
4083 ------------------------
4084 -- Expand_N_Allocator --
4085 ------------------------
4087 procedure Expand_N_Allocator
(N
: Node_Id
) is
4088 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4089 Loc
: constant Source_Ptr
:= Sloc
(N
);
4090 PtrT
: constant Entity_Id
:= Etype
(N
);
4092 procedure Rewrite_Coextension
(N
: Node_Id
);
4093 -- Static coextensions have the same lifetime as the entity they
4094 -- constrain. Such occurrences can be rewritten as aliased objects
4095 -- and their unrestricted access used instead of the coextension.
4097 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4098 -- Given a constrained array type E, returns a node representing the
4099 -- code to compute the size in storage elements for the given type.
4100 -- This is done without using the attribute (which malfunctions for
4103 -------------------------
4104 -- Rewrite_Coextension --
4105 -------------------------
4107 procedure Rewrite_Coextension
(N
: Node_Id
) is
4108 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4109 Temp_Decl
: Node_Id
;
4113 -- Cnn : aliased Etyp;
4116 Make_Object_Declaration
(Loc
,
4117 Defining_Identifier
=> Temp_Id
,
4118 Aliased_Present
=> True,
4119 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4121 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4122 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4125 Insert_Action
(N
, Temp_Decl
);
4127 Make_Attribute_Reference
(Loc
,
4128 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4129 Attribute_Name
=> Name_Unrestricted_Access
));
4131 Analyze_And_Resolve
(N
, PtrT
);
4132 end Rewrite_Coextension
;
4134 ------------------------------
4135 -- Size_In_Storage_Elements --
4136 ------------------------------
4138 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4140 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4141 -- However, the reason for the existence of this function is
4142 -- to construct a test for sizes too large, which means near the
4143 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4144 -- is that we get overflows when sizes are greater than 2**31.
4146 -- So what we end up doing for array types is to use the expression:
4148 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4150 -- which avoids this problem. All this is a bit bogus, but it does
4151 -- mean we catch common cases of trying to allocate arrays that
4152 -- are too large, and which in the absence of a check results in
4153 -- undetected chaos ???
4155 -- Note in particular that this is a pessimistic estimate in the
4156 -- case of packed array types, where an array element might occupy
4157 -- just a fraction of a storage element???
4164 for J
in 1 .. Number_Dimensions
(E
) loop
4166 Make_Attribute_Reference
(Loc
,
4167 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4168 Attribute_Name
=> Name_Length
,
4169 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4176 Make_Op_Multiply
(Loc
,
4183 Make_Op_Multiply
(Loc
,
4186 Make_Attribute_Reference
(Loc
,
4187 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4188 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4190 end Size_In_Storage_Elements
;
4194 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4198 Rel_Typ
: Entity_Id
;
4201 -- Start of processing for Expand_N_Allocator
4204 -- RM E.2.3(22). We enforce that the expected type of an allocator
4205 -- shall not be a remote access-to-class-wide-limited-private type
4207 -- Why is this being done at expansion time, seems clearly wrong ???
4209 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4211 -- Processing for anonymous access-to-controlled types. These access
4212 -- types receive a special finalization master which appears in the
4213 -- declarations of the enclosing semantic unit. This expansion is done
4214 -- now to ensure that any additional types generated by this routine or
4215 -- Expand_Allocator_Expression inherit the proper type attributes.
4217 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4218 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4219 and then Needs_Finalization
(Dtyp
)
4221 -- Detect the allocation of an anonymous controlled object where the
4222 -- type of the context is named. For example:
4224 -- procedure Proc (Ptr : Named_Access_Typ);
4225 -- Proc (new Designated_Typ);
4227 -- Regardless of the anonymous-to-named access type conversion, the
4228 -- lifetime of the object must be associated with the named access
4229 -- type. Use the finalization-related attributes of this type.
4231 if Nkind_In
(Parent
(N
), N_Type_Conversion
,
4232 N_Unchecked_Type_Conversion
)
4233 and then Ekind_In
(Etype
(Parent
(N
)), E_Access_Subtype
,
4235 E_General_Access_Type
)
4237 Rel_Typ
:= Etype
(Parent
(N
));
4242 -- Anonymous access-to-controlled types allocate on the global pool.
4243 -- Do not set this attribute on .NET/JVM since those targets do not
4246 if No
(Associated_Storage_Pool
(PtrT
)) and then VM_Target
= No_VM
then
4247 if Present
(Rel_Typ
) then
4248 Set_Associated_Storage_Pool
(PtrT
,
4249 Associated_Storage_Pool
(Rel_Typ
));
4251 Set_Associated_Storage_Pool
(PtrT
,
4252 Get_Global_Pool_For_Access_Type
(PtrT
));
4256 -- The finalization master must be inserted and analyzed as part of
4257 -- the current semantic unit. This form of expansion is not carried
4258 -- out in SPARK mode because it is useless. Note that the master is
4259 -- updated when analysis changes current units.
4261 if not SPARK_Mode
then
4262 if Present
(Rel_Typ
) then
4263 Set_Finalization_Master
(PtrT
, Finalization_Master
(Rel_Typ
));
4265 Set_Finalization_Master
(PtrT
, Current_Anonymous_Master
);
4270 -- Set the storage pool and find the appropriate version of Allocate to
4271 -- call. Do not overwrite the storage pool if it is already set, which
4272 -- can happen for build-in-place function returns (see
4273 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4275 if No
(Storage_Pool
(N
)) then
4276 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4278 if Present
(Pool
) then
4279 Set_Storage_Pool
(N
, Pool
);
4281 if Is_RTE
(Pool
, RE_SS_Pool
) then
4282 if VM_Target
= No_VM
then
4283 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4286 -- In the case of an allocator for a simple storage pool, locate
4287 -- and save a reference to the pool type's Allocate routine.
4289 elsif Present
(Get_Rep_Pragma
4290 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4293 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4294 Alloc_Op
: Entity_Id
;
4296 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4297 while Present
(Alloc_Op
) loop
4298 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4299 and then Present
(First_Formal
(Alloc_Op
))
4300 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4302 Set_Procedure_To_Call
(N
, Alloc_Op
);
4305 Alloc_Op
:= Homonym
(Alloc_Op
);
4310 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4311 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4314 Set_Procedure_To_Call
(N
,
4315 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4320 -- Under certain circumstances we can replace an allocator by an access
4321 -- to statically allocated storage. The conditions, as noted in AARM
4322 -- 3.10 (10c) are as follows:
4324 -- Size and initial value is known at compile time
4325 -- Access type is access-to-constant
4327 -- The allocator is not part of a constraint on a record component,
4328 -- because in that case the inserted actions are delayed until the
4329 -- record declaration is fully analyzed, which is too late for the
4330 -- analysis of the rewritten allocator.
4332 if Is_Access_Constant
(PtrT
)
4333 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4334 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4335 and then Size_Known_At_Compile_Time
4336 (Etype
(Expression
(Expression
(N
))))
4337 and then not Is_Record_Type
(Current_Scope
)
4339 -- Here we can do the optimization. For the allocator
4343 -- We insert an object declaration
4345 -- Tnn : aliased x := y;
4347 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4348 -- marked as requiring static allocation.
4350 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4351 Desig
:= Subtype_Mark
(Expression
(N
));
4353 -- If context is constrained, use constrained subtype directly,
4354 -- so that the constant is not labelled as having a nominally
4355 -- unconstrained subtype.
4357 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4358 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4362 Make_Object_Declaration
(Loc
,
4363 Defining_Identifier
=> Temp
,
4364 Aliased_Present
=> True,
4365 Constant_Present
=> Is_Access_Constant
(PtrT
),
4366 Object_Definition
=> Desig
,
4367 Expression
=> Expression
(Expression
(N
))));
4370 Make_Attribute_Reference
(Loc
,
4371 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4372 Attribute_Name
=> Name_Unrestricted_Access
));
4374 Analyze_And_Resolve
(N
, PtrT
);
4376 -- We set the variable as statically allocated, since we don't want
4377 -- it going on the stack of the current procedure!
4379 Set_Is_Statically_Allocated
(Temp
);
4383 -- Same if the allocator is an access discriminant for a local object:
4384 -- instead of an allocator we create a local value and constrain the
4385 -- enclosing object with the corresponding access attribute.
4387 if Is_Static_Coextension
(N
) then
4388 Rewrite_Coextension
(N
);
4392 -- Check for size too large, we do this because the back end misses
4393 -- proper checks here and can generate rubbish allocation calls when
4394 -- we are near the limit. We only do this for the 32-bit address case
4395 -- since that is from a practical point of view where we see a problem.
4397 if System_Address_Size
= 32
4398 and then not Storage_Checks_Suppressed
(PtrT
)
4399 and then not Storage_Checks_Suppressed
(Dtyp
)
4400 and then not Storage_Checks_Suppressed
(Etyp
)
4402 -- The check we want to generate should look like
4404 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4405 -- raise Storage_Error;
4408 -- where 3.5 gigabytes is a constant large enough to accommodate any
4409 -- reasonable request for. But we can't do it this way because at
4410 -- least at the moment we don't compute this attribute right, and
4411 -- can silently give wrong results when the result gets large. Since
4412 -- this is all about large results, that's bad, so instead we only
4413 -- apply the check for constrained arrays, and manually compute the
4414 -- value of the attribute ???
4416 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4418 Make_Raise_Storage_Error
(Loc
,
4421 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4423 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4424 Reason
=> SE_Object_Too_Large
));
4428 -- Handle case of qualified expression (other than optimization above)
4429 -- First apply constraint checks, because the bounds or discriminants
4430 -- in the aggregate might not match the subtype mark in the allocator.
4432 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4433 Apply_Constraint_Check
4434 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
4436 Expand_Allocator_Expression
(N
);
4440 -- If the allocator is for a type which requires initialization, and
4441 -- there is no initial value (i.e. operand is a subtype indication
4442 -- rather than a qualified expression), then we must generate a call to
4443 -- the initialization routine using an expressions action node:
4445 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4447 -- Here ptr_T is the pointer type for the allocator, and T is the
4448 -- subtype of the allocator. A special case arises if the designated
4449 -- type of the access type is a task or contains tasks. In this case
4450 -- the call to Init (Temp.all ...) is replaced by code that ensures
4451 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4452 -- for details). In addition, if the type T is a task T, then the
4453 -- first argument to Init must be converted to the task record type.
4456 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4462 Init_Arg1
: Node_Id
;
4463 Temp_Decl
: Node_Id
;
4464 Temp_Type
: Entity_Id
;
4467 if No_Initialization
(N
) then
4469 -- Even though this might be a simple allocation, create a custom
4470 -- Allocate if the context requires it. Since .NET/JVM compilers
4471 -- do not support pools, this step is skipped.
4473 if VM_Target
= No_VM
4474 and then Present
(Finalization_Master
(PtrT
))
4476 Build_Allocate_Deallocate_Proc
4478 Is_Allocate
=> True);
4481 -- Case of no initialization procedure present
4483 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4485 -- Case of simple initialization required
4487 if Needs_Simple_Initialization
(T
) then
4488 Check_Restriction
(No_Default_Initialization
, N
);
4489 Rewrite
(Expression
(N
),
4490 Make_Qualified_Expression
(Loc
,
4491 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4492 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4494 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4495 Analyze_And_Resolve
(Expression
(N
), T
);
4496 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4497 Expand_N_Allocator
(N
);
4499 -- No initialization required
4505 -- Case of initialization procedure present, must be called
4508 Check_Restriction
(No_Default_Initialization
, N
);
4510 if not Restriction_Active
(No_Default_Initialization
) then
4511 Init
:= Base_Init_Proc
(T
);
4513 Temp
:= Make_Temporary
(Loc
, 'P');
4515 -- Construct argument list for the initialization routine call
4518 Make_Explicit_Dereference
(Loc
,
4520 New_Reference_To
(Temp
, Loc
));
4522 Set_Assignment_OK
(Init_Arg1
);
4525 -- The initialization procedure expects a specific type. if the
4526 -- context is access to class wide, indicate that the object
4527 -- being allocated has the right specific type.
4529 if Is_Class_Wide_Type
(Dtyp
) then
4530 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4533 -- If designated type is a concurrent type or if it is private
4534 -- type whose definition is a concurrent type, the first
4535 -- argument in the Init routine has to be unchecked conversion
4536 -- to the corresponding record type. If the designated type is
4537 -- a derived type, also convert the argument to its root type.
4539 if Is_Concurrent_Type
(T
) then
4541 Unchecked_Convert_To
(
4542 Corresponding_Record_Type
(T
), Init_Arg1
);
4544 elsif Is_Private_Type
(T
)
4545 and then Present
(Full_View
(T
))
4546 and then Is_Concurrent_Type
(Full_View
(T
))
4549 Unchecked_Convert_To
4550 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4552 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4554 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4557 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4558 Set_Etype
(Init_Arg1
, Ftyp
);
4562 Args
:= New_List
(Init_Arg1
);
4564 -- For the task case, pass the Master_Id of the access type as
4565 -- the value of the _Master parameter, and _Chain as the value
4566 -- of the _Chain parameter (_Chain will be defined as part of
4567 -- the generated code for the allocator).
4569 -- In Ada 2005, the context may be a function that returns an
4570 -- anonymous access type. In that case the Master_Id has been
4571 -- created when expanding the function declaration.
4573 if Has_Task
(T
) then
4574 if No
(Master_Id
(Base_Type
(PtrT
))) then
4576 -- The designated type was an incomplete type, and the
4577 -- access type did not get expanded. Salvage it now.
4579 if not Restriction_Active
(No_Task_Hierarchy
) then
4580 if Present
(Parent
(Base_Type
(PtrT
))) then
4581 Expand_N_Full_Type_Declaration
4582 (Parent
(Base_Type
(PtrT
)));
4584 -- The only other possibility is an itype. For this
4585 -- case, the master must exist in the context. This is
4586 -- the case when the allocator initializes an access
4587 -- component in an init-proc.
4590 pragma Assert
(Is_Itype
(PtrT
));
4591 Build_Master_Renaming
(PtrT
, N
);
4596 -- If the context of the allocator is a declaration or an
4597 -- assignment, we can generate a meaningful image for it,
4598 -- even though subsequent assignments might remove the
4599 -- connection between task and entity. We build this image
4600 -- when the left-hand side is a simple variable, a simple
4601 -- indexed assignment or a simple selected component.
4603 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4605 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4608 if Is_Entity_Name
(Nam
) then
4610 Build_Task_Image_Decls
4613 (Entity
(Nam
), Sloc
(Nam
)), T
);
4615 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4616 N_Selected_Component
)
4617 and then Is_Entity_Name
(Prefix
(Nam
))
4620 Build_Task_Image_Decls
4621 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4623 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4627 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4629 Build_Task_Image_Decls
4630 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4633 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4636 if Restriction_Active
(No_Task_Hierarchy
) then
4638 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4642 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4645 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4647 Decl
:= Last
(Decls
);
4649 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4651 -- Has_Task is false, Decls not used
4657 -- Add discriminants if discriminated type
4660 Dis
: Boolean := False;
4664 if Has_Discriminants
(T
) then
4668 elsif Is_Private_Type
(T
)
4669 and then Present
(Full_View
(T
))
4670 and then Has_Discriminants
(Full_View
(T
))
4673 Typ
:= Full_View
(T
);
4678 -- If the allocated object will be constrained by the
4679 -- default values for discriminants, then build a subtype
4680 -- with those defaults, and change the allocated subtype
4681 -- to that. Note that this happens in fewer cases in Ada
4684 if not Is_Constrained
(Typ
)
4685 and then Present
(Discriminant_Default_Value
4686 (First_Discriminant
(Typ
)))
4687 and then (Ada_Version
< Ada_2005
4689 Object_Type_Has_Constrained_Partial_View
4690 (Typ
, Current_Scope
))
4692 Typ
:= Build_Default_Subtype
(Typ
, N
);
4693 Set_Expression
(N
, New_Reference_To
(Typ
, Loc
));
4696 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4697 while Present
(Discr
) loop
4698 Nod
:= Node
(Discr
);
4699 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4701 -- AI-416: when the discriminant constraint is an
4702 -- anonymous access type make sure an accessibility
4703 -- check is inserted if necessary (3.10.2(22.q/2))
4705 if Ada_Version
>= Ada_2005
4707 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4709 Apply_Accessibility_Check
4710 (Nod
, Typ
, Insert_Node
=> Nod
);
4718 -- We set the allocator as analyzed so that when we analyze
4719 -- the if expression node, we do not get an unwanted recursive
4720 -- expansion of the allocator expression.
4722 Set_Analyzed
(N
, True);
4723 Nod
:= Relocate_Node
(N
);
4725 -- Here is the transformation:
4726 -- input: new Ctrl_Typ
4727 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4728 -- Ctrl_TypIP (Temp.all, ...);
4729 -- [Deep_]Initialize (Temp.all);
4731 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4732 -- is the subtype of the allocator.
4735 Make_Object_Declaration
(Loc
,
4736 Defining_Identifier
=> Temp
,
4737 Constant_Present
=> True,
4738 Object_Definition
=> New_Reference_To
(Temp_Type
, Loc
),
4741 Set_Assignment_OK
(Temp_Decl
);
4742 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4744 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
4746 -- If the designated type is a task type or contains tasks,
4747 -- create block to activate created tasks, and insert
4748 -- declaration for Task_Image variable ahead of call.
4750 if Has_Task
(T
) then
4752 L
: constant List_Id
:= New_List
;
4755 Build_Task_Allocate_Block
(L
, Nod
, Args
);
4757 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
4758 Insert_Actions
(N
, L
);
4763 Make_Procedure_Call_Statement
(Loc
,
4764 Name
=> New_Reference_To
(Init
, Loc
),
4765 Parameter_Associations
=> Args
));
4768 if Needs_Finalization
(T
) then
4771 -- [Deep_]Initialize (Init_Arg1);
4775 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4778 if Present
(Finalization_Master
(PtrT
)) then
4780 -- Special processing for .NET/JVM, the allocated object
4781 -- is attached to the finalization master. Generate:
4783 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4785 -- Types derived from [Limited_]Controlled are the only
4786 -- ones considered since they have fields Prev and Next.
4788 if VM_Target
/= No_VM
then
4789 if Is_Controlled
(T
) then
4792 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4796 -- Default case, generate:
4798 -- Set_Finalize_Address
4799 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
4801 -- Do not generate this call in the following cases:
4803 -- * SPARK mode - the call is useless and results in
4804 -- unwanted expansion.
4806 -- * CodePeer mode - TSS primitive Finalize_Address is
4807 -- not created in this mode.
4809 elsif not (SPARK_Mode
or CodePeer_Mode
) then
4811 Make_Set_Finalize_Address_Call
4819 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
4820 Analyze_And_Resolve
(N
, PtrT
);
4825 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4826 -- object that has been rewritten as a reference, we displace "this"
4827 -- to reference properly its secondary dispatch table.
4829 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
4830 Displace_Allocator_Pointer
(N
);
4834 when RE_Not_Available
=>
4836 end Expand_N_Allocator
;
4838 -----------------------
4839 -- Expand_N_And_Then --
4840 -----------------------
4842 procedure Expand_N_And_Then
(N
: Node_Id
)
4843 renames Expand_Short_Circuit_Operator
;
4845 ------------------------------
4846 -- Expand_N_Case_Expression --
4847 ------------------------------
4849 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4850 Loc
: constant Source_Ptr
:= Sloc
(N
);
4851 Typ
: constant Entity_Id
:= Etype
(N
);
4861 -- Check for MINIMIZED/ELIMINATED overflow mode
4863 if Minimized_Eliminated_Overflow_Check
(N
) then
4864 Apply_Arithmetic_Overflow_Check
(N
);
4870 -- case X is when A => AX, when B => BX ...
4885 -- However, this expansion is wrong for limited types, and also
4886 -- wrong for unconstrained types (since the bounds may not be the
4887 -- same in all branches). Furthermore it involves an extra copy
4888 -- for large objects. So we take care of this by using the following
4889 -- modified expansion for non-elementary types:
4892 -- type Pnn is access all typ;
4896 -- T := AX'Unrestricted_Access;
4898 -- T := BX'Unrestricted_Access;
4904 Make_Case_Statement
(Loc
,
4905 Expression
=> Expression
(N
),
4906 Alternatives
=> New_List
);
4908 Actions
:= New_List
;
4912 if Is_Elementary_Type
(Typ
) then
4916 Pnn
:= Make_Temporary
(Loc
, 'P');
4918 Make_Full_Type_Declaration
(Loc
,
4919 Defining_Identifier
=> Pnn
,
4921 Make_Access_To_Object_Definition
(Loc
,
4922 All_Present
=> True,
4923 Subtype_Indication
=>
4924 New_Reference_To
(Typ
, Loc
))));
4928 Tnn
:= Make_Temporary
(Loc
, 'T');
4930 Make_Object_Declaration
(Loc
,
4931 Defining_Identifier
=> Tnn
,
4932 Object_Definition
=> New_Occurrence_Of
(Ttyp
, Loc
)));
4934 -- Now process the alternatives
4936 Alt
:= First
(Alternatives
(N
));
4937 while Present
(Alt
) loop
4939 Aexp
: Node_Id
:= Expression
(Alt
);
4940 Aloc
: constant Source_Ptr
:= Sloc
(Aexp
);
4944 -- As described above, take Unrestricted_Access for case of non-
4945 -- scalar types, to avoid big copies, and special cases.
4947 if not Is_Elementary_Type
(Typ
) then
4949 Make_Attribute_Reference
(Aloc
,
4950 Prefix
=> Relocate_Node
(Aexp
),
4951 Attribute_Name
=> Name_Unrestricted_Access
);
4955 Make_Assignment_Statement
(Aloc
,
4956 Name
=> New_Occurrence_Of
(Tnn
, Loc
),
4957 Expression
=> Aexp
));
4959 -- Propagate declarations inserted in the node by Insert_Actions
4960 -- (for example, temporaries generated to remove side effects).
4961 -- These actions must remain attached to the alternative, given
4962 -- that they are generated by the corresponding expression.
4964 if Present
(Sinfo
.Actions
(Alt
)) then
4965 Prepend_List
(Sinfo
.Actions
(Alt
), Stats
);
4969 (Alternatives
(Cstmt
),
4970 Make_Case_Statement_Alternative
(Sloc
(Alt
),
4971 Discrete_Choices
=> Discrete_Choices
(Alt
),
4972 Statements
=> Stats
));
4978 Append_To
(Actions
, Cstmt
);
4980 -- Construct and return final expression with actions
4982 if Is_Elementary_Type
(Typ
) then
4983 Fexp
:= New_Occurrence_Of
(Tnn
, Loc
);
4986 Make_Explicit_Dereference
(Loc
,
4987 Prefix
=> New_Occurrence_Of
(Tnn
, Loc
));
4991 Make_Expression_With_Actions
(Loc
,
4993 Actions
=> Actions
));
4995 Analyze_And_Resolve
(N
, Typ
);
4996 end Expand_N_Case_Expression
;
4998 -----------------------------------
4999 -- Expand_N_Explicit_Dereference --
5000 -----------------------------------
5002 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5004 -- Insert explicit dereference call for the checked storage pool case
5006 Insert_Dereference_Action
(Prefix
(N
));
5008 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5009 -- we set the atomic sync flag.
5011 if Is_Atomic
(Etype
(N
))
5012 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5014 Activate_Atomic_Synchronization
(N
);
5016 end Expand_N_Explicit_Dereference
;
5018 --------------------------------------
5019 -- Expand_N_Expression_With_Actions --
5020 --------------------------------------
5022 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5023 In_Case_Or_If_Expression
: constant Boolean :=
5024 Within_Case_Or_If_Expression
(N
);
5026 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5027 -- Inspect and process a single action of an expression_with_actions
5029 --------------------
5030 -- Process_Action --
5031 --------------------
5033 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5034 procedure Process_Transient_Object
(Obj_Decl
: Node_Id
);
5035 -- Obj_Decl denotes the declaration of a transient controlled object.
5036 -- Generate all necessary types and hooks to properly finalize the
5037 -- result when the enclosing context is elaborated/evaluated.
5039 ------------------------------
5040 -- Process_Transient_Object --
5041 ------------------------------
5043 procedure Process_Transient_Object
(Obj_Decl
: Node_Id
) is
5044 function Find_Enclosing_Context
return Node_Id
;
5045 -- Find the context where the expression_with_actions appears
5047 ----------------------------
5048 -- Find_Enclosing_Context --
5049 ----------------------------
5051 function Find_Enclosing_Context
return Node_Id
is
5056 -- The expression_with_actions is in a case/if expression and
5057 -- the lifetime of any temporary controlled object is therefore
5058 -- extended. Find a suitable insertion node by locating the top
5059 -- most case or if expressions.
5061 if In_Case_Or_If_Expression
then
5064 while Present
(Par
) loop
5065 if Nkind_In
(Original_Node
(Par
), N_Case_Expression
,
5070 -- Prevent the search from going too far
5072 elsif Is_Body_Or_Package_Declaration
(Par
) then
5076 Par
:= Parent
(Par
);
5079 -- The topmost case or if expression is now recovered, but
5080 -- it may still not be the correct place to add all the
5081 -- generated code. Climb to find a parent that is part of a
5082 -- declarative or statement list.
5085 while Present
(Par
) loop
5086 if Is_List_Member
(Par
)
5088 not Nkind_In
(Par
, N_Component_Association
,
5089 N_Discriminant_Association
,
5090 N_Parameter_Association
,
5091 N_Pragma_Argument_Association
)
5095 -- Prevent the search from going too far
5097 elsif Is_Body_Or_Package_Declaration
(Par
) then
5101 Par
:= Parent
(Par
);
5106 -- Short circuit operators in complex expressions are converted
5107 -- into expression_with_actions.
5110 -- Take care of the case where the expression_with_actions
5111 -- is buried deep inside an IF statement. The temporary
5112 -- function result must be finalized before the then, elsif
5113 -- or else statements are evaluated.
5116 -- and then Ctrl_Func_Call
5118 -- <result must be finalized at this point>
5122 -- To achieve this, find the topmost logical operator. The
5123 -- generated actions are then inserted before/after it.
5126 while Present
(Par
) loop
5128 -- Keep climbing past various operators
5130 if Nkind
(Parent
(Par
)) in N_Op
5131 or else Nkind_In
(Parent
(Par
), N_And_Then
, N_Or_Else
)
5133 Par
:= Parent
(Par
);
5141 -- The expression_with_actions might be located in a pragma
5142 -- in which case locate the pragma itself:
5144 -- pragma Precondition (... and then Ctrl_Func_Call ...);
5146 -- Similar case occurs when the expression_with_actions is
5147 -- related to an object declaration or assignment:
5149 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
5151 -- Another case to consider is an expression_with_actions as
5152 -- part of a return statement:
5154 -- return ... and then Ctrl_Func_Call ...;
5156 -- Yet another case: a formal in a procedure call statement:
5158 -- Proc (... and then Ctrl_Func_Call ...);
5160 while Present
(Par
) loop
5161 if Nkind_In
(Par
, N_Assignment_Statement
,
5162 N_Object_Declaration
,
5164 N_Procedure_Call_Statement
,
5165 N_Simple_Return_Statement
)
5169 -- Prevent the search from going too far
5171 elsif Is_Body_Or_Package_Declaration
(Par
) then
5175 Par
:= Parent
(Par
);
5178 -- Return the topmost short circuit operator
5182 end Find_Enclosing_Context
;
5186 Context
: constant Node_Id
:= Find_Enclosing_Context
;
5187 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5188 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Obj_Decl
);
5189 Obj_Typ
: constant Node_Id
:= Etype
(Obj_Id
);
5190 Desig_Typ
: Entity_Id
;
5194 Temp_Id
: Entity_Id
;
5196 -- Start of processing for Process_Transient_Object
5199 -- Step 1: Create the access type which provides a reference to
5200 -- the transient object.
5202 if Is_Access_Type
(Obj_Typ
) then
5203 Desig_Typ
:= Directly_Designated_Type
(Obj_Typ
);
5205 Desig_Typ
:= Obj_Typ
;
5208 Desig_Typ
:= Base_Type
(Desig_Typ
);
5211 -- Ann : access [all] <Desig_Typ>;
5213 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
5215 Insert_Action
(Context
,
5216 Make_Full_Type_Declaration
(Loc
,
5217 Defining_Identifier
=> Ptr_Id
,
5219 Make_Access_To_Object_Definition
(Loc
,
5221 Ekind
(Obj_Typ
) = E_General_Access_Type
,
5222 Subtype_Indication
=> New_Reference_To
(Desig_Typ
, Loc
))));
5224 -- Step 2: Create a temporary which acts as a hook to the
5225 -- transient object. Generate:
5227 -- Temp : Ptr_Id := null;
5229 Temp_Id
:= Make_Temporary
(Loc
, 'T');
5231 Insert_Action
(Context
,
5232 Make_Object_Declaration
(Loc
,
5233 Defining_Identifier
=> Temp_Id
,
5234 Object_Definition
=> New_Reference_To
(Ptr_Id
, Loc
)));
5236 -- Mark this temporary as created for the purposes of exporting
5237 -- the transient declaration out of the Actions list. This signals
5238 -- the machinery in Build_Finalizer to recognize this special
5241 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Obj_Decl
);
5243 -- Step 3: Hook the transient object to the temporary
5245 -- The use of unchecked conversion / unrestricted access is needed
5246 -- to avoid an accessibility violation. Note that the finalization
5247 -- code is structured in such a way that the "hook" is processed
5248 -- only when it points to an existing object.
5250 if Is_Access_Type
(Obj_Typ
) then
5252 Unchecked_Convert_To
(Ptr_Id
, New_Reference_To
(Obj_Id
, Loc
));
5255 Make_Attribute_Reference
(Loc
,
5256 Prefix
=> New_Reference_To
(Obj_Id
, Loc
),
5257 Attribute_Name
=> Name_Unrestricted_Access
);
5261 -- Temp := Ptr_Id (Obj_Id);
5263 -- Temp := Obj_Id'Unrestricted_Access;
5265 Insert_After_And_Analyze
(Obj_Decl
,
5266 Make_Assignment_Statement
(Loc
,
5267 Name
=> New_Reference_To
(Temp_Id
, Loc
),
5268 Expression
=> Expr
));
5270 -- Step 4: Finalize the function result after the context has been
5271 -- evaluated/elaborated. Generate:
5273 -- if Temp /= null then
5274 -- [Deep_]Finalize (Temp.all);
5278 -- When the expression_with_actions is part of a return statement,
5279 -- there is no need to insert a finalization call, as the general
5280 -- finalization mechanism (see Build_Finalizer) would take care of
5281 -- the temporary function result on subprogram exit. Note that it
5282 -- would also be impossible to insert the finalization code after
5283 -- the return statement as this would make it unreachable.
5285 if Nkind
(Context
) /= N_Simple_Return_Statement
then
5287 Make_Implicit_If_Statement
(Obj_Decl
,
5290 Left_Opnd
=> New_Reference_To
(Temp_Id
, Loc
),
5291 Right_Opnd
=> Make_Null
(Loc
)),
5293 Then_Statements
=> New_List
(
5296 Make_Explicit_Dereference
(Loc
,
5297 Prefix
=> New_Reference_To
(Temp_Id
, Loc
)),
5300 Make_Assignment_Statement
(Loc
,
5301 Name
=> New_Reference_To
(Temp_Id
, Loc
),
5302 Expression
=> Make_Null
(Loc
))));
5304 -- Use the Actions list of logical operators when inserting the
5305 -- finalization call. This ensures that all transient objects
5306 -- are finalized after the operators are evaluated.
5308 if Nkind_In
(Context
, N_And_Then
, N_Or_Else
) then
5309 Insert_Action
(Context
, Fin_Call
);
5311 Insert_Action_After
(Context
, Fin_Call
);
5314 end Process_Transient_Object
;
5316 -- Start of processing for Process_Action
5319 if Nkind
(Act
) = N_Object_Declaration
5320 and then Is_Finalizable_Transient
(Act
, N
)
5322 Process_Transient_Object
(Act
);
5324 -- Avoid processing temporary function results multiple times when
5325 -- dealing with nested expression_with_actions.
5327 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5330 -- Do not process temporary function results in loops. This is
5331 -- done by Expand_N_Loop_Statement and Build_Finalizer.
5333 elsif Nkind
(Act
) = N_Loop_Statement
then
5340 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5346 -- Start of processing for Expand_N_Expression_With_Actions
5349 Act
:= First
(Actions
(N
));
5350 while Present
(Act
) loop
5351 Process_Single_Action
(Act
);
5355 end Expand_N_Expression_With_Actions
;
5357 ----------------------------
5358 -- Expand_N_If_Expression --
5359 ----------------------------
5361 -- Deal with limited types and condition actions
5363 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5364 function Create_Alternative
5366 Temp_Id
: Entity_Id
;
5367 Flag_Id
: Entity_Id
;
5368 Expr
: Node_Id
) return List_Id
;
5369 -- Build the statements of a "then" or "else" dependent expression
5370 -- alternative. Temp_Id is the if expression result, Flag_Id is a
5371 -- finalization flag created to service expression Expr.
5373 function Is_Controlled_Function_Call
(Expr
: Node_Id
) return Boolean;
5374 -- Determine if expression Expr is a rewritten controlled function call
5376 ------------------------
5377 -- Create_Alternative --
5378 ------------------------
5380 function Create_Alternative
5382 Temp_Id
: Entity_Id
;
5383 Flag_Id
: Entity_Id
;
5384 Expr
: Node_Id
) return List_Id
5386 Result
: constant List_Id
:= New_List
;
5392 if Present
(Flag_Id
)
5393 and then not Is_Controlled_Function_Call
(Expr
)
5396 Make_Assignment_Statement
(Loc
,
5397 Name
=> New_Reference_To
(Flag_Id
, Loc
),
5398 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
5402 -- Cnn := <expr>'Unrestricted_Access;
5405 Make_Assignment_Statement
(Loc
,
5406 Name
=> New_Reference_To
(Temp_Id
, Loc
),
5408 Make_Attribute_Reference
(Loc
,
5409 Prefix
=> Relocate_Node
(Expr
),
5410 Attribute_Name
=> Name_Unrestricted_Access
)));
5413 end Create_Alternative
;
5415 ---------------------------------
5416 -- Is_Controlled_Function_Call --
5417 ---------------------------------
5419 function Is_Controlled_Function_Call
(Expr
: Node_Id
) return Boolean is
5422 Nkind
(Original_Node
(Expr
)) = N_Function_Call
5423 and then Needs_Finalization
(Etype
(Expr
));
5424 end Is_Controlled_Function_Call
;
5428 Loc
: constant Source_Ptr
:= Sloc
(N
);
5429 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5430 Thenx
: constant Node_Id
:= Next
(Cond
);
5431 Elsex
: constant Node_Id
:= Next
(Thenx
);
5432 Typ
: constant Entity_Id
:= Etype
(N
);
5441 -- Start of processing for Expand_N_If_Expression
5444 -- Check for MINIMIZED/ELIMINATED overflow mode
5446 if Minimized_Eliminated_Overflow_Check
(N
) then
5447 Apply_Arithmetic_Overflow_Check
(N
);
5451 -- Fold at compile time if condition known. We have already folded
5452 -- static if expressions, but it is possible to fold any case in which
5453 -- the condition is known at compile time, even though the result is
5456 -- Note that we don't do the fold of such cases in Sem_Elab because
5457 -- it can cause infinite loops with the expander adding a conditional
5458 -- expression, and Sem_Elab circuitry removing it repeatedly.
5460 if Compile_Time_Known_Value
(Cond
) then
5461 if Is_True
(Expr_Value
(Cond
)) then
5463 Actions
:= Then_Actions
(N
);
5466 Actions
:= Else_Actions
(N
);
5471 if Present
(Actions
) then
5473 Make_Expression_With_Actions
(Loc
,
5474 Expression
=> Relocate_Node
(Expr
),
5475 Actions
=> Actions
));
5476 Analyze_And_Resolve
(N
, Typ
);
5478 Rewrite
(N
, Relocate_Node
(Expr
));
5481 -- Note that the result is never static (legitimate cases of static
5482 -- if expressions were folded in Sem_Eval).
5484 Set_Is_Static_Expression
(N
, False);
5488 -- If the type is limited or unconstrained, we expand as follows to
5489 -- avoid any possibility of improper copies.
5491 -- Note: it may be possible to avoid this special processing if the
5492 -- back end uses its own mechanisms for handling by-reference types ???
5494 -- type Ptr is access all Typ;
5498 -- Cnn := then-expr'Unrestricted_Access;
5501 -- Cnn := else-expr'Unrestricted_Access;
5504 -- and replace the if expression by a reference to Cnn.all.
5506 -- This special case can be skipped if the back end handles limited
5507 -- types properly and ensures that no incorrect copies are made.
5509 if Is_By_Reference_Type
(Typ
)
5510 and then not Back_End_Handles_Limited_Types
5513 Flag_Id
: Entity_Id
;
5514 Ptr_Typ
: Entity_Id
;
5519 -- At least one of the if expression dependent expressions uses a
5520 -- controlled function to provide the result. Create a status flag
5521 -- to signal the finalization machinery that Cnn needs special
5524 if Is_Controlled_Function_Call
(Thenx
)
5526 Is_Controlled_Function_Call
(Elsex
)
5528 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5531 Make_Object_Declaration
(Loc
,
5532 Defining_Identifier
=> Flag_Id
,
5533 Object_Definition
=>
5534 New_Reference_To
(Standard_Boolean
, Loc
),
5536 New_Reference_To
(Standard_False
, Loc
)));
5540 -- type Ann is access all Typ;
5542 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5545 Make_Full_Type_Declaration
(Loc
,
5546 Defining_Identifier
=> Ptr_Typ
,
5548 Make_Access_To_Object_Definition
(Loc
,
5549 All_Present
=> True,
5550 Subtype_Indication
=> New_Reference_To
(Typ
, Loc
))));
5555 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5556 Set_Ekind
(Cnn
, E_Variable
);
5557 Set_Status_Flag_Or_Transient_Decl
(Cnn
, Flag_Id
);
5560 Make_Object_Declaration
(Loc
,
5561 Defining_Identifier
=> Cnn
,
5562 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5565 Make_Implicit_If_Statement
(N
,
5566 Condition
=> Relocate_Node
(Cond
),
5568 Create_Alternative
(Sloc
(Thenx
), Cnn
, Flag_Id
, Thenx
),
5570 Create_Alternative
(Sloc
(Elsex
), Cnn
, Flag_Id
, Elsex
));
5573 Make_Explicit_Dereference
(Loc
,
5574 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5577 -- For other types, we only need to expand if there are other actions
5578 -- associated with either branch.
5580 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5582 -- We now wrap the actions into the appropriate expression
5584 if Present
(Then_Actions
(N
)) then
5586 Make_Expression_With_Actions
(Sloc
(Thenx
),
5587 Actions
=> Then_Actions
(N
),
5588 Expression
=> Relocate_Node
(Thenx
)));
5589 Set_Then_Actions
(N
, No_List
);
5590 Analyze_And_Resolve
(Thenx
, Typ
);
5593 if Present
(Else_Actions
(N
)) then
5595 Make_Expression_With_Actions
(Sloc
(Elsex
),
5596 Actions
=> Else_Actions
(N
),
5597 Expression
=> Relocate_Node
(Elsex
)));
5598 Set_Else_Actions
(N
, No_List
);
5599 Analyze_And_Resolve
(Elsex
, Typ
);
5604 -- If no actions then no expansion needed, gigi will handle it using
5605 -- the same approach as a C conditional expression.
5611 -- Fall through here for either the limited expansion, or the case of
5612 -- inserting actions for non-limited types. In both these cases, we must
5613 -- move the SLOC of the parent If statement to the newly created one and
5614 -- change it to the SLOC of the expression which, after expansion, will
5615 -- correspond to what is being evaluated.
5617 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
5618 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5619 Set_Sloc
(Parent
(N
), Loc
);
5622 -- Make sure Then_Actions and Else_Actions are appropriately moved
5623 -- to the new if statement.
5625 if Present
(Then_Actions
(N
)) then
5627 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5630 if Present
(Else_Actions
(N
)) then
5632 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5635 Insert_Action
(N
, Decl
);
5636 Insert_Action
(N
, New_If
);
5638 Analyze_And_Resolve
(N
, Typ
);
5639 end Expand_N_If_Expression
;
5645 procedure Expand_N_In
(N
: Node_Id
) is
5646 Loc
: constant Source_Ptr
:= Sloc
(N
);
5647 Restyp
: constant Entity_Id
:= Etype
(N
);
5648 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5649 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5650 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5655 procedure Substitute_Valid_Check
;
5656 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5657 -- test for the left operand being in range of its subtype.
5659 ----------------------------
5660 -- Substitute_Valid_Check --
5661 ----------------------------
5663 procedure Substitute_Valid_Check
is
5666 Make_Attribute_Reference
(Loc
,
5667 Prefix
=> Relocate_Node
(Lop
),
5668 Attribute_Name
=> Name_Valid
));
5670 Analyze_And_Resolve
(N
, Restyp
);
5672 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5673 -- in which case, this usage makes sense, and in any case, we have
5674 -- actually eliminated the danger of optimization above.
5676 if Overflow_Check_Mode
not in Minimized_Or_Eliminated
then
5678 ("??explicit membership test may be optimized away", N
);
5679 Error_Msg_N
-- CODEFIX
5680 ("\??use ''Valid attribute instead", N
);
5684 end Substitute_Valid_Check
;
5686 -- Start of processing for Expand_N_In
5689 -- If set membership case, expand with separate procedure
5691 if Present
(Alternatives
(N
)) then
5692 Expand_Set_Membership
(N
);
5696 -- Not set membership, proceed with expansion
5698 Ltyp
:= Etype
(Left_Opnd
(N
));
5699 Rtyp
:= Etype
(Right_Opnd
(N
));
5701 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5702 -- type, then expand with a separate procedure. Note the use of the
5703 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5705 if Overflow_Check_Mode
in Minimized_Or_Eliminated
5706 and then Is_Signed_Integer_Type
(Ltyp
)
5707 and then not No_Minimize_Eliminate
(N
)
5709 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
5713 -- Check case of explicit test for an expression in range of its
5714 -- subtype. This is suspicious usage and we replace it with a 'Valid
5715 -- test and give a warning for scalar types.
5717 if Is_Scalar_Type
(Ltyp
)
5719 -- Only relevant for source comparisons
5721 and then Comes_From_Source
(N
)
5723 -- In floating-point this is a standard way to check for finite values
5724 -- and using 'Valid would typically be a pessimization.
5726 and then not Is_Floating_Point_Type
(Ltyp
)
5728 -- Don't give the message unless right operand is a type entity and
5729 -- the type of the left operand matches this type. Note that this
5730 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5731 -- checks have changed the type of the left operand.
5733 and then Nkind
(Rop
) in N_Has_Entity
5734 and then Ltyp
= Entity
(Rop
)
5736 -- Skip in VM mode, where we have no sense of invalid values. The
5737 -- warning still seems relevant, but not important enough to worry.
5739 and then VM_Target
= No_VM
5741 -- Skip this for predicated types, where such expressions are a
5742 -- reasonable way of testing if something meets the predicate.
5744 and then not Present
(Predicate_Function
(Ltyp
))
5746 Substitute_Valid_Check
;
5750 -- Do validity check on operands
5752 if Validity_Checks_On
and Validity_Check_Operands
then
5753 Ensure_Valid
(Left_Opnd
(N
));
5754 Validity_Check_Range
(Right_Opnd
(N
));
5757 -- Case of explicit range
5759 if Nkind
(Rop
) = N_Range
then
5761 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
5762 Hi
: constant Node_Id
:= High_Bound
(Rop
);
5764 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
5765 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
5767 Lcheck
: Compare_Result
;
5768 Ucheck
: Compare_Result
;
5770 Warn1
: constant Boolean :=
5771 Constant_Condition_Warnings
5772 and then Comes_From_Source
(N
)
5773 and then not In_Instance
;
5774 -- This must be true for any of the optimization warnings, we
5775 -- clearly want to give them only for source with the flag on. We
5776 -- also skip these warnings in an instance since it may be the
5777 -- case that different instantiations have different ranges.
5779 Warn2
: constant Boolean :=
5781 and then Nkind
(Original_Node
(Rop
)) = N_Range
5782 and then Is_Integer_Type
(Etype
(Lo
));
5783 -- For the case where only one bound warning is elided, we also
5784 -- insist on an explicit range and an integer type. The reason is
5785 -- that the use of enumeration ranges including an end point is
5786 -- common, as is the use of a subtype name, one of whose bounds is
5787 -- the same as the type of the expression.
5790 -- If test is explicit x'First .. x'Last, replace by valid check
5792 -- Could use some individual comments for this complex test ???
5794 if Is_Scalar_Type
(Ltyp
)
5796 -- And left operand is X'First where X matches left operand
5797 -- type (this eliminates cases of type mismatch, including
5798 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5799 -- type of the left operand.
5801 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
5802 and then Attribute_Name
(Lo_Orig
) = Name_First
5803 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
5804 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
5806 -- Same tests for right operand
5808 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
5809 and then Attribute_Name
(Hi_Orig
) = Name_Last
5810 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
5811 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
5813 -- Relevant only for source cases
5815 and then Comes_From_Source
(N
)
5817 -- Omit for VM cases, where we don't have invalid values
5819 and then VM_Target
= No_VM
5821 Substitute_Valid_Check
;
5825 -- If bounds of type are known at compile time, and the end points
5826 -- are known at compile time and identical, this is another case
5827 -- for substituting a valid test. We only do this for discrete
5828 -- types, since it won't arise in practice for float types.
5830 if Comes_From_Source
(N
)
5831 and then Is_Discrete_Type
(Ltyp
)
5832 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
5833 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
5834 and then Compile_Time_Known_Value
(Lo
)
5835 and then Compile_Time_Known_Value
(Hi
)
5836 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
5837 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
5839 -- Kill warnings in instances, since they may be cases where we
5840 -- have a test in the generic that makes sense with some types
5841 -- and not with other types.
5843 and then not In_Instance
5845 Substitute_Valid_Check
;
5849 -- If we have an explicit range, do a bit of optimization based on
5850 -- range analysis (we may be able to kill one or both checks).
5852 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
5853 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
5855 -- If either check is known to fail, replace result by False since
5856 -- the other check does not matter. Preserve the static flag for
5857 -- legality checks, because we are constant-folding beyond RM 4.9.
5859 if Lcheck
= LT
or else Ucheck
= GT
then
5861 Error_Msg_N
("?c?range test optimized away", N
);
5862 Error_Msg_N
("\?c?value is known to be out of range", N
);
5865 Rewrite
(N
, New_Reference_To
(Standard_False
, Loc
));
5866 Analyze_And_Resolve
(N
, Restyp
);
5867 Set_Is_Static_Expression
(N
, Static
);
5870 -- If both checks are known to succeed, replace result by True,
5871 -- since we know we are in range.
5873 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5875 Error_Msg_N
("?c?range test optimized away", N
);
5876 Error_Msg_N
("\?c?value is known to be in range", N
);
5879 Rewrite
(N
, New_Reference_To
(Standard_True
, Loc
));
5880 Analyze_And_Resolve
(N
, Restyp
);
5881 Set_Is_Static_Expression
(N
, Static
);
5884 -- If lower bound check succeeds and upper bound check is not
5885 -- known to succeed or fail, then replace the range check with
5886 -- a comparison against the upper bound.
5888 elsif Lcheck
in Compare_GE
then
5889 if Warn2
and then not In_Instance
then
5890 Error_Msg_N
("??lower bound test optimized away", Lo
);
5891 Error_Msg_N
("\??value is known to be in range", Lo
);
5897 Right_Opnd
=> High_Bound
(Rop
)));
5898 Analyze_And_Resolve
(N
, Restyp
);
5901 -- If upper bound check succeeds and lower bound check is not
5902 -- known to succeed or fail, then replace the range check with
5903 -- a comparison against the lower bound.
5905 elsif Ucheck
in Compare_LE
then
5906 if Warn2
and then not In_Instance
then
5907 Error_Msg_N
("??upper bound test optimized away", Hi
);
5908 Error_Msg_N
("\??value is known to be in range", Hi
);
5914 Right_Opnd
=> Low_Bound
(Rop
)));
5915 Analyze_And_Resolve
(N
, Restyp
);
5919 -- We couldn't optimize away the range check, but there is one
5920 -- more issue. If we are checking constant conditionals, then we
5921 -- see if we can determine the outcome assuming everything is
5922 -- valid, and if so give an appropriate warning.
5924 if Warn1
and then not Assume_No_Invalid_Values
then
5925 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
5926 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
5928 -- Result is out of range for valid value
5930 if Lcheck
= LT
or else Ucheck
= GT
then
5932 ("?c?value can only be in range if it is invalid", N
);
5934 -- Result is in range for valid value
5936 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5938 ("?c?value can only be out of range if it is invalid", N
);
5940 -- Lower bound check succeeds if value is valid
5942 elsif Warn2
and then Lcheck
in Compare_GE
then
5944 ("?c?lower bound check only fails if it is invalid", Lo
);
5946 -- Upper bound check succeeds if value is valid
5948 elsif Warn2
and then Ucheck
in Compare_LE
then
5950 ("?c?upper bound check only fails for invalid values", Hi
);
5955 -- For all other cases of an explicit range, nothing to be done
5959 -- Here right operand is a subtype mark
5963 Typ
: Entity_Id
:= Etype
(Rop
);
5964 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
5965 Cond
: Node_Id
:= Empty
;
5967 Obj
: Node_Id
:= Lop
;
5968 SCIL_Node
: Node_Id
;
5971 Remove_Side_Effects
(Obj
);
5973 -- For tagged type, do tagged membership operation
5975 if Is_Tagged_Type
(Typ
) then
5977 -- No expansion will be performed when VM_Target, as the VM
5978 -- back-ends will handle the membership tests directly (tags
5979 -- are not explicitly represented in Java objects, so the
5980 -- normal tagged membership expansion is not what we want).
5982 if Tagged_Type_Expansion
then
5983 Tagged_Membership
(N
, SCIL_Node
, New_N
);
5985 Analyze_And_Resolve
(N
, Restyp
);
5987 -- Update decoration of relocated node referenced by the
5990 if Generate_SCIL
and then Present
(SCIL_Node
) then
5991 Set_SCIL_Node
(N
, SCIL_Node
);
5997 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5998 -- This reason we do this is that the bounds may have the wrong
5999 -- type if they come from the original type definition. Also this
6000 -- way we get all the processing above for an explicit range.
6002 -- Don't do this for predicated types, since in this case we
6003 -- want to check the predicate!
6005 elsif Is_Scalar_Type
(Typ
) then
6006 if No
(Predicate_Function
(Typ
)) then
6010 Make_Attribute_Reference
(Loc
,
6011 Attribute_Name
=> Name_First
,
6012 Prefix
=> New_Reference_To
(Typ
, Loc
)),
6015 Make_Attribute_Reference
(Loc
,
6016 Attribute_Name
=> Name_Last
,
6017 Prefix
=> New_Reference_To
(Typ
, Loc
))));
6018 Analyze_And_Resolve
(N
, Restyp
);
6023 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
6024 -- a membership test if the subtype mark denotes a constrained
6025 -- Unchecked_Union subtype and the expression lacks inferable
6028 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
6029 and then Is_Constrained
(Typ
)
6030 and then not Has_Inferable_Discriminants
(Lop
)
6033 Make_Raise_Program_Error
(Loc
,
6034 Reason
=> PE_Unchecked_Union_Restriction
));
6036 -- Prevent Gigi from generating incorrect code by rewriting the
6037 -- test as False. What is this undocumented thing about ???
6039 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6043 -- Here we have a non-scalar type
6046 Typ
:= Designated_Type
(Typ
);
6049 if not Is_Constrained
(Typ
) then
6050 Rewrite
(N
, New_Reference_To
(Standard_True
, Loc
));
6051 Analyze_And_Resolve
(N
, Restyp
);
6053 -- For the constrained array case, we have to check the subscripts
6054 -- for an exact match if the lengths are non-zero (the lengths
6055 -- must match in any case).
6057 elsif Is_Array_Type
(Typ
) then
6058 Check_Subscripts
: declare
6059 function Build_Attribute_Reference
6062 Dim
: Nat
) return Node_Id
;
6063 -- Build attribute reference E'Nam (Dim)
6065 -------------------------------
6066 -- Build_Attribute_Reference --
6067 -------------------------------
6069 function Build_Attribute_Reference
6072 Dim
: Nat
) return Node_Id
6076 Make_Attribute_Reference
(Loc
,
6078 Attribute_Name
=> Nam
,
6079 Expressions
=> New_List
(
6080 Make_Integer_Literal
(Loc
, Dim
)));
6081 end Build_Attribute_Reference
;
6083 -- Start of processing for Check_Subscripts
6086 for J
in 1 .. Number_Dimensions
(Typ
) loop
6087 Evolve_And_Then
(Cond
,
6090 Build_Attribute_Reference
6091 (Duplicate_Subexpr_No_Checks
(Obj
),
6094 Build_Attribute_Reference
6095 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
6097 Evolve_And_Then
(Cond
,
6100 Build_Attribute_Reference
6101 (Duplicate_Subexpr_No_Checks
(Obj
),
6104 Build_Attribute_Reference
6105 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
6114 Right_Opnd
=> Make_Null
(Loc
)),
6115 Right_Opnd
=> Cond
);
6119 Analyze_And_Resolve
(N
, Restyp
);
6120 end Check_Subscripts
;
6122 -- These are the cases where constraint checks may be required,
6123 -- e.g. records with possible discriminants
6126 -- Expand the test into a series of discriminant comparisons.
6127 -- The expression that is built is the negation of the one that
6128 -- is used for checking discriminant constraints.
6130 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6132 if Has_Discriminants
(Typ
) then
6133 Cond
:= Make_Op_Not
(Loc
,
6134 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6137 Cond
:= Make_Or_Else
(Loc
,
6141 Right_Opnd
=> Make_Null
(Loc
)),
6142 Right_Opnd
=> Cond
);
6146 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6150 Analyze_And_Resolve
(N
, Restyp
);
6153 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6154 -- expression of an anonymous access type. This can involve an
6155 -- accessibility test and a tagged type membership test in the
6156 -- case of tagged designated types.
6158 if Ada_Version
>= Ada_2012
6160 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6163 Expr_Entity
: Entity_Id
:= Empty
;
6165 Param_Level
: Node_Id
;
6166 Type_Level
: Node_Id
;
6169 if Is_Entity_Name
(Lop
) then
6170 Expr_Entity
:= Param_Entity
(Lop
);
6172 if not Present
(Expr_Entity
) then
6173 Expr_Entity
:= Entity
(Lop
);
6177 -- If a conversion of the anonymous access value to the
6178 -- tested type would be illegal, then the result is False.
6180 if not Valid_Conversion
6181 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6183 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6184 Analyze_And_Resolve
(N
, Restyp
);
6186 -- Apply an accessibility check if the access object has an
6187 -- associated access level and when the level of the type is
6188 -- less deep than the level of the access parameter. This
6189 -- only occur for access parameters and stand-alone objects
6190 -- of an anonymous access type.
6193 if Present
(Expr_Entity
)
6196 (Effective_Extra_Accessibility
(Expr_Entity
))
6197 and then UI_Gt
(Object_Access_Level
(Lop
),
6198 Type_Access_Level
(Rtyp
))
6202 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
6205 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6207 -- Return True only if the accessibility level of the
6208 -- expression entity is not deeper than the level of
6209 -- the tested access type.
6213 Left_Opnd
=> Relocate_Node
(N
),
6214 Right_Opnd
=> Make_Op_Le
(Loc
,
6215 Left_Opnd
=> Param_Level
,
6216 Right_Opnd
=> Type_Level
)));
6218 Analyze_And_Resolve
(N
);
6221 -- If the designated type is tagged, do tagged membership
6224 -- *** NOTE: we have to check not null before doing the
6225 -- tagged membership test (but maybe that can be done
6226 -- inside Tagged_Membership?).
6228 if Is_Tagged_Type
(Typ
) then
6231 Left_Opnd
=> Relocate_Node
(N
),
6235 Right_Opnd
=> Make_Null
(Loc
))));
6237 -- No expansion will be performed when VM_Target, as
6238 -- the VM back-ends will handle the membership tests
6239 -- directly (tags are not explicitly represented in
6240 -- Java objects, so the normal tagged membership
6241 -- expansion is not what we want).
6243 if Tagged_Type_Expansion
then
6245 -- Note that we have to pass Original_Node, because
6246 -- the membership test might already have been
6247 -- rewritten by earlier parts of membership test.
6250 (Original_Node
(N
), SCIL_Node
, New_N
);
6252 -- Update decoration of relocated node referenced
6253 -- by the SCIL node.
6255 if Generate_SCIL
and then Present
(SCIL_Node
) then
6256 Set_SCIL_Node
(New_N
, SCIL_Node
);
6261 Left_Opnd
=> Relocate_Node
(N
),
6262 Right_Opnd
=> New_N
));
6264 Analyze_And_Resolve
(N
, Restyp
);
6273 -- At this point, we have done the processing required for the basic
6274 -- membership test, but not yet dealt with the predicate.
6278 -- If a predicate is present, then we do the predicate test, but we
6279 -- most certainly want to omit this if we are within the predicate
6280 -- function itself, since otherwise we have an infinite recursion!
6281 -- The check should also not be emitted when testing against a range
6282 -- (the check is only done when the right operand is a subtype; see
6283 -- RM12-4.5.2 (28.1/3-30/3)).
6286 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6290 and then Current_Scope
/= PFunc
6291 and then Nkind
(Rop
) /= N_Range
6295 Left_Opnd
=> Relocate_Node
(N
),
6296 Right_Opnd
=> Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True)));
6298 -- Analyze new expression, mark left operand as analyzed to
6299 -- avoid infinite recursion adding predicate calls. Similarly,
6300 -- suppress further range checks on the call.
6302 Set_Analyzed
(Left_Opnd
(N
));
6303 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6305 -- All done, skip attempt at compile time determination of result
6312 --------------------------------
6313 -- Expand_N_Indexed_Component --
6314 --------------------------------
6316 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6317 Loc
: constant Source_Ptr
:= Sloc
(N
);
6318 Typ
: constant Entity_Id
:= Etype
(N
);
6319 P
: constant Node_Id
:= Prefix
(N
);
6320 T
: constant Entity_Id
:= Etype
(P
);
6324 -- A special optimization, if we have an indexed component that is
6325 -- selecting from a slice, then we can eliminate the slice, since, for
6326 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6327 -- the range check required by the slice. The range check for the slice
6328 -- itself has already been generated. The range check for the
6329 -- subscripting operation is ensured by converting the subject to
6330 -- the subtype of the slice.
6332 -- This optimization not only generates better code, avoiding slice
6333 -- messing especially in the packed case, but more importantly bypasses
6334 -- some problems in handling this peculiar case, for example, the issue
6335 -- of dealing specially with object renamings.
6337 if Nkind
(P
) = N_Slice
then
6339 Make_Indexed_Component
(Loc
,
6340 Prefix
=> Prefix
(P
),
6341 Expressions
=> New_List
(
6343 (Etype
(First_Index
(Etype
(P
))),
6344 First
(Expressions
(N
))))));
6345 Analyze_And_Resolve
(N
, Typ
);
6349 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6350 -- function, then additional actuals must be passed.
6352 if Ada_Version
>= Ada_2005
6353 and then Is_Build_In_Place_Function_Call
(P
)
6355 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6358 -- If the prefix is an access type, then we unconditionally rewrite if
6359 -- as an explicit dereference. This simplifies processing for several
6360 -- cases, including packed array cases and certain cases in which checks
6361 -- must be generated. We used to try to do this only when it was
6362 -- necessary, but it cleans up the code to do it all the time.
6364 if Is_Access_Type
(T
) then
6365 Insert_Explicit_Dereference
(P
);
6366 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6367 Atp
:= Designated_Type
(T
);
6372 -- Generate index and validity checks
6374 Generate_Index_Checks
(N
);
6376 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6377 Apply_Subscript_Validity_Checks
(N
);
6380 -- If selecting from an array with atomic components, and atomic sync
6381 -- is not suppressed for this array type, set atomic sync flag.
6383 if (Has_Atomic_Components
(Atp
)
6384 and then not Atomic_Synchronization_Disabled
(Atp
))
6385 or else (Is_Atomic
(Typ
)
6386 and then not Atomic_Synchronization_Disabled
(Typ
))
6388 Activate_Atomic_Synchronization
(N
);
6391 -- All done for the non-packed case
6393 if not Is_Packed
(Etype
(Prefix
(N
))) then
6397 -- For packed arrays that are not bit-packed (i.e. the case of an array
6398 -- with one or more index types with a non-contiguous enumeration type),
6399 -- we can always use the normal packed element get circuit.
6401 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6402 Expand_Packed_Element_Reference
(N
);
6406 -- For a reference to a component of a bit packed array, we have to
6407 -- convert it to a reference to the corresponding Packed_Array_Type.
6408 -- We only want to do this for simple references, and not for:
6410 -- Left side of assignment, or prefix of left side of assignment, or
6411 -- prefix of the prefix, to handle packed arrays of packed arrays,
6412 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6414 -- Renaming objects in renaming associations
6415 -- This case is handled when a use of the renamed variable occurs
6417 -- Actual parameters for a procedure call
6418 -- This case is handled in Exp_Ch6.Expand_Actuals
6420 -- The second expression in a 'Read attribute reference
6422 -- The prefix of an address or bit or size attribute reference
6424 -- The following circuit detects these exceptions
6427 Child
: Node_Id
:= N
;
6428 Parnt
: Node_Id
:= Parent
(N
);
6432 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6435 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6436 N_Procedure_Call_Statement
)
6437 or else (Nkind
(Parnt
) = N_Parameter_Association
6439 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6443 elsif Nkind
(Parnt
) = N_Attribute_Reference
6444 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
6447 and then Prefix
(Parnt
) = Child
6451 elsif Nkind
(Parnt
) = N_Assignment_Statement
6452 and then Name
(Parnt
) = Child
6456 -- If the expression is an index of an indexed component, it must
6457 -- be expanded regardless of context.
6459 elsif Nkind
(Parnt
) = N_Indexed_Component
6460 and then Child
/= Prefix
(Parnt
)
6462 Expand_Packed_Element_Reference
(N
);
6465 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6466 and then Name
(Parent
(Parnt
)) = Parnt
6470 elsif Nkind
(Parnt
) = N_Attribute_Reference
6471 and then Attribute_Name
(Parnt
) = Name_Read
6472 and then Next
(First
(Expressions
(Parnt
))) = Child
6476 elsif Nkind_In
(Parnt
, N_Indexed_Component
, N_Selected_Component
)
6477 and then Prefix
(Parnt
) = Child
6482 Expand_Packed_Element_Reference
(N
);
6486 -- Keep looking up tree for unchecked expression, or if we are the
6487 -- prefix of a possible assignment left side.
6490 Parnt
:= Parent
(Child
);
6493 end Expand_N_Indexed_Component
;
6495 ---------------------
6496 -- Expand_N_Not_In --
6497 ---------------------
6499 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6500 -- can be done. This avoids needing to duplicate this expansion code.
6502 procedure Expand_N_Not_In
(N
: Node_Id
) is
6503 Loc
: constant Source_Ptr
:= Sloc
(N
);
6504 Typ
: constant Entity_Id
:= Etype
(N
);
6505 Cfs
: constant Boolean := Comes_From_Source
(N
);
6512 Left_Opnd
=> Left_Opnd
(N
),
6513 Right_Opnd
=> Right_Opnd
(N
))));
6515 -- If this is a set membership, preserve list of alternatives
6517 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6519 -- We want this to appear as coming from source if original does (see
6520 -- transformations in Expand_N_In).
6522 Set_Comes_From_Source
(N
, Cfs
);
6523 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6525 -- Now analyze transformed node
6527 Analyze_And_Resolve
(N
, Typ
);
6528 end Expand_N_Not_In
;
6534 -- The only replacement required is for the case of a null of a type that
6535 -- is an access to protected subprogram, or a subtype thereof. We represent
6536 -- such access values as a record, and so we must replace the occurrence of
6537 -- null by the equivalent record (with a null address and a null pointer in
6538 -- it), so that the backend creates the proper value.
6540 procedure Expand_N_Null
(N
: Node_Id
) is
6541 Loc
: constant Source_Ptr
:= Sloc
(N
);
6542 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6546 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6548 Make_Aggregate
(Loc
,
6549 Expressions
=> New_List
(
6550 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6554 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6556 -- For subsequent semantic analysis, the node must retain its type.
6557 -- Gigi in any case replaces this type by the corresponding record
6558 -- type before processing the node.
6564 when RE_Not_Available
=>
6568 ---------------------
6569 -- Expand_N_Op_Abs --
6570 ---------------------
6572 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6573 Loc
: constant Source_Ptr
:= Sloc
(N
);
6574 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6577 Unary_Op_Validity_Checks
(N
);
6579 -- Check for MINIMIZED/ELIMINATED overflow mode
6581 if Minimized_Eliminated_Overflow_Check
(N
) then
6582 Apply_Arithmetic_Overflow_Check
(N
);
6586 -- Deal with software overflow checking
6588 if not Backend_Overflow_Checks_On_Target
6589 and then Is_Signed_Integer_Type
(Etype
(N
))
6590 and then Do_Overflow_Check
(N
)
6592 -- The only case to worry about is when the argument is equal to the
6593 -- largest negative number, so what we do is to insert the check:
6595 -- [constraint_error when Expr = typ'Base'First]
6597 -- with the usual Duplicate_Subexpr use coding for expr
6600 Make_Raise_Constraint_Error
(Loc
,
6603 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6605 Make_Attribute_Reference
(Loc
,
6607 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6608 Attribute_Name
=> Name_First
)),
6609 Reason
=> CE_Overflow_Check_Failed
));
6612 -- Vax floating-point types case
6614 if Vax_Float
(Etype
(N
)) then
6615 Expand_Vax_Arith
(N
);
6617 end Expand_N_Op_Abs
;
6619 ---------------------
6620 -- Expand_N_Op_Add --
6621 ---------------------
6623 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6624 Typ
: constant Entity_Id
:= Etype
(N
);
6627 Binary_Op_Validity_Checks
(N
);
6629 -- Check for MINIMIZED/ELIMINATED overflow mode
6631 if Minimized_Eliminated_Overflow_Check
(N
) then
6632 Apply_Arithmetic_Overflow_Check
(N
);
6636 -- N + 0 = 0 + N = N for integer types
6638 if Is_Integer_Type
(Typ
) then
6639 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6640 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6642 Rewrite
(N
, Left_Opnd
(N
));
6645 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6646 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
6648 Rewrite
(N
, Right_Opnd
(N
));
6653 -- Arithmetic overflow checks for signed integer/fixed point types
6655 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
6656 Apply_Arithmetic_Overflow_Check
(N
);
6659 -- Vax floating-point types case
6661 elsif Vax_Float
(Typ
) then
6662 Expand_Vax_Arith
(N
);
6664 end Expand_N_Op_Add
;
6666 ---------------------
6667 -- Expand_N_Op_And --
6668 ---------------------
6670 procedure Expand_N_Op_And
(N
: Node_Id
) is
6671 Typ
: constant Entity_Id
:= Etype
(N
);
6674 Binary_Op_Validity_Checks
(N
);
6676 if Is_Array_Type
(Etype
(N
)) then
6677 Expand_Boolean_Operator
(N
);
6679 elsif Is_Boolean_Type
(Etype
(N
)) then
6680 Adjust_Condition
(Left_Opnd
(N
));
6681 Adjust_Condition
(Right_Opnd
(N
));
6682 Set_Etype
(N
, Standard_Boolean
);
6683 Adjust_Result_Type
(N
, Typ
);
6685 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
6686 Expand_Intrinsic_Call
(N
, Entity
(N
));
6689 end Expand_N_Op_And
;
6691 ------------------------
6692 -- Expand_N_Op_Concat --
6693 ------------------------
6695 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
6697 -- List of operands to be concatenated
6700 -- Node which is to be replaced by the result of concatenating the nodes
6701 -- in the list Opnds.
6704 -- Ensure validity of both operands
6706 Binary_Op_Validity_Checks
(N
);
6708 -- If we are the left operand of a concatenation higher up the tree,
6709 -- then do nothing for now, since we want to deal with a series of
6710 -- concatenations as a unit.
6712 if Nkind
(Parent
(N
)) = N_Op_Concat
6713 and then N
= Left_Opnd
(Parent
(N
))
6718 -- We get here with a concatenation whose left operand may be a
6719 -- concatenation itself with a consistent type. We need to process
6720 -- these concatenation operands from left to right, which means
6721 -- from the deepest node in the tree to the highest node.
6724 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
6725 Cnode
:= Left_Opnd
(Cnode
);
6728 -- Now Cnode is the deepest concatenation, and its parents are the
6729 -- concatenation nodes above, so now we process bottom up, doing the
6732 -- The outer loop runs more than once if more than one concatenation
6733 -- type is involved.
6736 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
6737 Set_Parent
(Opnds
, N
);
6739 -- The inner loop gathers concatenation operands
6741 Inner
: while Cnode
/= N
6742 and then Base_Type
(Etype
(Cnode
)) =
6743 Base_Type
(Etype
(Parent
(Cnode
)))
6745 Cnode
:= Parent
(Cnode
);
6746 Append
(Right_Opnd
(Cnode
), Opnds
);
6749 Expand_Concatenate
(Cnode
, Opnds
);
6751 exit Outer
when Cnode
= N
;
6752 Cnode
:= Parent
(Cnode
);
6754 end Expand_N_Op_Concat
;
6756 ------------------------
6757 -- Expand_N_Op_Divide --
6758 ------------------------
6760 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
6761 Loc
: constant Source_Ptr
:= Sloc
(N
);
6762 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
6763 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
6764 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
6765 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
6766 Typ
: Entity_Id
:= Etype
(N
);
6767 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
6769 Compile_Time_Known_Value
(Ropnd
);
6773 Binary_Op_Validity_Checks
(N
);
6775 -- Check for MINIMIZED/ELIMINATED overflow mode
6777 if Minimized_Eliminated_Overflow_Check
(N
) then
6778 Apply_Arithmetic_Overflow_Check
(N
);
6782 -- Otherwise proceed with expansion of division
6785 Rval
:= Expr_Value
(Ropnd
);
6788 -- N / 1 = N for integer types
6790 if Rknow
and then Rval
= Uint_1
then
6795 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6796 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6797 -- operand is an unsigned integer, as required for this to work.
6799 if Nkind
(Ropnd
) = N_Op_Expon
6800 and then Is_Power_Of_2_For_Shift
(Ropnd
)
6802 -- We cannot do this transformation in configurable run time mode if we
6803 -- have 64-bit integers and long shifts are not available.
6805 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
6808 Make_Op_Shift_Right
(Loc
,
6811 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
6812 Analyze_And_Resolve
(N
, Typ
);
6816 -- Do required fixup of universal fixed operation
6818 if Typ
= Universal_Fixed
then
6819 Fixup_Universal_Fixed_Operation
(N
);
6823 -- Divisions with fixed-point results
6825 if Is_Fixed_Point_Type
(Typ
) then
6827 -- No special processing if Treat_Fixed_As_Integer is set, since
6828 -- from a semantic point of view such operations are simply integer
6829 -- operations and will be treated that way.
6831 if not Treat_Fixed_As_Integer
(N
) then
6832 if Is_Integer_Type
(Rtyp
) then
6833 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
6835 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
6839 -- Other cases of division of fixed-point operands. Again we exclude the
6840 -- case where Treat_Fixed_As_Integer is set.
6842 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
6843 and then not Treat_Fixed_As_Integer
(N
)
6845 if Is_Integer_Type
(Typ
) then
6846 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
6848 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6849 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
6852 -- Mixed-mode operations can appear in a non-static universal context,
6853 -- in which case the integer argument must be converted explicitly.
6855 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
6857 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
6859 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
6861 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
6863 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
6865 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
6867 -- Non-fixed point cases, do integer zero divide and overflow checks
6869 elsif Is_Integer_Type
(Typ
) then
6870 Apply_Divide_Checks
(N
);
6872 -- Deal with Vax_Float
6874 elsif Vax_Float
(Typ
) then
6875 Expand_Vax_Arith
(N
);
6878 end Expand_N_Op_Divide
;
6880 --------------------
6881 -- Expand_N_Op_Eq --
6882 --------------------
6884 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
6885 Loc
: constant Source_Ptr
:= Sloc
(N
);
6886 Typ
: constant Entity_Id
:= Etype
(N
);
6887 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
6888 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
6889 Bodies
: constant List_Id
:= New_List
;
6890 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
6892 Typl
: Entity_Id
:= A_Typ
;
6893 Op_Name
: Entity_Id
;
6896 procedure Build_Equality_Call
(Eq
: Entity_Id
);
6897 -- If a constructed equality exists for the type or for its parent,
6898 -- build and analyze call, adding conversions if the operation is
6901 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
6902 -- Determines whether a type has a subcomponent of an unconstrained
6903 -- Unchecked_Union subtype. Typ is a record type.
6905 -------------------------
6906 -- Build_Equality_Call --
6907 -------------------------
6909 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
6910 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
6911 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
6912 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
6915 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
6916 and then not Is_Class_Wide_Type
(A_Typ
)
6918 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
6919 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
6922 -- If we have an Unchecked_Union, we need to add the inferred
6923 -- discriminant values as actuals in the function call. At this
6924 -- point, the expansion has determined that both operands have
6925 -- inferable discriminants.
6927 if Is_Unchecked_Union
(Op_Type
) then
6929 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
6930 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
6931 Lhs_Discr_Val
: Node_Id
;
6932 Rhs_Discr_Val
: Node_Id
;
6935 -- Per-object constrained selected components require special
6936 -- attention. If the enclosing scope of the component is an
6937 -- Unchecked_Union, we cannot reference its discriminants
6938 -- directly. This is why we use the two extra parameters of
6939 -- the equality function of the enclosing Unchecked_Union.
6941 -- type UU_Type (Discr : Integer := 0) is
6944 -- pragma Unchecked_Union (UU_Type);
6946 -- 1. Unchecked_Union enclosing record:
6948 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6950 -- Comp : UU_Type (Discr);
6952 -- end Enclosing_UU_Type;
6953 -- pragma Unchecked_Union (Enclosing_UU_Type);
6955 -- Obj1 : Enclosing_UU_Type;
6956 -- Obj2 : Enclosing_UU_Type (1);
6958 -- [. . .] Obj1 = Obj2 [. . .]
6962 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6964 -- A and B are the formal parameters of the equality function
6965 -- of Enclosing_UU_Type. The function always has two extra
6966 -- formals to capture the inferred discriminant values.
6968 -- 2. Non-Unchecked_Union enclosing record:
6971 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6974 -- Comp : UU_Type (Discr);
6976 -- end Enclosing_Non_UU_Type;
6978 -- Obj1 : Enclosing_Non_UU_Type;
6979 -- Obj2 : Enclosing_Non_UU_Type (1);
6981 -- ... Obj1 = Obj2 ...
6985 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6986 -- obj1.discr, obj2.discr)) then
6988 -- In this case we can directly reference the discriminants of
6989 -- the enclosing record.
6993 if Nkind
(Lhs
) = N_Selected_Component
6995 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
6997 -- Enclosing record is an Unchecked_Union, use formal A
6999 if Is_Unchecked_Union
7000 (Scope
(Entity
(Selector_Name
(Lhs
))))
7002 Lhs_Discr_Val
:= Make_Identifier
(Loc
, Name_A
);
7004 -- Enclosing record is of a non-Unchecked_Union type, it is
7005 -- possible to reference the discriminant.
7009 Make_Selected_Component
(Loc
,
7010 Prefix
=> Prefix
(Lhs
),
7013 (Get_Discriminant_Value
7014 (First_Discriminant
(Lhs_Type
),
7016 Stored_Constraint
(Lhs_Type
))));
7019 -- Comment needed here ???
7022 -- Infer the discriminant value
7026 (Get_Discriminant_Value
7027 (First_Discriminant
(Lhs_Type
),
7029 Stored_Constraint
(Lhs_Type
)));
7034 if Nkind
(Rhs
) = N_Selected_Component
7036 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
7038 if Is_Unchecked_Union
7039 (Scope
(Entity
(Selector_Name
(Rhs
))))
7041 Rhs_Discr_Val
:= Make_Identifier
(Loc
, Name_B
);
7045 Make_Selected_Component
(Loc
,
7046 Prefix
=> Prefix
(Rhs
),
7048 New_Copy
(Get_Discriminant_Value
(
7049 First_Discriminant
(Rhs_Type
),
7051 Stored_Constraint
(Rhs_Type
))));
7056 New_Copy
(Get_Discriminant_Value
(
7057 First_Discriminant
(Rhs_Type
),
7059 Stored_Constraint
(Rhs_Type
)));
7064 Make_Function_Call
(Loc
,
7065 Name
=> New_Reference_To
(Eq
, Loc
),
7066 Parameter_Associations
=> New_List
(
7073 -- Normal case, not an unchecked union
7077 Make_Function_Call
(Loc
,
7078 Name
=> New_Reference_To
(Eq
, Loc
),
7079 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7082 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7083 end Build_Equality_Call
;
7085 ------------------------------------
7086 -- Has_Unconstrained_UU_Component --
7087 ------------------------------------
7089 function Has_Unconstrained_UU_Component
7090 (Typ
: Node_Id
) return Boolean
7092 Tdef
: constant Node_Id
:=
7093 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
7097 function Component_Is_Unconstrained_UU
7098 (Comp
: Node_Id
) return Boolean;
7099 -- Determines whether the subtype of the component is an
7100 -- unconstrained Unchecked_Union.
7102 function Variant_Is_Unconstrained_UU
7103 (Variant
: Node_Id
) return Boolean;
7104 -- Determines whether a component of the variant has an unconstrained
7105 -- Unchecked_Union subtype.
7107 -----------------------------------
7108 -- Component_Is_Unconstrained_UU --
7109 -----------------------------------
7111 function Component_Is_Unconstrained_UU
7112 (Comp
: Node_Id
) return Boolean
7115 if Nkind
(Comp
) /= N_Component_Declaration
then
7120 Sindic
: constant Node_Id
:=
7121 Subtype_Indication
(Component_Definition
(Comp
));
7124 -- Unconstrained nominal type. In the case of a constraint
7125 -- present, the node kind would have been N_Subtype_Indication.
7127 if Nkind
(Sindic
) = N_Identifier
then
7128 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
7133 end Component_Is_Unconstrained_UU
;
7135 ---------------------------------
7136 -- Variant_Is_Unconstrained_UU --
7137 ---------------------------------
7139 function Variant_Is_Unconstrained_UU
7140 (Variant
: Node_Id
) return Boolean
7142 Clist
: constant Node_Id
:= Component_List
(Variant
);
7145 if Is_Empty_List
(Component_Items
(Clist
)) then
7149 -- We only need to test one component
7152 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7155 while Present
(Comp
) loop
7156 if Component_Is_Unconstrained_UU
(Comp
) then
7164 -- None of the components withing the variant were of
7165 -- unconstrained Unchecked_Union type.
7168 end Variant_Is_Unconstrained_UU
;
7170 -- Start of processing for Has_Unconstrained_UU_Component
7173 if Null_Present
(Tdef
) then
7177 Clist
:= Component_List
(Tdef
);
7178 Vpart
:= Variant_Part
(Clist
);
7180 -- Inspect available components
7182 if Present
(Component_Items
(Clist
)) then
7184 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7187 while Present
(Comp
) loop
7189 -- One component is sufficient
7191 if Component_Is_Unconstrained_UU
(Comp
) then
7200 -- Inspect available components withing variants
7202 if Present
(Vpart
) then
7204 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7207 while Present
(Variant
) loop
7209 -- One component within a variant is sufficient
7211 if Variant_Is_Unconstrained_UU
(Variant
) then
7220 -- Neither the available components, nor the components inside the
7221 -- variant parts were of an unconstrained Unchecked_Union subtype.
7224 end Has_Unconstrained_UU_Component
;
7226 -- Start of processing for Expand_N_Op_Eq
7229 Binary_Op_Validity_Checks
(N
);
7231 -- Deal with private types
7233 if Ekind
(Typl
) = E_Private_Type
then
7234 Typl
:= Underlying_Type
(Typl
);
7235 elsif Ekind
(Typl
) = E_Private_Subtype
then
7236 Typl
:= Underlying_Type
(Base_Type
(Typl
));
7241 -- It may happen in error situations that the underlying type is not
7242 -- set. The error will be detected later, here we just defend the
7249 Typl
:= Base_Type
(Typl
);
7251 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7252 -- means we no longer have a comparison operation, we are all done.
7254 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7256 if Nkind
(N
) /= N_Op_Eq
then
7260 -- Boolean types (requiring handling of non-standard case)
7262 if Is_Boolean_Type
(Typl
) then
7263 Adjust_Condition
(Left_Opnd
(N
));
7264 Adjust_Condition
(Right_Opnd
(N
));
7265 Set_Etype
(N
, Standard_Boolean
);
7266 Adjust_Result_Type
(N
, Typ
);
7270 elsif Is_Array_Type
(Typl
) then
7272 -- If we are doing full validity checking, and it is possible for the
7273 -- array elements to be invalid then expand out array comparisons to
7274 -- make sure that we check the array elements.
7276 if Validity_Check_Operands
7277 and then not Is_Known_Valid
(Component_Type
(Typl
))
7280 Save_Force_Validity_Checks
: constant Boolean :=
7281 Force_Validity_Checks
;
7283 Force_Validity_Checks
:= True;
7285 Expand_Array_Equality
7287 Relocate_Node
(Lhs
),
7288 Relocate_Node
(Rhs
),
7291 Insert_Actions
(N
, Bodies
);
7292 Analyze_And_Resolve
(N
, Standard_Boolean
);
7293 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7296 -- Packed case where both operands are known aligned
7298 elsif Is_Bit_Packed_Array
(Typl
)
7299 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7300 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7302 Expand_Packed_Eq
(N
);
7304 -- Where the component type is elementary we can use a block bit
7305 -- comparison (if supported on the target) exception in the case
7306 -- of floating-point (negative zero issues require element by
7307 -- element comparison), and atomic types (where we must be sure
7308 -- to load elements independently) and possibly unaligned arrays.
7310 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7311 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7312 and then not Is_Atomic
(Component_Type
(Typl
))
7313 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7314 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7315 and then Support_Composite_Compare_On_Target
7319 -- For composite and floating-point cases, expand equality loop to
7320 -- make sure of using proper comparisons for tagged types, and
7321 -- correctly handling the floating-point case.
7325 Expand_Array_Equality
7327 Relocate_Node
(Lhs
),
7328 Relocate_Node
(Rhs
),
7331 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7332 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7337 elsif Is_Record_Type
(Typl
) then
7339 -- For tagged types, use the primitive "="
7341 if Is_Tagged_Type
(Typl
) then
7343 -- No need to do anything else compiling under restriction
7344 -- No_Dispatching_Calls. During the semantic analysis we
7345 -- already notified such violation.
7347 if Restriction_Active
(No_Dispatching_Calls
) then
7351 -- If this is derived from an untagged private type completed with
7352 -- a tagged type, it does not have a full view, so we use the
7353 -- primitive operations of the private type. This check should no
7354 -- longer be necessary when these types get their full views???
7356 if Is_Private_Type
(A_Typ
)
7357 and then not Is_Tagged_Type
(A_Typ
)
7358 and then Is_Derived_Type
(A_Typ
)
7359 and then No
(Full_View
(A_Typ
))
7361 -- Search for equality operation, checking that the operands
7362 -- have the same type. Note that we must find a matching entry,
7363 -- or something is very wrong!
7365 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7367 while Present
(Prim
) loop
7368 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7369 and then Etype
(First_Formal
(Node
(Prim
))) =
7370 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7372 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7377 pragma Assert
(Present
(Prim
));
7378 Op_Name
:= Node
(Prim
);
7380 -- Find the type's predefined equality or an overriding
7381 -- user- defined equality. The reason for not simply calling
7382 -- Find_Prim_Op here is that there may be a user-defined
7383 -- overloaded equality op that precedes the equality that we want,
7384 -- so we have to explicitly search (e.g., there could be an
7385 -- equality with two different parameter types).
7388 if Is_Class_Wide_Type
(Typl
) then
7389 Typl
:= Root_Type
(Typl
);
7392 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7393 while Present
(Prim
) loop
7394 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7395 and then Etype
(First_Formal
(Node
(Prim
))) =
7396 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7398 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7403 pragma Assert
(Present
(Prim
));
7404 Op_Name
:= Node
(Prim
);
7407 Build_Equality_Call
(Op_Name
);
7409 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7410 -- predefined equality operator for a type which has a subcomponent
7411 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7413 elsif Has_Unconstrained_UU_Component
(Typl
) then
7415 Make_Raise_Program_Error
(Loc
,
7416 Reason
=> PE_Unchecked_Union_Restriction
));
7418 -- Prevent Gigi from generating incorrect code by rewriting the
7419 -- equality as a standard False. (is this documented somewhere???)
7422 New_Occurrence_Of
(Standard_False
, Loc
));
7424 elsif Is_Unchecked_Union
(Typl
) then
7426 -- If we can infer the discriminants of the operands, we make a
7427 -- call to the TSS equality function.
7429 if Has_Inferable_Discriminants
(Lhs
)
7431 Has_Inferable_Discriminants
(Rhs
)
7434 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7437 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7438 -- the predefined equality operator for an Unchecked_Union type
7439 -- if either of the operands lack inferable discriminants.
7442 Make_Raise_Program_Error
(Loc
,
7443 Reason
=> PE_Unchecked_Union_Restriction
));
7445 -- Prevent Gigi from generating incorrect code by rewriting
7446 -- the equality as a standard False (documented where???).
7449 New_Occurrence_Of
(Standard_False
, Loc
));
7453 -- If a type support function is present (for complex cases), use it
7455 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7457 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7459 -- Otherwise expand the component by component equality. Note that
7460 -- we never use block-bit comparisons for records, because of the
7461 -- problems with gaps. The backend will often be able to recombine
7462 -- the separate comparisons that we generate here.
7465 Remove_Side_Effects
(Lhs
);
7466 Remove_Side_Effects
(Rhs
);
7468 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7470 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7471 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7475 -- Test if result is known at compile time
7477 Rewrite_Comparison
(N
);
7479 -- If we still have comparison for Vax_Float, process it
7481 if Vax_Float
(Typl
) and then Nkind
(N
) in N_Op_Compare
then
7482 Expand_Vax_Comparison
(N
);
7486 Optimize_Length_Comparison
(N
);
7489 -----------------------
7490 -- Expand_N_Op_Expon --
7491 -----------------------
7493 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
7494 Loc
: constant Source_Ptr
:= Sloc
(N
);
7495 Typ
: constant Entity_Id
:= Etype
(N
);
7496 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
7497 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
7498 Bastyp
: constant Node_Id
:= Etype
(Base
);
7499 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
7500 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
7501 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
7510 Binary_Op_Validity_Checks
(N
);
7512 -- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node
7514 if CodePeer_Mode
or SPARK_Mode
then
7518 -- If either operand is of a private type, then we have the use of an
7519 -- intrinsic operator, and we get rid of the privateness, by using root
7520 -- types of underlying types for the actual operation. Otherwise the
7521 -- private types will cause trouble if we expand multiplications or
7522 -- shifts etc. We also do this transformation if the result type is
7523 -- different from the base type.
7525 if Is_Private_Type
(Etype
(Base
))
7526 or else Is_Private_Type
(Typ
)
7527 or else Is_Private_Type
(Exptyp
)
7528 or else Rtyp
/= Root_Type
(Bastyp
)
7531 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
7532 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
7536 Unchecked_Convert_To
(Typ
,
7538 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
7539 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
7540 Analyze_And_Resolve
(N
, Typ
);
7545 -- Check for MINIMIZED/ELIMINATED overflow mode
7547 if Minimized_Eliminated_Overflow_Check
(N
) then
7548 Apply_Arithmetic_Overflow_Check
(N
);
7552 -- Test for case of known right argument where we can replace the
7553 -- exponentiation by an equivalent expression using multiplication.
7555 if Compile_Time_Known_Value
(Exp
) then
7556 Expv
:= Expr_Value
(Exp
);
7558 -- We only fold small non-negative exponents. You might think we
7559 -- could fold small negative exponents for the real case, but we
7560 -- can't because we are required to raise Constraint_Error for
7561 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7562 -- See ACVC test C4A012B.
7564 if Expv
>= 0 and then Expv
<= 4 then
7566 -- X ** 0 = 1 (or 1.0)
7570 -- Call Remove_Side_Effects to ensure that any side effects
7571 -- in the ignored left operand (in particular function calls
7572 -- to user defined functions) are properly executed.
7574 Remove_Side_Effects
(Base
);
7576 if Ekind
(Typ
) in Integer_Kind
then
7577 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
7579 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
7591 Make_Op_Multiply
(Loc
,
7592 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7593 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7595 -- X ** 3 = X * X * X
7599 Make_Op_Multiply
(Loc
,
7601 Make_Op_Multiply
(Loc
,
7602 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7603 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
7604 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7609 -- En : constant base'type := base * base;
7614 pragma Assert
(Expv
= 4);
7615 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
7618 Make_Expression_With_Actions
(Loc
,
7619 Actions
=> New_List
(
7620 Make_Object_Declaration
(Loc
,
7621 Defining_Identifier
=> Temp
,
7622 Constant_Present
=> True,
7623 Object_Definition
=> New_Reference_To
(Typ
, Loc
),
7625 Make_Op_Multiply
(Loc
,
7627 Duplicate_Subexpr
(Base
),
7629 Duplicate_Subexpr_No_Checks
(Base
)))),
7632 Make_Op_Multiply
(Loc
,
7633 Left_Opnd
=> New_Reference_To
(Temp
, Loc
),
7634 Right_Opnd
=> New_Reference_To
(Temp
, Loc
)));
7638 Analyze_And_Resolve
(N
, Typ
);
7643 -- Case of (2 ** expression) appearing as an argument of an integer
7644 -- multiplication, or as the right argument of a division of a non-
7645 -- negative integer. In such cases we leave the node untouched, setting
7646 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
7647 -- of the higher level node converts it into a shift.
7649 -- Another case is 2 ** N in any other context. We simply convert
7650 -- this to 1 * 2 ** N, and then the above transformation applies.
7652 -- Note: this transformation is not applicable for a modular type with
7653 -- a non-binary modulus in the multiplication case, since we get a wrong
7654 -- result if the shift causes an overflow before the modular reduction.
7656 if Nkind
(Base
) = N_Integer_Literal
7657 and then Intval
(Base
) = 2
7658 and then Is_Integer_Type
(Root_Type
(Exptyp
))
7659 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
7660 and then Is_Unsigned_Type
(Exptyp
)
7663 -- First the multiply and divide cases
7665 if Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
) then
7667 P
: constant Node_Id
:= Parent
(N
);
7668 L
: constant Node_Id
:= Left_Opnd
(P
);
7669 R
: constant Node_Id
:= Right_Opnd
(P
);
7672 if (Nkind
(P
) = N_Op_Multiply
7673 and then not Non_Binary_Modulus
(Typ
)
7675 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
7677 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
7678 and then not Do_Overflow_Check
(P
))
7680 (Nkind
(P
) = N_Op_Divide
7681 and then Is_Integer_Type
(Etype
(L
))
7682 and then Is_Unsigned_Type
(Etype
(L
))
7684 and then not Do_Overflow_Check
(P
))
7686 Set_Is_Power_Of_2_For_Shift
(N
);
7691 -- Now the other cases
7693 elsif not Non_Binary_Modulus
(Typ
) then
7695 Make_Op_Multiply
(Loc
,
7696 Left_Opnd
=> Make_Integer_Literal
(Loc
, 1),
7697 Right_Opnd
=> Relocate_Node
(N
)));
7698 Analyze_And_Resolve
(N
, Typ
);
7703 -- Fall through if exponentiation must be done using a runtime routine
7705 -- First deal with modular case
7707 if Is_Modular_Integer_Type
(Rtyp
) then
7709 -- Non-binary case, we call the special exponentiation routine for
7710 -- the non-binary case, converting the argument to Long_Long_Integer
7711 -- and passing the modulus value. Then the result is converted back
7712 -- to the base type.
7714 if Non_Binary_Modulus
(Rtyp
) then
7717 Make_Function_Call
(Loc
,
7718 Name
=> New_Reference_To
(RTE
(RE_Exp_Modular
), Loc
),
7719 Parameter_Associations
=> New_List
(
7720 Convert_To
(Standard_Integer
, Base
),
7721 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
7724 -- Binary case, in this case, we call one of two routines, either the
7725 -- unsigned integer case, or the unsigned long long integer case,
7726 -- with a final "and" operation to do the required mod.
7729 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
7730 Ent
:= RTE
(RE_Exp_Unsigned
);
7732 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
7739 Make_Function_Call
(Loc
,
7740 Name
=> New_Reference_To
(Ent
, Loc
),
7741 Parameter_Associations
=> New_List
(
7742 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
7745 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
7749 -- Common exit point for modular type case
7751 Analyze_And_Resolve
(N
, Typ
);
7754 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7755 -- It is not worth having routines for Short_[Short_]Integer, since for
7756 -- most machines it would not help, and it would generate more code that
7757 -- might need certification when a certified run time is required.
7759 -- In the integer cases, we have two routines, one for when overflow
7760 -- checks are required, and one when they are not required, since there
7761 -- is a real gain in omitting checks on many machines.
7763 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
7764 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
7766 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
7767 or else Rtyp
= Universal_Integer
7769 Etyp
:= Standard_Long_Long_Integer
;
7772 Rent
:= RE_Exp_Long_Long_Integer
;
7774 Rent
:= RE_Exn_Long_Long_Integer
;
7777 elsif Is_Signed_Integer_Type
(Rtyp
) then
7778 Etyp
:= Standard_Integer
;
7781 Rent
:= RE_Exp_Integer
;
7783 Rent
:= RE_Exn_Integer
;
7786 -- Floating-point cases, always done using Long_Long_Float. We do not
7787 -- need separate routines for the overflow case here, since in the case
7788 -- of floating-point, we generate infinities anyway as a rule (either
7789 -- that or we automatically trap overflow), and if there is an infinity
7790 -- generated and a range check is required, the check will fail anyway.
7793 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
7794 Etyp
:= Standard_Long_Long_Float
;
7795 Rent
:= RE_Exn_Long_Long_Float
;
7798 -- Common processing for integer cases and floating-point cases.
7799 -- If we are in the right type, we can call runtime routine directly
7802 and then Rtyp
/= Universal_Integer
7803 and then Rtyp
/= Universal_Real
7806 Make_Function_Call
(Loc
,
7807 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
7808 Parameter_Associations
=> New_List
(Base
, Exp
)));
7810 -- Otherwise we have to introduce conversions (conversions are also
7811 -- required in the universal cases, since the runtime routine is
7812 -- typed using one of the standard types).
7817 Make_Function_Call
(Loc
,
7818 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
7819 Parameter_Associations
=> New_List
(
7820 Convert_To
(Etyp
, Base
),
7824 Analyze_And_Resolve
(N
, Typ
);
7828 when RE_Not_Available
=>
7830 end Expand_N_Op_Expon
;
7832 --------------------
7833 -- Expand_N_Op_Ge --
7834 --------------------
7836 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
7837 Typ
: constant Entity_Id
:= Etype
(N
);
7838 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7839 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7840 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7843 Binary_Op_Validity_Checks
(N
);
7845 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7846 -- means we no longer have a comparison operation, we are all done.
7848 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7850 if Nkind
(N
) /= N_Op_Ge
then
7856 if Is_Array_Type
(Typ1
) then
7857 Expand_Array_Comparison
(N
);
7861 -- Deal with boolean operands
7863 if Is_Boolean_Type
(Typ1
) then
7864 Adjust_Condition
(Op1
);
7865 Adjust_Condition
(Op2
);
7866 Set_Etype
(N
, Standard_Boolean
);
7867 Adjust_Result_Type
(N
, Typ
);
7870 Rewrite_Comparison
(N
);
7872 -- If we still have comparison, and Vax_Float type, process it
7874 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7875 Expand_Vax_Comparison
(N
);
7879 Optimize_Length_Comparison
(N
);
7882 --------------------
7883 -- Expand_N_Op_Gt --
7884 --------------------
7886 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
7887 Typ
: constant Entity_Id
:= Etype
(N
);
7888 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7889 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7890 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7893 Binary_Op_Validity_Checks
(N
);
7895 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7896 -- means we no longer have a comparison operation, we are all done.
7898 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7900 if Nkind
(N
) /= N_Op_Gt
then
7904 -- Deal with array type operands
7906 if Is_Array_Type
(Typ1
) then
7907 Expand_Array_Comparison
(N
);
7911 -- Deal with boolean type operands
7913 if Is_Boolean_Type
(Typ1
) then
7914 Adjust_Condition
(Op1
);
7915 Adjust_Condition
(Op2
);
7916 Set_Etype
(N
, Standard_Boolean
);
7917 Adjust_Result_Type
(N
, Typ
);
7920 Rewrite_Comparison
(N
);
7922 -- If we still have comparison, and Vax_Float type, process it
7924 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7925 Expand_Vax_Comparison
(N
);
7929 Optimize_Length_Comparison
(N
);
7932 --------------------
7933 -- Expand_N_Op_Le --
7934 --------------------
7936 procedure Expand_N_Op_Le
(N
: Node_Id
) is
7937 Typ
: constant Entity_Id
:= Etype
(N
);
7938 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7939 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7940 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7943 Binary_Op_Validity_Checks
(N
);
7945 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7946 -- means we no longer have a comparison operation, we are all done.
7948 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7950 if Nkind
(N
) /= N_Op_Le
then
7954 -- Deal with array type operands
7956 if Is_Array_Type
(Typ1
) then
7957 Expand_Array_Comparison
(N
);
7961 -- Deal with Boolean type operands
7963 if Is_Boolean_Type
(Typ1
) then
7964 Adjust_Condition
(Op1
);
7965 Adjust_Condition
(Op2
);
7966 Set_Etype
(N
, Standard_Boolean
);
7967 Adjust_Result_Type
(N
, Typ
);
7970 Rewrite_Comparison
(N
);
7972 -- If we still have comparison, and Vax_Float type, process it
7974 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7975 Expand_Vax_Comparison
(N
);
7979 Optimize_Length_Comparison
(N
);
7982 --------------------
7983 -- Expand_N_Op_Lt --
7984 --------------------
7986 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
7987 Typ
: constant Entity_Id
:= Etype
(N
);
7988 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7989 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7990 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7993 Binary_Op_Validity_Checks
(N
);
7995 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7996 -- means we no longer have a comparison operation, we are all done.
7998 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8000 if Nkind
(N
) /= N_Op_Lt
then
8004 -- Deal with array type operands
8006 if Is_Array_Type
(Typ1
) then
8007 Expand_Array_Comparison
(N
);
8011 -- Deal with Boolean type operands
8013 if Is_Boolean_Type
(Typ1
) then
8014 Adjust_Condition
(Op1
);
8015 Adjust_Condition
(Op2
);
8016 Set_Etype
(N
, Standard_Boolean
);
8017 Adjust_Result_Type
(N
, Typ
);
8020 Rewrite_Comparison
(N
);
8022 -- If we still have comparison, and Vax_Float type, process it
8024 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
8025 Expand_Vax_Comparison
(N
);
8029 Optimize_Length_Comparison
(N
);
8032 -----------------------
8033 -- Expand_N_Op_Minus --
8034 -----------------------
8036 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
8037 Loc
: constant Source_Ptr
:= Sloc
(N
);
8038 Typ
: constant Entity_Id
:= Etype
(N
);
8041 Unary_Op_Validity_Checks
(N
);
8043 -- Check for MINIMIZED/ELIMINATED overflow mode
8045 if Minimized_Eliminated_Overflow_Check
(N
) then
8046 Apply_Arithmetic_Overflow_Check
(N
);
8050 if not Backend_Overflow_Checks_On_Target
8051 and then Is_Signed_Integer_Type
(Etype
(N
))
8052 and then Do_Overflow_Check
(N
)
8054 -- Software overflow checking expands -expr into (0 - expr)
8057 Make_Op_Subtract
(Loc
,
8058 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
8059 Right_Opnd
=> Right_Opnd
(N
)));
8061 Analyze_And_Resolve
(N
, Typ
);
8063 -- Vax floating-point types case
8065 elsif Vax_Float
(Etype
(N
)) then
8066 Expand_Vax_Arith
(N
);
8068 end Expand_N_Op_Minus
;
8070 ---------------------
8071 -- Expand_N_Op_Mod --
8072 ---------------------
8074 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
8075 Loc
: constant Source_Ptr
:= Sloc
(N
);
8076 Typ
: constant Entity_Id
:= Etype
(N
);
8077 DDC
: constant Boolean := Do_Division_Check
(N
);
8090 pragma Warnings
(Off
, Lhi
);
8093 Binary_Op_Validity_Checks
(N
);
8095 -- Check for MINIMIZED/ELIMINATED overflow mode
8097 if Minimized_Eliminated_Overflow_Check
(N
) then
8098 Apply_Arithmetic_Overflow_Check
(N
);
8102 if Is_Integer_Type
(Etype
(N
)) then
8103 Apply_Divide_Checks
(N
);
8105 -- All done if we don't have a MOD any more, which can happen as a
8106 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8108 if Nkind
(N
) /= N_Op_Mod
then
8113 -- Proceed with expansion of mod operator
8115 Left
:= Left_Opnd
(N
);
8116 Right
:= Right_Opnd
(N
);
8118 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
8119 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
8121 -- Convert mod to rem if operands are known non-negative. We do this
8122 -- since it is quite likely that this will improve the quality of code,
8123 -- (the operation now corresponds to the hardware remainder), and it
8124 -- does not seem likely that it could be harmful.
8126 if LOK
and then Llo
>= 0 and then ROK
and then Rlo
>= 0 then
8128 Make_Op_Rem
(Sloc
(N
),
8129 Left_Opnd
=> Left_Opnd
(N
),
8130 Right_Opnd
=> Right_Opnd
(N
)));
8132 -- Instead of reanalyzing the node we do the analysis manually. This
8133 -- avoids anomalies when the replacement is done in an instance and
8134 -- is epsilon more efficient.
8136 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
8138 Set_Do_Division_Check
(N
, DDC
);
8139 Expand_N_Op_Rem
(N
);
8142 -- Otherwise, normal mod processing
8145 -- Apply optimization x mod 1 = 0. We don't really need that with
8146 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
8147 -- certainly harmless.
8149 if Is_Integer_Type
(Etype
(N
))
8150 and then Compile_Time_Known_Value
(Right
)
8151 and then Expr_Value
(Right
) = Uint_1
8153 -- Call Remove_Side_Effects to ensure that any side effects in
8154 -- the ignored left operand (in particular function calls to
8155 -- user defined functions) are properly executed.
8157 Remove_Side_Effects
(Left
);
8159 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8160 Analyze_And_Resolve
(N
, Typ
);
8164 -- Deal with annoying case of largest negative number remainder
8165 -- minus one. Gigi may not handle this case correctly, because
8166 -- on some targets, the mod value is computed using a divide
8167 -- instruction which gives an overflow trap for this case.
8169 -- It would be a bit more efficient to figure out which targets
8170 -- this is really needed for, but in practice it is reasonable
8171 -- to do the following special check in all cases, since it means
8172 -- we get a clearer message, and also the overhead is minimal given
8173 -- that division is expensive in any case.
8175 -- In fact the check is quite easy, if the right operand is -1, then
8176 -- the mod value is always 0, and we can just ignore the left operand
8177 -- completely in this case.
8179 -- This only applies if we still have a mod operator. Skip if we
8180 -- have already rewritten this (e.g. in the case of eliminated
8181 -- overflow checks which have driven us into bignum mode).
8183 if Nkind
(N
) = N_Op_Mod
then
8185 -- The operand type may be private (e.g. in the expansion of an
8186 -- intrinsic operation) so we must use the underlying type to get
8187 -- the bounds, and convert the literals explicitly.
8191 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
8193 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
8194 and then ((not LOK
) or else (Llo
= LLB
))
8197 Make_If_Expression
(Loc
,
8198 Expressions
=> New_List
(
8200 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8202 Unchecked_Convert_To
(Typ
,
8203 Make_Integer_Literal
(Loc
, -1))),
8204 Unchecked_Convert_To
(Typ
,
8205 Make_Integer_Literal
(Loc
, Uint_0
)),
8206 Relocate_Node
(N
))));
8208 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8209 Analyze_And_Resolve
(N
, Typ
);
8213 end Expand_N_Op_Mod
;
8215 --------------------------
8216 -- Expand_N_Op_Multiply --
8217 --------------------------
8219 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
8220 Loc
: constant Source_Ptr
:= Sloc
(N
);
8221 Lop
: constant Node_Id
:= Left_Opnd
(N
);
8222 Rop
: constant Node_Id
:= Right_Opnd
(N
);
8224 Lp2
: constant Boolean :=
8225 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
8226 Rp2
: constant Boolean :=
8227 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
8229 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
8230 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
8231 Typ
: Entity_Id
:= Etype
(N
);
8234 Binary_Op_Validity_Checks
(N
);
8236 -- Check for MINIMIZED/ELIMINATED overflow mode
8238 if Minimized_Eliminated_Overflow_Check
(N
) then
8239 Apply_Arithmetic_Overflow_Check
(N
);
8243 -- Special optimizations for integer types
8245 if Is_Integer_Type
(Typ
) then
8247 -- N * 0 = 0 for integer types
8249 if Compile_Time_Known_Value
(Rop
)
8250 and then Expr_Value
(Rop
) = Uint_0
8252 -- Call Remove_Side_Effects to ensure that any side effects in
8253 -- the ignored left operand (in particular function calls to
8254 -- user defined functions) are properly executed.
8256 Remove_Side_Effects
(Lop
);
8258 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8259 Analyze_And_Resolve
(N
, Typ
);
8263 -- Similar handling for 0 * N = 0
8265 if Compile_Time_Known_Value
(Lop
)
8266 and then Expr_Value
(Lop
) = Uint_0
8268 Remove_Side_Effects
(Rop
);
8269 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8270 Analyze_And_Resolve
(N
, Typ
);
8274 -- N * 1 = 1 * N = N for integer types
8276 -- This optimisation is not done if we are going to
8277 -- rewrite the product 1 * 2 ** N to a shift.
8279 if Compile_Time_Known_Value
(Rop
)
8280 and then Expr_Value
(Rop
) = Uint_1
8286 elsif Compile_Time_Known_Value
(Lop
)
8287 and then Expr_Value
(Lop
) = Uint_1
8295 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8296 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8297 -- operand is an integer, as required for this to work.
8302 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8306 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
8309 Left_Opnd
=> Right_Opnd
(Lop
),
8310 Right_Opnd
=> Right_Opnd
(Rop
))));
8311 Analyze_And_Resolve
(N
, Typ
);
8316 Make_Op_Shift_Left
(Loc
,
8319 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
8320 Analyze_And_Resolve
(N
, Typ
);
8324 -- Same processing for the operands the other way round
8328 Make_Op_Shift_Left
(Loc
,
8331 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
8332 Analyze_And_Resolve
(N
, Typ
);
8336 -- Do required fixup of universal fixed operation
8338 if Typ
= Universal_Fixed
then
8339 Fixup_Universal_Fixed_Operation
(N
);
8343 -- Multiplications with fixed-point results
8345 if Is_Fixed_Point_Type
(Typ
) then
8347 -- No special processing if Treat_Fixed_As_Integer is set, since from
8348 -- a semantic point of view such operations are simply integer
8349 -- operations and will be treated that way.
8351 if not Treat_Fixed_As_Integer
(N
) then
8353 -- Case of fixed * integer => fixed
8355 if Is_Integer_Type
(Rtyp
) then
8356 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
8358 -- Case of integer * fixed => fixed
8360 elsif Is_Integer_Type
(Ltyp
) then
8361 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
8363 -- Case of fixed * fixed => fixed
8366 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
8370 -- Other cases of multiplication of fixed-point operands. Again we
8371 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8373 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
8374 and then not Treat_Fixed_As_Integer
(N
)
8376 if Is_Integer_Type
(Typ
) then
8377 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
8379 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8380 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
8383 -- Mixed-mode operations can appear in a non-static universal context,
8384 -- in which case the integer argument must be converted explicitly.
8386 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
8387 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
8388 Analyze_And_Resolve
(Rop
, Universal_Real
);
8390 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
8391 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
8392 Analyze_And_Resolve
(Lop
, Universal_Real
);
8394 -- Non-fixed point cases, check software overflow checking required
8396 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
8397 Apply_Arithmetic_Overflow_Check
(N
);
8399 -- Deal with VAX float case
8401 elsif Vax_Float
(Typ
) then
8402 Expand_Vax_Arith
(N
);
8405 end Expand_N_Op_Multiply
;
8407 --------------------
8408 -- Expand_N_Op_Ne --
8409 --------------------
8411 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
8412 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
8415 -- Case of elementary type with standard operator
8417 if Is_Elementary_Type
(Typ
)
8418 and then Sloc
(Entity
(N
)) = Standard_Location
8420 Binary_Op_Validity_Checks
(N
);
8422 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8423 -- means we no longer have a /= operation, we are all done.
8425 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8427 if Nkind
(N
) /= N_Op_Ne
then
8431 -- Boolean types (requiring handling of non-standard case)
8433 if Is_Boolean_Type
(Typ
) then
8434 Adjust_Condition
(Left_Opnd
(N
));
8435 Adjust_Condition
(Right_Opnd
(N
));
8436 Set_Etype
(N
, Standard_Boolean
);
8437 Adjust_Result_Type
(N
, Typ
);
8440 Rewrite_Comparison
(N
);
8442 -- If we still have comparison for Vax_Float, process it
8444 if Vax_Float
(Typ
) and then Nkind
(N
) in N_Op_Compare
then
8445 Expand_Vax_Comparison
(N
);
8449 -- For all cases other than elementary types, we rewrite node as the
8450 -- negation of an equality operation, and reanalyze. The equality to be
8451 -- used is defined in the same scope and has the same signature. This
8452 -- signature must be set explicitly since in an instance it may not have
8453 -- the same visibility as in the generic unit. This avoids duplicating
8454 -- or factoring the complex code for record/array equality tests etc.
8458 Loc
: constant Source_Ptr
:= Sloc
(N
);
8460 Ne
: constant Entity_Id
:= Entity
(N
);
8463 Binary_Op_Validity_Checks
(N
);
8469 Left_Opnd
=> Left_Opnd
(N
),
8470 Right_Opnd
=> Right_Opnd
(N
)));
8471 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
8473 if Scope
(Ne
) /= Standard_Standard
then
8474 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
8477 -- For navigation purposes, we want to treat the inequality as an
8478 -- implicit reference to the corresponding equality. Preserve the
8479 -- Comes_From_ source flag to generate proper Xref entries.
8481 Preserve_Comes_From_Source
(Neg
, N
);
8482 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
8484 Analyze_And_Resolve
(N
, Standard_Boolean
);
8488 Optimize_Length_Comparison
(N
);
8491 ---------------------
8492 -- Expand_N_Op_Not --
8493 ---------------------
8495 -- If the argument is other than a Boolean array type, there is no special
8496 -- expansion required, except for VMS operations on signed integers.
8498 -- For the packed case, we call the special routine in Exp_Pakd, except
8499 -- that if the component size is greater than one, we use the standard
8500 -- routine generating a gruesome loop (it is so peculiar to have packed
8501 -- arrays with non-standard Boolean representations anyway, so it does not
8502 -- matter that we do not handle this case efficiently).
8504 -- For the unpacked case (and for the special packed case where we have non
8505 -- standard Booleans, as discussed above), we generate and insert into the
8506 -- tree the following function definition:
8508 -- function Nnnn (A : arr) is
8511 -- for J in a'range loop
8512 -- B (J) := not A (J);
8517 -- Here arr is the actual subtype of the parameter (and hence always
8518 -- constrained). Then we replace the not with a call to this function.
8520 procedure Expand_N_Op_Not
(N
: Node_Id
) is
8521 Loc
: constant Source_Ptr
:= Sloc
(N
);
8522 Typ
: constant Entity_Id
:= Etype
(N
);
8531 Func_Name
: Entity_Id
;
8532 Loop_Statement
: Node_Id
;
8535 Unary_Op_Validity_Checks
(N
);
8537 -- For boolean operand, deal with non-standard booleans
8539 if Is_Boolean_Type
(Typ
) then
8540 Adjust_Condition
(Right_Opnd
(N
));
8541 Set_Etype
(N
, Standard_Boolean
);
8542 Adjust_Result_Type
(N
, Typ
);
8546 -- For the VMS "not" on signed integer types, use conversion to and from
8547 -- a predefined modular type.
8549 if Is_VMS_Operator
(Entity
(N
)) then
8555 -- If this is a derived type, retrieve original VMS type so that
8556 -- the proper sized type is used for intermediate values.
8558 if Is_Derived_Type
(Typ
) then
8559 Rtyp
:= First_Subtype
(Etype
(Typ
));
8564 -- The proper unsigned type must have a size compatible with the
8565 -- operand, to prevent misalignment.
8567 if RM_Size
(Rtyp
) <= 8 then
8568 Utyp
:= RTE
(RE_Unsigned_8
);
8570 elsif RM_Size
(Rtyp
) <= 16 then
8571 Utyp
:= RTE
(RE_Unsigned_16
);
8573 elsif RM_Size
(Rtyp
) = RM_Size
(Standard_Unsigned
) then
8574 Utyp
:= RTE
(RE_Unsigned_32
);
8577 Utyp
:= RTE
(RE_Long_Long_Unsigned
);
8581 Unchecked_Convert_To
(Typ
,
8583 Unchecked_Convert_To
(Utyp
, Right_Opnd
(N
)))));
8584 Analyze_And_Resolve
(N
, Typ
);
8589 -- Only array types need any other processing
8591 if not Is_Array_Type
(Typ
) then
8595 -- Case of array operand. If bit packed with a component size of 1,
8596 -- handle it in Exp_Pakd if the operand is known to be aligned.
8598 if Is_Bit_Packed_Array
(Typ
)
8599 and then Component_Size
(Typ
) = 1
8600 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
8602 Expand_Packed_Not
(N
);
8606 -- Case of array operand which is not bit-packed. If the context is
8607 -- a safe assignment, call in-place operation, If context is a larger
8608 -- boolean expression in the context of a safe assignment, expansion is
8609 -- done by enclosing operation.
8611 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
8612 Convert_To_Actual_Subtype
(Opnd
);
8613 Arr
:= Etype
(Opnd
);
8614 Ensure_Defined
(Arr
, N
);
8615 Silly_Boolean_Array_Not_Test
(N
, Arr
);
8617 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
8618 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
8619 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8622 -- Special case the negation of a binary operation
8624 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
8625 and then Safe_In_Place_Array_Op
8626 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
8628 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8632 elsif Nkind
(Parent
(N
)) in N_Binary_Op
8633 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
8636 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
8637 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
8638 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
8641 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
8643 -- (not A) op (not B) can be reduced to a single call
8645 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
8648 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
8651 -- A xor (not B) can also be special-cased
8653 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
8660 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
8661 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8662 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
8665 Make_Indexed_Component
(Loc
,
8666 Prefix
=> New_Reference_To
(A
, Loc
),
8667 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
8670 Make_Indexed_Component
(Loc
,
8671 Prefix
=> New_Reference_To
(B
, Loc
),
8672 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
8675 Make_Implicit_Loop_Statement
(N
,
8676 Identifier
=> Empty
,
8679 Make_Iteration_Scheme
(Loc
,
8680 Loop_Parameter_Specification
=>
8681 Make_Loop_Parameter_Specification
(Loc
,
8682 Defining_Identifier
=> J
,
8683 Discrete_Subtype_Definition
=>
8684 Make_Attribute_Reference
(Loc
,
8685 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
8686 Attribute_Name
=> Name_Range
))),
8688 Statements
=> New_List
(
8689 Make_Assignment_Statement
(Loc
,
8691 Expression
=> Make_Op_Not
(Loc
, A_J
))));
8693 Func_Name
:= Make_Temporary
(Loc
, 'N');
8694 Set_Is_Inlined
(Func_Name
);
8697 Make_Subprogram_Body
(Loc
,
8699 Make_Function_Specification
(Loc
,
8700 Defining_Unit_Name
=> Func_Name
,
8701 Parameter_Specifications
=> New_List
(
8702 Make_Parameter_Specification
(Loc
,
8703 Defining_Identifier
=> A
,
8704 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))),
8705 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
8707 Declarations
=> New_List
(
8708 Make_Object_Declaration
(Loc
,
8709 Defining_Identifier
=> B
,
8710 Object_Definition
=> New_Reference_To
(Arr
, Loc
))),
8712 Handled_Statement_Sequence
=>
8713 Make_Handled_Sequence_Of_Statements
(Loc
,
8714 Statements
=> New_List
(
8716 Make_Simple_Return_Statement
(Loc
,
8717 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
8720 Make_Function_Call
(Loc
,
8721 Name
=> New_Reference_To
(Func_Name
, Loc
),
8722 Parameter_Associations
=> New_List
(Opnd
)));
8724 Analyze_And_Resolve
(N
, Typ
);
8725 end Expand_N_Op_Not
;
8727 --------------------
8728 -- Expand_N_Op_Or --
8729 --------------------
8731 procedure Expand_N_Op_Or
(N
: Node_Id
) is
8732 Typ
: constant Entity_Id
:= Etype
(N
);
8735 Binary_Op_Validity_Checks
(N
);
8737 if Is_Array_Type
(Etype
(N
)) then
8738 Expand_Boolean_Operator
(N
);
8740 elsif Is_Boolean_Type
(Etype
(N
)) then
8741 Adjust_Condition
(Left_Opnd
(N
));
8742 Adjust_Condition
(Right_Opnd
(N
));
8743 Set_Etype
(N
, Standard_Boolean
);
8744 Adjust_Result_Type
(N
, Typ
);
8746 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8747 Expand_Intrinsic_Call
(N
, Entity
(N
));
8752 ----------------------
8753 -- Expand_N_Op_Plus --
8754 ----------------------
8756 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
8758 Unary_Op_Validity_Checks
(N
);
8760 -- Check for MINIMIZED/ELIMINATED overflow mode
8762 if Minimized_Eliminated_Overflow_Check
(N
) then
8763 Apply_Arithmetic_Overflow_Check
(N
);
8766 end Expand_N_Op_Plus
;
8768 ---------------------
8769 -- Expand_N_Op_Rem --
8770 ---------------------
8772 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
8773 Loc
: constant Source_Ptr
:= Sloc
(N
);
8774 Typ
: constant Entity_Id
:= Etype
(N
);
8785 -- Set if corresponding operand can be negative
8787 pragma Unreferenced
(Hi
);
8790 Binary_Op_Validity_Checks
(N
);
8792 -- Check for MINIMIZED/ELIMINATED overflow mode
8794 if Minimized_Eliminated_Overflow_Check
(N
) then
8795 Apply_Arithmetic_Overflow_Check
(N
);
8799 if Is_Integer_Type
(Etype
(N
)) then
8800 Apply_Divide_Checks
(N
);
8802 -- All done if we don't have a REM any more, which can happen as a
8803 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8805 if Nkind
(N
) /= N_Op_Rem
then
8810 -- Proceed with expansion of REM
8812 Left
:= Left_Opnd
(N
);
8813 Right
:= Right_Opnd
(N
);
8815 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
8816 -- but it is useful with other back ends (e.g. AAMP), and is certainly
8819 if Is_Integer_Type
(Etype
(N
))
8820 and then Compile_Time_Known_Value
(Right
)
8821 and then Expr_Value
(Right
) = Uint_1
8823 -- Call Remove_Side_Effects to ensure that any side effects in the
8824 -- ignored left operand (in particular function calls to user defined
8825 -- functions) are properly executed.
8827 Remove_Side_Effects
(Left
);
8829 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8830 Analyze_And_Resolve
(N
, Typ
);
8834 -- Deal with annoying case of largest negative number remainder minus
8835 -- one. Gigi may not handle this case correctly, because on some
8836 -- targets, the mod value is computed using a divide instruction
8837 -- which gives an overflow trap for this case.
8839 -- It would be a bit more efficient to figure out which targets this
8840 -- is really needed for, but in practice it is reasonable to do the
8841 -- following special check in all cases, since it means we get a clearer
8842 -- message, and also the overhead is minimal given that division is
8843 -- expensive in any case.
8845 -- In fact the check is quite easy, if the right operand is -1, then
8846 -- the remainder is always 0, and we can just ignore the left operand
8847 -- completely in this case.
8849 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8850 Lneg
:= (not OK
) or else Lo
< 0;
8852 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8853 Rneg
:= (not OK
) or else Lo
< 0;
8855 -- We won't mess with trying to find out if the left operand can really
8856 -- be the largest negative number (that's a pain in the case of private
8857 -- types and this is really marginal). We will just assume that we need
8858 -- the test if the left operand can be negative at all.
8860 if Lneg
and Rneg
then
8862 Make_If_Expression
(Loc
,
8863 Expressions
=> New_List
(
8865 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8867 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
8869 Unchecked_Convert_To
(Typ
,
8870 Make_Integer_Literal
(Loc
, Uint_0
)),
8872 Relocate_Node
(N
))));
8874 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8875 Analyze_And_Resolve
(N
, Typ
);
8877 end Expand_N_Op_Rem
;
8879 -----------------------------
8880 -- Expand_N_Op_Rotate_Left --
8881 -----------------------------
8883 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
8885 Binary_Op_Validity_Checks
(N
);
8886 end Expand_N_Op_Rotate_Left
;
8888 ------------------------------
8889 -- Expand_N_Op_Rotate_Right --
8890 ------------------------------
8892 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
8894 Binary_Op_Validity_Checks
(N
);
8895 end Expand_N_Op_Rotate_Right
;
8897 ----------------------------
8898 -- Expand_N_Op_Shift_Left --
8899 ----------------------------
8901 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
8903 Binary_Op_Validity_Checks
(N
);
8904 end Expand_N_Op_Shift_Left
;
8906 -----------------------------
8907 -- Expand_N_Op_Shift_Right --
8908 -----------------------------
8910 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
8912 Binary_Op_Validity_Checks
(N
);
8913 end Expand_N_Op_Shift_Right
;
8915 ----------------------------------------
8916 -- Expand_N_Op_Shift_Right_Arithmetic --
8917 ----------------------------------------
8919 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
8921 Binary_Op_Validity_Checks
(N
);
8922 end Expand_N_Op_Shift_Right_Arithmetic
;
8924 --------------------------
8925 -- Expand_N_Op_Subtract --
8926 --------------------------
8928 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
8929 Typ
: constant Entity_Id
:= Etype
(N
);
8932 Binary_Op_Validity_Checks
(N
);
8934 -- Check for MINIMIZED/ELIMINATED overflow mode
8936 if Minimized_Eliminated_Overflow_Check
(N
) then
8937 Apply_Arithmetic_Overflow_Check
(N
);
8941 -- N - 0 = N for integer types
8943 if Is_Integer_Type
(Typ
)
8944 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
8945 and then Expr_Value
(Right_Opnd
(N
)) = 0
8947 Rewrite
(N
, Left_Opnd
(N
));
8951 -- Arithmetic overflow checks for signed integer/fixed point types
8953 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
8954 Apply_Arithmetic_Overflow_Check
(N
);
8956 -- VAX floating-point types case
8958 elsif Vax_Float
(Typ
) then
8959 Expand_Vax_Arith
(N
);
8961 end Expand_N_Op_Subtract
;
8963 ---------------------
8964 -- Expand_N_Op_Xor --
8965 ---------------------
8967 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
8968 Typ
: constant Entity_Id
:= Etype
(N
);
8971 Binary_Op_Validity_Checks
(N
);
8973 if Is_Array_Type
(Etype
(N
)) then
8974 Expand_Boolean_Operator
(N
);
8976 elsif Is_Boolean_Type
(Etype
(N
)) then
8977 Adjust_Condition
(Left_Opnd
(N
));
8978 Adjust_Condition
(Right_Opnd
(N
));
8979 Set_Etype
(N
, Standard_Boolean
);
8980 Adjust_Result_Type
(N
, Typ
);
8982 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8983 Expand_Intrinsic_Call
(N
, Entity
(N
));
8986 end Expand_N_Op_Xor
;
8988 ----------------------
8989 -- Expand_N_Or_Else --
8990 ----------------------
8992 procedure Expand_N_Or_Else
(N
: Node_Id
)
8993 renames Expand_Short_Circuit_Operator
;
8995 -----------------------------------
8996 -- Expand_N_Qualified_Expression --
8997 -----------------------------------
8999 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
9000 Operand
: constant Node_Id
:= Expression
(N
);
9001 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
9004 -- Do validity check if validity checking operands
9006 if Validity_Checks_On
and Validity_Check_Operands
then
9007 Ensure_Valid
(Operand
);
9010 -- Apply possible constraint check
9012 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
9014 if Do_Range_Check
(Operand
) then
9015 Set_Do_Range_Check
(Operand
, False);
9016 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
9018 end Expand_N_Qualified_Expression
;
9020 ------------------------------------
9021 -- Expand_N_Quantified_Expression --
9022 ------------------------------------
9026 -- for all X in range => Cond
9031 -- for X in range loop
9038 -- Similarly, an existentially quantified expression:
9040 -- for some X in range => Cond
9045 -- for X in range loop
9052 -- In both cases, the iteration may be over a container in which case it is
9053 -- given by an iterator specification, not a loop parameter specification.
9055 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
9056 Actions
: constant List_Id
:= New_List
;
9057 For_All
: constant Boolean := All_Present
(N
);
9058 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
9059 Loc
: constant Source_Ptr
:= Sloc
(N
);
9060 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
9067 -- Create the declaration of the flag which tracks the status of the
9068 -- quantified expression. Generate:
9070 -- Flag : Boolean := (True | False);
9072 Flag
:= Make_Temporary
(Loc
, 'T', N
);
9075 Make_Object_Declaration
(Loc
,
9076 Defining_Identifier
=> Flag
,
9077 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
9079 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
9081 -- Construct the circuitry which tracks the status of the quantified
9082 -- expression. Generate:
9084 -- if [not] Cond then
9085 -- Flag := (False | True);
9089 Cond
:= Relocate_Node
(Condition
(N
));
9092 Cond
:= Make_Op_Not
(Loc
, Cond
);
9096 Make_Implicit_If_Statement
(N
,
9098 Then_Statements
=> New_List
(
9099 Make_Assignment_Statement
(Loc
,
9100 Name
=> New_Occurrence_Of
(Flag
, Loc
),
9102 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
9103 Make_Exit_Statement
(Loc
))));
9105 -- Build the loop equivalent of the quantified expression
9107 if Present
(Iter_Spec
) then
9109 Make_Iteration_Scheme
(Loc
,
9110 Iterator_Specification
=> Iter_Spec
);
9113 Make_Iteration_Scheme
(Loc
,
9114 Loop_Parameter_Specification
=> Loop_Spec
);
9118 Make_Loop_Statement
(Loc
,
9119 Iteration_Scheme
=> Scheme
,
9120 Statements
=> Stmts
,
9121 End_Label
=> Empty
));
9123 -- Transform the quantified expression
9126 Make_Expression_With_Actions
(Loc
,
9127 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
9128 Actions
=> Actions
));
9129 Analyze_And_Resolve
(N
, Standard_Boolean
);
9130 end Expand_N_Quantified_Expression
;
9132 ---------------------------------
9133 -- Expand_N_Selected_Component --
9134 ---------------------------------
9136 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
9137 Loc
: constant Source_Ptr
:= Sloc
(N
);
9138 Par
: constant Node_Id
:= Parent
(N
);
9139 P
: constant Node_Id
:= Prefix
(N
);
9140 S
: constant Node_Id
:= Selector_Name
(N
);
9141 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
9147 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
9148 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9149 -- unless the context of an assignment can provide size information.
9150 -- Don't we have a general routine that does this???
9152 function Is_Subtype_Declaration
return Boolean;
9153 -- The replacement of a discriminant reference by its value is required
9154 -- if this is part of the initialization of an temporary generated by a
9155 -- change of representation. This shows up as the construction of a
9156 -- discriminant constraint for a subtype declared at the same point as
9157 -- the entity in the prefix of the selected component. We recognize this
9158 -- case when the context of the reference is:
9159 -- subtype ST is T(Obj.D);
9160 -- where the entity for Obj comes from source, and ST has the same sloc.
9162 -----------------------
9163 -- In_Left_Hand_Side --
9164 -----------------------
9166 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
9168 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
9169 and then Comp
= Name
(Parent
(Comp
)))
9170 or else (Present
(Parent
(Comp
))
9171 and then Nkind
(Parent
(Comp
)) in N_Subexpr
9172 and then In_Left_Hand_Side
(Parent
(Comp
)));
9173 end In_Left_Hand_Side
;
9175 -----------------------------
9176 -- Is_Subtype_Declaration --
9177 -----------------------------
9179 function Is_Subtype_Declaration
return Boolean is
9180 Par
: constant Node_Id
:= Parent
(N
);
9183 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
9184 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
9185 and then Comes_From_Source
(Entity
(Prefix
(N
)))
9186 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
9187 end Is_Subtype_Declaration
;
9189 -- Start of processing for Expand_N_Selected_Component
9192 -- Insert explicit dereference if required
9194 if Is_Access_Type
(Ptyp
) then
9196 -- First set prefix type to proper access type, in case it currently
9197 -- has a private (non-access) view of this type.
9199 Set_Etype
(P
, Ptyp
);
9201 Insert_Explicit_Dereference
(P
);
9202 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
9204 if Ekind
(Etype
(P
)) = E_Private_Subtype
9205 and then Is_For_Access_Subtype
(Etype
(P
))
9207 Set_Etype
(P
, Base_Type
(Etype
(P
)));
9213 -- Deal with discriminant check required
9215 if Do_Discriminant_Check
(N
) then
9216 if Present
(Discriminant_Checking_Func
9217 (Original_Record_Component
(Entity
(S
))))
9219 -- Present the discriminant checking function to the backend, so
9220 -- that it can inline the call to the function.
9223 (Discriminant_Checking_Func
9224 (Original_Record_Component
(Entity
(S
))));
9226 -- Now reset the flag and generate the call
9228 Set_Do_Discriminant_Check
(N
, False);
9229 Generate_Discriminant_Check
(N
);
9231 -- In the case of Unchecked_Union, no discriminant checking is
9232 -- actually performed.
9235 Set_Do_Discriminant_Check
(N
, False);
9239 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9240 -- function, then additional actuals must be passed.
9242 if Ada_Version
>= Ada_2005
9243 and then Is_Build_In_Place_Function_Call
(P
)
9245 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
9248 -- Gigi cannot handle unchecked conversions that are the prefix of a
9249 -- selected component with discriminants. This must be checked during
9250 -- expansion, because during analysis the type of the selector is not
9251 -- known at the point the prefix is analyzed. If the conversion is the
9252 -- target of an assignment, then we cannot force the evaluation.
9254 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
9255 and then Has_Discriminants
(Etype
(N
))
9256 and then not In_Left_Hand_Side
(N
)
9258 Force_Evaluation
(Prefix
(N
));
9261 -- Remaining processing applies only if selector is a discriminant
9263 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
9265 -- If the selector is a discriminant of a constrained record type,
9266 -- we may be able to rewrite the expression with the actual value
9267 -- of the discriminant, a useful optimization in some cases.
9269 if Is_Record_Type
(Ptyp
)
9270 and then Has_Discriminants
(Ptyp
)
9271 and then Is_Constrained
(Ptyp
)
9273 -- Do this optimization for discrete types only, and not for
9274 -- access types (access discriminants get us into trouble!)
9276 if not Is_Discrete_Type
(Etype
(N
)) then
9279 -- Don't do this on the left hand of an assignment statement.
9280 -- Normally one would think that references like this would not
9281 -- occur, but they do in generated code, and mean that we really
9282 -- do want to assign the discriminant!
9284 elsif Nkind
(Par
) = N_Assignment_Statement
9285 and then Name
(Par
) = N
9289 -- Don't do this optimization for the prefix of an attribute or
9290 -- the name of an object renaming declaration since these are
9291 -- contexts where we do not want the value anyway.
9293 elsif (Nkind
(Par
) = N_Attribute_Reference
9294 and then Prefix
(Par
) = N
)
9295 or else Is_Renamed_Object
(N
)
9299 -- Don't do this optimization if we are within the code for a
9300 -- discriminant check, since the whole point of such a check may
9301 -- be to verify the condition on which the code below depends!
9303 elsif Is_In_Discriminant_Check
(N
) then
9306 -- Green light to see if we can do the optimization. There is
9307 -- still one condition that inhibits the optimization below but
9308 -- now is the time to check the particular discriminant.
9311 -- Loop through discriminants to find the matching discriminant
9312 -- constraint to see if we can copy it.
9314 Disc
:= First_Discriminant
(Ptyp
);
9315 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
9316 Discr_Loop
: while Present
(Dcon
) loop
9317 Dval
:= Node
(Dcon
);
9319 -- Check if this is the matching discriminant and if the
9320 -- discriminant value is simple enough to make sense to
9321 -- copy. We don't want to copy complex expressions, and
9322 -- indeed to do so can cause trouble (before we put in
9323 -- this guard, a discriminant expression containing an
9324 -- AND THEN was copied, causing problems for coverage
9327 -- However, if the reference is part of the initialization
9328 -- code generated for an object declaration, we must use
9329 -- the discriminant value from the subtype constraint,
9330 -- because the selected component may be a reference to the
9331 -- object being initialized, whose discriminant is not yet
9332 -- set. This only happens in complex cases involving changes
9333 -- or representation.
9335 if Disc
= Entity
(Selector_Name
(N
))
9336 and then (Is_Entity_Name
(Dval
)
9337 or else Compile_Time_Known_Value
(Dval
)
9338 or else Is_Subtype_Declaration
)
9340 -- Here we have the matching discriminant. Check for
9341 -- the case of a discriminant of a component that is
9342 -- constrained by an outer discriminant, which cannot
9343 -- be optimized away.
9345 if Denotes_Discriminant
9346 (Dval
, Check_Concurrent
=> True)
9350 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
9352 Denotes_Discriminant
9353 (Selector_Name
(Original_Node
(Dval
)), True)
9357 -- Do not retrieve value if constraint is not static. It
9358 -- is generally not useful, and the constraint may be a
9359 -- rewritten outer discriminant in which case it is in
9362 elsif Is_Entity_Name
(Dval
)
9364 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
9365 and then Present
(Expression
(Parent
(Entity
(Dval
))))
9367 Is_Static_Expression
9368 (Expression
(Parent
(Entity
(Dval
))))
9372 -- In the context of a case statement, the expression may
9373 -- have the base type of the discriminant, and we need to
9374 -- preserve the constraint to avoid spurious errors on
9377 elsif Nkind
(Parent
(N
)) = N_Case_Statement
9378 and then Etype
(Dval
) /= Etype
(Disc
)
9381 Make_Qualified_Expression
(Loc
,
9383 New_Occurrence_Of
(Etype
(Disc
), Loc
),
9385 New_Copy_Tree
(Dval
)));
9386 Analyze_And_Resolve
(N
, Etype
(Disc
));
9388 -- In case that comes out as a static expression,
9389 -- reset it (a selected component is never static).
9391 Set_Is_Static_Expression
(N
, False);
9394 -- Otherwise we can just copy the constraint, but the
9395 -- result is certainly not static! In some cases the
9396 -- discriminant constraint has been analyzed in the
9397 -- context of the original subtype indication, but for
9398 -- itypes the constraint might not have been analyzed
9399 -- yet, and this must be done now.
9402 Rewrite
(N
, New_Copy_Tree
(Dval
));
9403 Analyze_And_Resolve
(N
);
9404 Set_Is_Static_Expression
(N
, False);
9410 Next_Discriminant
(Disc
);
9411 end loop Discr_Loop
;
9413 -- Note: the above loop should always find a matching
9414 -- discriminant, but if it does not, we just missed an
9415 -- optimization due to some glitch (perhaps a previous
9416 -- error), so ignore.
9421 -- The only remaining processing is in the case of a discriminant of
9422 -- a concurrent object, where we rewrite the prefix to denote the
9423 -- corresponding record type. If the type is derived and has renamed
9424 -- discriminants, use corresponding discriminant, which is the one
9425 -- that appears in the corresponding record.
9427 if not Is_Concurrent_Type
(Ptyp
) then
9431 Disc
:= Entity
(Selector_Name
(N
));
9433 if Is_Derived_Type
(Ptyp
)
9434 and then Present
(Corresponding_Discriminant
(Disc
))
9436 Disc
:= Corresponding_Discriminant
(Disc
);
9440 Make_Selected_Component
(Loc
,
9442 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
9444 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
9450 -- Set Atomic_Sync_Required if necessary for atomic component
9452 if Nkind
(N
) = N_Selected_Component
then
9454 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
9458 -- If component is atomic, but type is not, setting depends on
9459 -- disable/enable state for the component.
9461 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
9462 Set
:= not Atomic_Synchronization_Disabled
(E
);
9464 -- If component is not atomic, but its type is atomic, setting
9465 -- depends on disable/enable state for the type.
9467 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9468 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
9470 -- If both component and type are atomic, we disable if either
9471 -- component or its type have sync disabled.
9473 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9474 Set
:= (not Atomic_Synchronization_Disabled
(E
))
9476 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
9482 -- Set flag if required
9485 Activate_Atomic_Synchronization
(N
);
9489 end Expand_N_Selected_Component
;
9491 --------------------
9492 -- Expand_N_Slice --
9493 --------------------
9495 procedure Expand_N_Slice
(N
: Node_Id
) is
9496 Loc
: constant Source_Ptr
:= Sloc
(N
);
9497 Typ
: constant Entity_Id
:= Etype
(N
);
9498 Pfx
: constant Node_Id
:= Prefix
(N
);
9499 Ptp
: Entity_Id
:= Etype
(Pfx
);
9501 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
9502 -- Check whether the argument is an actual for a procedure call, in
9503 -- which case the expansion of a bit-packed slice is deferred until the
9504 -- call itself is expanded. The reason this is required is that we might
9505 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9506 -- that copy out would be missed if we created a temporary here in
9507 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9508 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9509 -- is harmless to defer expansion in the IN case, since the call
9510 -- processing will still generate the appropriate copy in operation,
9511 -- which will take care of the slice.
9513 procedure Make_Temporary_For_Slice
;
9514 -- Create a named variable for the value of the slice, in cases where
9515 -- the back-end cannot handle it properly, e.g. when packed types or
9516 -- unaligned slices are involved.
9518 -------------------------
9519 -- Is_Procedure_Actual --
9520 -------------------------
9522 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
9523 Par
: Node_Id
:= Parent
(N
);
9527 -- If our parent is a procedure call we can return
9529 if Nkind
(Par
) = N_Procedure_Call_Statement
then
9532 -- If our parent is a type conversion, keep climbing the tree,
9533 -- since a type conversion can be a procedure actual. Also keep
9534 -- climbing if parameter association or a qualified expression,
9535 -- since these are additional cases that do can appear on
9536 -- procedure actuals.
9538 elsif Nkind_In
(Par
, N_Type_Conversion
,
9539 N_Parameter_Association
,
9540 N_Qualified_Expression
)
9542 Par
:= Parent
(Par
);
9544 -- Any other case is not what we are looking for
9550 end Is_Procedure_Actual
;
9552 ------------------------------
9553 -- Make_Temporary_For_Slice --
9554 ------------------------------
9556 procedure Make_Temporary_For_Slice
is
9558 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
9562 Make_Object_Declaration
(Loc
,
9563 Defining_Identifier
=> Ent
,
9564 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
9566 Set_No_Initialization
(Decl
);
9568 Insert_Actions
(N
, New_List
(
9570 Make_Assignment_Statement
(Loc
,
9571 Name
=> New_Occurrence_Of
(Ent
, Loc
),
9572 Expression
=> Relocate_Node
(N
))));
9574 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
9575 Analyze_And_Resolve
(N
, Typ
);
9576 end Make_Temporary_For_Slice
;
9578 -- Start of processing for Expand_N_Slice
9581 -- Special handling for access types
9583 if Is_Access_Type
(Ptp
) then
9585 Ptp
:= Designated_Type
(Ptp
);
9588 Make_Explicit_Dereference
(Sloc
(N
),
9589 Prefix
=> Relocate_Node
(Pfx
)));
9591 Analyze_And_Resolve
(Pfx
, Ptp
);
9594 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9595 -- function, then additional actuals must be passed.
9597 if Ada_Version
>= Ada_2005
9598 and then Is_Build_In_Place_Function_Call
(Pfx
)
9600 Make_Build_In_Place_Call_In_Anonymous_Context
(Pfx
);
9603 -- The remaining case to be handled is packed slices. We can leave
9604 -- packed slices as they are in the following situations:
9606 -- 1. Right or left side of an assignment (we can handle this
9607 -- situation correctly in the assignment statement expansion).
9609 -- 2. Prefix of indexed component (the slide is optimized away in this
9610 -- case, see the start of Expand_N_Slice.)
9612 -- 3. Object renaming declaration, since we want the name of the
9613 -- slice, not the value.
9615 -- 4. Argument to procedure call, since copy-in/copy-out handling may
9616 -- be required, and this is handled in the expansion of call
9619 -- 5. Prefix of an address attribute (this is an error which is caught
9620 -- elsewhere, and the expansion would interfere with generating the
9623 if not Is_Packed
(Typ
) then
9625 -- Apply transformation for actuals of a function call, where
9626 -- Expand_Actuals is not used.
9628 if Nkind
(Parent
(N
)) = N_Function_Call
9629 and then Is_Possibly_Unaligned_Slice
(N
)
9631 Make_Temporary_For_Slice
;
9634 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
9635 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9636 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
9640 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
9641 or else Is_Renamed_Object
(N
)
9642 or else Is_Procedure_Actual
(N
)
9646 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
9647 and then Attribute_Name
(Parent
(N
)) = Name_Address
9652 Make_Temporary_For_Slice
;
9656 ------------------------------
9657 -- Expand_N_Type_Conversion --
9658 ------------------------------
9660 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
9661 Loc
: constant Source_Ptr
:= Sloc
(N
);
9662 Operand
: constant Node_Id
:= Expression
(N
);
9663 Target_Type
: constant Entity_Id
:= Etype
(N
);
9664 Operand_Type
: Entity_Id
:= Etype
(Operand
);
9666 procedure Handle_Changed_Representation
;
9667 -- This is called in the case of record and array type conversions to
9668 -- see if there is a change of representation to be handled. Change of
9669 -- representation is actually handled at the assignment statement level,
9670 -- and what this procedure does is rewrite node N conversion as an
9671 -- assignment to temporary. If there is no change of representation,
9672 -- then the conversion node is unchanged.
9674 procedure Raise_Accessibility_Error
;
9675 -- Called when we know that an accessibility check will fail. Rewrites
9676 -- node N to an appropriate raise statement and outputs warning msgs.
9677 -- The Etype of the raise node is set to Target_Type.
9679 procedure Real_Range_Check
;
9680 -- Handles generation of range check for real target value
9682 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
9683 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
9684 -- evaluates to True.
9686 -----------------------------------
9687 -- Handle_Changed_Representation --
9688 -----------------------------------
9690 procedure Handle_Changed_Representation
is
9699 -- Nothing else to do if no change of representation
9701 if Same_Representation
(Operand_Type
, Target_Type
) then
9704 -- The real change of representation work is done by the assignment
9705 -- statement processing. So if this type conversion is appearing as
9706 -- the expression of an assignment statement, nothing needs to be
9707 -- done to the conversion.
9709 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9712 -- Otherwise we need to generate a temporary variable, and do the
9713 -- change of representation assignment into that temporary variable.
9714 -- The conversion is then replaced by a reference to this variable.
9719 -- If type is unconstrained we have to add a constraint, copied
9720 -- from the actual value of the left hand side.
9722 if not Is_Constrained
(Target_Type
) then
9723 if Has_Discriminants
(Operand_Type
) then
9724 Disc
:= First_Discriminant
(Operand_Type
);
9726 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
9727 Disc
:= First_Stored_Discriminant
(Operand_Type
);
9731 while Present
(Disc
) loop
9733 Make_Selected_Component
(Loc
,
9735 Duplicate_Subexpr_Move_Checks
(Operand
),
9737 Make_Identifier
(Loc
, Chars
(Disc
))));
9738 Next_Discriminant
(Disc
);
9741 elsif Is_Array_Type
(Operand_Type
) then
9742 N_Ix
:= First_Index
(Target_Type
);
9745 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
9747 -- We convert the bounds explicitly. We use an unchecked
9748 -- conversion because bounds checks are done elsewhere.
9753 Unchecked_Convert_To
(Etype
(N_Ix
),
9754 Make_Attribute_Reference
(Loc
,
9756 Duplicate_Subexpr_No_Checks
9757 (Operand
, Name_Req
=> True),
9758 Attribute_Name
=> Name_First
,
9759 Expressions
=> New_List
(
9760 Make_Integer_Literal
(Loc
, J
)))),
9763 Unchecked_Convert_To
(Etype
(N_Ix
),
9764 Make_Attribute_Reference
(Loc
,
9766 Duplicate_Subexpr_No_Checks
9767 (Operand
, Name_Req
=> True),
9768 Attribute_Name
=> Name_Last
,
9769 Expressions
=> New_List
(
9770 Make_Integer_Literal
(Loc
, J
))))));
9777 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
9779 if Present
(Cons
) then
9781 Make_Subtype_Indication
(Loc
,
9782 Subtype_Mark
=> Odef
,
9784 Make_Index_Or_Discriminant_Constraint
(Loc
,
9785 Constraints
=> Cons
));
9788 Temp
:= Make_Temporary
(Loc
, 'C');
9790 Make_Object_Declaration
(Loc
,
9791 Defining_Identifier
=> Temp
,
9792 Object_Definition
=> Odef
);
9794 Set_No_Initialization
(Decl
, True);
9796 -- Insert required actions. It is essential to suppress checks
9797 -- since we have suppressed default initialization, which means
9798 -- that the variable we create may have no discriminants.
9803 Make_Assignment_Statement
(Loc
,
9804 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9805 Expression
=> Relocate_Node
(N
))),
9806 Suppress
=> All_Checks
);
9808 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9811 end Handle_Changed_Representation
;
9813 -------------------------------
9814 -- Raise_Accessibility_Error --
9815 -------------------------------
9817 procedure Raise_Accessibility_Error
is
9820 Make_Raise_Program_Error
(Sloc
(N
),
9821 Reason
=> PE_Accessibility_Check_Failed
));
9822 Set_Etype
(N
, Target_Type
);
9825 ("??accessibility check failure", N
);
9827 ("\??& will be raised at run time", N
, Standard_Program_Error
);
9828 end Raise_Accessibility_Error
;
9830 ----------------------
9831 -- Real_Range_Check --
9832 ----------------------
9834 -- Case of conversions to floating-point or fixed-point. If range checks
9835 -- are enabled and the target type has a range constraint, we convert:
9841 -- Tnn : typ'Base := typ'Base (x);
9842 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
9845 -- This is necessary when there is a conversion of integer to float or
9846 -- to fixed-point to ensure that the correct checks are made. It is not
9847 -- necessary for float to float where it is enough to simply set the
9848 -- Do_Range_Check flag.
9850 procedure Real_Range_Check
is
9851 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
9852 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
9853 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
9854 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
9859 -- Nothing to do if conversion was rewritten
9861 if Nkind
(N
) /= N_Type_Conversion
then
9865 -- Nothing to do if range checks suppressed, or target has the same
9866 -- range as the base type (or is the base type).
9868 if Range_Checks_Suppressed
(Target_Type
)
9869 or else (Lo
= Type_Low_Bound
(Btyp
)
9871 Hi
= Type_High_Bound
(Btyp
))
9876 -- Nothing to do if expression is an entity on which checks have been
9879 if Is_Entity_Name
(Operand
)
9880 and then Range_Checks_Suppressed
(Entity
(Operand
))
9885 -- Nothing to do if bounds are all static and we can tell that the
9886 -- expression is within the bounds of the target. Note that if the
9887 -- operand is of an unconstrained floating-point type, then we do
9888 -- not trust it to be in range (might be infinite)
9891 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
9892 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
9895 if (not Is_Floating_Point_Type
(Xtyp
)
9896 or else Is_Constrained
(Xtyp
))
9897 and then Compile_Time_Known_Value
(S_Lo
)
9898 and then Compile_Time_Known_Value
(S_Hi
)
9899 and then Compile_Time_Known_Value
(Hi
)
9900 and then Compile_Time_Known_Value
(Lo
)
9903 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
9904 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
9909 if Is_Real_Type
(Xtyp
) then
9910 S_Lov
:= Expr_Value_R
(S_Lo
);
9911 S_Hiv
:= Expr_Value_R
(S_Hi
);
9913 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
9914 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
9918 and then S_Lov
>= D_Lov
9919 and then S_Hiv
<= D_Hiv
9921 Set_Do_Range_Check
(Operand
, False);
9928 -- For float to float conversions, we are done
9930 if Is_Floating_Point_Type
(Xtyp
)
9932 Is_Floating_Point_Type
(Btyp
)
9937 -- Otherwise rewrite the conversion as described above
9939 Conv
:= Relocate_Node
(N
);
9940 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
9941 Set_Etype
(Conv
, Btyp
);
9943 -- Enable overflow except for case of integer to float conversions,
9944 -- where it is never required, since we can never have overflow in
9947 if not Is_Integer_Type
(Etype
(Operand
)) then
9948 Enable_Overflow_Check
(Conv
);
9951 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
9953 Insert_Actions
(N
, New_List
(
9954 Make_Object_Declaration
(Loc
,
9955 Defining_Identifier
=> Tnn
,
9956 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
9957 Constant_Present
=> True,
9958 Expression
=> Conv
),
9960 Make_Raise_Constraint_Error
(Loc
,
9965 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9967 Make_Attribute_Reference
(Loc
,
9968 Attribute_Name
=> Name_First
,
9970 New_Occurrence_Of
(Target_Type
, Loc
))),
9974 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9976 Make_Attribute_Reference
(Loc
,
9977 Attribute_Name
=> Name_Last
,
9979 New_Occurrence_Of
(Target_Type
, Loc
)))),
9980 Reason
=> CE_Range_Check_Failed
)));
9982 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
9983 Analyze_And_Resolve
(N
, Btyp
);
9984 end Real_Range_Check
;
9986 -----------------------------
9987 -- Has_Extra_Accessibility --
9988 -----------------------------
9990 -- Returns true for a formal of an anonymous access type or for
9991 -- an Ada 2012-style stand-alone object of an anonymous access type.
9993 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
9995 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
9996 return Present
(Effective_Extra_Accessibility
(Id
));
10000 end Has_Extra_Accessibility
;
10002 -- Start of processing for Expand_N_Type_Conversion
10005 -- First remove check marks put by the semantic analysis on the type
10006 -- conversion between array types. We need these checks, and they will
10007 -- be generated by this expansion routine, but we do not depend on these
10008 -- flags being set, and since we do intend to expand the checks in the
10009 -- front end, we don't want them on the tree passed to the back end.
10011 if Is_Array_Type
(Target_Type
) then
10012 if Is_Constrained
(Target_Type
) then
10013 Set_Do_Length_Check
(N
, False);
10015 Set_Do_Range_Check
(Operand
, False);
10019 -- Nothing at all to do if conversion is to the identical type so remove
10020 -- the conversion completely, it is useless, except that it may carry
10021 -- an Assignment_OK attribute, which must be propagated to the operand.
10023 if Operand_Type
= Target_Type
then
10024 if Assignment_OK
(N
) then
10025 Set_Assignment_OK
(Operand
);
10028 Rewrite
(N
, Relocate_Node
(Operand
));
10032 -- Nothing to do if this is the second argument of read. This is a
10033 -- "backwards" conversion that will be handled by the specialized code
10034 -- in attribute processing.
10036 if Nkind
(Parent
(N
)) = N_Attribute_Reference
10037 and then Attribute_Name
(Parent
(N
)) = Name_Read
10038 and then Next
(First
(Expressions
(Parent
(N
)))) = N
10043 -- Check for case of converting to a type that has an invariant
10044 -- associated with it. This required an invariant check. We convert
10050 -- do invariant_check (typ (expr)) in typ (expr);
10052 -- using Duplicate_Subexpr to avoid multiple side effects
10054 -- Note: the Comes_From_Source check, and then the resetting of this
10055 -- flag prevents what would otherwise be an infinite recursion.
10057 if Has_Invariants
(Target_Type
)
10058 and then Present
(Invariant_Procedure
(Target_Type
))
10059 and then Comes_From_Source
(N
)
10061 Set_Comes_From_Source
(N
, False);
10063 Make_Expression_With_Actions
(Loc
,
10064 Actions
=> New_List
(
10065 Make_Invariant_Call
(Duplicate_Subexpr
(N
))),
10066 Expression
=> Duplicate_Subexpr_No_Checks
(N
)));
10067 Analyze_And_Resolve
(N
, Target_Type
);
10071 -- Here if we may need to expand conversion
10073 -- If the operand of the type conversion is an arithmetic operation on
10074 -- signed integers, and the based type of the signed integer type in
10075 -- question is smaller than Standard.Integer, we promote both of the
10076 -- operands to type Integer.
10078 -- For example, if we have
10080 -- target-type (opnd1 + opnd2)
10082 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10085 -- target-type (integer(opnd1) + integer(opnd2))
10087 -- We do this because we are always allowed to compute in a larger type
10088 -- if we do the right thing with the result, and in this case we are
10089 -- going to do a conversion which will do an appropriate check to make
10090 -- sure that things are in range of the target type in any case. This
10091 -- avoids some unnecessary intermediate overflows.
10093 -- We might consider a similar transformation in the case where the
10094 -- target is a real type or a 64-bit integer type, and the operand
10095 -- is an arithmetic operation using a 32-bit integer type. However,
10096 -- we do not bother with this case, because it could cause significant
10097 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10098 -- much cheaper, but we don't want different behavior on 32-bit and
10099 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10100 -- handles the configurable run-time cases where 64-bit arithmetic
10101 -- may simply be unavailable.
10103 -- Note: this circuit is partially redundant with respect to the circuit
10104 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10105 -- the processing here. Also we still need the Checks circuit, since we
10106 -- have to be sure not to generate junk overflow checks in the first
10107 -- place, since it would be trick to remove them here!
10109 if Integer_Promotion_Possible
(N
) then
10111 -- All conditions met, go ahead with transformation
10119 Make_Type_Conversion
(Loc
,
10120 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
10121 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
10123 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
10124 Set_Right_Opnd
(Opnd
, R
);
10126 if Nkind
(Operand
) in N_Binary_Op
then
10128 Make_Type_Conversion
(Loc
,
10129 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
10130 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
10132 Set_Left_Opnd
(Opnd
, L
);
10136 Make_Type_Conversion
(Loc
,
10137 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
10138 Expression
=> Opnd
));
10140 Analyze_And_Resolve
(N
, Target_Type
);
10145 -- Do validity check if validity checking operands
10147 if Validity_Checks_On
and Validity_Check_Operands
then
10148 Ensure_Valid
(Operand
);
10151 -- Special case of converting from non-standard boolean type
10153 if Is_Boolean_Type
(Operand_Type
)
10154 and then (Nonzero_Is_True
(Operand_Type
))
10156 Adjust_Condition
(Operand
);
10157 Set_Etype
(Operand
, Standard_Boolean
);
10158 Operand_Type
:= Standard_Boolean
;
10161 -- Case of converting to an access type
10163 if Is_Access_Type
(Target_Type
) then
10165 -- Apply an accessibility check when the conversion operand is an
10166 -- access parameter (or a renaming thereof), unless conversion was
10167 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10168 -- Note that other checks may still need to be applied below (such
10169 -- as tagged type checks).
10171 if Is_Entity_Name
(Operand
)
10172 and then Has_Extra_Accessibility
(Entity
(Operand
))
10173 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
10174 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
10175 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
10177 Apply_Accessibility_Check
10178 (Operand
, Target_Type
, Insert_Node
=> Operand
);
10180 -- If the level of the operand type is statically deeper than the
10181 -- level of the target type, then force Program_Error. Note that this
10182 -- can only occur for cases where the attribute is within the body of
10183 -- an instantiation (otherwise the conversion will already have been
10184 -- rejected as illegal). Note: warnings are issued by the analyzer
10185 -- for the instance cases.
10187 elsif In_Instance_Body
10188 and then Type_Access_Level
(Operand_Type
) >
10189 Type_Access_Level
(Target_Type
)
10191 Raise_Accessibility_Error
;
10193 -- When the operand is a selected access discriminant the check needs
10194 -- to be made against the level of the object denoted by the prefix
10195 -- of the selected name. Force Program_Error for this case as well
10196 -- (this accessibility violation can only happen if within the body
10197 -- of an instantiation).
10199 elsif In_Instance_Body
10200 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
10201 and then Nkind
(Operand
) = N_Selected_Component
10202 and then Object_Access_Level
(Operand
) >
10203 Type_Access_Level
(Target_Type
)
10205 Raise_Accessibility_Error
;
10210 -- Case of conversions of tagged types and access to tagged types
10212 -- When needed, that is to say when the expression is class-wide, Add
10213 -- runtime a tag check for (strict) downward conversion by using the
10214 -- membership test, generating:
10216 -- [constraint_error when Operand not in Target_Type'Class]
10218 -- or in the access type case
10220 -- [constraint_error
10221 -- when Operand /= null
10222 -- and then Operand.all not in
10223 -- Designated_Type (Target_Type)'Class]
10225 if (Is_Access_Type
(Target_Type
)
10226 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
10227 or else Is_Tagged_Type
(Target_Type
)
10229 -- Do not do any expansion in the access type case if the parent is a
10230 -- renaming, since this is an error situation which will be caught by
10231 -- Sem_Ch8, and the expansion can interfere with this error check.
10233 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
10237 -- Otherwise, proceed with processing tagged conversion
10239 Tagged_Conversion
: declare
10240 Actual_Op_Typ
: Entity_Id
;
10241 Actual_Targ_Typ
: Entity_Id
;
10242 Make_Conversion
: Boolean := False;
10243 Root_Op_Typ
: Entity_Id
;
10245 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
10246 -- Create a membership check to test whether Operand is a member
10247 -- of Targ_Typ. If the original Target_Type is an access, include
10248 -- a test for null value. The check is inserted at N.
10250 --------------------
10251 -- Make_Tag_Check --
10252 --------------------
10254 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
10259 -- [Constraint_Error
10260 -- when Operand /= null
10261 -- and then Operand.all not in Targ_Typ]
10263 if Is_Access_Type
(Target_Type
) then
10265 Make_And_Then
(Loc
,
10268 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10269 Right_Opnd
=> Make_Null
(Loc
)),
10274 Make_Explicit_Dereference
(Loc
,
10275 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
10276 Right_Opnd
=> New_Reference_To
(Targ_Typ
, Loc
)));
10279 -- [Constraint_Error when Operand not in Targ_Typ]
10284 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10285 Right_Opnd
=> New_Reference_To
(Targ_Typ
, Loc
));
10289 Make_Raise_Constraint_Error
(Loc
,
10291 Reason
=> CE_Tag_Check_Failed
));
10292 end Make_Tag_Check
;
10294 -- Start of processing for Tagged_Conversion
10297 -- Handle entities from the limited view
10299 if Is_Access_Type
(Operand_Type
) then
10301 Available_View
(Designated_Type
(Operand_Type
));
10303 Actual_Op_Typ
:= Operand_Type
;
10306 if Is_Access_Type
(Target_Type
) then
10308 Available_View
(Designated_Type
(Target_Type
));
10310 Actual_Targ_Typ
:= Target_Type
;
10313 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
10315 -- Ada 2005 (AI-251): Handle interface type conversion
10317 if Is_Interface
(Actual_Op_Typ
) then
10318 Expand_Interface_Conversion
(N
);
10322 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
10324 -- Create a runtime tag check for a downward class-wide type
10327 if Is_Class_Wide_Type
(Actual_Op_Typ
)
10328 and then Actual_Op_Typ
/= Actual_Targ_Typ
10329 and then Root_Op_Typ
/= Actual_Targ_Typ
10330 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
10331 Use_Full_View
=> True)
10333 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
10334 Make_Conversion
:= True;
10337 -- AI05-0073: If the result subtype of the function is defined
10338 -- by an access_definition designating a specific tagged type
10339 -- T, a check is made that the result value is null or the tag
10340 -- of the object designated by the result value identifies T.
10341 -- Constraint_Error is raised if this check fails.
10343 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
10346 Func_Typ
: Entity_Id
;
10349 -- Climb scope stack looking for the enclosing function
10351 Func
:= Current_Scope
;
10352 while Present
(Func
)
10353 and then Ekind
(Func
) /= E_Function
10355 Func
:= Scope
(Func
);
10358 -- The function's return subtype must be defined using
10359 -- an access definition.
10361 if Nkind
(Result_Definition
(Parent
(Func
))) =
10362 N_Access_Definition
10364 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
10366 -- The return subtype denotes a specific tagged type,
10367 -- in other words, a non class-wide type.
10369 if Is_Tagged_Type
(Func_Typ
)
10370 and then not Is_Class_Wide_Type
(Func_Typ
)
10372 Make_Tag_Check
(Actual_Targ_Typ
);
10373 Make_Conversion
:= True;
10379 -- We have generated a tag check for either a class-wide type
10380 -- conversion or for AI05-0073.
10382 if Make_Conversion
then
10387 Make_Unchecked_Type_Conversion
(Loc
,
10388 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
10389 Expression
=> Relocate_Node
(Expression
(N
)));
10391 Analyze_And_Resolve
(N
, Target_Type
);
10395 end Tagged_Conversion
;
10397 -- Case of other access type conversions
10399 elsif Is_Access_Type
(Target_Type
) then
10400 Apply_Constraint_Check
(Operand
, Target_Type
);
10402 -- Case of conversions from a fixed-point type
10404 -- These conversions require special expansion and processing, found in
10405 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10406 -- since from a semantic point of view, these are simple integer
10407 -- conversions, which do not need further processing.
10409 elsif Is_Fixed_Point_Type
(Operand_Type
)
10410 and then not Conversion_OK
(N
)
10412 -- We should never see universal fixed at this case, since the
10413 -- expansion of the constituent divide or multiply should have
10414 -- eliminated the explicit mention of universal fixed.
10416 pragma Assert
(Operand_Type
/= Universal_Fixed
);
10418 -- Check for special case of the conversion to universal real that
10419 -- occurs as a result of the use of a round attribute. In this case,
10420 -- the real type for the conversion is taken from the target type of
10421 -- the Round attribute and the result must be marked as rounded.
10423 if Target_Type
= Universal_Real
10424 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
10425 and then Attribute_Name
(Parent
(N
)) = Name_Round
10427 Set_Rounded_Result
(N
);
10428 Set_Etype
(N
, Etype
(Parent
(N
)));
10431 -- Otherwise do correct fixed-conversion, but skip these if the
10432 -- Conversion_OK flag is set, because from a semantic point of view
10433 -- these are simple integer conversions needing no further processing
10434 -- (the backend will simply treat them as integers).
10436 if not Conversion_OK
(N
) then
10437 if Is_Fixed_Point_Type
(Etype
(N
)) then
10438 Expand_Convert_Fixed_To_Fixed
(N
);
10441 elsif Is_Integer_Type
(Etype
(N
)) then
10442 Expand_Convert_Fixed_To_Integer
(N
);
10445 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
10446 Expand_Convert_Fixed_To_Float
(N
);
10451 -- Case of conversions to a fixed-point type
10453 -- These conversions require special expansion and processing, found in
10454 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10455 -- since from a semantic point of view, these are simple integer
10456 -- conversions, which do not need further processing.
10458 elsif Is_Fixed_Point_Type
(Target_Type
)
10459 and then not Conversion_OK
(N
)
10461 if Is_Integer_Type
(Operand_Type
) then
10462 Expand_Convert_Integer_To_Fixed
(N
);
10465 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
10466 Expand_Convert_Float_To_Fixed
(N
);
10470 -- Case of float-to-integer conversions
10472 -- We also handle float-to-fixed conversions with Conversion_OK set
10473 -- since semantically the fixed-point target is treated as though it
10474 -- were an integer in such cases.
10476 elsif Is_Floating_Point_Type
(Operand_Type
)
10478 (Is_Integer_Type
(Target_Type
)
10480 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
10482 -- One more check here, gcc is still not able to do conversions of
10483 -- this type with proper overflow checking, and so gigi is doing an
10484 -- approximation of what is required by doing floating-point compares
10485 -- with the end-point. But that can lose precision in some cases, and
10486 -- give a wrong result. Converting the operand to Universal_Real is
10487 -- helpful, but still does not catch all cases with 64-bit integers
10488 -- on targets with only 64-bit floats.
10490 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10491 -- Can this code be removed ???
10493 if Do_Range_Check
(Operand
) then
10495 Make_Type_Conversion
(Loc
,
10497 New_Occurrence_Of
(Universal_Real
, Loc
),
10499 Relocate_Node
(Operand
)));
10501 Set_Etype
(Operand
, Universal_Real
);
10502 Enable_Range_Check
(Operand
);
10503 Set_Do_Range_Check
(Expression
(Operand
), False);
10506 -- Case of array conversions
10508 -- Expansion of array conversions, add required length/range checks but
10509 -- only do this if there is no change of representation. For handling of
10510 -- this case, see Handle_Changed_Representation.
10512 elsif Is_Array_Type
(Target_Type
) then
10513 if Is_Constrained
(Target_Type
) then
10514 Apply_Length_Check
(Operand
, Target_Type
);
10516 Apply_Range_Check
(Operand
, Target_Type
);
10519 Handle_Changed_Representation
;
10521 -- Case of conversions of discriminated types
10523 -- Add required discriminant checks if target is constrained. Again this
10524 -- change is skipped if we have a change of representation.
10526 elsif Has_Discriminants
(Target_Type
)
10527 and then Is_Constrained
(Target_Type
)
10529 Apply_Discriminant_Check
(Operand
, Target_Type
);
10530 Handle_Changed_Representation
;
10532 -- Case of all other record conversions. The only processing required
10533 -- is to check for a change of representation requiring the special
10534 -- assignment processing.
10536 elsif Is_Record_Type
(Target_Type
) then
10538 -- Ada 2005 (AI-216): Program_Error is raised when converting from
10539 -- a derived Unchecked_Union type to an unconstrained type that is
10540 -- not Unchecked_Union if the operand lacks inferable discriminants.
10542 if Is_Derived_Type
(Operand_Type
)
10543 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
10544 and then not Is_Constrained
(Target_Type
)
10545 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
10546 and then not Has_Inferable_Discriminants
(Operand
)
10548 -- To prevent Gigi from generating illegal code, we generate a
10549 -- Program_Error node, but we give it the target type of the
10550 -- conversion (is this requirement documented somewhere ???)
10553 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
10554 Reason
=> PE_Unchecked_Union_Restriction
);
10557 Set_Etype
(PE
, Target_Type
);
10562 Handle_Changed_Representation
;
10565 -- Case of conversions of enumeration types
10567 elsif Is_Enumeration_Type
(Target_Type
) then
10569 -- Special processing is required if there is a change of
10570 -- representation (from enumeration representation clauses).
10572 if not Same_Representation
(Target_Type
, Operand_Type
) then
10574 -- Convert: x(y) to x'val (ytyp'val (y))
10577 Make_Attribute_Reference
(Loc
,
10578 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
10579 Attribute_Name
=> Name_Val
,
10580 Expressions
=> New_List
(
10581 Make_Attribute_Reference
(Loc
,
10582 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
10583 Attribute_Name
=> Name_Pos
,
10584 Expressions
=> New_List
(Operand
)))));
10586 Analyze_And_Resolve
(N
, Target_Type
);
10589 -- Case of conversions to floating-point
10591 elsif Is_Floating_Point_Type
(Target_Type
) then
10595 -- At this stage, either the conversion node has been transformed into
10596 -- some other equivalent expression, or left as a conversion that can be
10597 -- handled by Gigi, in the following cases:
10599 -- Conversions with no change of representation or type
10601 -- Numeric conversions involving integer, floating- and fixed-point
10602 -- values. Fixed-point values are allowed only if Conversion_OK is
10603 -- set, i.e. if the fixed-point values are to be treated as integers.
10605 -- No other conversions should be passed to Gigi
10607 -- Check: are these rules stated in sinfo??? if so, why restate here???
10609 -- The only remaining step is to generate a range check if we still have
10610 -- a type conversion at this stage and Do_Range_Check is set. For now we
10611 -- do this only for conversions of discrete types.
10613 if Nkind
(N
) = N_Type_Conversion
10614 and then Is_Discrete_Type
(Etype
(N
))
10617 Expr
: constant Node_Id
:= Expression
(N
);
10622 if Do_Range_Check
(Expr
)
10623 and then Is_Discrete_Type
(Etype
(Expr
))
10625 Set_Do_Range_Check
(Expr
, False);
10627 -- Before we do a range check, we have to deal with treating a
10628 -- fixed-point operand as an integer. The way we do this is
10629 -- simply to do an unchecked conversion to an appropriate
10630 -- integer type large enough to hold the result.
10632 -- This code is not active yet, because we are only dealing
10633 -- with discrete types so far ???
10635 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
10636 and then Treat_Fixed_As_Integer
(Expr
)
10638 Ftyp
:= Base_Type
(Etype
(Expr
));
10640 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
10641 Ityp
:= Standard_Long_Long_Integer
;
10643 Ityp
:= Standard_Integer
;
10646 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
10649 -- Reset overflow flag, since the range check will include
10650 -- dealing with possible overflow, and generate the check. If
10651 -- Address is either a source type or target type, suppress
10652 -- range check to avoid typing anomalies when it is a visible
10655 Set_Do_Overflow_Check
(N
, False);
10656 if not Is_Descendent_Of_Address
(Etype
(Expr
))
10657 and then not Is_Descendent_Of_Address
(Target_Type
)
10659 Generate_Range_Check
10660 (Expr
, Target_Type
, CE_Range_Check_Failed
);
10666 -- Final step, if the result is a type conversion involving Vax_Float
10667 -- types, then it is subject for further special processing.
10669 if Nkind
(N
) = N_Type_Conversion
10670 and then (Vax_Float
(Operand_Type
) or else Vax_Float
(Target_Type
))
10672 Expand_Vax_Conversion
(N
);
10676 -- Here at end of processing
10679 -- Apply predicate check if required. Note that we can't just call
10680 -- Apply_Predicate_Check here, because the type looks right after
10681 -- the conversion and it would omit the check. The Comes_From_Source
10682 -- guard is necessary to prevent infinite recursions when we generate
10683 -- internal conversions for the purpose of checking predicates.
10685 if Present
(Predicate_Function
(Target_Type
))
10686 and then Target_Type
/= Operand_Type
10687 and then Comes_From_Source
(N
)
10690 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
10693 -- Avoid infinite recursion on the subsequent expansion of
10694 -- of the copy of the original type conversion.
10696 Set_Comes_From_Source
(New_Expr
, False);
10697 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
10700 end Expand_N_Type_Conversion
;
10702 -----------------------------------
10703 -- Expand_N_Unchecked_Expression --
10704 -----------------------------------
10706 -- Remove the unchecked expression node from the tree. Its job was simply
10707 -- to make sure that its constituent expression was handled with checks
10708 -- off, and now that that is done, we can remove it from the tree, and
10709 -- indeed must, since Gigi does not expect to see these nodes.
10711 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
10712 Exp
: constant Node_Id
:= Expression
(N
);
10714 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
10716 end Expand_N_Unchecked_Expression
;
10718 ----------------------------------------
10719 -- Expand_N_Unchecked_Type_Conversion --
10720 ----------------------------------------
10722 -- If this cannot be handled by Gigi and we haven't already made a
10723 -- temporary for it, do it now.
10725 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
10726 Target_Type
: constant Entity_Id
:= Etype
(N
);
10727 Operand
: constant Node_Id
:= Expression
(N
);
10728 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
10731 -- Nothing at all to do if conversion is to the identical type so remove
10732 -- the conversion completely, it is useless, except that it may carry
10733 -- an Assignment_OK indication which must be propagated to the operand.
10735 if Operand_Type
= Target_Type
then
10737 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
10739 if Assignment_OK
(N
) then
10740 Set_Assignment_OK
(Operand
);
10743 Rewrite
(N
, Relocate_Node
(Operand
));
10747 -- If we have a conversion of a compile time known value to a target
10748 -- type and the value is in range of the target type, then we can simply
10749 -- replace the construct by an integer literal of the correct type. We
10750 -- only apply this to integer types being converted. Possibly it may
10751 -- apply in other cases, but it is too much trouble to worry about.
10753 -- Note that we do not do this transformation if the Kill_Range_Check
10754 -- flag is set, since then the value may be outside the expected range.
10755 -- This happens in the Normalize_Scalars case.
10757 -- We also skip this if either the target or operand type is biased
10758 -- because in this case, the unchecked conversion is supposed to
10759 -- preserve the bit pattern, not the integer value.
10761 if Is_Integer_Type
(Target_Type
)
10762 and then not Has_Biased_Representation
(Target_Type
)
10763 and then Is_Integer_Type
(Operand_Type
)
10764 and then not Has_Biased_Representation
(Operand_Type
)
10765 and then Compile_Time_Known_Value
(Operand
)
10766 and then not Kill_Range_Check
(N
)
10769 Val
: constant Uint
:= Expr_Value
(Operand
);
10772 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
10774 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
10776 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
10778 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
10780 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
10782 -- If Address is the target type, just set the type to avoid a
10783 -- spurious type error on the literal when Address is a visible
10786 if Is_Descendent_Of_Address
(Target_Type
) then
10787 Set_Etype
(N
, Target_Type
);
10789 Analyze_And_Resolve
(N
, Target_Type
);
10797 -- Nothing to do if conversion is safe
10799 if Safe_Unchecked_Type_Conversion
(N
) then
10803 -- Otherwise force evaluation unless Assignment_OK flag is set (this
10804 -- flag indicates ??? More comments needed here)
10806 if Assignment_OK
(N
) then
10809 Force_Evaluation
(N
);
10811 end Expand_N_Unchecked_Type_Conversion
;
10813 ----------------------------
10814 -- Expand_Record_Equality --
10815 ----------------------------
10817 -- For non-variant records, Equality is expanded when needed into:
10819 -- and then Lhs.Discr1 = Rhs.Discr1
10821 -- and then Lhs.Discrn = Rhs.Discrn
10822 -- and then Lhs.Cmp1 = Rhs.Cmp1
10824 -- and then Lhs.Cmpn = Rhs.Cmpn
10826 -- The expression is folded by the back-end for adjacent fields. This
10827 -- function is called for tagged record in only one occasion: for imple-
10828 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
10829 -- otherwise the primitive "=" is used directly.
10831 function Expand_Record_Equality
10836 Bodies
: List_Id
) return Node_Id
10838 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
10843 First_Time
: Boolean := True;
10845 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
10846 -- Return the next discriminant or component to compare, starting with
10847 -- C, skipping inherited components.
10849 ------------------------
10850 -- Element_To_Compare --
10851 ------------------------
10853 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
10859 -- Exit loop when the next element to be compared is found, or
10860 -- there is no more such element.
10862 exit when No
(Comp
);
10864 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
10867 -- Skip inherited components
10869 -- Note: for a tagged type, we always generate the "=" primitive
10870 -- for the base type (not on the first subtype), so the test for
10871 -- Comp /= Original_Record_Component (Comp) is True for
10872 -- inherited components only.
10874 (Is_Tagged_Type
(Typ
)
10875 and then Comp
/= Original_Record_Component
(Comp
))
10879 or else Chars
(Comp
) = Name_uTag
10881 -- The .NET/JVM version of type Root_Controlled contains two
10882 -- fields which should not be considered part of the object. To
10883 -- achieve proper equiality between two controlled objects on
10884 -- .NET/JVM, skip _Parent whenever it has type Root_Controlled.
10886 or else (Chars
(Comp
) = Name_uParent
10887 and then VM_Target
/= No_VM
10888 and then Etype
(Comp
) = RTE
(RE_Root_Controlled
))
10890 -- Skip interface elements (secondary tags???)
10892 or else Is_Interface
(Etype
(Comp
)));
10894 Next_Entity
(Comp
);
10898 end Element_To_Compare
;
10900 -- Start of processing for Expand_Record_Equality
10903 -- Generates the following code: (assuming that Typ has one Discr and
10904 -- component C2 is also a record)
10907 -- and then Lhs.Discr1 = Rhs.Discr1
10908 -- and then Lhs.C1 = Rhs.C1
10909 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
10911 -- and then Lhs.Cmpn = Rhs.Cmpn
10913 Result
:= New_Reference_To
(Standard_True
, Loc
);
10914 C
:= Element_To_Compare
(First_Entity
(Typ
));
10915 while Present
(C
) loop
10923 First_Time
:= False;
10927 New_Lhs
:= New_Copy_Tree
(Lhs
);
10928 New_Rhs
:= New_Copy_Tree
(Rhs
);
10932 Expand_Composite_Equality
(Nod
, Etype
(C
),
10934 Make_Selected_Component
(Loc
,
10936 Selector_Name
=> New_Reference_To
(C
, Loc
)),
10938 Make_Selected_Component
(Loc
,
10940 Selector_Name
=> New_Reference_To
(C
, Loc
)),
10943 -- If some (sub)component is an unchecked_union, the whole
10944 -- operation will raise program error.
10946 if Nkind
(Check
) = N_Raise_Program_Error
then
10948 Set_Etype
(Result
, Standard_Boolean
);
10952 Make_And_Then
(Loc
,
10953 Left_Opnd
=> Result
,
10954 Right_Opnd
=> Check
);
10958 C
:= Element_To_Compare
(Next_Entity
(C
));
10962 end Expand_Record_Equality
;
10964 ---------------------------
10965 -- Expand_Set_Membership --
10966 ---------------------------
10968 procedure Expand_Set_Membership
(N
: Node_Id
) is
10969 Lop
: constant Node_Id
:= Left_Opnd
(N
);
10973 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
10974 -- If the alternative is a subtype mark, create a simple membership
10975 -- test. Otherwise create an equality test for it.
10981 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
10983 L
: constant Node_Id
:= New_Copy
(Lop
);
10984 R
: constant Node_Id
:= Relocate_Node
(Alt
);
10987 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
10988 or else Nkind
(Alt
) = N_Range
10991 Make_In
(Sloc
(Alt
),
10996 Make_Op_Eq
(Sloc
(Alt
),
11004 -- Start of processing for Expand_Set_Membership
11007 Remove_Side_Effects
(Lop
);
11009 Alt
:= Last
(Alternatives
(N
));
11010 Res
:= Make_Cond
(Alt
);
11013 while Present
(Alt
) loop
11015 Make_Or_Else
(Sloc
(Alt
),
11016 Left_Opnd
=> Make_Cond
(Alt
),
11017 Right_Opnd
=> Res
);
11022 Analyze_And_Resolve
(N
, Standard_Boolean
);
11023 end Expand_Set_Membership
;
11025 -----------------------------------
11026 -- Expand_Short_Circuit_Operator --
11027 -----------------------------------
11029 -- Deal with special expansion if actions are present for the right operand
11030 -- and deal with optimizing case of arguments being True or False. We also
11031 -- deal with the special case of non-standard boolean values.
11033 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
11034 Loc
: constant Source_Ptr
:= Sloc
(N
);
11035 Typ
: constant Entity_Id
:= Etype
(N
);
11036 Left
: constant Node_Id
:= Left_Opnd
(N
);
11037 Right
: constant Node_Id
:= Right_Opnd
(N
);
11038 LocR
: constant Source_Ptr
:= Sloc
(Right
);
11041 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
11042 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
11043 -- If Left = Shortcut_Value then Right need not be evaluated
11046 -- Deal with non-standard booleans
11048 if Is_Boolean_Type
(Typ
) then
11049 Adjust_Condition
(Left
);
11050 Adjust_Condition
(Right
);
11051 Set_Etype
(N
, Standard_Boolean
);
11054 -- Check for cases where left argument is known to be True or False
11056 if Compile_Time_Known_Value
(Left
) then
11058 -- Mark SCO for left condition as compile time known
11060 if Generate_SCO
and then Comes_From_Source
(Left
) then
11061 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
11064 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11065 -- Any actions associated with Right will be executed unconditionally
11066 -- and can thus be inserted into the tree unconditionally.
11068 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
11069 if Present
(Actions
(N
)) then
11070 Insert_Actions
(N
, Actions
(N
));
11073 Rewrite
(N
, Right
);
11075 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11076 -- In this case we can forget the actions associated with Right,
11077 -- since they will never be executed.
11080 Kill_Dead_Code
(Right
);
11081 Kill_Dead_Code
(Actions
(N
));
11082 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11085 Adjust_Result_Type
(N
, Typ
);
11089 -- If Actions are present for the right operand, we have to do some
11090 -- special processing. We can't just let these actions filter back into
11091 -- code preceding the short circuit (which is what would have happened
11092 -- if we had not trapped them in the short-circuit form), since they
11093 -- must only be executed if the right operand of the short circuit is
11094 -- executed and not otherwise.
11096 if Present
(Actions
(N
)) then
11097 Actlist
:= Actions
(N
);
11099 -- We now use an Expression_With_Actions node for the right operand
11100 -- of the short-circuit form. Note that this solves the traceability
11101 -- problems for coverage analysis.
11104 Make_Expression_With_Actions
(LocR
,
11105 Expression
=> Relocate_Node
(Right
),
11106 Actions
=> Actlist
));
11107 Set_Actions
(N
, No_List
);
11108 Analyze_And_Resolve
(Right
, Standard_Boolean
);
11110 Adjust_Result_Type
(N
, Typ
);
11114 -- No actions present, check for cases of right argument True/False
11116 if Compile_Time_Known_Value
(Right
) then
11118 -- Mark SCO for left condition as compile time known
11120 if Generate_SCO
and then Comes_From_Source
(Right
) then
11121 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
11124 -- Change (Left and then True), (Left or else False) to Left.
11125 -- Note that we know there are no actions associated with the right
11126 -- operand, since we just checked for this case above.
11128 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
11131 -- Change (Left and then False), (Left or else True) to Right,
11132 -- making sure to preserve any side effects associated with the Left
11136 Remove_Side_Effects
(Left
);
11137 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11141 Adjust_Result_Type
(N
, Typ
);
11142 end Expand_Short_Circuit_Operator
;
11144 -------------------------------------
11145 -- Fixup_Universal_Fixed_Operation --
11146 -------------------------------------
11148 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
11149 Conv
: constant Node_Id
:= Parent
(N
);
11152 -- We must have a type conversion immediately above us
11154 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
11156 -- Normally the type conversion gives our target type. The exception
11157 -- occurs in the case of the Round attribute, where the conversion
11158 -- will be to universal real, and our real type comes from the Round
11159 -- attribute (as well as an indication that we must round the result)
11161 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
11162 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
11164 Set_Etype
(N
, Etype
(Parent
(Conv
)));
11165 Set_Rounded_Result
(N
);
11167 -- Normal case where type comes from conversion above us
11170 Set_Etype
(N
, Etype
(Conv
));
11172 end Fixup_Universal_Fixed_Operation
;
11174 ---------------------------------
11175 -- Has_Inferable_Discriminants --
11176 ---------------------------------
11178 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
11180 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
11181 -- Determines whether the left-most prefix of a selected component is a
11182 -- formal parameter in a subprogram. Assumes N is a selected component.
11184 --------------------------------
11185 -- Prefix_Is_Formal_Parameter --
11186 --------------------------------
11188 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
11189 Sel_Comp
: Node_Id
;
11192 -- Move to the left-most prefix by climbing up the tree
11195 while Present
(Parent
(Sel_Comp
))
11196 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
11198 Sel_Comp
:= Parent
(Sel_Comp
);
11201 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
11202 end Prefix_Is_Formal_Parameter
;
11204 -- Start of processing for Has_Inferable_Discriminants
11207 -- For selected components, the subtype of the selector must be a
11208 -- constrained Unchecked_Union. If the component is subject to a
11209 -- per-object constraint, then the enclosing object must have inferable
11212 if Nkind
(N
) = N_Selected_Component
then
11213 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
11215 -- A small hack. If we have a per-object constrained selected
11216 -- component of a formal parameter, return True since we do not
11217 -- know the actual parameter association yet.
11219 if Prefix_Is_Formal_Parameter
(N
) then
11222 -- Otherwise, check the enclosing object and the selector
11225 return Has_Inferable_Discriminants
(Prefix
(N
))
11226 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
11229 -- The call to Has_Inferable_Discriminants will determine whether
11230 -- the selector has a constrained Unchecked_Union nominal type.
11233 return Has_Inferable_Discriminants
(Selector_Name
(N
));
11236 -- A qualified expression has inferable discriminants if its subtype
11237 -- mark is a constrained Unchecked_Union subtype.
11239 elsif Nkind
(N
) = N_Qualified_Expression
then
11240 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
11241 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
11243 -- For all other names, it is sufficient to have a constrained
11244 -- Unchecked_Union nominal subtype.
11247 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
11248 and then Is_Constrained
(Etype
(N
));
11250 end Has_Inferable_Discriminants
;
11252 -------------------------------
11253 -- Insert_Dereference_Action --
11254 -------------------------------
11256 procedure Insert_Dereference_Action
(N
: Node_Id
) is
11258 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
11259 -- Return true if type of P is derived from Checked_Pool;
11261 -----------------------------
11262 -- Is_Checked_Storage_Pool --
11263 -----------------------------
11265 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
11274 while T
/= Etype
(T
) loop
11275 if Is_RTE
(T
, RE_Checked_Pool
) then
11283 end Is_Checked_Storage_Pool
;
11287 Typ
: constant Entity_Id
:= Etype
(N
);
11288 Desig
: constant Entity_Id
:= Available_View
(Designated_Type
(Typ
));
11289 Loc
: constant Source_Ptr
:= Sloc
(N
);
11290 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
11291 Pnod
: constant Node_Id
:= Parent
(N
);
11299 -- Start of processing for Insert_Dereference_Action
11302 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
11304 -- Do not re-expand a dereference which has already been processed by
11307 if Has_Dereference_Action
(Pnod
) then
11310 -- Do not perform this type of expansion for internally-generated
11313 elsif not Comes_From_Source
(Original_Node
(Pnod
)) then
11316 -- A dereference action is only applicable to objects which have been
11317 -- allocated on a checked pool.
11319 elsif not Is_Checked_Storage_Pool
(Pool
) then
11323 -- Extract the address of the dereferenced object. Generate:
11325 -- Addr : System.Address := <N>'Pool_Address;
11327 Addr
:= Make_Temporary
(Loc
, 'P');
11330 Make_Object_Declaration
(Loc
,
11331 Defining_Identifier
=> Addr
,
11332 Object_Definition
=>
11333 New_Reference_To
(RTE
(RE_Address
), Loc
),
11335 Make_Attribute_Reference
(Loc
,
11336 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
11337 Attribute_Name
=> Name_Pool_Address
)));
11339 -- Calculate the size of the dereferenced object. Generate:
11341 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11344 Make_Explicit_Dereference
(Loc
,
11345 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11346 Set_Has_Dereference_Action
(Deref
);
11348 Size
:= Make_Temporary
(Loc
, 'S');
11351 Make_Object_Declaration
(Loc
,
11352 Defining_Identifier
=> Size
,
11354 Object_Definition
=>
11355 New_Reference_To
(RTE
(RE_Storage_Count
), Loc
),
11358 Make_Op_Divide
(Loc
,
11360 Make_Attribute_Reference
(Loc
,
11362 Attribute_Name
=> Name_Size
),
11364 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
11366 -- Calculate the alignment of the dereferenced object. Generate:
11367 -- Alig : constant Storage_Count := <N>.all'Alignment;
11370 Make_Explicit_Dereference
(Loc
,
11371 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11372 Set_Has_Dereference_Action
(Deref
);
11374 Alig
:= Make_Temporary
(Loc
, 'A');
11377 Make_Object_Declaration
(Loc
,
11378 Defining_Identifier
=> Alig
,
11379 Object_Definition
=>
11380 New_Reference_To
(RTE
(RE_Storage_Count
), Loc
),
11382 Make_Attribute_Reference
(Loc
,
11384 Attribute_Name
=> Name_Alignment
)));
11386 -- A dereference of a controlled object requires special processing. The
11387 -- finalization machinery requests additional space from the underlying
11388 -- pool to allocate and hide two pointers. As a result, a checked pool
11389 -- may mark the wrong memory as valid. Since checked pools do not have
11390 -- knowledge of hidden pointers, we have to bring the two pointers back
11391 -- in view in order to restore the original state of the object.
11393 if Needs_Finalization
(Desig
) then
11395 -- Adjust the address and size of the dereferenced object. Generate:
11396 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11399 Make_Procedure_Call_Statement
(Loc
,
11401 New_Reference_To
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
11402 Parameter_Associations
=> New_List
(
11403 New_Reference_To
(Addr
, Loc
),
11404 New_Reference_To
(Size
, Loc
),
11405 New_Reference_To
(Alig
, Loc
)));
11407 -- Class-wide types complicate things because we cannot determine
11408 -- statically whether the actual object is truly controlled. We must
11409 -- generate a runtime check to detect this property. Generate:
11411 -- if Needs_Finalization (<N>.all'Tag) then
11415 if Is_Class_Wide_Type
(Desig
) then
11417 Make_Explicit_Dereference
(Loc
,
11418 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11419 Set_Has_Dereference_Action
(Deref
);
11422 Make_Implicit_If_Statement
(N
,
11424 Make_Function_Call
(Loc
,
11426 New_Reference_To
(RTE
(RE_Needs_Finalization
), Loc
),
11427 Parameter_Associations
=> New_List
(
11428 Make_Attribute_Reference
(Loc
,
11430 Attribute_Name
=> Name_Tag
))),
11431 Then_Statements
=> New_List
(Stmt
));
11434 Insert_Action
(N
, Stmt
);
11438 -- Dereference (Pool, Addr, Size, Alig);
11441 Make_Procedure_Call_Statement
(Loc
,
11444 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
11445 Parameter_Associations
=> New_List
(
11446 New_Reference_To
(Pool
, Loc
),
11447 New_Reference_To
(Addr
, Loc
),
11448 New_Reference_To
(Size
, Loc
),
11449 New_Reference_To
(Alig
, Loc
))));
11451 -- Mark the explicit dereference as processed to avoid potential
11452 -- infinite expansion.
11454 Set_Has_Dereference_Action
(Pnod
);
11457 when RE_Not_Available
=>
11459 end Insert_Dereference_Action
;
11461 --------------------------------
11462 -- Integer_Promotion_Possible --
11463 --------------------------------
11465 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
11466 Operand
: constant Node_Id
:= Expression
(N
);
11467 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11468 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
11471 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
11475 -- We only do the transformation for source constructs. We assume
11476 -- that the expander knows what it is doing when it generates code.
11478 Comes_From_Source
(N
)
11480 -- If the operand type is Short_Integer or Short_Short_Integer,
11481 -- then we will promote to Integer, which is available on all
11482 -- targets, and is sufficient to ensure no intermediate overflow.
11483 -- Furthermore it is likely to be as efficient or more efficient
11484 -- than using the smaller type for the computation so we do this
11485 -- unconditionally.
11488 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
11490 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
11492 -- Test for interesting operation, which includes addition,
11493 -- division, exponentiation, multiplication, subtraction, absolute
11494 -- value and unary negation. Unary "+" is omitted since it is a
11495 -- no-op and thus can't overflow.
11497 and then Nkind_In
(Operand
, N_Op_Abs
,
11504 end Integer_Promotion_Possible
;
11506 ------------------------------
11507 -- Make_Array_Comparison_Op --
11508 ------------------------------
11510 -- This is a hand-coded expansion of the following generic function:
11513 -- type elem is (<>);
11514 -- type index is (<>);
11515 -- type a is array (index range <>) of elem;
11517 -- function Gnnn (X : a; Y: a) return boolean is
11518 -- J : index := Y'first;
11521 -- if X'length = 0 then
11524 -- elsif Y'length = 0 then
11528 -- for I in X'range loop
11529 -- if X (I) = Y (J) then
11530 -- if J = Y'last then
11533 -- J := index'succ (J);
11537 -- return X (I) > Y (J);
11541 -- return X'length > Y'length;
11545 -- Note that since we are essentially doing this expansion by hand, we
11546 -- do not need to generate an actual or formal generic part, just the
11547 -- instantiated function itself.
11549 function Make_Array_Comparison_Op
11551 Nod
: Node_Id
) return Node_Id
11553 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11555 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
11556 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
11557 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
11558 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
11560 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
11562 Loop_Statement
: Node_Id
;
11563 Loop_Body
: Node_Id
;
11565 Inner_If
: Node_Id
;
11566 Final_Expr
: Node_Id
;
11567 Func_Body
: Node_Id
;
11568 Func_Name
: Entity_Id
;
11574 -- if J = Y'last then
11577 -- J := index'succ (J);
11581 Make_Implicit_If_Statement
(Nod
,
11584 Left_Opnd
=> New_Reference_To
(J
, Loc
),
11586 Make_Attribute_Reference
(Loc
,
11587 Prefix
=> New_Reference_To
(Y
, Loc
),
11588 Attribute_Name
=> Name_Last
)),
11590 Then_Statements
=> New_List
(
11591 Make_Exit_Statement
(Loc
)),
11595 Make_Assignment_Statement
(Loc
,
11596 Name
=> New_Reference_To
(J
, Loc
),
11598 Make_Attribute_Reference
(Loc
,
11599 Prefix
=> New_Reference_To
(Index
, Loc
),
11600 Attribute_Name
=> Name_Succ
,
11601 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))))));
11603 -- if X (I) = Y (J) then
11606 -- return X (I) > Y (J);
11610 Make_Implicit_If_Statement
(Nod
,
11614 Make_Indexed_Component
(Loc
,
11615 Prefix
=> New_Reference_To
(X
, Loc
),
11616 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
11619 Make_Indexed_Component
(Loc
,
11620 Prefix
=> New_Reference_To
(Y
, Loc
),
11621 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)))),
11623 Then_Statements
=> New_List
(Inner_If
),
11625 Else_Statements
=> New_List
(
11626 Make_Simple_Return_Statement
(Loc
,
11630 Make_Indexed_Component
(Loc
,
11631 Prefix
=> New_Reference_To
(X
, Loc
),
11632 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
11635 Make_Indexed_Component
(Loc
,
11636 Prefix
=> New_Reference_To
(Y
, Loc
),
11637 Expressions
=> New_List
(
11638 New_Reference_To
(J
, Loc
)))))));
11640 -- for I in X'range loop
11645 Make_Implicit_Loop_Statement
(Nod
,
11646 Identifier
=> Empty
,
11648 Iteration_Scheme
=>
11649 Make_Iteration_Scheme
(Loc
,
11650 Loop_Parameter_Specification
=>
11651 Make_Loop_Parameter_Specification
(Loc
,
11652 Defining_Identifier
=> I
,
11653 Discrete_Subtype_Definition
=>
11654 Make_Attribute_Reference
(Loc
,
11655 Prefix
=> New_Reference_To
(X
, Loc
),
11656 Attribute_Name
=> Name_Range
))),
11658 Statements
=> New_List
(Loop_Body
));
11660 -- if X'length = 0 then
11662 -- elsif Y'length = 0 then
11665 -- for ... loop ... end loop;
11666 -- return X'length > Y'length;
11670 Make_Attribute_Reference
(Loc
,
11671 Prefix
=> New_Reference_To
(X
, Loc
),
11672 Attribute_Name
=> Name_Length
);
11675 Make_Attribute_Reference
(Loc
,
11676 Prefix
=> New_Reference_To
(Y
, Loc
),
11677 Attribute_Name
=> Name_Length
);
11681 Left_Opnd
=> Length1
,
11682 Right_Opnd
=> Length2
);
11685 Make_Implicit_If_Statement
(Nod
,
11689 Make_Attribute_Reference
(Loc
,
11690 Prefix
=> New_Reference_To
(X
, Loc
),
11691 Attribute_Name
=> Name_Length
),
11693 Make_Integer_Literal
(Loc
, 0)),
11697 Make_Simple_Return_Statement
(Loc
,
11698 Expression
=> New_Reference_To
(Standard_False
, Loc
))),
11700 Elsif_Parts
=> New_List
(
11701 Make_Elsif_Part
(Loc
,
11705 Make_Attribute_Reference
(Loc
,
11706 Prefix
=> New_Reference_To
(Y
, Loc
),
11707 Attribute_Name
=> Name_Length
),
11709 Make_Integer_Literal
(Loc
, 0)),
11713 Make_Simple_Return_Statement
(Loc
,
11714 Expression
=> New_Reference_To
(Standard_True
, Loc
))))),
11716 Else_Statements
=> New_List
(
11718 Make_Simple_Return_Statement
(Loc
,
11719 Expression
=> Final_Expr
)));
11723 Formals
:= New_List
(
11724 Make_Parameter_Specification
(Loc
,
11725 Defining_Identifier
=> X
,
11726 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
11728 Make_Parameter_Specification
(Loc
,
11729 Defining_Identifier
=> Y
,
11730 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
11732 -- function Gnnn (...) return boolean is
11733 -- J : index := Y'first;
11738 Func_Name
:= Make_Temporary
(Loc
, 'G');
11741 Make_Subprogram_Body
(Loc
,
11743 Make_Function_Specification
(Loc
,
11744 Defining_Unit_Name
=> Func_Name
,
11745 Parameter_Specifications
=> Formals
,
11746 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
11748 Declarations
=> New_List
(
11749 Make_Object_Declaration
(Loc
,
11750 Defining_Identifier
=> J
,
11751 Object_Definition
=> New_Reference_To
(Index
, Loc
),
11753 Make_Attribute_Reference
(Loc
,
11754 Prefix
=> New_Reference_To
(Y
, Loc
),
11755 Attribute_Name
=> Name_First
))),
11757 Handled_Statement_Sequence
=>
11758 Make_Handled_Sequence_Of_Statements
(Loc
,
11759 Statements
=> New_List
(If_Stat
)));
11762 end Make_Array_Comparison_Op
;
11764 ---------------------------
11765 -- Make_Boolean_Array_Op --
11766 ---------------------------
11768 -- For logical operations on boolean arrays, expand in line the following,
11769 -- replacing 'and' with 'or' or 'xor' where needed:
11771 -- function Annn (A : typ; B: typ) return typ is
11774 -- for J in A'range loop
11775 -- C (J) := A (J) op B (J);
11780 -- Here typ is the boolean array type
11782 function Make_Boolean_Array_Op
11784 N
: Node_Id
) return Node_Id
11786 Loc
: constant Source_Ptr
:= Sloc
(N
);
11788 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
11789 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
11790 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
11791 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
11799 Func_Name
: Entity_Id
;
11800 Func_Body
: Node_Id
;
11801 Loop_Statement
: Node_Id
;
11805 Make_Indexed_Component
(Loc
,
11806 Prefix
=> New_Reference_To
(A
, Loc
),
11807 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11810 Make_Indexed_Component
(Loc
,
11811 Prefix
=> New_Reference_To
(B
, Loc
),
11812 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11815 Make_Indexed_Component
(Loc
,
11816 Prefix
=> New_Reference_To
(C
, Loc
),
11817 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11819 if Nkind
(N
) = N_Op_And
then
11823 Right_Opnd
=> B_J
);
11825 elsif Nkind
(N
) = N_Op_Or
then
11829 Right_Opnd
=> B_J
);
11835 Right_Opnd
=> B_J
);
11839 Make_Implicit_Loop_Statement
(N
,
11840 Identifier
=> Empty
,
11842 Iteration_Scheme
=>
11843 Make_Iteration_Scheme
(Loc
,
11844 Loop_Parameter_Specification
=>
11845 Make_Loop_Parameter_Specification
(Loc
,
11846 Defining_Identifier
=> J
,
11847 Discrete_Subtype_Definition
=>
11848 Make_Attribute_Reference
(Loc
,
11849 Prefix
=> New_Reference_To
(A
, Loc
),
11850 Attribute_Name
=> Name_Range
))),
11852 Statements
=> New_List
(
11853 Make_Assignment_Statement
(Loc
,
11855 Expression
=> Op
)));
11857 Formals
:= New_List
(
11858 Make_Parameter_Specification
(Loc
,
11859 Defining_Identifier
=> A
,
11860 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
11862 Make_Parameter_Specification
(Loc
,
11863 Defining_Identifier
=> B
,
11864 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
11866 Func_Name
:= Make_Temporary
(Loc
, 'A');
11867 Set_Is_Inlined
(Func_Name
);
11870 Make_Subprogram_Body
(Loc
,
11872 Make_Function_Specification
(Loc
,
11873 Defining_Unit_Name
=> Func_Name
,
11874 Parameter_Specifications
=> Formals
,
11875 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
11877 Declarations
=> New_List
(
11878 Make_Object_Declaration
(Loc
,
11879 Defining_Identifier
=> C
,
11880 Object_Definition
=> New_Reference_To
(Typ
, Loc
))),
11882 Handled_Statement_Sequence
=>
11883 Make_Handled_Sequence_Of_Statements
(Loc
,
11884 Statements
=> New_List
(
11886 Make_Simple_Return_Statement
(Loc
,
11887 Expression
=> New_Reference_To
(C
, Loc
)))));
11890 end Make_Boolean_Array_Op
;
11892 -----------------------------------------
11893 -- Minimized_Eliminated_Overflow_Check --
11894 -----------------------------------------
11896 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
11899 Is_Signed_Integer_Type
(Etype
(N
))
11900 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
11901 end Minimized_Eliminated_Overflow_Check
;
11903 --------------------------------
11904 -- Optimize_Length_Comparison --
11905 --------------------------------
11907 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
11908 Loc
: constant Source_Ptr
:= Sloc
(N
);
11909 Typ
: constant Entity_Id
:= Etype
(N
);
11914 -- First and Last attribute reference nodes, which end up as left and
11915 -- right operands of the optimized result.
11918 -- True for comparison operand of zero
11921 -- Comparison operand, set only if Is_Zero is false
11924 -- Entity whose length is being compared
11927 -- Integer_Literal node for length attribute expression, or Empty
11928 -- if there is no such expression present.
11931 -- Type of array index to which 'Length is applied
11933 Op
: Node_Kind
:= Nkind
(N
);
11934 -- Kind of comparison operator, gets flipped if operands backwards
11936 function Is_Optimizable
(N
: Node_Id
) return Boolean;
11937 -- Tests N to see if it is an optimizable comparison value (defined as
11938 -- constant zero or one, or something else where the value is known to
11939 -- be positive and in the range of 32-bits, and where the corresponding
11940 -- Length value is also known to be 32-bits. If result is true, sets
11941 -- Is_Zero, Ityp, and Comp accordingly.
11943 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
11944 -- Tests if N is a length attribute applied to a simple entity. If so,
11945 -- returns True, and sets Ent to the entity, and Index to the integer
11946 -- literal provided as an attribute expression, or to Empty if none.
11947 -- Also returns True if the expression is a generated type conversion
11948 -- whose expression is of the desired form. This latter case arises
11949 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
11950 -- to check for being in range, which is not needed in this context.
11951 -- Returns False if neither condition holds.
11953 function Prepare_64
(N
: Node_Id
) return Node_Id
;
11954 -- Given a discrete expression, returns a Long_Long_Integer typed
11955 -- expression representing the underlying value of the expression.
11956 -- This is done with an unchecked conversion to the result type. We
11957 -- use unchecked conversion to handle the enumeration type case.
11959 ----------------------
11960 -- Is_Entity_Length --
11961 ----------------------
11963 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
11965 if Nkind
(N
) = N_Attribute_Reference
11966 and then Attribute_Name
(N
) = Name_Length
11967 and then Is_Entity_Name
(Prefix
(N
))
11969 Ent
:= Entity
(Prefix
(N
));
11971 if Present
(Expressions
(N
)) then
11972 Index
:= First
(Expressions
(N
));
11979 elsif Nkind
(N
) = N_Type_Conversion
11980 and then not Comes_From_Source
(N
)
11982 return Is_Entity_Length
(Expression
(N
));
11987 end Is_Entity_Length
;
11989 --------------------
11990 -- Is_Optimizable --
11991 --------------------
11993 function Is_Optimizable
(N
: Node_Id
) return Boolean is
12001 if Compile_Time_Known_Value
(N
) then
12002 Val
:= Expr_Value
(N
);
12004 if Val
= Uint_0
then
12009 elsif Val
= Uint_1
then
12016 -- Here we have to make sure of being within 32-bits
12018 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12021 or else Lo
< Uint_1
12022 or else Hi
> UI_From_Int
(Int
'Last)
12027 -- Comparison value was within range, so now we must check the index
12028 -- value to make sure it is also within 32-bits.
12030 Indx
:= First_Index
(Etype
(Ent
));
12032 if Present
(Index
) then
12033 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
12038 Ityp
:= Etype
(Indx
);
12040 if Esize
(Ityp
) > 32 then
12047 end Is_Optimizable
;
12053 function Prepare_64
(N
: Node_Id
) return Node_Id
is
12055 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
12058 -- Start of processing for Optimize_Length_Comparison
12061 -- Nothing to do if not a comparison
12063 if Op
not in N_Op_Compare
then
12067 -- Nothing to do if special -gnatd.P debug flag set
12069 if Debug_Flag_Dot_PP
then
12073 -- Ent'Length op 0/1
12075 if Is_Entity_Length
(Left_Opnd
(N
))
12076 and then Is_Optimizable
(Right_Opnd
(N
))
12080 -- 0/1 op Ent'Length
12082 elsif Is_Entity_Length
(Right_Opnd
(N
))
12083 and then Is_Optimizable
(Left_Opnd
(N
))
12085 -- Flip comparison to opposite sense
12088 when N_Op_Lt
=> Op
:= N_Op_Gt
;
12089 when N_Op_Le
=> Op
:= N_Op_Ge
;
12090 when N_Op_Gt
=> Op
:= N_Op_Lt
;
12091 when N_Op_Ge
=> Op
:= N_Op_Le
;
12092 when others => null;
12095 -- Else optimization not possible
12101 -- Fall through if we will do the optimization
12103 -- Cases to handle:
12105 -- X'Length = 0 => X'First > X'Last
12106 -- X'Length = 1 => X'First = X'Last
12107 -- X'Length = n => X'First + (n - 1) = X'Last
12109 -- X'Length /= 0 => X'First <= X'Last
12110 -- X'Length /= 1 => X'First /= X'Last
12111 -- X'Length /= n => X'First + (n - 1) /= X'Last
12113 -- X'Length >= 0 => always true, warn
12114 -- X'Length >= 1 => X'First <= X'Last
12115 -- X'Length >= n => X'First + (n - 1) <= X'Last
12117 -- X'Length > 0 => X'First <= X'Last
12118 -- X'Length > 1 => X'First < X'Last
12119 -- X'Length > n => X'First + (n - 1) < X'Last
12121 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12122 -- X'Length <= 1 => X'First >= X'Last
12123 -- X'Length <= n => X'First + (n - 1) >= X'Last
12125 -- X'Length < 0 => always false (warn)
12126 -- X'Length < 1 => X'First > X'Last
12127 -- X'Length < n => X'First + (n - 1) > X'Last
12129 -- Note: for the cases of n (not constant 0,1), we require that the
12130 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12131 -- and the same for the comparison value. Then we do the comparison
12132 -- using 64-bit arithmetic (actually long long integer), so that we
12133 -- cannot have overflow intefering with the result.
12135 -- First deal with warning cases
12144 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
12145 Analyze_And_Resolve
(N
, Typ
);
12146 Warn_On_Known_Condition
(N
);
12153 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
12154 Analyze_And_Resolve
(N
, Typ
);
12155 Warn_On_Known_Condition
(N
);
12159 if Constant_Condition_Warnings
12160 and then Comes_From_Source
(Original_Node
(N
))
12162 Error_Msg_N
("could replace by ""'=""?c?", N
);
12172 -- Build the First reference we will use
12175 Make_Attribute_Reference
(Loc
,
12176 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12177 Attribute_Name
=> Name_First
);
12179 if Present
(Index
) then
12180 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
12183 -- If general value case, then do the addition of (n - 1), and
12184 -- also add the needed conversions to type Long_Long_Integer.
12186 if Present
(Comp
) then
12189 Left_Opnd
=> Prepare_64
(Left
),
12191 Make_Op_Subtract
(Loc
,
12192 Left_Opnd
=> Prepare_64
(Comp
),
12193 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
12196 -- Build the Last reference we will use
12199 Make_Attribute_Reference
(Loc
,
12200 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12201 Attribute_Name
=> Name_Last
);
12203 if Present
(Index
) then
12204 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
12207 -- If general operand, convert Last reference to Long_Long_Integer
12209 if Present
(Comp
) then
12210 Right
:= Prepare_64
(Right
);
12213 -- Check for cases to optimize
12215 -- X'Length = 0 => X'First > X'Last
12216 -- X'Length < 1 => X'First > X'Last
12217 -- X'Length < n => X'First + (n - 1) > X'Last
12219 if (Is_Zero
and then Op
= N_Op_Eq
)
12220 or else (not Is_Zero
and then Op
= N_Op_Lt
)
12225 Right_Opnd
=> Right
);
12227 -- X'Length = 1 => X'First = X'Last
12228 -- X'Length = n => X'First + (n - 1) = X'Last
12230 elsif not Is_Zero
and then Op
= N_Op_Eq
then
12234 Right_Opnd
=> Right
);
12236 -- X'Length /= 0 => X'First <= X'Last
12237 -- X'Length > 0 => X'First <= X'Last
12239 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
12243 Right_Opnd
=> Right
);
12245 -- X'Length /= 1 => X'First /= X'Last
12246 -- X'Length /= n => X'First + (n - 1) /= X'Last
12248 elsif not Is_Zero
and then Op
= N_Op_Ne
then
12252 Right_Opnd
=> Right
);
12254 -- X'Length >= 1 => X'First <= X'Last
12255 -- X'Length >= n => X'First + (n - 1) <= X'Last
12257 elsif not Is_Zero
and then Op
= N_Op_Ge
then
12261 Right_Opnd
=> Right
);
12263 -- X'Length > 1 => X'First < X'Last
12264 -- X'Length > n => X'First + (n = 1) < X'Last
12266 elsif not Is_Zero
and then Op
= N_Op_Gt
then
12270 Right_Opnd
=> Right
);
12272 -- X'Length <= 1 => X'First >= X'Last
12273 -- X'Length <= n => X'First + (n - 1) >= X'Last
12275 elsif not Is_Zero
and then Op
= N_Op_Le
then
12279 Right_Opnd
=> Right
);
12281 -- Should not happen at this stage
12284 raise Program_Error
;
12287 -- Rewrite and finish up
12289 Rewrite
(N
, Result
);
12290 Analyze_And_Resolve
(N
, Typ
);
12292 end Optimize_Length_Comparison
;
12294 ------------------------
12295 -- Rewrite_Comparison --
12296 ------------------------
12298 procedure Rewrite_Comparison
(N
: Node_Id
) is
12299 Warning_Generated
: Boolean := False;
12300 -- Set to True if first pass with Assume_Valid generates a warning in
12301 -- which case we skip the second pass to avoid warning overloaded.
12304 -- Set to Standard_True or Standard_False
12307 if Nkind
(N
) = N_Type_Conversion
then
12308 Rewrite_Comparison
(Expression
(N
));
12311 elsif Nkind
(N
) not in N_Op_Compare
then
12315 -- Now start looking at the comparison in detail. We potentially go
12316 -- through this loop twice. The first time, Assume_Valid is set False
12317 -- in the call to Compile_Time_Compare. If this call results in a
12318 -- clear result of always True or Always False, that's decisive and
12319 -- we are done. Otherwise we repeat the processing with Assume_Valid
12320 -- set to True to generate additional warnings. We can skip that step
12321 -- if Constant_Condition_Warnings is False.
12323 for AV
in False .. True loop
12325 Typ
: constant Entity_Id
:= Etype
(N
);
12326 Op1
: constant Node_Id
:= Left_Opnd
(N
);
12327 Op2
: constant Node_Id
:= Right_Opnd
(N
);
12329 Res
: constant Compare_Result
:=
12330 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
12331 -- Res indicates if compare outcome can be compile time determined
12333 True_Result
: Boolean;
12334 False_Result
: Boolean;
12337 case N_Op_Compare
(Nkind
(N
)) is
12339 True_Result
:= Res
= EQ
;
12340 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
12343 True_Result
:= Res
in Compare_GE
;
12344 False_Result
:= Res
= LT
;
12347 and then Constant_Condition_Warnings
12348 and then Comes_From_Source
(Original_Node
(N
))
12349 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
12350 and then not In_Instance
12351 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12352 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12355 ("can never be greater than, could replace by ""'=""?c?",
12357 Warning_Generated
:= True;
12361 True_Result
:= Res
= GT
;
12362 False_Result
:= Res
in Compare_LE
;
12365 True_Result
:= Res
= LT
;
12366 False_Result
:= Res
in Compare_GE
;
12369 True_Result
:= Res
in Compare_LE
;
12370 False_Result
:= Res
= GT
;
12373 and then Constant_Condition_Warnings
12374 and then Comes_From_Source
(Original_Node
(N
))
12375 and then Nkind
(Original_Node
(N
)) = N_Op_Le
12376 and then not In_Instance
12377 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12378 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12381 ("can never be less than, could replace by ""'=""?c?", N
);
12382 Warning_Generated
:= True;
12386 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
12387 False_Result
:= Res
= EQ
;
12390 -- If this is the first iteration, then we actually convert the
12391 -- comparison into True or False, if the result is certain.
12394 if True_Result
or False_Result
then
12395 Result
:= Boolean_Literals
(True_Result
);
12398 New_Occurrence_Of
(Result
, Sloc
(N
))));
12399 Analyze_And_Resolve
(N
, Typ
);
12400 Warn_On_Known_Condition
(N
);
12404 -- If this is the second iteration (AV = True), and the original
12405 -- node comes from source and we are not in an instance, then give
12406 -- a warning if we know result would be True or False. Note: we
12407 -- know Constant_Condition_Warnings is set if we get here.
12409 elsif Comes_From_Source
(Original_Node
(N
))
12410 and then not In_Instance
12412 if True_Result
then
12414 ("condition can only be False if invalid values present??",
12416 elsif False_Result
then
12418 ("condition can only be True if invalid values present??",
12424 -- Skip second iteration if not warning on constant conditions or
12425 -- if the first iteration already generated a warning of some kind or
12426 -- if we are in any case assuming all values are valid (so that the
12427 -- first iteration took care of the valid case).
12429 exit when not Constant_Condition_Warnings
;
12430 exit when Warning_Generated
;
12431 exit when Assume_No_Invalid_Values
;
12433 end Rewrite_Comparison
;
12435 ----------------------------
12436 -- Safe_In_Place_Array_Op --
12437 ----------------------------
12439 function Safe_In_Place_Array_Op
12442 Op2
: Node_Id
) return Boolean
12444 Target
: Entity_Id
;
12446 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
12447 -- Operand is safe if it cannot overlap part of the target of the
12448 -- operation. If the operand and the target are identical, the operand
12449 -- is safe. The operand can be empty in the case of negation.
12451 function Is_Unaliased
(N
: Node_Id
) return Boolean;
12452 -- Check that N is a stand-alone entity
12458 function Is_Unaliased
(N
: Node_Id
) return Boolean is
12462 and then No
(Address_Clause
(Entity
(N
)))
12463 and then No
(Renamed_Object
(Entity
(N
)));
12466 ---------------------
12467 -- Is_Safe_Operand --
12468 ---------------------
12470 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
12475 elsif Is_Entity_Name
(Op
) then
12476 return Is_Unaliased
(Op
);
12478 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
12479 return Is_Unaliased
(Prefix
(Op
));
12481 elsif Nkind
(Op
) = N_Slice
then
12483 Is_Unaliased
(Prefix
(Op
))
12484 and then Entity
(Prefix
(Op
)) /= Target
;
12486 elsif Nkind
(Op
) = N_Op_Not
then
12487 return Is_Safe_Operand
(Right_Opnd
(Op
));
12492 end Is_Safe_Operand
;
12494 -- Start of processing for Safe_In_Place_Array_Op
12497 -- Skip this processing if the component size is different from system
12498 -- storage unit (since at least for NOT this would cause problems).
12500 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
12503 -- Cannot do in place stuff on VM_Target since cannot pass addresses
12505 elsif VM_Target
/= No_VM
then
12508 -- Cannot do in place stuff if non-standard Boolean representation
12510 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
12513 elsif not Is_Unaliased
(Lhs
) then
12517 Target
:= Entity
(Lhs
);
12518 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
12520 end Safe_In_Place_Array_Op
;
12522 -----------------------
12523 -- Tagged_Membership --
12524 -----------------------
12526 -- There are two different cases to consider depending on whether the right
12527 -- operand is a class-wide type or not. If not we just compare the actual
12528 -- tag of the left expr to the target type tag:
12530 -- Left_Expr.Tag = Right_Type'Tag;
12532 -- If it is a class-wide type we use the RT function CW_Membership which is
12533 -- usually implemented by looking in the ancestor tables contained in the
12534 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
12536 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
12537 -- function IW_Membership which is usually implemented by looking in the
12538 -- table of abstract interface types plus the ancestor table contained in
12539 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
12541 procedure Tagged_Membership
12543 SCIL_Node
: out Node_Id
;
12544 Result
: out Node_Id
)
12546 Left
: constant Node_Id
:= Left_Opnd
(N
);
12547 Right
: constant Node_Id
:= Right_Opnd
(N
);
12548 Loc
: constant Source_Ptr
:= Sloc
(N
);
12550 Full_R_Typ
: Entity_Id
;
12551 Left_Type
: Entity_Id
;
12552 New_Node
: Node_Id
;
12553 Right_Type
: Entity_Id
;
12557 SCIL_Node
:= Empty
;
12559 -- Handle entities from the limited view
12561 Left_Type
:= Available_View
(Etype
(Left
));
12562 Right_Type
:= Available_View
(Etype
(Right
));
12564 -- In the case where the type is an access type, the test is applied
12565 -- using the designated types (needed in Ada 2012 for implicit anonymous
12566 -- access conversions, for AI05-0149).
12568 if Is_Access_Type
(Right_Type
) then
12569 Left_Type
:= Designated_Type
(Left_Type
);
12570 Right_Type
:= Designated_Type
(Right_Type
);
12573 if Is_Class_Wide_Type
(Left_Type
) then
12574 Left_Type
:= Root_Type
(Left_Type
);
12577 if Is_Class_Wide_Type
(Right_Type
) then
12578 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
12580 Full_R_Typ
:= Underlying_Type
(Right_Type
);
12584 Make_Selected_Component
(Loc
,
12585 Prefix
=> Relocate_Node
(Left
),
12587 New_Reference_To
(First_Tag_Component
(Left_Type
), Loc
));
12589 if Is_Class_Wide_Type
(Right_Type
) then
12591 -- No need to issue a run-time check if we statically know that the
12592 -- result of this membership test is always true. For example,
12593 -- considering the following declarations:
12595 -- type Iface is interface;
12596 -- type T is tagged null record;
12597 -- type DT is new T and Iface with null record;
12602 -- These membership tests are always true:
12605 -- Obj2 in T'Class;
12606 -- Obj2 in Iface'Class;
12608 -- We do not need to handle cases where the membership is illegal.
12611 -- Obj1 in DT'Class; -- Compile time error
12612 -- Obj1 in Iface'Class; -- Compile time error
12614 if not Is_Class_Wide_Type
(Left_Type
)
12615 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
12616 Use_Full_View
=> True)
12617 or else (Is_Interface
(Etype
(Right_Type
))
12618 and then Interface_Present_In_Ancestor
12620 Iface
=> Etype
(Right_Type
))))
12622 Result
:= New_Reference_To
(Standard_True
, Loc
);
12626 -- Ada 2005 (AI-251): Class-wide applied to interfaces
12628 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
12630 -- Support to: "Iface_CW_Typ in Typ'Class"
12632 or else Is_Interface
(Left_Type
)
12634 -- Issue error if IW_Membership operation not available in a
12635 -- configurable run time setting.
12637 if not RTE_Available
(RE_IW_Membership
) then
12639 ("dynamic membership test on interface types", N
);
12645 Make_Function_Call
(Loc
,
12646 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
12647 Parameter_Associations
=> New_List
(
12648 Make_Attribute_Reference
(Loc
,
12650 Attribute_Name
=> Name_Address
),
12652 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
12655 -- Ada 95: Normal case
12658 Build_CW_Membership
(Loc
,
12659 Obj_Tag_Node
=> Obj_Tag
,
12662 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
12664 New_Node
=> New_Node
);
12666 -- Generate the SCIL node for this class-wide membership test.
12667 -- Done here because the previous call to Build_CW_Membership
12668 -- relocates Obj_Tag.
12670 if Generate_SCIL
then
12671 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
12672 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
12673 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
12676 Result
:= New_Node
;
12679 -- Right_Type is not a class-wide type
12682 -- No need to check the tag of the object if Right_Typ is abstract
12684 if Is_Abstract_Type
(Right_Type
) then
12685 Result
:= New_Reference_To
(Standard_False
, Loc
);
12690 Left_Opnd
=> Obj_Tag
,
12693 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
12696 end Tagged_Membership
;
12698 ------------------------------
12699 -- Unary_Op_Validity_Checks --
12700 ------------------------------
12702 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
12704 if Validity_Checks_On
and Validity_Check_Operands
then
12705 Ensure_Valid
(Right_Opnd
(N
));
12707 end Unary_Op_Validity_Checks
;