1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Aggr
; use Exp_Aggr
;
33 with Exp_Atag
; use Exp_Atag
;
34 with Exp_Ch2
; use Exp_Ch2
;
35 with Exp_Ch3
; use Exp_Ch3
;
36 with Exp_Ch6
; use Exp_Ch6
;
37 with Exp_Ch7
; use Exp_Ch7
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Disp
; use Exp_Disp
;
40 with Exp_Fixd
; use Exp_Fixd
;
41 with Exp_Intr
; use Exp_Intr
;
42 with Exp_Pakd
; use Exp_Pakd
;
43 with Exp_Tss
; use Exp_Tss
;
44 with Exp_Util
; use Exp_Util
;
45 with Exp_VFpt
; use Exp_VFpt
;
46 with Freeze
; use Freeze
;
47 with Inline
; use Inline
;
49 with Namet
; use Namet
;
50 with Nlists
; use Nlists
;
51 with Nmake
; use Nmake
;
53 with Par_SCO
; use Par_SCO
;
54 with Restrict
; use Restrict
;
55 with Rident
; use Rident
;
56 with Rtsfind
; use Rtsfind
;
58 with Sem_Aux
; use Sem_Aux
;
59 with Sem_Cat
; use Sem_Cat
;
60 with Sem_Ch3
; use Sem_Ch3
;
61 with Sem_Ch8
; use Sem_Ch8
;
62 with Sem_Ch13
; use Sem_Ch13
;
63 with Sem_Eval
; use Sem_Eval
;
64 with Sem_Res
; use Sem_Res
;
65 with Sem_Type
; use Sem_Type
;
66 with Sem_Util
; use Sem_Util
;
67 with Sem_Warn
; use Sem_Warn
;
68 with Sinfo
; use Sinfo
;
69 with Snames
; use Snames
;
70 with Stand
; use Stand
;
71 with SCIL_LL
; use SCIL_LL
;
72 with Targparm
; use Targparm
;
73 with Tbuild
; use Tbuild
;
74 with Ttypes
; use Ttypes
;
75 with Uintp
; use Uintp
;
76 with Urealp
; use Urealp
;
77 with Validsw
; use Validsw
;
79 package body Exp_Ch4
is
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
86 pragma Inline
(Binary_Op_Validity_Checks
);
87 -- Performs validity checks for a binary operator
89 procedure Build_Boolean_Array_Proc_Call
93 -- If a boolean array assignment can be done in place, build call to
94 -- corresponding library procedure.
96 function Current_Anonymous_Master
return Entity_Id
;
97 -- Return the entity of the heterogeneous finalization master belonging to
98 -- the current unit (either function, package or procedure). This master
99 -- services all anonymous access-to-controlled types. If the current unit
100 -- does not have such master, create one.
102 procedure Displace_Allocator_Pointer
(N
: Node_Id
);
103 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
104 -- Expand_Allocator_Expression. Allocating class-wide interface objects
105 -- this routine displaces the pointer to the allocated object to reference
106 -- the component referencing the corresponding secondary dispatch table.
108 procedure Expand_Allocator_Expression
(N
: Node_Id
);
109 -- Subsidiary to Expand_N_Allocator, for the case when the expression
110 -- is a qualified expression or an aggregate.
112 procedure Expand_Array_Comparison
(N
: Node_Id
);
113 -- This routine handles expansion of the comparison operators (N_Op_Lt,
114 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
115 -- code for these operators is similar, differing only in the details of
116 -- the actual comparison call that is made. Special processing (call a
119 function Expand_Array_Equality
124 Typ
: Entity_Id
) return Node_Id
;
125 -- Expand an array equality into a call to a function implementing this
126 -- equality, and a call to it. Loc is the location for the generated nodes.
127 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
128 -- on which to attach bodies of local functions that are created in the
129 -- process. It is the responsibility of the caller to insert those bodies
130 -- at the right place. Nod provides the Sloc value for the generated code.
131 -- Normally the types used for the generated equality routine are taken
132 -- from Lhs and Rhs. However, in some situations of generated code, the
133 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
134 -- the type to be used for the formal parameters.
136 procedure Expand_Boolean_Operator
(N
: Node_Id
);
137 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
138 -- case of array type arguments.
140 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
);
141 -- Common expansion processing for short-circuit boolean operators
143 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
);
144 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
145 -- where we allow comparison of "out of range" values.
147 function Expand_Composite_Equality
152 Bodies
: List_Id
) return Node_Id
;
153 -- Local recursive function used to expand equality for nested composite
154 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
155 -- to attach bodies of local functions that are created in the process.
156 -- It is the responsibility of the caller to insert those bodies at the
157 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
158 -- are the left and right sides for the comparison, and Typ is the type of
159 -- the objects to compare.
161 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
162 -- Routine to expand concatenation of a sequence of two or more operands
163 -- (in the list Operands) and replace node Cnode with the result of the
164 -- concatenation. The operands can be of any appropriate type, and can
165 -- include both arrays and singleton elements.
167 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
);
168 -- N is an N_In membership test mode, with the overflow check mode set to
169 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
170 -- integer type. This is a case where top level processing is required to
171 -- handle overflow checks in subtrees.
173 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
174 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
175 -- fixed. We do not have such a type at runtime, so the purpose of this
176 -- routine is to find the real type by looking up the tree. We also
177 -- determine if the operation must be rounded.
179 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
180 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
181 -- discriminants if it has a constrained nominal type, unless the object
182 -- is a component of an enclosing Unchecked_Union object that is subject
183 -- to a per-object constraint and the enclosing object lacks inferable
186 -- An expression of an Unchecked_Union type has inferable discriminants
187 -- if it is either a name of an object with inferable discriminants or a
188 -- qualified expression whose subtype mark denotes a constrained subtype.
190 procedure Insert_Dereference_Action
(N
: Node_Id
);
191 -- N is an expression whose type is an access. When the type of the
192 -- associated storage pool is derived from Checked_Pool, generate a
193 -- call to the 'Dereference' primitive operation.
195 function Make_Array_Comparison_Op
197 Nod
: Node_Id
) return Node_Id
;
198 -- Comparisons between arrays are expanded in line. This function produces
199 -- the body of the implementation of (a > b), where a and b are one-
200 -- dimensional arrays of some discrete type. The original node is then
201 -- expanded into the appropriate call to this function. Nod provides the
202 -- Sloc value for the generated code.
204 function Make_Boolean_Array_Op
206 N
: Node_Id
) return Node_Id
;
207 -- Boolean operations on boolean arrays are expanded in line. This function
208 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
209 -- b). It is used only the normal case and not the packed case. The type
210 -- involved, Typ, is the Boolean array type, and the logical operations in
211 -- the body are simple boolean operations. Note that Typ is always a
212 -- constrained type (the caller has ensured this by using
213 -- Convert_To_Actual_Subtype if necessary).
215 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean;
216 -- For signed arithmetic operations when the current overflow mode is
217 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
218 -- as the first thing we do. We then return. We count on the recursive
219 -- apparatus for overflow checks to call us back with an equivalent
220 -- operation that is in CHECKED mode, avoiding a recursive entry into this
221 -- routine, and that is when we will proceed with the expansion of the
222 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
223 -- these optimizations without first making this check, since there may be
224 -- operands further down the tree that are relying on the recursive calls
225 -- triggered by the top level nodes to properly process overflow checking
226 -- and remaining expansion on these nodes. Note that this call back may be
227 -- skipped if the operation is done in Bignum mode but that's fine, since
228 -- the Bignum call takes care of everything.
230 procedure Optimize_Length_Comparison
(N
: Node_Id
);
231 -- Given an expression, if it is of the form X'Length op N (or the other
232 -- way round), where N is known at compile time to be 0 or 1, and X is a
233 -- simple entity, and op is a comparison operator, optimizes it into a
234 -- comparison of First and Last.
236 procedure Process_Transient_Object
239 -- Subsidiary routine to the expansion of expression_with_actions and if
240 -- expressions. Generate all the necessary code to finalize a transient
241 -- controlled object when the enclosing context is elaborated or evaluated.
242 -- Decl denotes the declaration of the transient controlled object which is
243 -- usually the result of a controlled function call. Rel_Node denotes the
244 -- context, either an expression_with_actions or an if expression.
246 procedure Rewrite_Comparison
(N
: Node_Id
);
247 -- If N is the node for a comparison whose outcome can be determined at
248 -- compile time, then the node N can be rewritten with True or False. If
249 -- the outcome cannot be determined at compile time, the call has no
250 -- effect. If N is a type conversion, then this processing is applied to
251 -- its expression. If N is neither comparison nor a type conversion, the
252 -- call has no effect.
254 procedure Tagged_Membership
256 SCIL_Node
: out Node_Id
;
257 Result
: out Node_Id
);
258 -- Construct the expression corresponding to the tagged membership test.
259 -- Deals with a second operand being (or not) a class-wide type.
261 function Safe_In_Place_Array_Op
264 Op2
: Node_Id
) return Boolean;
265 -- In the context of an assignment, where the right-hand side is a boolean
266 -- operation on arrays, check whether operation can be performed in place.
268 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
269 pragma Inline
(Unary_Op_Validity_Checks
);
270 -- Performs validity checks for a unary operator
272 -------------------------------
273 -- Binary_Op_Validity_Checks --
274 -------------------------------
276 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
278 if Validity_Checks_On
and Validity_Check_Operands
then
279 Ensure_Valid
(Left_Opnd
(N
));
280 Ensure_Valid
(Right_Opnd
(N
));
282 end Binary_Op_Validity_Checks
;
284 ------------------------------------
285 -- Build_Boolean_Array_Proc_Call --
286 ------------------------------------
288 procedure Build_Boolean_Array_Proc_Call
293 Loc
: constant Source_Ptr
:= Sloc
(N
);
294 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
295 Target
: constant Node_Id
:=
296 Make_Attribute_Reference
(Loc
,
298 Attribute_Name
=> Name_Address
);
300 Arg1
: Node_Id
:= Op1
;
301 Arg2
: Node_Id
:= Op2
;
303 Proc_Name
: Entity_Id
;
306 if Kind
= N_Op_Not
then
307 if Nkind
(Op1
) in N_Binary_Op
then
309 -- Use negated version of the binary operators
311 if Nkind
(Op1
) = N_Op_And
then
312 Proc_Name
:= RTE
(RE_Vector_Nand
);
314 elsif Nkind
(Op1
) = N_Op_Or
then
315 Proc_Name
:= RTE
(RE_Vector_Nor
);
317 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
318 Proc_Name
:= RTE
(RE_Vector_Xor
);
322 Make_Procedure_Call_Statement
(Loc
,
323 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
325 Parameter_Associations
=> New_List
(
327 Make_Attribute_Reference
(Loc
,
328 Prefix
=> Left_Opnd
(Op1
),
329 Attribute_Name
=> Name_Address
),
331 Make_Attribute_Reference
(Loc
,
332 Prefix
=> Right_Opnd
(Op1
),
333 Attribute_Name
=> Name_Address
),
335 Make_Attribute_Reference
(Loc
,
336 Prefix
=> Left_Opnd
(Op1
),
337 Attribute_Name
=> Name_Length
)));
340 Proc_Name
:= RTE
(RE_Vector_Not
);
343 Make_Procedure_Call_Statement
(Loc
,
344 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
345 Parameter_Associations
=> New_List
(
348 Make_Attribute_Reference
(Loc
,
350 Attribute_Name
=> Name_Address
),
352 Make_Attribute_Reference
(Loc
,
354 Attribute_Name
=> Name_Length
)));
358 -- We use the following equivalences:
360 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
361 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
362 -- (not X) xor (not Y) = X xor Y
363 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
365 if Nkind
(Op1
) = N_Op_Not
then
366 Arg1
:= Right_Opnd
(Op1
);
367 Arg2
:= Right_Opnd
(Op2
);
369 if Kind
= N_Op_And
then
370 Proc_Name
:= RTE
(RE_Vector_Nor
);
371 elsif Kind
= N_Op_Or
then
372 Proc_Name
:= RTE
(RE_Vector_Nand
);
374 Proc_Name
:= RTE
(RE_Vector_Xor
);
378 if Kind
= N_Op_And
then
379 Proc_Name
:= RTE
(RE_Vector_And
);
380 elsif Kind
= N_Op_Or
then
381 Proc_Name
:= RTE
(RE_Vector_Or
);
382 elsif Nkind
(Op2
) = N_Op_Not
then
383 Proc_Name
:= RTE
(RE_Vector_Nxor
);
384 Arg2
:= Right_Opnd
(Op2
);
386 Proc_Name
:= RTE
(RE_Vector_Xor
);
391 Make_Procedure_Call_Statement
(Loc
,
392 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
393 Parameter_Associations
=> New_List
(
395 Make_Attribute_Reference
(Loc
,
397 Attribute_Name
=> Name_Address
),
398 Make_Attribute_Reference
(Loc
,
400 Attribute_Name
=> Name_Address
),
401 Make_Attribute_Reference
(Loc
,
403 Attribute_Name
=> Name_Length
)));
406 Rewrite
(N
, Call_Node
);
410 when RE_Not_Available
=>
412 end Build_Boolean_Array_Proc_Call
;
414 ------------------------------
415 -- Current_Anonymous_Master --
416 ------------------------------
418 function Current_Anonymous_Master
return Entity_Id
is
426 Unit_Id
:= Cunit_Entity
(Current_Sem_Unit
);
428 -- Find the entity of the current unit
430 if Ekind
(Unit_Id
) = E_Subprogram_Body
then
432 -- When processing subprogram bodies, the proper scope is always that
435 Subp_Body
:= Unit_Id
;
436 while Present
(Subp_Body
)
437 and then Nkind
(Subp_Body
) /= N_Subprogram_Body
439 Subp_Body
:= Parent
(Subp_Body
);
442 Unit_Id
:= Corresponding_Spec
(Subp_Body
);
445 Loc
:= Sloc
(Unit_Id
);
446 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
448 -- Find the declarations list of the current unit
450 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
451 Unit_Decl
:= Specification
(Unit_Decl
);
452 Decls
:= Visible_Declarations
(Unit_Decl
);
455 Decls
:= New_List
(Make_Null_Statement
(Loc
));
456 Set_Visible_Declarations
(Unit_Decl
, Decls
);
458 elsif Is_Empty_List
(Decls
) then
459 Append_To
(Decls
, Make_Null_Statement
(Loc
));
463 Decls
:= Declarations
(Unit_Decl
);
466 Decls
:= New_List
(Make_Null_Statement
(Loc
));
467 Set_Declarations
(Unit_Decl
, Decls
);
469 elsif Is_Empty_List
(Decls
) then
470 Append_To
(Decls
, Make_Null_Statement
(Loc
));
474 -- The current unit has an existing anonymous master, traverse its
475 -- declarations and locate the entity.
477 if Has_Anonymous_Master
(Unit_Id
) then
480 Fin_Mas_Id
: Entity_Id
;
483 Decl
:= First
(Decls
);
484 while Present
(Decl
) loop
486 -- Look for the first variable in the declarations whole type
487 -- is Finalization_Master.
489 if Nkind
(Decl
) = N_Object_Declaration
then
490 Fin_Mas_Id
:= Defining_Identifier
(Decl
);
492 if Ekind
(Fin_Mas_Id
) = E_Variable
493 and then Etype
(Fin_Mas_Id
) = RTE
(RE_Finalization_Master
)
502 -- The master was not found even though the unit was labeled as
508 -- Create a new anonymous master
512 First_Decl
: constant Node_Id
:= First
(Decls
);
514 Fin_Mas_Id
: Entity_Id
;
517 -- Since the master and its associated initialization is inserted
518 -- at top level, use the scope of the unit when analyzing.
520 Push_Scope
(Unit_Id
);
522 -- Create the finalization master
525 Make_Defining_Identifier
(Loc
,
526 Chars
=> New_External_Name
(Chars
(Unit_Id
), "AM"));
529 -- <Fin_Mas_Id> : Finalization_Master;
532 Make_Object_Declaration
(Loc
,
533 Defining_Identifier
=> Fin_Mas_Id
,
535 New_Reference_To
(RTE
(RE_Finalization_Master
), Loc
));
537 Insert_Before_And_Analyze
(First_Decl
, Action
);
539 -- Mark the unit to prevent the generation of multiple masters
541 Set_Has_Anonymous_Master
(Unit_Id
);
543 -- Do not set the base pool and mode of operation on .NET/JVM
544 -- since those targets do not support pools and all VM masters
545 -- are heterogeneous by default.
547 if VM_Target
= No_VM
then
551 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
554 Make_Procedure_Call_Statement
(Loc
,
556 New_Reference_To
(RTE
(RE_Set_Base_Pool
), Loc
),
558 Parameter_Associations
=> New_List
(
559 New_Reference_To
(Fin_Mas_Id
, Loc
),
560 Make_Attribute_Reference
(Loc
,
562 New_Reference_To
(RTE
(RE_Global_Pool_Object
), Loc
),
563 Attribute_Name
=> Name_Unrestricted_Access
)));
565 Insert_Before_And_Analyze
(First_Decl
, Action
);
568 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
571 Make_Procedure_Call_Statement
(Loc
,
573 New_Reference_To
(RTE
(RE_Set_Is_Heterogeneous
), Loc
),
574 Parameter_Associations
=> New_List
(
575 New_Reference_To
(Fin_Mas_Id
, Loc
)));
577 Insert_Before_And_Analyze
(First_Decl
, Action
);
580 -- Restore the original state of the scope stack
587 end Current_Anonymous_Master
;
589 --------------------------------
590 -- Displace_Allocator_Pointer --
591 --------------------------------
593 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
594 Loc
: constant Source_Ptr
:= Sloc
(N
);
595 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
601 -- Do nothing in case of VM targets: the virtual machine will handle
602 -- interfaces directly.
604 if not Tagged_Type_Expansion
then
608 pragma Assert
(Nkind
(N
) = N_Identifier
609 and then Nkind
(Orig_Node
) = N_Allocator
);
611 PtrT
:= Etype
(Orig_Node
);
612 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
613 Etyp
:= Etype
(Expression
(Orig_Node
));
615 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
617 -- If the type of the allocator expression is not an interface type
618 -- we can generate code to reference the record component containing
619 -- the pointer to the secondary dispatch table.
621 if not Is_Interface
(Etyp
) then
623 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
626 -- 1) Get access to the allocated object
629 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
633 -- 2) Add the conversion to displace the pointer to reference
634 -- the secondary dispatch table.
636 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
637 Analyze_And_Resolve
(N
, Dtyp
);
639 -- 3) The 'access to the secondary dispatch table will be used
640 -- as the value returned by the allocator.
643 Make_Attribute_Reference
(Loc
,
644 Prefix
=> Relocate_Node
(N
),
645 Attribute_Name
=> Name_Access
));
646 Set_Etype
(N
, Saved_Typ
);
650 -- If the type of the allocator expression is an interface type we
651 -- generate a run-time call to displace "this" to reference the
652 -- component containing the pointer to the secondary dispatch table
653 -- or else raise Constraint_Error if the actual object does not
654 -- implement the target interface. This case corresponds to the
655 -- following example:
657 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
659 -- return new Iface_2'Class'(Obj);
664 Unchecked_Convert_To
(PtrT
,
665 Make_Function_Call
(Loc
,
666 Name
=> New_Reference_To
(RTE
(RE_Displace
), Loc
),
667 Parameter_Associations
=> New_List
(
668 Unchecked_Convert_To
(RTE
(RE_Address
),
674 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
676 Analyze_And_Resolve
(N
, PtrT
);
679 end Displace_Allocator_Pointer
;
681 ---------------------------------
682 -- Expand_Allocator_Expression --
683 ---------------------------------
685 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
686 Loc
: constant Source_Ptr
:= Sloc
(N
);
687 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
688 PtrT
: constant Entity_Id
:= Etype
(N
);
689 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
691 procedure Apply_Accessibility_Check
693 Built_In_Place
: Boolean := False);
694 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
695 -- type, generate an accessibility check to verify that the level of the
696 -- type of the created object is not deeper than the level of the access
697 -- type. If the type of the qualified expression is class-wide, then
698 -- always generate the check (except in the case where it is known to be
699 -- unnecessary, see comment below). Otherwise, only generate the check
700 -- if the level of the qualified expression type is statically deeper
701 -- than the access type.
703 -- Although the static accessibility will generally have been performed
704 -- as a legality check, it won't have been done in cases where the
705 -- allocator appears in generic body, so a run-time check is needed in
706 -- general. One special case is when the access type is declared in the
707 -- same scope as the class-wide allocator, in which case the check can
708 -- never fail, so it need not be generated.
710 -- As an open issue, there seem to be cases where the static level
711 -- associated with the class-wide object's underlying type is not
712 -- sufficient to perform the proper accessibility check, such as for
713 -- allocators in nested subprograms or accept statements initialized by
714 -- class-wide formals when the actual originates outside at a deeper
715 -- static level. The nested subprogram case might require passing
716 -- accessibility levels along with class-wide parameters, and the task
717 -- case seems to be an actual gap in the language rules that needs to
718 -- be fixed by the ARG. ???
720 -------------------------------
721 -- Apply_Accessibility_Check --
722 -------------------------------
724 procedure Apply_Accessibility_Check
726 Built_In_Place
: Boolean := False)
733 if Ada_Version
>= Ada_2005
734 and then Is_Class_Wide_Type
(DesigT
)
735 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
737 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
739 (Is_Class_Wide_Type
(Etype
(Exp
))
740 and then Scope
(PtrT
) /= Current_Scope
))
741 and then (Tagged_Type_Expansion
or else VM_Target
/= No_VM
)
743 -- If the allocator was built in place, Ref is already a reference
744 -- to the access object initialized to the result of the allocator
745 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
746 -- Remove_Side_Effects for cases where the build-in-place call may
747 -- still be the prefix of the reference (to avoid generating
748 -- duplicate calls). Otherwise, it is the entity associated with
749 -- the object containing the address of the allocated object.
751 if Built_In_Place
then
752 Remove_Side_Effects
(Ref
);
753 Obj_Ref
:= New_Copy
(Ref
);
755 Obj_Ref
:= New_Reference_To
(Ref
, Loc
);
758 -- Step 1: Create the object clean up code
762 -- Why don't we free the object ??? discussion and explanation
763 -- needed of why old approach did not work ???
766 -- [Deep_]Finalize (Obj_Ref.all);
768 if Needs_Finalization
(DesigT
) then
772 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
776 -- Signal the accessibility failure through a Program_Error
778 -- Since we may have a storage leak, I would be inclined to
779 -- define a new PE_ code that warns of this possibility where
780 -- the message would be Accessibility_Check_Failed (causing
784 Make_Raise_Program_Error
(Loc
,
785 Condition
=> New_Reference_To
(Standard_True
, Loc
),
786 Reason
=> PE_Accessibility_Check_Failed
));
788 -- Step 2: Create the accessibility comparison
794 Make_Attribute_Reference
(Loc
,
796 Attribute_Name
=> Name_Tag
);
798 -- For tagged types, determine the accessibility level by looking
799 -- at the type specific data of the dispatch table. Generate:
801 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
803 if Tagged_Type_Expansion
then
804 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
806 -- Use a runtime call to determine the accessibility level when
807 -- compiling on virtual machine targets. Generate:
809 -- Get_Access_Level (Ref'Tag)
813 Make_Function_Call
(Loc
,
815 New_Reference_To
(RTE
(RE_Get_Access_Level
), Loc
),
816 Parameter_Associations
=> New_List
(Obj_Ref
));
823 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
825 -- Due to the complexity and side effects of the check, utilize an
826 -- if statement instead of the regular Program_Error circuitry.
829 Make_Implicit_If_Statement
(N
,
831 Then_Statements
=> Stmts
));
833 end Apply_Accessibility_Check
;
837 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
838 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
839 T
: constant Entity_Id
:= Entity
(Indic
);
841 Tag_Assign
: Node_Id
;
845 TagT
: Entity_Id
:= Empty
;
846 -- Type used as source for tag assignment
848 TagR
: Node_Id
:= Empty
;
849 -- Target reference for tag assignment
851 -- Start of processing for Expand_Allocator_Expression
854 -- Handle call to C++ constructor
856 if Is_CPP_Constructor_Call
(Exp
) then
857 Make_CPP_Constructor_Call_In_Allocator
859 Function_Call
=> Exp
);
863 -- In the case of an Ada 2012 allocator whose initial value comes from a
864 -- function call, pass "the accessibility level determined by the point
865 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
866 -- Expand_Call but it couldn't be done there (because the Etype of the
867 -- allocator wasn't set then) so we generate the parameter here. See
868 -- the Boolean variable Defer in (a block within) Expand_Call.
870 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
875 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
876 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
878 Subp
:= Entity
(Name
(Exp
));
881 Subp
:= Ultimate_Alias
(Subp
);
883 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
884 Add_Extra_Actual_To_Call
885 (Subprogram_Call
=> Exp
,
886 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
887 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
892 -- Case of tagged type or type requiring finalization
894 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
896 -- Ada 2005 (AI-318-02): If the initialization expression is a call
897 -- to a build-in-place function, then access to the allocated object
898 -- must be passed to the function. Currently we limit such functions
899 -- to those with constrained limited result subtypes, but eventually
900 -- we plan to expand the allowed forms of functions that are treated
901 -- as build-in-place.
903 if Ada_Version
>= Ada_2005
904 and then Is_Build_In_Place_Function_Call
(Exp
)
906 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
907 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
911 -- Actions inserted before:
912 -- Temp : constant ptr_T := new T'(Expression);
913 -- Temp._tag = T'tag; -- when not class-wide
914 -- [Deep_]Adjust (Temp.all);
916 -- We analyze by hand the new internal allocator to avoid any
917 -- recursion and inappropriate call to Initialize
919 -- We don't want to remove side effects when the expression must be
920 -- built in place. In the case of a build-in-place function call,
921 -- that could lead to a duplication of the call, which was already
922 -- substituted for the allocator.
924 if not Aggr_In_Place
then
925 Remove_Side_Effects
(Exp
);
928 Temp
:= Make_Temporary
(Loc
, 'P', N
);
930 -- For a class wide allocation generate the following code:
932 -- type Equiv_Record is record ... end record;
933 -- implicit subtype CW is <Class_Wide_Subytpe>;
934 -- temp : PtrT := new CW'(CW!(expr));
936 if Is_Class_Wide_Type
(T
) then
937 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
939 -- Ada 2005 (AI-251): If the expression is a class-wide interface
940 -- object we generate code to move up "this" to reference the
941 -- base of the object before allocating the new object.
943 -- Note that Exp'Address is recursively expanded into a call
944 -- to Base_Address (Exp.Tag)
946 if Is_Class_Wide_Type
(Etype
(Exp
))
947 and then Is_Interface
(Etype
(Exp
))
948 and then Tagged_Type_Expansion
952 Unchecked_Convert_To
(Entity
(Indic
),
953 Make_Explicit_Dereference
(Loc
,
954 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
955 Make_Attribute_Reference
(Loc
,
957 Attribute_Name
=> Name_Address
)))));
961 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
964 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
967 -- Processing for allocators returning non-interface types
969 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
970 if Aggr_In_Place
then
972 Make_Object_Declaration
(Loc
,
973 Defining_Identifier
=> Temp
,
974 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
978 New_Reference_To
(Etype
(Exp
), Loc
)));
980 -- Copy the Comes_From_Source flag for the allocator we just
981 -- built, since logically this allocator is a replacement of
982 -- the original allocator node. This is for proper handling of
983 -- restriction No_Implicit_Heap_Allocations.
985 Set_Comes_From_Source
986 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
988 Set_No_Initialization
(Expression
(Temp_Decl
));
989 Insert_Action
(N
, Temp_Decl
);
991 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
992 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
994 -- Attach the object to the associated finalization master.
995 -- This is done manually on .NET/JVM since those compilers do
996 -- no support pools and can't benefit from internally generated
997 -- Allocate / Deallocate procedures.
999 if VM_Target
/= No_VM
1000 and then Is_Controlled
(DesigT
)
1001 and then Present
(Finalization_Master
(PtrT
))
1006 New_Reference_To
(Temp
, Loc
),
1011 Node
:= Relocate_Node
(N
);
1012 Set_Analyzed
(Node
);
1015 Make_Object_Declaration
(Loc
,
1016 Defining_Identifier
=> Temp
,
1017 Constant_Present
=> True,
1018 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1019 Expression
=> Node
);
1021 Insert_Action
(N
, Temp_Decl
);
1022 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1024 -- Attach the object to the associated finalization master.
1025 -- This is done manually on .NET/JVM since those compilers do
1026 -- no support pools and can't benefit from internally generated
1027 -- Allocate / Deallocate procedures.
1029 if VM_Target
/= No_VM
1030 and then Is_Controlled
(DesigT
)
1031 and then Present
(Finalization_Master
(PtrT
))
1036 New_Reference_To
(Temp
, Loc
),
1041 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1042 -- interface type. In this case we use the type of the qualified
1043 -- expression to allocate the object.
1047 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1052 Make_Full_Type_Declaration
(Loc
,
1053 Defining_Identifier
=> Def_Id
,
1055 Make_Access_To_Object_Definition
(Loc
,
1056 All_Present
=> True,
1057 Null_Exclusion_Present
=> False,
1059 Is_Access_Constant
(Etype
(N
)),
1060 Subtype_Indication
=>
1061 New_Reference_To
(Etype
(Exp
), Loc
)));
1063 Insert_Action
(N
, New_Decl
);
1065 -- Inherit the allocation-related attributes from the original
1068 Set_Finalization_Master
(Def_Id
, Finalization_Master
(PtrT
));
1070 Set_Associated_Storage_Pool
(Def_Id
,
1071 Associated_Storage_Pool
(PtrT
));
1073 -- Declare the object using the previous type declaration
1075 if Aggr_In_Place
then
1077 Make_Object_Declaration
(Loc
,
1078 Defining_Identifier
=> Temp
,
1079 Object_Definition
=> New_Reference_To
(Def_Id
, Loc
),
1081 Make_Allocator
(Loc
,
1082 New_Reference_To
(Etype
(Exp
), Loc
)));
1084 -- Copy the Comes_From_Source flag for the allocator we just
1085 -- built, since logically this allocator is a replacement of
1086 -- the original allocator node. This is for proper handling
1087 -- of restriction No_Implicit_Heap_Allocations.
1089 Set_Comes_From_Source
1090 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1092 Set_No_Initialization
(Expression
(Temp_Decl
));
1093 Insert_Action
(N
, Temp_Decl
);
1095 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1096 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1099 Node
:= Relocate_Node
(N
);
1100 Set_Analyzed
(Node
);
1103 Make_Object_Declaration
(Loc
,
1104 Defining_Identifier
=> Temp
,
1105 Constant_Present
=> True,
1106 Object_Definition
=> New_Reference_To
(Def_Id
, Loc
),
1107 Expression
=> Node
);
1109 Insert_Action
(N
, Temp_Decl
);
1110 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1113 -- Generate an additional object containing the address of the
1114 -- returned object. The type of this second object declaration
1115 -- is the correct type required for the common processing that
1116 -- is still performed by this subprogram. The displacement of
1117 -- this pointer to reference the component associated with the
1118 -- interface type will be done at the end of common processing.
1121 Make_Object_Declaration
(Loc
,
1122 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
1123 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1125 Unchecked_Convert_To
(PtrT
,
1126 New_Reference_To
(Temp
, Loc
)));
1128 Insert_Action
(N
, New_Decl
);
1130 Temp_Decl
:= New_Decl
;
1131 Temp
:= Defining_Identifier
(New_Decl
);
1135 Apply_Accessibility_Check
(Temp
);
1137 -- Generate the tag assignment
1139 -- Suppress the tag assignment when VM_Target because VM tags are
1140 -- represented implicitly in objects.
1142 if not Tagged_Type_Expansion
then
1145 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1146 -- interface objects because in this case the tag does not change.
1148 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1149 pragma Assert
(Is_Class_Wide_Type
1150 (Directly_Designated_Type
(Etype
(N
))));
1153 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1155 TagR
:= New_Reference_To
(Temp
, Loc
);
1157 elsif Is_Private_Type
(T
)
1158 and then Is_Tagged_Type
(Underlying_Type
(T
))
1160 TagT
:= Underlying_Type
(T
);
1162 Unchecked_Convert_To
(Underlying_Type
(T
),
1163 Make_Explicit_Dereference
(Loc
,
1164 Prefix
=> New_Reference_To
(Temp
, Loc
)));
1167 if Present
(TagT
) then
1169 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1172 Make_Assignment_Statement
(Loc
,
1174 Make_Selected_Component
(Loc
,
1177 New_Reference_To
(First_Tag_Component
(Full_T
), Loc
)),
1179 Unchecked_Convert_To
(RTE
(RE_Tag
),
1182 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1185 -- The previous assignment has to be done in any case
1187 Set_Assignment_OK
(Name
(Tag_Assign
));
1188 Insert_Action
(N
, Tag_Assign
);
1191 if Needs_Finalization
(DesigT
) and then Needs_Finalization
(T
) then
1193 -- Generate an Adjust call if the object will be moved. In Ada
1194 -- 2005, the object may be inherently limited, in which case
1195 -- there is no Adjust procedure, and the object is built in
1196 -- place. In Ada 95, the object can be limited but not
1197 -- inherently limited if this allocator came from a return
1198 -- statement (we're allocating the result on the secondary
1199 -- stack). In that case, the object will be moved, so we _do_
1202 if not Aggr_In_Place
1203 and then not Is_Immutably_Limited_Type
(T
)
1207 -- An unchecked conversion is needed in the classwide case
1208 -- because the designated type can be an ancestor of the
1209 -- subtype mark of the allocator.
1213 Unchecked_Convert_To
(T
,
1214 Make_Explicit_Dereference
(Loc
,
1215 Prefix
=> New_Reference_To
(Temp
, Loc
))),
1220 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1222 -- Do not generate this call in the following cases:
1224 -- * .NET/JVM - these targets do not support address arithmetic
1225 -- and unchecked conversion, key elements of Finalize_Address.
1227 -- * SPARK mode - the call is useless and results in unwanted
1230 -- * CodePeer mode - TSS primitive Finalize_Address is not
1231 -- created in this mode.
1233 if VM_Target
= No_VM
1234 and then not SPARK_Mode
1235 and then not CodePeer_Mode
1236 and then Present
(Finalization_Master
(PtrT
))
1237 and then Present
(Temp_Decl
)
1238 and then Nkind
(Expression
(Temp_Decl
)) = N_Allocator
1241 Make_Set_Finalize_Address_Call
1248 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1249 Analyze_And_Resolve
(N
, PtrT
);
1251 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1252 -- component containing the secondary dispatch table of the interface
1255 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1256 Displace_Allocator_Pointer
(N
);
1259 elsif Aggr_In_Place
then
1260 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1262 Make_Object_Declaration
(Loc
,
1263 Defining_Identifier
=> Temp
,
1264 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1266 Make_Allocator
(Loc
,
1267 Expression
=> New_Reference_To
(Etype
(Exp
), Loc
)));
1269 -- Copy the Comes_From_Source flag for the allocator we just built,
1270 -- since logically this allocator is a replacement of the original
1271 -- allocator node. This is for proper handling of restriction
1272 -- No_Implicit_Heap_Allocations.
1274 Set_Comes_From_Source
1275 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1277 Set_No_Initialization
(Expression
(Temp_Decl
));
1278 Insert_Action
(N
, Temp_Decl
);
1280 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1281 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1283 -- Attach the object to the associated finalization master. Thisis
1284 -- done manually on .NET/JVM since those compilers do no support
1285 -- pools and cannot benefit from internally generated Allocate and
1286 -- Deallocate procedures.
1288 if VM_Target
/= No_VM
1289 and then Is_Controlled
(DesigT
)
1290 and then Present
(Finalization_Master
(PtrT
))
1294 (Obj_Ref
=> New_Reference_To
(Temp
, Loc
),
1298 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1299 Analyze_And_Resolve
(N
, PtrT
);
1301 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1302 Install_Null_Excluding_Check
(Exp
);
1304 elsif Is_Access_Type
(DesigT
)
1305 and then Nkind
(Exp
) = N_Allocator
1306 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1308 -- Apply constraint to designated subtype indication
1310 Apply_Constraint_Check
(Expression
(Exp
),
1311 Designated_Type
(DesigT
),
1312 No_Sliding
=> True);
1314 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1316 -- Propagate constraint_error to enclosing allocator
1318 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1322 Build_Allocate_Deallocate_Proc
(N
, True);
1325 -- type A is access T1;
1326 -- X : A := new T2'(...);
1327 -- T1 and T2 can be different subtypes, and we might need to check
1328 -- both constraints. First check against the type of the qualified
1331 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1333 if Do_Range_Check
(Exp
) then
1334 Set_Do_Range_Check
(Exp
, False);
1335 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1338 -- A check is also needed in cases where the designated subtype is
1339 -- constrained and differs from the subtype given in the qualified
1340 -- expression. Note that the check on the qualified expression does
1341 -- not allow sliding, but this check does (a relaxation from Ada 83).
1343 if Is_Constrained
(DesigT
)
1344 and then not Subtypes_Statically_Match
(T
, DesigT
)
1346 Apply_Constraint_Check
1347 (Exp
, DesigT
, No_Sliding
=> False);
1349 if Do_Range_Check
(Exp
) then
1350 Set_Do_Range_Check
(Exp
, False);
1351 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1355 -- For an access to unconstrained packed array, GIGI needs to see an
1356 -- expression with a constrained subtype in order to compute the
1357 -- proper size for the allocator.
1359 if Is_Array_Type
(T
)
1360 and then not Is_Constrained
(T
)
1361 and then Is_Packed
(T
)
1364 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1365 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1368 Make_Subtype_Declaration
(Loc
,
1369 Defining_Identifier
=> ConstrT
,
1370 Subtype_Indication
=>
1371 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1372 Freeze_Itype
(ConstrT
, Exp
);
1373 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1377 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1378 -- to a build-in-place function, then access to the allocated object
1379 -- must be passed to the function. Currently we limit such functions
1380 -- to those with constrained limited result subtypes, but eventually
1381 -- we plan to expand the allowed forms of functions that are treated
1382 -- as build-in-place.
1384 if Ada_Version
>= Ada_2005
1385 and then Is_Build_In_Place_Function_Call
(Exp
)
1387 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1392 when RE_Not_Available
=>
1394 end Expand_Allocator_Expression
;
1396 -----------------------------
1397 -- Expand_Array_Comparison --
1398 -----------------------------
1400 -- Expansion is only required in the case of array types. For the unpacked
1401 -- case, an appropriate runtime routine is called. For packed cases, and
1402 -- also in some other cases where a runtime routine cannot be called, the
1403 -- form of the expansion is:
1405 -- [body for greater_nn; boolean_expression]
1407 -- The body is built by Make_Array_Comparison_Op, and the form of the
1408 -- Boolean expression depends on the operator involved.
1410 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1411 Loc
: constant Source_Ptr
:= Sloc
(N
);
1412 Op1
: Node_Id
:= Left_Opnd
(N
);
1413 Op2
: Node_Id
:= Right_Opnd
(N
);
1414 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1415 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1418 Func_Body
: Node_Id
;
1419 Func_Name
: Entity_Id
;
1423 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1424 -- True for byte addressable target
1426 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1427 -- Returns True if the length of the given operand is known to be less
1428 -- than 4. Returns False if this length is known to be four or greater
1429 -- or is not known at compile time.
1431 ------------------------
1432 -- Length_Less_Than_4 --
1433 ------------------------
1435 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1436 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1439 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1440 return String_Literal_Length
(Otyp
) < 4;
1444 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1445 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1446 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1451 if Compile_Time_Known_Value
(Lo
) then
1452 Lov
:= Expr_Value
(Lo
);
1457 if Compile_Time_Known_Value
(Hi
) then
1458 Hiv
:= Expr_Value
(Hi
);
1463 return Hiv
< Lov
+ 3;
1466 end Length_Less_Than_4
;
1468 -- Start of processing for Expand_Array_Comparison
1471 -- Deal first with unpacked case, where we can call a runtime routine
1472 -- except that we avoid this for targets for which are not addressable
1473 -- by bytes, and for the JVM/CIL, since they do not support direct
1474 -- addressing of array components.
1476 if not Is_Bit_Packed_Array
(Typ1
)
1477 and then Byte_Addressable
1478 and then VM_Target
= No_VM
1480 -- The call we generate is:
1482 -- Compare_Array_xn[_Unaligned]
1483 -- (left'address, right'address, left'length, right'length) <op> 0
1485 -- x = U for unsigned, S for signed
1486 -- n = 8,16,32,64 for component size
1487 -- Add _Unaligned if length < 4 and component size is 8.
1488 -- <op> is the standard comparison operator
1490 if Component_Size
(Typ1
) = 8 then
1491 if Length_Less_Than_4
(Op1
)
1493 Length_Less_Than_4
(Op2
)
1495 if Is_Unsigned_Type
(Ctyp
) then
1496 Comp
:= RE_Compare_Array_U8_Unaligned
;
1498 Comp
:= RE_Compare_Array_S8_Unaligned
;
1502 if Is_Unsigned_Type
(Ctyp
) then
1503 Comp
:= RE_Compare_Array_U8
;
1505 Comp
:= RE_Compare_Array_S8
;
1509 elsif Component_Size
(Typ1
) = 16 then
1510 if Is_Unsigned_Type
(Ctyp
) then
1511 Comp
:= RE_Compare_Array_U16
;
1513 Comp
:= RE_Compare_Array_S16
;
1516 elsif Component_Size
(Typ1
) = 32 then
1517 if Is_Unsigned_Type
(Ctyp
) then
1518 Comp
:= RE_Compare_Array_U32
;
1520 Comp
:= RE_Compare_Array_S32
;
1523 else pragma Assert
(Component_Size
(Typ1
) = 64);
1524 if Is_Unsigned_Type
(Ctyp
) then
1525 Comp
:= RE_Compare_Array_U64
;
1527 Comp
:= RE_Compare_Array_S64
;
1531 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1532 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1535 Make_Function_Call
(Sloc
(Op1
),
1536 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1538 Parameter_Associations
=> New_List
(
1539 Make_Attribute_Reference
(Loc
,
1540 Prefix
=> Relocate_Node
(Op1
),
1541 Attribute_Name
=> Name_Address
),
1543 Make_Attribute_Reference
(Loc
,
1544 Prefix
=> Relocate_Node
(Op2
),
1545 Attribute_Name
=> Name_Address
),
1547 Make_Attribute_Reference
(Loc
,
1548 Prefix
=> Relocate_Node
(Op1
),
1549 Attribute_Name
=> Name_Length
),
1551 Make_Attribute_Reference
(Loc
,
1552 Prefix
=> Relocate_Node
(Op2
),
1553 Attribute_Name
=> Name_Length
))));
1556 Make_Integer_Literal
(Sloc
(Op2
),
1559 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1560 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1564 -- Cases where we cannot make runtime call
1566 -- For (a <= b) we convert to not (a > b)
1568 if Chars
(N
) = Name_Op_Le
then
1574 Right_Opnd
=> Op2
)));
1575 Analyze_And_Resolve
(N
, Standard_Boolean
);
1578 -- For < the Boolean expression is
1579 -- greater__nn (op2, op1)
1581 elsif Chars
(N
) = Name_Op_Lt
then
1582 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1586 Op1
:= Right_Opnd
(N
);
1587 Op2
:= Left_Opnd
(N
);
1589 -- For (a >= b) we convert to not (a < b)
1591 elsif Chars
(N
) = Name_Op_Ge
then
1597 Right_Opnd
=> Op2
)));
1598 Analyze_And_Resolve
(N
, Standard_Boolean
);
1601 -- For > the Boolean expression is
1602 -- greater__nn (op1, op2)
1605 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1606 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1609 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1611 Make_Function_Call
(Loc
,
1612 Name
=> New_Reference_To
(Func_Name
, Loc
),
1613 Parameter_Associations
=> New_List
(Op1
, Op2
));
1615 Insert_Action
(N
, Func_Body
);
1617 Analyze_And_Resolve
(N
, Standard_Boolean
);
1620 when RE_Not_Available
=>
1622 end Expand_Array_Comparison
;
1624 ---------------------------
1625 -- Expand_Array_Equality --
1626 ---------------------------
1628 -- Expand an equality function for multi-dimensional arrays. Here is an
1629 -- example of such a function for Nb_Dimension = 2
1631 -- function Enn (A : atyp; B : btyp) return boolean is
1633 -- if (A'length (1) = 0 or else A'length (2) = 0)
1635 -- (B'length (1) = 0 or else B'length (2) = 0)
1637 -- return True; -- RM 4.5.2(22)
1640 -- if A'length (1) /= B'length (1)
1642 -- A'length (2) /= B'length (2)
1644 -- return False; -- RM 4.5.2(23)
1648 -- A1 : Index_T1 := A'first (1);
1649 -- B1 : Index_T1 := B'first (1);
1653 -- A2 : Index_T2 := A'first (2);
1654 -- B2 : Index_T2 := B'first (2);
1657 -- if A (A1, A2) /= B (B1, B2) then
1661 -- exit when A2 = A'last (2);
1662 -- A2 := Index_T2'succ (A2);
1663 -- B2 := Index_T2'succ (B2);
1667 -- exit when A1 = A'last (1);
1668 -- A1 := Index_T1'succ (A1);
1669 -- B1 := Index_T1'succ (B1);
1676 -- Note on the formal types used (atyp and btyp). If either of the arrays
1677 -- is of a private type, we use the underlying type, and do an unchecked
1678 -- conversion of the actual. If either of the arrays has a bound depending
1679 -- on a discriminant, then we use the base type since otherwise we have an
1680 -- escaped discriminant in the function.
1682 -- If both arrays are constrained and have the same bounds, we can generate
1683 -- a loop with an explicit iteration scheme using a 'Range attribute over
1686 function Expand_Array_Equality
1691 Typ
: Entity_Id
) return Node_Id
1693 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1694 Decls
: constant List_Id
:= New_List
;
1695 Index_List1
: constant List_Id
:= New_List
;
1696 Index_List2
: constant List_Id
:= New_List
;
1700 Func_Name
: Entity_Id
;
1701 Func_Body
: Node_Id
;
1703 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1704 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1708 -- The parameter types to be used for the formals
1713 Num
: Int
) return Node_Id
;
1714 -- This builds the attribute reference Arr'Nam (Expr)
1716 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1717 -- Create one statement to compare corresponding components, designated
1718 -- by a full set of indexes.
1720 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1721 -- Given one of the arguments, computes the appropriate type to be used
1722 -- for that argument in the corresponding function formal
1724 function Handle_One_Dimension
1726 Index
: Node_Id
) return Node_Id
;
1727 -- This procedure returns the following code
1730 -- Bn : Index_T := B'First (N);
1734 -- exit when An = A'Last (N);
1735 -- An := Index_T'Succ (An)
1736 -- Bn := Index_T'Succ (Bn)
1740 -- If both indexes are constrained and identical, the procedure
1741 -- returns a simpler loop:
1743 -- for An in A'Range (N) loop
1747 -- N is the dimension for which we are generating a loop. Index is the
1748 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1749 -- xxx statement is either the loop or declare for the next dimension
1750 -- or if this is the last dimension the comparison of corresponding
1751 -- components of the arrays.
1753 -- The actual way the code works is to return the comparison of
1754 -- corresponding components for the N+1 call. That's neater!
1756 function Test_Empty_Arrays
return Node_Id
;
1757 -- This function constructs the test for both arrays being empty
1758 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1760 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1762 function Test_Lengths_Correspond
return Node_Id
;
1763 -- This function constructs the test for arrays having different lengths
1764 -- in at least one index position, in which case the resulting code is:
1766 -- A'length (1) /= B'length (1)
1768 -- A'length (2) /= B'length (2)
1779 Num
: Int
) return Node_Id
1783 Make_Attribute_Reference
(Loc
,
1784 Attribute_Name
=> Nam
,
1785 Prefix
=> New_Reference_To
(Arr
, Loc
),
1786 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1789 ------------------------
1790 -- Component_Equality --
1791 ------------------------
1793 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1798 -- if a(i1...) /= b(j1...) then return false; end if;
1801 Make_Indexed_Component
(Loc
,
1802 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1803 Expressions
=> Index_List1
);
1806 Make_Indexed_Component
(Loc
,
1807 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1808 Expressions
=> Index_List2
);
1810 Test
:= Expand_Composite_Equality
1811 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1813 -- If some (sub)component is an unchecked_union, the whole operation
1814 -- will raise program error.
1816 if Nkind
(Test
) = N_Raise_Program_Error
then
1818 -- This node is going to be inserted at a location where a
1819 -- statement is expected: clear its Etype so analysis will set
1820 -- it to the expected Standard_Void_Type.
1822 Set_Etype
(Test
, Empty
);
1827 Make_Implicit_If_Statement
(Nod
,
1828 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1829 Then_Statements
=> New_List
(
1830 Make_Simple_Return_Statement
(Loc
,
1831 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1833 end Component_Equality
;
1839 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1850 T
:= Underlying_Type
(T
);
1852 X
:= First_Index
(T
);
1853 while Present
(X
) loop
1854 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1856 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1869 --------------------------
1870 -- Handle_One_Dimension --
1871 ---------------------------
1873 function Handle_One_Dimension
1875 Index
: Node_Id
) return Node_Id
1877 Need_Separate_Indexes
: constant Boolean :=
1878 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1879 -- If the index types are identical, and we are working with
1880 -- constrained types, then we can use the same index for both
1883 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1886 Index_T
: Entity_Id
;
1891 if N
> Number_Dimensions
(Ltyp
) then
1892 return Component_Equality
(Ltyp
);
1895 -- Case where we generate a loop
1897 Index_T
:= Base_Type
(Etype
(Index
));
1899 if Need_Separate_Indexes
then
1900 Bn
:= Make_Temporary
(Loc
, 'B');
1905 Append
(New_Reference_To
(An
, Loc
), Index_List1
);
1906 Append
(New_Reference_To
(Bn
, Loc
), Index_List2
);
1908 Stm_List
:= New_List
(
1909 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1911 if Need_Separate_Indexes
then
1913 -- Generate guard for loop, followed by increments of indexes
1915 Append_To
(Stm_List
,
1916 Make_Exit_Statement
(Loc
,
1919 Left_Opnd
=> New_Reference_To
(An
, Loc
),
1920 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1922 Append_To
(Stm_List
,
1923 Make_Assignment_Statement
(Loc
,
1924 Name
=> New_Reference_To
(An
, Loc
),
1926 Make_Attribute_Reference
(Loc
,
1927 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1928 Attribute_Name
=> Name_Succ
,
1929 Expressions
=> New_List
(New_Reference_To
(An
, Loc
)))));
1931 Append_To
(Stm_List
,
1932 Make_Assignment_Statement
(Loc
,
1933 Name
=> New_Reference_To
(Bn
, Loc
),
1935 Make_Attribute_Reference
(Loc
,
1936 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1937 Attribute_Name
=> Name_Succ
,
1938 Expressions
=> New_List
(New_Reference_To
(Bn
, Loc
)))));
1941 -- If separate indexes, we need a declare block for An and Bn, and a
1942 -- loop without an iteration scheme.
1944 if Need_Separate_Indexes
then
1946 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1949 Make_Block_Statement
(Loc
,
1950 Declarations
=> New_List
(
1951 Make_Object_Declaration
(Loc
,
1952 Defining_Identifier
=> An
,
1953 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1954 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1956 Make_Object_Declaration
(Loc
,
1957 Defining_Identifier
=> Bn
,
1958 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1959 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1961 Handled_Statement_Sequence
=>
1962 Make_Handled_Sequence_Of_Statements
(Loc
,
1963 Statements
=> New_List
(Loop_Stm
)));
1965 -- If no separate indexes, return loop statement with explicit
1966 -- iteration scheme on its own
1970 Make_Implicit_Loop_Statement
(Nod
,
1971 Statements
=> Stm_List
,
1973 Make_Iteration_Scheme
(Loc
,
1974 Loop_Parameter_Specification
=>
1975 Make_Loop_Parameter_Specification
(Loc
,
1976 Defining_Identifier
=> An
,
1977 Discrete_Subtype_Definition
=>
1978 Arr_Attr
(A
, Name_Range
, N
))));
1981 end Handle_One_Dimension
;
1983 -----------------------
1984 -- Test_Empty_Arrays --
1985 -----------------------
1987 function Test_Empty_Arrays
return Node_Id
is
1997 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2000 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2001 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2005 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
2006 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2015 Left_Opnd
=> Relocate_Node
(Alist
),
2016 Right_Opnd
=> Atest
);
2020 Left_Opnd
=> Relocate_Node
(Blist
),
2021 Right_Opnd
=> Btest
);
2028 Right_Opnd
=> Blist
);
2029 end Test_Empty_Arrays
;
2031 -----------------------------
2032 -- Test_Lengths_Correspond --
2033 -----------------------------
2035 function Test_Lengths_Correspond
return Node_Id
is
2041 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2044 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2045 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
2052 Left_Opnd
=> Relocate_Node
(Result
),
2053 Right_Opnd
=> Rtest
);
2058 end Test_Lengths_Correspond
;
2060 -- Start of processing for Expand_Array_Equality
2063 Ltyp
:= Get_Arg_Type
(Lhs
);
2064 Rtyp
:= Get_Arg_Type
(Rhs
);
2066 -- For now, if the argument types are not the same, go to the base type,
2067 -- since the code assumes that the formals have the same type. This is
2068 -- fixable in future ???
2070 if Ltyp
/= Rtyp
then
2071 Ltyp
:= Base_Type
(Ltyp
);
2072 Rtyp
:= Base_Type
(Rtyp
);
2073 pragma Assert
(Ltyp
= Rtyp
);
2076 -- Build list of formals for function
2078 Formals
:= New_List
(
2079 Make_Parameter_Specification
(Loc
,
2080 Defining_Identifier
=> A
,
2081 Parameter_Type
=> New_Reference_To
(Ltyp
, Loc
)),
2083 Make_Parameter_Specification
(Loc
,
2084 Defining_Identifier
=> B
,
2085 Parameter_Type
=> New_Reference_To
(Rtyp
, Loc
)));
2087 Func_Name
:= Make_Temporary
(Loc
, 'E');
2089 -- Build statement sequence for function
2092 Make_Subprogram_Body
(Loc
,
2094 Make_Function_Specification
(Loc
,
2095 Defining_Unit_Name
=> Func_Name
,
2096 Parameter_Specifications
=> Formals
,
2097 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
2099 Declarations
=> Decls
,
2101 Handled_Statement_Sequence
=>
2102 Make_Handled_Sequence_Of_Statements
(Loc
,
2103 Statements
=> New_List
(
2105 Make_Implicit_If_Statement
(Nod
,
2106 Condition
=> Test_Empty_Arrays
,
2107 Then_Statements
=> New_List
(
2108 Make_Simple_Return_Statement
(Loc
,
2110 New_Occurrence_Of
(Standard_True
, Loc
)))),
2112 Make_Implicit_If_Statement
(Nod
,
2113 Condition
=> Test_Lengths_Correspond
,
2114 Then_Statements
=> New_List
(
2115 Make_Simple_Return_Statement
(Loc
,
2117 New_Occurrence_Of
(Standard_False
, Loc
)))),
2119 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
2121 Make_Simple_Return_Statement
(Loc
,
2122 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2124 Set_Has_Completion
(Func_Name
, True);
2125 Set_Is_Inlined
(Func_Name
);
2127 -- If the array type is distinct from the type of the arguments, it
2128 -- is the full view of a private type. Apply an unchecked conversion
2129 -- to insure that analysis of the call succeeds.
2139 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
2141 L
:= OK_Convert_To
(Ltyp
, Lhs
);
2145 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
2147 R
:= OK_Convert_To
(Rtyp
, Rhs
);
2150 Actuals
:= New_List
(L
, R
);
2153 Append_To
(Bodies
, Func_Body
);
2156 Make_Function_Call
(Loc
,
2157 Name
=> New_Reference_To
(Func_Name
, Loc
),
2158 Parameter_Associations
=> Actuals
);
2159 end Expand_Array_Equality
;
2161 -----------------------------
2162 -- Expand_Boolean_Operator --
2163 -----------------------------
2165 -- Note that we first get the actual subtypes of the operands, since we
2166 -- always want to deal with types that have bounds.
2168 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2169 Typ
: constant Entity_Id
:= Etype
(N
);
2172 -- Special case of bit packed array where both operands are known to be
2173 -- properly aligned. In this case we use an efficient run time routine
2174 -- to carry out the operation (see System.Bit_Ops).
2176 if Is_Bit_Packed_Array
(Typ
)
2177 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2178 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2180 Expand_Packed_Boolean_Operator
(N
);
2184 -- For the normal non-packed case, the general expansion is to build
2185 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2186 -- and then inserting it into the tree. The original operator node is
2187 -- then rewritten as a call to this function. We also use this in the
2188 -- packed case if either operand is a possibly unaligned object.
2191 Loc
: constant Source_Ptr
:= Sloc
(N
);
2192 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2193 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2194 Func_Body
: Node_Id
;
2195 Func_Name
: Entity_Id
;
2198 Convert_To_Actual_Subtype
(L
);
2199 Convert_To_Actual_Subtype
(R
);
2200 Ensure_Defined
(Etype
(L
), N
);
2201 Ensure_Defined
(Etype
(R
), N
);
2202 Apply_Length_Check
(R
, Etype
(L
));
2204 if Nkind
(N
) = N_Op_Xor
then
2205 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2208 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2209 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2211 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2213 elsif Nkind
(Parent
(N
)) = N_Op_Not
2214 and then Nkind
(N
) = N_Op_And
2216 Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2221 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2222 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2223 Insert_Action
(N
, Func_Body
);
2225 -- Now rewrite the expression with a call
2228 Make_Function_Call
(Loc
,
2229 Name
=> New_Reference_To
(Func_Name
, Loc
),
2230 Parameter_Associations
=>
2233 Make_Type_Conversion
2234 (Loc
, New_Reference_To
(Etype
(L
), Loc
), R
))));
2236 Analyze_And_Resolve
(N
, Typ
);
2239 end Expand_Boolean_Operator
;
2241 ------------------------------------------------
2242 -- Expand_Compare_Minimize_Eliminate_Overflow --
2243 ------------------------------------------------
2245 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2246 Loc
: constant Source_Ptr
:= Sloc
(N
);
2248 Result_Type
: constant Entity_Id
:= Etype
(N
);
2249 -- Capture result type (could be a derived boolean type)
2254 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2255 -- Entity for Long_Long_Integer'Base
2257 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2258 -- Current overflow checking mode
2261 procedure Set_False
;
2262 -- These procedures rewrite N with an occurrence of Standard_True or
2263 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2269 procedure Set_False
is
2271 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2272 Warn_On_Known_Condition
(N
);
2279 procedure Set_True
is
2281 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2282 Warn_On_Known_Condition
(N
);
2285 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2288 -- Nothing to do unless we have a comparison operator with operands
2289 -- that are signed integer types, and we are operating in either
2290 -- MINIMIZED or ELIMINATED overflow checking mode.
2292 if Nkind
(N
) not in N_Op_Compare
2293 or else Check
not in Minimized_Or_Eliminated
2294 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2299 -- OK, this is the case we are interested in. First step is to process
2300 -- our operands using the Minimize_Eliminate circuitry which applies
2301 -- this processing to the two operand subtrees.
2303 Minimize_Eliminate_Overflows
2304 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2305 Minimize_Eliminate_Overflows
2306 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2308 -- See if the range information decides the result of the comparison.
2309 -- We can only do this if we in fact have full range information (which
2310 -- won't be the case if either operand is bignum at this stage).
2312 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2313 case N_Op_Compare
(Nkind
(N
)) is
2315 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2317 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2324 elsif Lhi
< Rlo
then
2331 elsif Lhi
<= Rlo
then
2338 elsif Lhi
<= Rlo
then
2345 elsif Lhi
< Rlo
then
2350 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2352 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2357 -- All done if we did the rewrite
2359 if Nkind
(N
) not in N_Op_Compare
then
2364 -- Otherwise, time to do the comparison
2367 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2368 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2371 -- If the two operands have the same signed integer type we are
2372 -- all set, nothing more to do. This is the case where either
2373 -- both operands were unchanged, or we rewrote both of them to
2374 -- be Long_Long_Integer.
2376 -- Note: Entity for the comparison may be wrong, but it's not worth
2377 -- the effort to change it, since the back end does not use it.
2379 if Is_Signed_Integer_Type
(Ltype
)
2380 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2384 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2386 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2388 Left
: Node_Id
:= Left_Opnd
(N
);
2389 Right
: Node_Id
:= Right_Opnd
(N
);
2390 -- Bignum references for left and right operands
2393 if not Is_RTE
(Ltype
, RE_Bignum
) then
2394 Left
:= Convert_To_Bignum
(Left
);
2395 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2396 Right
:= Convert_To_Bignum
(Right
);
2399 -- We rewrite our node with:
2402 -- Bnn : Result_Type;
2404 -- M : Mark_Id := SS_Mark;
2406 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2414 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2415 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2419 case N_Op_Compare
(Nkind
(N
)) is
2420 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2421 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2422 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2423 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2424 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2425 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2428 -- Insert assignment to Bnn into the bignum block
2431 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2432 Make_Assignment_Statement
(Loc
,
2433 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2435 Make_Function_Call
(Loc
,
2437 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2438 Parameter_Associations
=> New_List
(Left
, Right
))));
2440 -- Now do the rewrite with expression actions
2443 Make_Expression_With_Actions
(Loc
,
2444 Actions
=> New_List
(
2445 Make_Object_Declaration
(Loc
,
2446 Defining_Identifier
=> Bnn
,
2447 Object_Definition
=>
2448 New_Occurrence_Of
(Result_Type
, Loc
)),
2450 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2451 Analyze_And_Resolve
(N
, Result_Type
);
2455 -- No bignums involved, but types are different, so we must have
2456 -- rewritten one of the operands as a Long_Long_Integer but not
2459 -- If left operand is Long_Long_Integer, convert right operand
2460 -- and we are done (with a comparison of two Long_Long_Integers).
2462 elsif Ltype
= LLIB
then
2463 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2464 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2467 -- If right operand is Long_Long_Integer, convert left operand
2468 -- and we are done (with a comparison of two Long_Long_Integers).
2470 -- This is the only remaining possibility
2472 else pragma Assert
(Rtype
= LLIB
);
2473 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2474 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2478 end Expand_Compare_Minimize_Eliminate_Overflow
;
2480 -------------------------------
2481 -- Expand_Composite_Equality --
2482 -------------------------------
2484 -- This function is only called for comparing internal fields of composite
2485 -- types when these fields are themselves composites. This is a special
2486 -- case because it is not possible to respect normal Ada visibility rules.
2488 function Expand_Composite_Equality
2493 Bodies
: List_Id
) return Node_Id
2495 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2496 Full_Type
: Entity_Id
;
2500 function Find_Primitive_Eq
return Node_Id
;
2501 -- AI05-0123: Locate primitive equality for type if it exists, and
2502 -- build the corresponding call. If operation is abstract, replace
2503 -- call with an explicit raise. Return Empty if there is no primitive.
2505 -----------------------
2506 -- Find_Primitive_Eq --
2507 -----------------------
2509 function Find_Primitive_Eq
return Node_Id
is
2514 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2515 while Present
(Prim_E
) loop
2516 Prim
:= Node
(Prim_E
);
2518 -- Locate primitive equality with the right signature
2520 if Chars
(Prim
) = Name_Op_Eq
2521 and then Etype
(First_Formal
(Prim
)) =
2522 Etype
(Next_Formal
(First_Formal
(Prim
)))
2523 and then Etype
(Prim
) = Standard_Boolean
2525 if Is_Abstract_Subprogram
(Prim
) then
2527 Make_Raise_Program_Error
(Loc
,
2528 Reason
=> PE_Explicit_Raise
);
2532 Make_Function_Call
(Loc
,
2533 Name
=> New_Reference_To
(Prim
, Loc
),
2534 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2541 -- If not found, predefined operation will be used
2544 end Find_Primitive_Eq
;
2546 -- Start of processing for Expand_Composite_Equality
2549 if Is_Private_Type
(Typ
) then
2550 Full_Type
:= Underlying_Type
(Typ
);
2555 -- If the private type has no completion the context may be the
2556 -- expansion of a composite equality for a composite type with some
2557 -- still incomplete components. The expression will not be analyzed
2558 -- until the enclosing type is completed, at which point this will be
2559 -- properly expanded, unless there is a bona fide completion error.
2561 if No
(Full_Type
) then
2562 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2565 Full_Type
:= Base_Type
(Full_Type
);
2567 -- When the base type itself is private, use the full view to expand
2568 -- the composite equality.
2570 if Is_Private_Type
(Full_Type
) then
2571 Full_Type
:= Underlying_Type
(Full_Type
);
2574 -- Case of array types
2576 if Is_Array_Type
(Full_Type
) then
2578 -- If the operand is an elementary type other than a floating-point
2579 -- type, then we can simply use the built-in block bitwise equality,
2580 -- since the predefined equality operators always apply and bitwise
2581 -- equality is fine for all these cases.
2583 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2584 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2586 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2588 -- For composite component types, and floating-point types, use the
2589 -- expansion. This deals with tagged component types (where we use
2590 -- the applicable equality routine) and floating-point, (where we
2591 -- need to worry about negative zeroes), and also the case of any
2592 -- composite type recursively containing such fields.
2595 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2598 -- Case of tagged record types
2600 elsif Is_Tagged_Type
(Full_Type
) then
2602 -- Call the primitive operation "=" of this type
2604 if Is_Class_Wide_Type
(Full_Type
) then
2605 Full_Type
:= Root_Type
(Full_Type
);
2608 -- If this is derived from an untagged private type completed with a
2609 -- tagged type, it does not have a full view, so we use the primitive
2610 -- operations of the private type. This check should no longer be
2611 -- necessary when these types receive their full views ???
2613 if Is_Private_Type
(Typ
)
2614 and then not Is_Tagged_Type
(Typ
)
2615 and then not Is_Controlled
(Typ
)
2616 and then Is_Derived_Type
(Typ
)
2617 and then No
(Full_View
(Typ
))
2619 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2621 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2625 Eq_Op
:= Node
(Prim
);
2626 exit when Chars
(Eq_Op
) = Name_Op_Eq
2627 and then Etype
(First_Formal
(Eq_Op
)) =
2628 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2629 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2631 pragma Assert
(Present
(Prim
));
2634 Eq_Op
:= Node
(Prim
);
2637 Make_Function_Call
(Loc
,
2638 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2639 Parameter_Associations
=>
2641 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2642 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2644 -- Case of untagged record types
2646 elsif Is_Record_Type
(Full_Type
) then
2647 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2649 if Present
(Eq_Op
) then
2650 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2652 -- Inherited equality from parent type. Convert the actuals to
2653 -- match signature of operation.
2656 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2660 Make_Function_Call
(Loc
,
2661 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2662 Parameter_Associations
=> New_List
(
2663 OK_Convert_To
(T
, Lhs
),
2664 OK_Convert_To
(T
, Rhs
)));
2668 -- Comparison between Unchecked_Union components
2670 if Is_Unchecked_Union
(Full_Type
) then
2672 Lhs_Type
: Node_Id
:= Full_Type
;
2673 Rhs_Type
: Node_Id
:= Full_Type
;
2674 Lhs_Discr_Val
: Node_Id
;
2675 Rhs_Discr_Val
: Node_Id
;
2680 if Nkind
(Lhs
) = N_Selected_Component
then
2681 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2686 if Nkind
(Rhs
) = N_Selected_Component
then
2687 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2690 -- Lhs of the composite equality
2692 if Is_Constrained
(Lhs_Type
) then
2694 -- Since the enclosing record type can never be an
2695 -- Unchecked_Union (this code is executed for records
2696 -- that do not have variants), we may reference its
2699 if Nkind
(Lhs
) = N_Selected_Component
2700 and then Has_Per_Object_Constraint
2701 (Entity
(Selector_Name
(Lhs
)))
2704 Make_Selected_Component
(Loc
,
2705 Prefix
=> Prefix
(Lhs
),
2708 (Get_Discriminant_Value
2709 (First_Discriminant
(Lhs_Type
),
2711 Stored_Constraint
(Lhs_Type
))));
2716 (Get_Discriminant_Value
2717 (First_Discriminant
(Lhs_Type
),
2719 Stored_Constraint
(Lhs_Type
)));
2723 -- It is not possible to infer the discriminant since
2724 -- the subtype is not constrained.
2727 Make_Raise_Program_Error
(Loc
,
2728 Reason
=> PE_Unchecked_Union_Restriction
);
2731 -- Rhs of the composite equality
2733 if Is_Constrained
(Rhs_Type
) then
2734 if Nkind
(Rhs
) = N_Selected_Component
2735 and then Has_Per_Object_Constraint
2736 (Entity
(Selector_Name
(Rhs
)))
2739 Make_Selected_Component
(Loc
,
2740 Prefix
=> Prefix
(Rhs
),
2743 (Get_Discriminant_Value
2744 (First_Discriminant
(Rhs_Type
),
2746 Stored_Constraint
(Rhs_Type
))));
2751 (Get_Discriminant_Value
2752 (First_Discriminant
(Rhs_Type
),
2754 Stored_Constraint
(Rhs_Type
)));
2759 Make_Raise_Program_Error
(Loc
,
2760 Reason
=> PE_Unchecked_Union_Restriction
);
2763 -- Call the TSS equality function with the inferred
2764 -- discriminant values.
2767 Make_Function_Call
(Loc
,
2768 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2769 Parameter_Associations
=> New_List
(
2778 Make_Function_Call
(Loc
,
2779 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2780 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2784 -- Equality composes in Ada 2012 for untagged record types. It also
2785 -- composes for bounded strings, because they are part of the
2786 -- predefined environment. We could make it compose for bounded
2787 -- strings by making them tagged, or by making sure all subcomponents
2788 -- are set to the same value, even when not used. Instead, we have
2789 -- this special case in the compiler, because it's more efficient.
2791 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2793 -- If no TSS has been created for the type, check whether there is
2794 -- a primitive equality declared for it.
2797 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2800 -- Use user-defined primitive if it exists, otherwise use
2801 -- predefined equality.
2803 if Present
(Op
) then
2806 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2811 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2814 -- Non-composite types (always use predefined equality)
2817 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2819 end Expand_Composite_Equality
;
2821 ------------------------
2822 -- Expand_Concatenate --
2823 ------------------------
2825 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2826 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2828 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2829 -- Result type of concatenation
2831 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2832 -- Component type. Elements of this component type can appear as one
2833 -- of the operands of concatenation as well as arrays.
2835 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2838 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2839 -- Index type. This is the base type of the index subtype, and is used
2840 -- for all computed bounds (which may be out of range of Istyp in the
2841 -- case of null ranges).
2844 -- This is the type we use to do arithmetic to compute the bounds and
2845 -- lengths of operands. The choice of this type is a little subtle and
2846 -- is discussed in a separate section at the start of the body code.
2848 Concatenation_Error
: exception;
2849 -- Raised if concatenation is sure to raise a CE
2851 Result_May_Be_Null
: Boolean := True;
2852 -- Reset to False if at least one operand is encountered which is known
2853 -- at compile time to be non-null. Used for handling the special case
2854 -- of setting the high bound to the last operand high bound for a null
2855 -- result, thus ensuring a proper high bound in the super-flat case.
2857 N
: constant Nat
:= List_Length
(Opnds
);
2858 -- Number of concatenation operands including possibly null operands
2861 -- Number of operands excluding any known to be null, except that the
2862 -- last operand is always retained, in case it provides the bounds for
2866 -- Current operand being processed in the loop through operands. After
2867 -- this loop is complete, always contains the last operand (which is not
2868 -- the same as Operands (NN), since null operands are skipped).
2870 -- Arrays describing the operands, only the first NN entries of each
2871 -- array are set (NN < N when we exclude known null operands).
2873 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2874 -- True if length of corresponding operand known at compile time
2876 Operands
: array (1 .. N
) of Node_Id
;
2877 -- Set to the corresponding entry in the Opnds list (but note that null
2878 -- operands are excluded, so not all entries in the list are stored).
2880 Fixed_Length
: array (1 .. N
) of Uint
;
2881 -- Set to length of operand. Entries in this array are set only if the
2882 -- corresponding entry in Is_Fixed_Length is True.
2884 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2885 -- Set to lower bound of operand. Either an integer literal in the case
2886 -- where the bound is known at compile time, else actual lower bound.
2887 -- The operand low bound is of type Ityp.
2889 Var_Length
: array (1 .. N
) of Entity_Id
;
2890 -- Set to an entity of type Natural that contains the length of an
2891 -- operand whose length is not known at compile time. Entries in this
2892 -- array are set only if the corresponding entry in Is_Fixed_Length
2893 -- is False. The entity is of type Artyp.
2895 Aggr_Length
: array (0 .. N
) of Node_Id
;
2896 -- The J'th entry in an expression node that represents the total length
2897 -- of operands 1 through J. It is either an integer literal node, or a
2898 -- reference to a constant entity with the right value, so it is fine
2899 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2900 -- entry always is set to zero. The length is of type Artyp.
2902 Low_Bound
: Node_Id
;
2903 -- A tree node representing the low bound of the result (of type Ityp).
2904 -- This is either an integer literal node, or an identifier reference to
2905 -- a constant entity initialized to the appropriate value.
2907 Last_Opnd_Low_Bound
: Node_Id
;
2908 -- A tree node representing the low bound of the last operand. This
2909 -- need only be set if the result could be null. It is used for the
2910 -- special case of setting the right low bound for a null result.
2911 -- This is of type Ityp.
2913 Last_Opnd_High_Bound
: Node_Id
;
2914 -- A tree node representing the high bound of the last operand. This
2915 -- need only be set if the result could be null. It is used for the
2916 -- special case of setting the right high bound for a null result.
2917 -- This is of type Ityp.
2919 High_Bound
: Node_Id
;
2920 -- A tree node representing the high bound of the result (of type Ityp)
2923 -- Result of the concatenation (of type Ityp)
2925 Actions
: constant List_Id
:= New_List
;
2926 -- Collect actions to be inserted
2928 Known_Non_Null_Operand_Seen
: Boolean;
2929 -- Set True during generation of the assignments of operands into
2930 -- result once an operand known to be non-null has been seen.
2932 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2933 -- This function makes an N_Integer_Literal node that is returned in
2934 -- analyzed form with the type set to Artyp. Importantly this literal
2935 -- is not flagged as static, so that if we do computations with it that
2936 -- result in statically detected out of range conditions, we will not
2937 -- generate error messages but instead warning messages.
2939 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2940 -- Given a node of type Ityp, returns the corresponding value of type
2941 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2942 -- For enum types, the Pos of the value is returned.
2944 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2945 -- The inverse function (uses Val in the case of enumeration types)
2947 ------------------------
2948 -- Make_Artyp_Literal --
2949 ------------------------
2951 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2952 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2954 Set_Etype
(Result
, Artyp
);
2955 Set_Analyzed
(Result
, True);
2956 Set_Is_Static_Expression
(Result
, False);
2958 end Make_Artyp_Literal
;
2964 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2966 if Ityp
= Base_Type
(Artyp
) then
2969 elsif Is_Enumeration_Type
(Ityp
) then
2971 Make_Attribute_Reference
(Loc
,
2972 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2973 Attribute_Name
=> Name_Pos
,
2974 Expressions
=> New_List
(X
));
2977 return Convert_To
(Artyp
, X
);
2985 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2987 if Is_Enumeration_Type
(Ityp
) then
2989 Make_Attribute_Reference
(Loc
,
2990 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2991 Attribute_Name
=> Name_Val
,
2992 Expressions
=> New_List
(X
));
2994 -- Case where we will do a type conversion
2997 if Ityp
= Base_Type
(Artyp
) then
3000 return Convert_To
(Ityp
, X
);
3005 -- Local Declarations
3007 Opnd_Typ
: Entity_Id
;
3014 -- Start of processing for Expand_Concatenate
3017 -- Choose an appropriate computational type
3019 -- We will be doing calculations of lengths and bounds in this routine
3020 -- and computing one from the other in some cases, e.g. getting the high
3021 -- bound by adding the length-1 to the low bound.
3023 -- We can't just use the index type, or even its base type for this
3024 -- purpose for two reasons. First it might be an enumeration type which
3025 -- is not suitable for computations of any kind, and second it may
3026 -- simply not have enough range. For example if the index type is
3027 -- -128..+127 then lengths can be up to 256, which is out of range of
3030 -- For enumeration types, we can simply use Standard_Integer, this is
3031 -- sufficient since the actual number of enumeration literals cannot
3032 -- possibly exceed the range of integer (remember we will be doing the
3033 -- arithmetic with POS values, not representation values).
3035 if Is_Enumeration_Type
(Ityp
) then
3036 Artyp
:= Standard_Integer
;
3038 -- If index type is Positive, we use the standard unsigned type, to give
3039 -- more room on the top of the range, obviating the need for an overflow
3040 -- check when creating the upper bound. This is needed to avoid junk
3041 -- overflow checks in the common case of String types.
3043 -- ??? Disabled for now
3045 -- elsif Istyp = Standard_Positive then
3046 -- Artyp := Standard_Unsigned;
3048 -- For modular types, we use a 32-bit modular type for types whose size
3049 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3050 -- identity type, and for larger unsigned types we use 64-bits.
3052 elsif Is_Modular_Integer_Type
(Ityp
) then
3053 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
3054 Artyp
:= Standard_Unsigned
;
3055 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
3058 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
3061 -- Similar treatment for signed types
3064 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
3065 Artyp
:= Standard_Integer
;
3066 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
3069 Artyp
:= Standard_Long_Long_Integer
;
3073 -- Supply dummy entry at start of length array
3075 Aggr_Length
(0) := Make_Artyp_Literal
(0);
3077 -- Go through operands setting up the above arrays
3081 Opnd
:= Remove_Head
(Opnds
);
3082 Opnd_Typ
:= Etype
(Opnd
);
3084 -- The parent got messed up when we put the operands in a list,
3085 -- so now put back the proper parent for the saved operand, that
3086 -- is to say the concatenation node, to make sure that each operand
3087 -- is seen as a subexpression, e.g. if actions must be inserted.
3089 Set_Parent
(Opnd
, Cnode
);
3091 -- Set will be True when we have setup one entry in the array
3095 -- Singleton element (or character literal) case
3097 if Base_Type
(Opnd_Typ
) = Ctyp
then
3099 Operands
(NN
) := Opnd
;
3100 Is_Fixed_Length
(NN
) := True;
3101 Fixed_Length
(NN
) := Uint_1
;
3102 Result_May_Be_Null
:= False;
3104 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3105 -- since we know that the result cannot be null).
3107 Opnd_Low_Bound
(NN
) :=
3108 Make_Attribute_Reference
(Loc
,
3109 Prefix
=> New_Reference_To
(Istyp
, Loc
),
3110 Attribute_Name
=> Name_First
);
3114 -- String literal case (can only occur for strings of course)
3116 elsif Nkind
(Opnd
) = N_String_Literal
then
3117 Len
:= String_Literal_Length
(Opnd_Typ
);
3120 Result_May_Be_Null
:= False;
3123 -- Capture last operand low and high bound if result could be null
3125 if J
= N
and then Result_May_Be_Null
then
3126 Last_Opnd_Low_Bound
:=
3127 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3129 Last_Opnd_High_Bound
:=
3130 Make_Op_Subtract
(Loc
,
3132 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3133 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3136 -- Skip null string literal
3138 if J
< N
and then Len
= 0 then
3143 Operands
(NN
) := Opnd
;
3144 Is_Fixed_Length
(NN
) := True;
3146 -- Set length and bounds
3148 Fixed_Length
(NN
) := Len
;
3150 Opnd_Low_Bound
(NN
) :=
3151 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3158 -- Check constrained case with known bounds
3160 if Is_Constrained
(Opnd_Typ
) then
3162 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3163 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3164 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3165 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3168 -- Fixed length constrained array type with known at compile
3169 -- time bounds is last case of fixed length operand.
3171 if Compile_Time_Known_Value
(Lo
)
3173 Compile_Time_Known_Value
(Hi
)
3176 Loval
: constant Uint
:= Expr_Value
(Lo
);
3177 Hival
: constant Uint
:= Expr_Value
(Hi
);
3178 Len
: constant Uint
:=
3179 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3183 Result_May_Be_Null
:= False;
3186 -- Capture last operand bounds if result could be null
3188 if J
= N
and then Result_May_Be_Null
then
3189 Last_Opnd_Low_Bound
:=
3191 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3193 Last_Opnd_High_Bound
:=
3195 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3198 -- Exclude null length case unless last operand
3200 if J
< N
and then Len
= 0 then
3205 Operands
(NN
) := Opnd
;
3206 Is_Fixed_Length
(NN
) := True;
3207 Fixed_Length
(NN
) := Len
;
3209 Opnd_Low_Bound
(NN
) :=
3211 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3218 -- All cases where the length is not known at compile time, or the
3219 -- special case of an operand which is known to be null but has a
3220 -- lower bound other than 1 or is other than a string type.
3225 -- Capture operand bounds
3227 Opnd_Low_Bound
(NN
) :=
3228 Make_Attribute_Reference
(Loc
,
3230 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3231 Attribute_Name
=> Name_First
);
3233 -- Capture last operand bounds if result could be null
3235 if J
= N
and Result_May_Be_Null
then
3236 Last_Opnd_Low_Bound
:=
3238 Make_Attribute_Reference
(Loc
,
3240 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3241 Attribute_Name
=> Name_First
));
3243 Last_Opnd_High_Bound
:=
3245 Make_Attribute_Reference
(Loc
,
3247 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3248 Attribute_Name
=> Name_Last
));
3251 -- Capture length of operand in entity
3253 Operands
(NN
) := Opnd
;
3254 Is_Fixed_Length
(NN
) := False;
3256 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3259 Make_Object_Declaration
(Loc
,
3260 Defining_Identifier
=> Var_Length
(NN
),
3261 Constant_Present
=> True,
3262 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3264 Make_Attribute_Reference
(Loc
,
3266 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3267 Attribute_Name
=> Name_Length
)));
3271 -- Set next entry in aggregate length array
3273 -- For first entry, make either integer literal for fixed length
3274 -- or a reference to the saved length for variable length.
3277 if Is_Fixed_Length
(1) then
3278 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3280 Aggr_Length
(1) := New_Reference_To
(Var_Length
(1), Loc
);
3283 -- If entry is fixed length and only fixed lengths so far, make
3284 -- appropriate new integer literal adding new length.
3286 elsif Is_Fixed_Length
(NN
)
3287 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3290 Make_Integer_Literal
(Loc
,
3291 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3293 -- All other cases, construct an addition node for the length and
3294 -- create an entity initialized to this length.
3297 Ent
:= Make_Temporary
(Loc
, 'L');
3299 if Is_Fixed_Length
(NN
) then
3300 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3302 Clen
:= New_Reference_To
(Var_Length
(NN
), Loc
);
3306 Make_Object_Declaration
(Loc
,
3307 Defining_Identifier
=> Ent
,
3308 Constant_Present
=> True,
3309 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3312 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
3313 Right_Opnd
=> Clen
)));
3315 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3322 -- If we have only skipped null operands, return the last operand
3329 -- If we have only one non-null operand, return it and we are done.
3330 -- There is one case in which this cannot be done, and that is when
3331 -- the sole operand is of the element type, in which case it must be
3332 -- converted to an array, and the easiest way of doing that is to go
3333 -- through the normal general circuit.
3335 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3336 Result
:= Operands
(1);
3340 -- Cases where we have a real concatenation
3342 -- Next step is to find the low bound for the result array that we
3343 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3345 -- If the ultimate ancestor of the index subtype is a constrained array
3346 -- definition, then the lower bound is that of the index subtype as
3347 -- specified by (RM 4.5.3(6)).
3349 -- The right test here is to go to the root type, and then the ultimate
3350 -- ancestor is the first subtype of this root type.
3352 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3354 Make_Attribute_Reference
(Loc
,
3356 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3357 Attribute_Name
=> Name_First
);
3359 -- If the first operand in the list has known length we know that
3360 -- the lower bound of the result is the lower bound of this operand.
3362 elsif Is_Fixed_Length
(1) then
3363 Low_Bound
:= Opnd_Low_Bound
(1);
3365 -- OK, we don't know the lower bound, we have to build a horrible
3366 -- if expression node of the form
3368 -- if Cond1'Length /= 0 then
3371 -- if Opnd2'Length /= 0 then
3376 -- The nesting ends either when we hit an operand whose length is known
3377 -- at compile time, or on reaching the last operand, whose low bound we
3378 -- take unconditionally whether or not it is null. It's easiest to do
3379 -- this with a recursive procedure:
3383 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3384 -- Returns the lower bound determined by operands J .. NN
3386 ---------------------
3387 -- Get_Known_Bound --
3388 ---------------------
3390 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3392 if Is_Fixed_Length
(J
) or else J
= NN
then
3393 return New_Copy
(Opnd_Low_Bound
(J
));
3397 Make_If_Expression
(Loc
,
3398 Expressions
=> New_List
(
3401 Left_Opnd
=> New_Reference_To
(Var_Length
(J
), Loc
),
3402 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3404 New_Copy
(Opnd_Low_Bound
(J
)),
3405 Get_Known_Bound
(J
+ 1)));
3407 end Get_Known_Bound
;
3410 Ent
:= Make_Temporary
(Loc
, 'L');
3413 Make_Object_Declaration
(Loc
,
3414 Defining_Identifier
=> Ent
,
3415 Constant_Present
=> True,
3416 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3417 Expression
=> Get_Known_Bound
(1)));
3419 Low_Bound
:= New_Reference_To
(Ent
, Loc
);
3423 -- Now we can safely compute the upper bound, normally
3424 -- Low_Bound + Length - 1.
3429 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3431 Make_Op_Subtract
(Loc
,
3432 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3433 Right_Opnd
=> Make_Artyp_Literal
(1))));
3435 -- Note that calculation of the high bound may cause overflow in some
3436 -- very weird cases, so in the general case we need an overflow check on
3437 -- the high bound. We can avoid this for the common case of string types
3438 -- and other types whose index is Positive, since we chose a wider range
3439 -- for the arithmetic type.
3441 if Istyp
/= Standard_Positive
then
3442 Activate_Overflow_Check
(High_Bound
);
3445 -- Handle the exceptional case where the result is null, in which case
3446 -- case the bounds come from the last operand (so that we get the proper
3447 -- bounds if the last operand is super-flat).
3449 if Result_May_Be_Null
then
3451 Make_If_Expression
(Loc
,
3452 Expressions
=> New_List
(
3454 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3455 Right_Opnd
=> Make_Artyp_Literal
(0)),
3456 Last_Opnd_Low_Bound
,
3460 Make_If_Expression
(Loc
,
3461 Expressions
=> New_List
(
3463 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3464 Right_Opnd
=> Make_Artyp_Literal
(0)),
3465 Last_Opnd_High_Bound
,
3469 -- Here is where we insert the saved up actions
3471 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3473 -- Now we construct an array object with appropriate bounds. We mark
3474 -- the target as internal to prevent useless initialization when
3475 -- Initialize_Scalars is enabled. Also since this is the actual result
3476 -- entity, we make sure we have debug information for the result.
3478 Ent
:= Make_Temporary
(Loc
, 'S');
3479 Set_Is_Internal
(Ent
);
3480 Set_Needs_Debug_Info
(Ent
);
3482 -- If the bound is statically known to be out of range, we do not want
3483 -- to abort, we want a warning and a runtime constraint error. Note that
3484 -- we have arranged that the result will not be treated as a static
3485 -- constant, so we won't get an illegality during this insertion.
3487 Insert_Action
(Cnode
,
3488 Make_Object_Declaration
(Loc
,
3489 Defining_Identifier
=> Ent
,
3490 Object_Definition
=>
3491 Make_Subtype_Indication
(Loc
,
3492 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3494 Make_Index_Or_Discriminant_Constraint
(Loc
,
3495 Constraints
=> New_List
(
3497 Low_Bound
=> Low_Bound
,
3498 High_Bound
=> High_Bound
))))),
3499 Suppress
=> All_Checks
);
3501 -- If the result of the concatenation appears as the initializing
3502 -- expression of an object declaration, we can just rename the
3503 -- result, rather than copying it.
3505 Set_OK_To_Rename
(Ent
);
3507 -- Catch the static out of range case now
3509 if Raises_Constraint_Error
(High_Bound
) then
3510 raise Concatenation_Error
;
3513 -- Now we will generate the assignments to do the actual concatenation
3515 -- There is one case in which we will not do this, namely when all the
3516 -- following conditions are met:
3518 -- The result type is Standard.String
3520 -- There are nine or fewer retained (non-null) operands
3522 -- The optimization level is -O0
3524 -- The corresponding System.Concat_n.Str_Concat_n routine is
3525 -- available in the run time.
3527 -- The debug flag gnatd.c is not set
3529 -- If all these conditions are met then we generate a call to the
3530 -- relevant concatenation routine. The purpose of this is to avoid
3531 -- undesirable code bloat at -O0.
3533 if Atyp
= Standard_String
3534 and then NN
in 2 .. 9
3535 and then (Opt
.Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3536 and then not Debug_Flag_Dot_C
3539 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3550 if RTE_Available
(RR
(NN
)) then
3552 Opnds
: constant List_Id
:=
3553 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3556 for J
in 1 .. NN
loop
3557 if Is_List_Member
(Operands
(J
)) then
3558 Remove
(Operands
(J
));
3561 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3563 Make_Aggregate
(Loc
,
3564 Component_Associations
=> New_List
(
3565 Make_Component_Association
(Loc
,
3566 Choices
=> New_List
(
3567 Make_Integer_Literal
(Loc
, 1)),
3568 Expression
=> Operands
(J
)))));
3571 Append_To
(Opnds
, Operands
(J
));
3575 Insert_Action
(Cnode
,
3576 Make_Procedure_Call_Statement
(Loc
,
3577 Name
=> New_Reference_To
(RTE
(RR
(NN
)), Loc
),
3578 Parameter_Associations
=> Opnds
));
3580 Result
:= New_Reference_To
(Ent
, Loc
);
3587 -- Not special case so generate the assignments
3589 Known_Non_Null_Operand_Seen
:= False;
3591 for J
in 1 .. NN
loop
3593 Lo
: constant Node_Id
:=
3595 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3596 Right_Opnd
=> Aggr_Length
(J
- 1));
3598 Hi
: constant Node_Id
:=
3600 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3602 Make_Op_Subtract
(Loc
,
3603 Left_Opnd
=> Aggr_Length
(J
),
3604 Right_Opnd
=> Make_Artyp_Literal
(1)));
3607 -- Singleton case, simple assignment
3609 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3610 Known_Non_Null_Operand_Seen
:= True;
3611 Insert_Action
(Cnode
,
3612 Make_Assignment_Statement
(Loc
,
3614 Make_Indexed_Component
(Loc
,
3615 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3616 Expressions
=> New_List
(To_Ityp
(Lo
))),
3617 Expression
=> Operands
(J
)),
3618 Suppress
=> All_Checks
);
3620 -- Array case, slice assignment, skipped when argument is fixed
3621 -- length and known to be null.
3623 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3626 Make_Assignment_Statement
(Loc
,
3630 New_Occurrence_Of
(Ent
, Loc
),
3633 Low_Bound
=> To_Ityp
(Lo
),
3634 High_Bound
=> To_Ityp
(Hi
))),
3635 Expression
=> Operands
(J
));
3637 if Is_Fixed_Length
(J
) then
3638 Known_Non_Null_Operand_Seen
:= True;
3640 elsif not Known_Non_Null_Operand_Seen
then
3642 -- Here if operand length is not statically known and no
3643 -- operand known to be non-null has been processed yet.
3644 -- If operand length is 0, we do not need to perform the
3645 -- assignment, and we must avoid the evaluation of the
3646 -- high bound of the slice, since it may underflow if the
3647 -- low bound is Ityp'First.
3650 Make_Implicit_If_Statement
(Cnode
,
3654 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3655 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3656 Then_Statements
=> New_List
(Assign
));
3659 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3665 -- Finally we build the result, which is a reference to the array object
3667 Result
:= New_Reference_To
(Ent
, Loc
);
3670 Rewrite
(Cnode
, Result
);
3671 Analyze_And_Resolve
(Cnode
, Atyp
);
3674 when Concatenation_Error
=>
3676 -- Kill warning generated for the declaration of the static out of
3677 -- range high bound, and instead generate a Constraint_Error with
3678 -- an appropriate specific message.
3680 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3681 Apply_Compile_Time_Constraint_Error
3683 Msg
=> "concatenation result upper bound out of range??",
3684 Reason
=> CE_Range_Check_Failed
);
3685 end Expand_Concatenate
;
3687 ---------------------------------------------------
3688 -- Expand_Membership_Minimize_Eliminate_Overflow --
3689 ---------------------------------------------------
3691 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3692 pragma Assert
(Nkind
(N
) = N_In
);
3693 -- Despite the name, this routine applies only to N_In, not to
3694 -- N_Not_In. The latter is always rewritten as not (X in Y).
3696 Result_Type
: constant Entity_Id
:= Etype
(N
);
3697 -- Capture result type, may be a derived boolean type
3699 Loc
: constant Source_Ptr
:= Sloc
(N
);
3700 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3701 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3703 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3704 -- is thus tempting to capture these values, but due to the rewrites
3705 -- that occur as a result of overflow checking, these values change
3706 -- as we go along, and it is safe just to always use Etype explicitly.
3708 Restype
: constant Entity_Id
:= Etype
(N
);
3712 -- Bounds in Minimize calls, not used currently
3714 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3715 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3718 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3720 -- If right operand is a subtype name, and the subtype name has no
3721 -- predicate, then we can just replace the right operand with an
3722 -- explicit range T'First .. T'Last, and use the explicit range code.
3724 if Nkind
(Rop
) /= N_Range
3725 and then No
(Predicate_Function
(Etype
(Rop
)))
3728 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3733 Make_Attribute_Reference
(Loc
,
3734 Attribute_Name
=> Name_First
,
3735 Prefix
=> New_Reference_To
(Rtyp
, Loc
)),
3737 Make_Attribute_Reference
(Loc
,
3738 Attribute_Name
=> Name_Last
,
3739 Prefix
=> New_Reference_To
(Rtyp
, Loc
))));
3740 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3744 -- Here for the explicit range case. Note that the bounds of the range
3745 -- have not been processed for minimized or eliminated checks.
3747 if Nkind
(Rop
) = N_Range
then
3748 Minimize_Eliminate_Overflows
3749 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3750 Minimize_Eliminate_Overflows
3751 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3753 -- We have A in B .. C, treated as A >= B and then A <= C
3757 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3758 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3759 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3762 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3763 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3764 L
: constant Entity_Id
:=
3765 Make_Defining_Identifier
(Loc
, Name_uL
);
3766 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3767 Lbound
: constant Node_Id
:=
3768 Convert_To_Bignum
(Low_Bound
(Rop
));
3769 Hbound
: constant Node_Id
:=
3770 Convert_To_Bignum
(High_Bound
(Rop
));
3772 -- Now we rewrite the membership test node to look like
3775 -- Bnn : Result_Type;
3777 -- M : Mark_Id := SS_Mark;
3778 -- L : Bignum := Lopnd;
3780 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3788 -- Insert declaration of L into declarations of bignum block
3791 (Last
(Declarations
(Blk
)),
3792 Make_Object_Declaration
(Loc
,
3793 Defining_Identifier
=> L
,
3794 Object_Definition
=>
3795 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3796 Expression
=> Lopnd
));
3798 -- Insert assignment to Bnn into expressions of bignum block
3801 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3802 Make_Assignment_Statement
(Loc
,
3803 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3807 Make_Function_Call
(Loc
,
3809 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3810 Parameter_Associations
=> New_List
(
3811 New_Occurrence_Of
(L
, Loc
),
3814 Make_Function_Call
(Loc
,
3816 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3817 Parameter_Associations
=> New_List
(
3818 New_Occurrence_Of
(L
, Loc
),
3821 -- Now rewrite the node
3824 Make_Expression_With_Actions
(Loc
,
3825 Actions
=> New_List
(
3826 Make_Object_Declaration
(Loc
,
3827 Defining_Identifier
=> Bnn
,
3828 Object_Definition
=>
3829 New_Occurrence_Of
(Result_Type
, Loc
)),
3831 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3832 Analyze_And_Resolve
(N
, Result_Type
);
3836 -- Here if no bignums around
3839 -- Case where types are all the same
3841 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3843 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3847 -- If types are not all the same, it means that we have rewritten
3848 -- at least one of them to be of type Long_Long_Integer, and we
3849 -- will convert the other operands to Long_Long_Integer.
3852 Convert_To_And_Rewrite
(LLIB
, Lop
);
3853 Set_Analyzed
(Lop
, False);
3854 Analyze_And_Resolve
(Lop
, LLIB
);
3856 -- For the right operand, avoid unnecessary recursion into
3857 -- this routine, we know that overflow is not possible.
3859 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3860 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3861 Set_Analyzed
(Rop
, False);
3862 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3865 -- Now the three operands are of the same signed integer type,
3866 -- so we can use the normal expansion routine for membership,
3867 -- setting the flag to prevent recursion into this procedure.
3869 Set_No_Minimize_Eliminate
(N
);
3873 -- Right operand is a subtype name and the subtype has a predicate. We
3874 -- have to make sure the predicate is checked, and for that we need to
3875 -- use the standard N_In circuitry with appropriate types.
3878 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3880 -- If types are "right", just call Expand_N_In preventing recursion
3882 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3883 Set_No_Minimize_Eliminate
(N
);
3888 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3890 -- For X in T, we want to rewrite our node as
3893 -- Bnn : Result_Type;
3896 -- M : Mark_Id := SS_Mark;
3897 -- Lnn : Long_Long_Integer'Base
3903 -- if not Bignum_In_LLI_Range (Nnn) then
3906 -- Lnn := From_Bignum (Nnn);
3908 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3909 -- and then T'Base (Lnn) in T;
3918 -- A bit gruesome, but there doesn't seem to be a simpler way
3921 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3922 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3923 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3924 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3925 T
: constant Entity_Id
:= Etype
(Rop
);
3926 TB
: constant Entity_Id
:= Base_Type
(T
);
3930 -- Mark the last membership operation to prevent recursion
3934 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3935 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3936 Set_No_Minimize_Eliminate
(Nin
);
3938 -- Now decorate the block
3941 (Last
(Declarations
(Blk
)),
3942 Make_Object_Declaration
(Loc
,
3943 Defining_Identifier
=> Lnn
,
3944 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3947 (Last
(Declarations
(Blk
)),
3948 Make_Object_Declaration
(Loc
,
3949 Defining_Identifier
=> Nnn
,
3950 Object_Definition
=>
3951 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3954 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3956 Make_Assignment_Statement
(Loc
,
3957 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3958 Expression
=> Relocate_Node
(Lop
)),
3960 Make_Implicit_If_Statement
(N
,
3964 Make_Function_Call
(Loc
,
3967 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3968 Parameter_Associations
=> New_List
(
3969 New_Occurrence_Of
(Nnn
, Loc
)))),
3971 Then_Statements
=> New_List
(
3972 Make_Assignment_Statement
(Loc
,
3973 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3975 New_Occurrence_Of
(Standard_False
, Loc
))),
3977 Else_Statements
=> New_List
(
3978 Make_Assignment_Statement
(Loc
,
3979 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3981 Make_Function_Call
(Loc
,
3983 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3984 Parameter_Associations
=> New_List
(
3985 New_Occurrence_Of
(Nnn
, Loc
)))),
3987 Make_Assignment_Statement
(Loc
,
3988 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3993 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3998 Make_Attribute_Reference
(Loc
,
3999 Attribute_Name
=> Name_First
,
4001 New_Occurrence_Of
(TB
, Loc
))),
4005 Make_Attribute_Reference
(Loc
,
4006 Attribute_Name
=> Name_Last
,
4008 New_Occurrence_Of
(TB
, Loc
))))),
4010 Right_Opnd
=> Nin
))))));
4012 -- Now we can do the rewrite
4015 Make_Expression_With_Actions
(Loc
,
4016 Actions
=> New_List
(
4017 Make_Object_Declaration
(Loc
,
4018 Defining_Identifier
=> Bnn
,
4019 Object_Definition
=>
4020 New_Occurrence_Of
(Result_Type
, Loc
)),
4022 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
4023 Analyze_And_Resolve
(N
, Result_Type
);
4027 -- Not bignum case, but types don't match (this means we rewrote the
4028 -- left operand to be Long_Long_Integer).
4031 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
4033 -- We rewrite the membership test as (where T is the type with
4034 -- the predicate, i.e. the type of the right operand)
4036 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4037 -- and then T'Base (Lop) in T
4040 T
: constant Entity_Id
:= Etype
(Rop
);
4041 TB
: constant Entity_Id
:= Base_Type
(T
);
4045 -- The last membership test is marked to prevent recursion
4049 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
4050 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4051 Set_No_Minimize_Eliminate
(Nin
);
4053 -- Now do the rewrite
4064 Make_Attribute_Reference
(Loc
,
4065 Attribute_Name
=> Name_First
,
4066 Prefix
=> New_Occurrence_Of
(TB
, Loc
))),
4069 Make_Attribute_Reference
(Loc
,
4070 Attribute_Name
=> Name_Last
,
4071 Prefix
=> New_Occurrence_Of
(TB
, Loc
))))),
4072 Right_Opnd
=> Nin
));
4073 Set_Analyzed
(N
, False);
4074 Analyze_And_Resolve
(N
, Restype
);
4078 end Expand_Membership_Minimize_Eliminate_Overflow
;
4080 ------------------------
4081 -- Expand_N_Allocator --
4082 ------------------------
4084 procedure Expand_N_Allocator
(N
: Node_Id
) is
4085 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4086 Loc
: constant Source_Ptr
:= Sloc
(N
);
4087 PtrT
: constant Entity_Id
:= Etype
(N
);
4089 procedure Rewrite_Coextension
(N
: Node_Id
);
4090 -- Static coextensions have the same lifetime as the entity they
4091 -- constrain. Such occurrences can be rewritten as aliased objects
4092 -- and their unrestricted access used instead of the coextension.
4094 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4095 -- Given a constrained array type E, returns a node representing the
4096 -- code to compute the size in storage elements for the given type.
4097 -- This is done without using the attribute (which malfunctions for
4100 -------------------------
4101 -- Rewrite_Coextension --
4102 -------------------------
4104 procedure Rewrite_Coextension
(N
: Node_Id
) is
4105 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4106 Temp_Decl
: Node_Id
;
4110 -- Cnn : aliased Etyp;
4113 Make_Object_Declaration
(Loc
,
4114 Defining_Identifier
=> Temp_Id
,
4115 Aliased_Present
=> True,
4116 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4118 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4119 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4122 Insert_Action
(N
, Temp_Decl
);
4124 Make_Attribute_Reference
(Loc
,
4125 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4126 Attribute_Name
=> Name_Unrestricted_Access
));
4128 Analyze_And_Resolve
(N
, PtrT
);
4129 end Rewrite_Coextension
;
4131 ------------------------------
4132 -- Size_In_Storage_Elements --
4133 ------------------------------
4135 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4137 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4138 -- However, the reason for the existence of this function is
4139 -- to construct a test for sizes too large, which means near the
4140 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4141 -- is that we get overflows when sizes are greater than 2**31.
4143 -- So what we end up doing for array types is to use the expression:
4145 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4147 -- which avoids this problem. All this is a bit bogus, but it does
4148 -- mean we catch common cases of trying to allocate arrays that
4149 -- are too large, and which in the absence of a check results in
4150 -- undetected chaos ???
4152 -- Note in particular that this is a pessimistic estimate in the
4153 -- case of packed array types, where an array element might occupy
4154 -- just a fraction of a storage element???
4161 for J
in 1 .. Number_Dimensions
(E
) loop
4163 Make_Attribute_Reference
(Loc
,
4164 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4165 Attribute_Name
=> Name_Length
,
4166 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4173 Make_Op_Multiply
(Loc
,
4180 Make_Op_Multiply
(Loc
,
4183 Make_Attribute_Reference
(Loc
,
4184 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4185 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4187 end Size_In_Storage_Elements
;
4191 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4195 Rel_Typ
: Entity_Id
;
4198 -- Start of processing for Expand_N_Allocator
4201 -- RM E.2.3(22). We enforce that the expected type of an allocator
4202 -- shall not be a remote access-to-class-wide-limited-private type
4204 -- Why is this being done at expansion time, seems clearly wrong ???
4206 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4208 -- Processing for anonymous access-to-controlled types. These access
4209 -- types receive a special finalization master which appears in the
4210 -- declarations of the enclosing semantic unit. This expansion is done
4211 -- now to ensure that any additional types generated by this routine or
4212 -- Expand_Allocator_Expression inherit the proper type attributes.
4214 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4215 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4216 and then Needs_Finalization
(Dtyp
)
4218 -- Detect the allocation of an anonymous controlled object where the
4219 -- type of the context is named. For example:
4221 -- procedure Proc (Ptr : Named_Access_Typ);
4222 -- Proc (new Designated_Typ);
4224 -- Regardless of the anonymous-to-named access type conversion, the
4225 -- lifetime of the object must be associated with the named access
4226 -- type. Use the finalization-related attributes of this type.
4228 if Nkind_In
(Parent
(N
), N_Type_Conversion
,
4229 N_Unchecked_Type_Conversion
)
4230 and then Ekind_In
(Etype
(Parent
(N
)), E_Access_Subtype
,
4232 E_General_Access_Type
)
4234 Rel_Typ
:= Etype
(Parent
(N
));
4239 -- Anonymous access-to-controlled types allocate on the global pool.
4240 -- Do not set this attribute on .NET/JVM since those targets do not
4243 if No
(Associated_Storage_Pool
(PtrT
)) and then VM_Target
= No_VM
then
4244 if Present
(Rel_Typ
) then
4245 Set_Associated_Storage_Pool
(PtrT
,
4246 Associated_Storage_Pool
(Rel_Typ
));
4248 Set_Associated_Storage_Pool
(PtrT
,
4249 Get_Global_Pool_For_Access_Type
(PtrT
));
4253 -- The finalization master must be inserted and analyzed as part of
4254 -- the current semantic unit. This form of expansion is not carried
4255 -- out in SPARK mode because it is useless. Note that the master is
4256 -- updated when analysis changes current units.
4258 if not SPARK_Mode
then
4259 if Present
(Rel_Typ
) then
4260 Set_Finalization_Master
(PtrT
, Finalization_Master
(Rel_Typ
));
4262 Set_Finalization_Master
(PtrT
, Current_Anonymous_Master
);
4267 -- Set the storage pool and find the appropriate version of Allocate to
4268 -- call. Do not overwrite the storage pool if it is already set, which
4269 -- can happen for build-in-place function returns (see
4270 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4272 if No
(Storage_Pool
(N
)) then
4273 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4275 if Present
(Pool
) then
4276 Set_Storage_Pool
(N
, Pool
);
4278 if Is_RTE
(Pool
, RE_SS_Pool
) then
4279 if VM_Target
= No_VM
then
4280 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4283 -- In the case of an allocator for a simple storage pool, locate
4284 -- and save a reference to the pool type's Allocate routine.
4286 elsif Present
(Get_Rep_Pragma
4287 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4290 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4291 Alloc_Op
: Entity_Id
;
4293 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4294 while Present
(Alloc_Op
) loop
4295 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4296 and then Present
(First_Formal
(Alloc_Op
))
4297 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4299 Set_Procedure_To_Call
(N
, Alloc_Op
);
4302 Alloc_Op
:= Homonym
(Alloc_Op
);
4307 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4308 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4311 Set_Procedure_To_Call
(N
,
4312 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4317 -- Under certain circumstances we can replace an allocator by an access
4318 -- to statically allocated storage. The conditions, as noted in AARM
4319 -- 3.10 (10c) are as follows:
4321 -- Size and initial value is known at compile time
4322 -- Access type is access-to-constant
4324 -- The allocator is not part of a constraint on a record component,
4325 -- because in that case the inserted actions are delayed until the
4326 -- record declaration is fully analyzed, which is too late for the
4327 -- analysis of the rewritten allocator.
4329 if Is_Access_Constant
(PtrT
)
4330 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4331 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4332 and then Size_Known_At_Compile_Time
4333 (Etype
(Expression
(Expression
(N
))))
4334 and then not Is_Record_Type
(Current_Scope
)
4336 -- Here we can do the optimization. For the allocator
4340 -- We insert an object declaration
4342 -- Tnn : aliased x := y;
4344 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4345 -- marked as requiring static allocation.
4347 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4348 Desig
:= Subtype_Mark
(Expression
(N
));
4350 -- If context is constrained, use constrained subtype directly,
4351 -- so that the constant is not labelled as having a nominally
4352 -- unconstrained subtype.
4354 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4355 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4359 Make_Object_Declaration
(Loc
,
4360 Defining_Identifier
=> Temp
,
4361 Aliased_Present
=> True,
4362 Constant_Present
=> Is_Access_Constant
(PtrT
),
4363 Object_Definition
=> Desig
,
4364 Expression
=> Expression
(Expression
(N
))));
4367 Make_Attribute_Reference
(Loc
,
4368 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4369 Attribute_Name
=> Name_Unrestricted_Access
));
4371 Analyze_And_Resolve
(N
, PtrT
);
4373 -- We set the variable as statically allocated, since we don't want
4374 -- it going on the stack of the current procedure!
4376 Set_Is_Statically_Allocated
(Temp
);
4380 -- Same if the allocator is an access discriminant for a local object:
4381 -- instead of an allocator we create a local value and constrain the
4382 -- enclosing object with the corresponding access attribute.
4384 if Is_Static_Coextension
(N
) then
4385 Rewrite_Coextension
(N
);
4389 -- Check for size too large, we do this because the back end misses
4390 -- proper checks here and can generate rubbish allocation calls when
4391 -- we are near the limit. We only do this for the 32-bit address case
4392 -- since that is from a practical point of view where we see a problem.
4394 if System_Address_Size
= 32
4395 and then not Storage_Checks_Suppressed
(PtrT
)
4396 and then not Storage_Checks_Suppressed
(Dtyp
)
4397 and then not Storage_Checks_Suppressed
(Etyp
)
4399 -- The check we want to generate should look like
4401 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4402 -- raise Storage_Error;
4405 -- where 3.5 gigabytes is a constant large enough to accommodate any
4406 -- reasonable request for. But we can't do it this way because at
4407 -- least at the moment we don't compute this attribute right, and
4408 -- can silently give wrong results when the result gets large. Since
4409 -- this is all about large results, that's bad, so instead we only
4410 -- apply the check for constrained arrays, and manually compute the
4411 -- value of the attribute ???
4413 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4415 Make_Raise_Storage_Error
(Loc
,
4418 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4420 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4421 Reason
=> SE_Object_Too_Large
));
4425 -- Handle case of qualified expression (other than optimization above)
4426 -- First apply constraint checks, because the bounds or discriminants
4427 -- in the aggregate might not match the subtype mark in the allocator.
4429 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4430 Apply_Constraint_Check
4431 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
4433 Expand_Allocator_Expression
(N
);
4437 -- If the allocator is for a type which requires initialization, and
4438 -- there is no initial value (i.e. operand is a subtype indication
4439 -- rather than a qualified expression), then we must generate a call to
4440 -- the initialization routine using an expressions action node:
4442 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4444 -- Here ptr_T is the pointer type for the allocator, and T is the
4445 -- subtype of the allocator. A special case arises if the designated
4446 -- type of the access type is a task or contains tasks. In this case
4447 -- the call to Init (Temp.all ...) is replaced by code that ensures
4448 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4449 -- for details). In addition, if the type T is a task T, then the
4450 -- first argument to Init must be converted to the task record type.
4453 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4459 Init_Arg1
: Node_Id
;
4460 Temp_Decl
: Node_Id
;
4461 Temp_Type
: Entity_Id
;
4464 if No_Initialization
(N
) then
4466 -- Even though this might be a simple allocation, create a custom
4467 -- Allocate if the context requires it. Since .NET/JVM compilers
4468 -- do not support pools, this step is skipped.
4470 if VM_Target
= No_VM
4471 and then Present
(Finalization_Master
(PtrT
))
4473 Build_Allocate_Deallocate_Proc
4475 Is_Allocate
=> True);
4478 -- Case of no initialization procedure present
4480 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4482 -- Case of simple initialization required
4484 if Needs_Simple_Initialization
(T
) then
4485 Check_Restriction
(No_Default_Initialization
, N
);
4486 Rewrite
(Expression
(N
),
4487 Make_Qualified_Expression
(Loc
,
4488 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4489 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4491 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4492 Analyze_And_Resolve
(Expression
(N
), T
);
4493 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4494 Expand_N_Allocator
(N
);
4496 -- No initialization required
4502 -- Case of initialization procedure present, must be called
4505 Check_Restriction
(No_Default_Initialization
, N
);
4507 if not Restriction_Active
(No_Default_Initialization
) then
4508 Init
:= Base_Init_Proc
(T
);
4510 Temp
:= Make_Temporary
(Loc
, 'P');
4512 -- Construct argument list for the initialization routine call
4515 Make_Explicit_Dereference
(Loc
,
4517 New_Reference_To
(Temp
, Loc
));
4519 Set_Assignment_OK
(Init_Arg1
);
4522 -- The initialization procedure expects a specific type. if the
4523 -- context is access to class wide, indicate that the object
4524 -- being allocated has the right specific type.
4526 if Is_Class_Wide_Type
(Dtyp
) then
4527 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4530 -- If designated type is a concurrent type or if it is private
4531 -- type whose definition is a concurrent type, the first
4532 -- argument in the Init routine has to be unchecked conversion
4533 -- to the corresponding record type. If the designated type is
4534 -- a derived type, also convert the argument to its root type.
4536 if Is_Concurrent_Type
(T
) then
4538 Unchecked_Convert_To
(
4539 Corresponding_Record_Type
(T
), Init_Arg1
);
4541 elsif Is_Private_Type
(T
)
4542 and then Present
(Full_View
(T
))
4543 and then Is_Concurrent_Type
(Full_View
(T
))
4546 Unchecked_Convert_To
4547 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4549 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4551 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4554 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4555 Set_Etype
(Init_Arg1
, Ftyp
);
4559 Args
:= New_List
(Init_Arg1
);
4561 -- For the task case, pass the Master_Id of the access type as
4562 -- the value of the _Master parameter, and _Chain as the value
4563 -- of the _Chain parameter (_Chain will be defined as part of
4564 -- the generated code for the allocator).
4566 -- In Ada 2005, the context may be a function that returns an
4567 -- anonymous access type. In that case the Master_Id has been
4568 -- created when expanding the function declaration.
4570 if Has_Task
(T
) then
4571 if No
(Master_Id
(Base_Type
(PtrT
))) then
4573 -- The designated type was an incomplete type, and the
4574 -- access type did not get expanded. Salvage it now.
4576 if not Restriction_Active
(No_Task_Hierarchy
) then
4577 if Present
(Parent
(Base_Type
(PtrT
))) then
4578 Expand_N_Full_Type_Declaration
4579 (Parent
(Base_Type
(PtrT
)));
4581 -- The only other possibility is an itype. For this
4582 -- case, the master must exist in the context. This is
4583 -- the case when the allocator initializes an access
4584 -- component in an init-proc.
4587 pragma Assert
(Is_Itype
(PtrT
));
4588 Build_Master_Renaming
(PtrT
, N
);
4593 -- If the context of the allocator is a declaration or an
4594 -- assignment, we can generate a meaningful image for it,
4595 -- even though subsequent assignments might remove the
4596 -- connection between task and entity. We build this image
4597 -- when the left-hand side is a simple variable, a simple
4598 -- indexed assignment or a simple selected component.
4600 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4602 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4605 if Is_Entity_Name
(Nam
) then
4607 Build_Task_Image_Decls
4610 (Entity
(Nam
), Sloc
(Nam
)), T
);
4612 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4613 N_Selected_Component
)
4614 and then Is_Entity_Name
(Prefix
(Nam
))
4617 Build_Task_Image_Decls
4618 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4620 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4624 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4626 Build_Task_Image_Decls
4627 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4630 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4633 if Restriction_Active
(No_Task_Hierarchy
) then
4635 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4639 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4642 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4644 Decl
:= Last
(Decls
);
4646 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4648 -- Has_Task is false, Decls not used
4654 -- Add discriminants if discriminated type
4657 Dis
: Boolean := False;
4661 if Has_Discriminants
(T
) then
4665 elsif Is_Private_Type
(T
)
4666 and then Present
(Full_View
(T
))
4667 and then Has_Discriminants
(Full_View
(T
))
4670 Typ
:= Full_View
(T
);
4675 -- If the allocated object will be constrained by the
4676 -- default values for discriminants, then build a subtype
4677 -- with those defaults, and change the allocated subtype
4678 -- to that. Note that this happens in fewer cases in Ada
4681 if not Is_Constrained
(Typ
)
4682 and then Present
(Discriminant_Default_Value
4683 (First_Discriminant
(Typ
)))
4684 and then (Ada_Version
< Ada_2005
4686 Object_Type_Has_Constrained_Partial_View
4687 (Typ
, Current_Scope
))
4689 Typ
:= Build_Default_Subtype
(Typ
, N
);
4690 Set_Expression
(N
, New_Reference_To
(Typ
, Loc
));
4693 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4694 while Present
(Discr
) loop
4695 Nod
:= Node
(Discr
);
4696 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4698 -- AI-416: when the discriminant constraint is an
4699 -- anonymous access type make sure an accessibility
4700 -- check is inserted if necessary (3.10.2(22.q/2))
4702 if Ada_Version
>= Ada_2005
4704 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4706 Apply_Accessibility_Check
4707 (Nod
, Typ
, Insert_Node
=> Nod
);
4715 -- We set the allocator as analyzed so that when we analyze
4716 -- the if expression node, we do not get an unwanted recursive
4717 -- expansion of the allocator expression.
4719 Set_Analyzed
(N
, True);
4720 Nod
:= Relocate_Node
(N
);
4722 -- Here is the transformation:
4723 -- input: new Ctrl_Typ
4724 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4725 -- Ctrl_TypIP (Temp.all, ...);
4726 -- [Deep_]Initialize (Temp.all);
4728 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4729 -- is the subtype of the allocator.
4732 Make_Object_Declaration
(Loc
,
4733 Defining_Identifier
=> Temp
,
4734 Constant_Present
=> True,
4735 Object_Definition
=> New_Reference_To
(Temp_Type
, Loc
),
4738 Set_Assignment_OK
(Temp_Decl
);
4739 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4741 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
4743 -- If the designated type is a task type or contains tasks,
4744 -- create block to activate created tasks, and insert
4745 -- declaration for Task_Image variable ahead of call.
4747 if Has_Task
(T
) then
4749 L
: constant List_Id
:= New_List
;
4752 Build_Task_Allocate_Block
(L
, Nod
, Args
);
4754 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
4755 Insert_Actions
(N
, L
);
4760 Make_Procedure_Call_Statement
(Loc
,
4761 Name
=> New_Reference_To
(Init
, Loc
),
4762 Parameter_Associations
=> Args
));
4765 if Needs_Finalization
(T
) then
4768 -- [Deep_]Initialize (Init_Arg1);
4772 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4775 if Present
(Finalization_Master
(PtrT
)) then
4777 -- Special processing for .NET/JVM, the allocated object
4778 -- is attached to the finalization master. Generate:
4780 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4782 -- Types derived from [Limited_]Controlled are the only
4783 -- ones considered since they have fields Prev and Next.
4785 if VM_Target
/= No_VM
then
4786 if Is_Controlled
(T
) then
4789 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4793 -- Default case, generate:
4795 -- Set_Finalize_Address
4796 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
4798 -- Do not generate this call in the following cases:
4800 -- * SPARK mode - the call is useless and results in
4801 -- unwanted expansion.
4803 -- * CodePeer mode - TSS primitive Finalize_Address is
4804 -- not created in this mode.
4806 elsif not (SPARK_Mode
or CodePeer_Mode
) then
4808 Make_Set_Finalize_Address_Call
4816 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
4817 Analyze_And_Resolve
(N
, PtrT
);
4822 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4823 -- object that has been rewritten as a reference, we displace "this"
4824 -- to reference properly its secondary dispatch table.
4826 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
4827 Displace_Allocator_Pointer
(N
);
4831 when RE_Not_Available
=>
4833 end Expand_N_Allocator
;
4835 -----------------------
4836 -- Expand_N_And_Then --
4837 -----------------------
4839 procedure Expand_N_And_Then
(N
: Node_Id
)
4840 renames Expand_Short_Circuit_Operator
;
4842 ------------------------------
4843 -- Expand_N_Case_Expression --
4844 ------------------------------
4846 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4847 Loc
: constant Source_Ptr
:= Sloc
(N
);
4848 Typ
: constant Entity_Id
:= Etype
(N
);
4858 -- Check for MINIMIZED/ELIMINATED overflow mode
4860 if Minimized_Eliminated_Overflow_Check
(N
) then
4861 Apply_Arithmetic_Overflow_Check
(N
);
4867 -- case X is when A => AX, when B => BX ...
4882 -- However, this expansion is wrong for limited types, and also
4883 -- wrong for unconstrained types (since the bounds may not be the
4884 -- same in all branches). Furthermore it involves an extra copy
4885 -- for large objects. So we take care of this by using the following
4886 -- modified expansion for non-elementary types:
4889 -- type Pnn is access all typ;
4893 -- T := AX'Unrestricted_Access;
4895 -- T := BX'Unrestricted_Access;
4901 Make_Case_Statement
(Loc
,
4902 Expression
=> Expression
(N
),
4903 Alternatives
=> New_List
);
4905 Actions
:= New_List
;
4909 if Is_Elementary_Type
(Typ
) then
4913 Pnn
:= Make_Temporary
(Loc
, 'P');
4915 Make_Full_Type_Declaration
(Loc
,
4916 Defining_Identifier
=> Pnn
,
4918 Make_Access_To_Object_Definition
(Loc
,
4919 All_Present
=> True,
4920 Subtype_Indication
=>
4921 New_Reference_To
(Typ
, Loc
))));
4925 Tnn
:= Make_Temporary
(Loc
, 'T');
4927 Make_Object_Declaration
(Loc
,
4928 Defining_Identifier
=> Tnn
,
4929 Object_Definition
=> New_Occurrence_Of
(Ttyp
, Loc
)));
4931 -- Now process the alternatives
4933 Alt
:= First
(Alternatives
(N
));
4934 while Present
(Alt
) loop
4936 Aexp
: Node_Id
:= Expression
(Alt
);
4937 Aloc
: constant Source_Ptr
:= Sloc
(Aexp
);
4941 -- As described above, take Unrestricted_Access for case of non-
4942 -- scalar types, to avoid big copies, and special cases.
4944 if not Is_Elementary_Type
(Typ
) then
4946 Make_Attribute_Reference
(Aloc
,
4947 Prefix
=> Relocate_Node
(Aexp
),
4948 Attribute_Name
=> Name_Unrestricted_Access
);
4952 Make_Assignment_Statement
(Aloc
,
4953 Name
=> New_Occurrence_Of
(Tnn
, Loc
),
4954 Expression
=> Aexp
));
4956 -- Propagate declarations inserted in the node by Insert_Actions
4957 -- (for example, temporaries generated to remove side effects).
4958 -- These actions must remain attached to the alternative, given
4959 -- that they are generated by the corresponding expression.
4961 if Present
(Sinfo
.Actions
(Alt
)) then
4962 Prepend_List
(Sinfo
.Actions
(Alt
), Stats
);
4966 (Alternatives
(Cstmt
),
4967 Make_Case_Statement_Alternative
(Sloc
(Alt
),
4968 Discrete_Choices
=> Discrete_Choices
(Alt
),
4969 Statements
=> Stats
));
4975 Append_To
(Actions
, Cstmt
);
4977 -- Construct and return final expression with actions
4979 if Is_Elementary_Type
(Typ
) then
4980 Fexp
:= New_Occurrence_Of
(Tnn
, Loc
);
4983 Make_Explicit_Dereference
(Loc
,
4984 Prefix
=> New_Occurrence_Of
(Tnn
, Loc
));
4988 Make_Expression_With_Actions
(Loc
,
4990 Actions
=> Actions
));
4992 Analyze_And_Resolve
(N
, Typ
);
4993 end Expand_N_Case_Expression
;
4995 -----------------------------------
4996 -- Expand_N_Explicit_Dereference --
4997 -----------------------------------
4999 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5001 -- Insert explicit dereference call for the checked storage pool case
5003 Insert_Dereference_Action
(Prefix
(N
));
5005 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5006 -- we set the atomic sync flag.
5008 if Is_Atomic
(Etype
(N
))
5009 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5011 Activate_Atomic_Synchronization
(N
);
5013 end Expand_N_Explicit_Dereference
;
5015 --------------------------------------
5016 -- Expand_N_Expression_With_Actions --
5017 --------------------------------------
5019 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5020 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5021 -- Inspect and process a single action of an expression_with_actions for
5022 -- transient controlled objects. If such objects are found, the routine
5023 -- generates code to clean them up when the context of the expression is
5024 -- evaluated or elaborated.
5026 --------------------
5027 -- Process_Action --
5028 --------------------
5030 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5032 if Nkind
(Act
) = N_Object_Declaration
5033 and then Is_Finalizable_Transient
(Act
, N
)
5035 Process_Transient_Object
(Act
, N
);
5038 -- Avoid processing temporary function results multiple times when
5039 -- dealing with nested expression_with_actions.
5041 elsif Nkind
(Act
) = N_Expression_With_Actions
then
5044 -- Do not process temporary function results in loops. This is done
5045 -- by Expand_N_Loop_Statement and Build_Finalizer.
5047 elsif Nkind
(Act
) = N_Loop_Statement
then
5054 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5060 -- Start of processing for Expand_N_Expression_With_Actions
5063 Act
:= First
(Actions
(N
));
5064 while Present
(Act
) loop
5065 Process_Single_Action
(Act
);
5069 end Expand_N_Expression_With_Actions
;
5071 ----------------------------
5072 -- Expand_N_If_Expression --
5073 ----------------------------
5075 -- Deal with limited types and condition actions
5077 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5078 procedure Process_Actions
(Actions
: List_Id
);
5079 -- Inspect and process a single action list of an if expression for
5080 -- transient controlled objects. If such objects are found, the routine
5081 -- generates code to clean them up when the context of the expression is
5082 -- evaluated or elaborated.
5084 ---------------------
5085 -- Process_Actions --
5086 ---------------------
5088 procedure Process_Actions
(Actions
: List_Id
) is
5092 Act
:= First
(Actions
);
5093 while Present
(Act
) loop
5094 if Nkind
(Act
) = N_Object_Declaration
5095 and then Is_Finalizable_Transient
(Act
, N
)
5097 Process_Transient_Object
(Act
, N
);
5102 end Process_Actions
;
5106 Loc
: constant Source_Ptr
:= Sloc
(N
);
5107 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5108 Thenx
: constant Node_Id
:= Next
(Cond
);
5109 Elsex
: constant Node_Id
:= Next
(Thenx
);
5110 Typ
: constant Entity_Id
:= Etype
(N
);
5118 Ptr_Typ
: Entity_Id
;
5120 -- Start of processing for Expand_N_If_Expression
5123 -- Check for MINIMIZED/ELIMINATED overflow mode
5125 if Minimized_Eliminated_Overflow_Check
(N
) then
5126 Apply_Arithmetic_Overflow_Check
(N
);
5130 -- Fold at compile time if condition known. We have already folded
5131 -- static if expressions, but it is possible to fold any case in which
5132 -- the condition is known at compile time, even though the result is
5135 -- Note that we don't do the fold of such cases in Sem_Elab because
5136 -- it can cause infinite loops with the expander adding a conditional
5137 -- expression, and Sem_Elab circuitry removing it repeatedly.
5139 if Compile_Time_Known_Value
(Cond
) then
5140 if Is_True
(Expr_Value
(Cond
)) then
5142 Actions
:= Then_Actions
(N
);
5145 Actions
:= Else_Actions
(N
);
5150 if Present
(Actions
) then
5152 Make_Expression_With_Actions
(Loc
,
5153 Expression
=> Relocate_Node
(Expr
),
5154 Actions
=> Actions
));
5155 Analyze_And_Resolve
(N
, Typ
);
5157 Rewrite
(N
, Relocate_Node
(Expr
));
5160 -- Note that the result is never static (legitimate cases of static
5161 -- if expressions were folded in Sem_Eval).
5163 Set_Is_Static_Expression
(N
, False);
5167 -- If the type is limited or unconstrained, we expand as follows to
5168 -- avoid any possibility of improper copies.
5170 -- Note: it may be possible to avoid this special processing if the
5171 -- back end uses its own mechanisms for handling by-reference types ???
5173 -- type Ptr is access all Typ;
5177 -- Cnn := then-expr'Unrestricted_Access;
5180 -- Cnn := else-expr'Unrestricted_Access;
5183 -- and replace the if expression by a reference to Cnn.all.
5185 -- This special case can be skipped if the back end handles limited
5186 -- types properly and ensures that no incorrect copies are made.
5188 if Is_By_Reference_Type
(Typ
)
5189 and then not Back_End_Handles_Limited_Types
5191 -- When the "then" or "else" expressions involve controlled function
5192 -- calls, generated temporaries are chained on the corresponding list
5193 -- of actions. These temporaries need to be finalized after the if
5194 -- expression is evaluated.
5196 Process_Actions
(Then_Actions
(N
));
5197 Process_Actions
(Else_Actions
(N
));
5200 -- type Ann is access all Typ;
5202 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5205 Make_Full_Type_Declaration
(Loc
,
5206 Defining_Identifier
=> Ptr_Typ
,
5208 Make_Access_To_Object_Definition
(Loc
,
5209 All_Present
=> True,
5210 Subtype_Indication
=> New_Reference_To
(Typ
, Loc
))));
5215 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5218 Make_Object_Declaration
(Loc
,
5219 Defining_Identifier
=> Cnn
,
5220 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5224 -- Cnn := <Thenx>'Unrestricted_Access;
5226 -- Cnn := <Elsex>'Unrestricted_Access;
5230 Make_Implicit_If_Statement
(N
,
5231 Condition
=> Relocate_Node
(Cond
),
5232 Then_Statements
=> New_List
(
5233 Make_Assignment_Statement
(Sloc
(Thenx
),
5234 Name
=> New_Reference_To
(Cnn
, Sloc
(Thenx
)),
5236 Make_Attribute_Reference
(Loc
,
5237 Prefix
=> Relocate_Node
(Thenx
),
5238 Attribute_Name
=> Name_Unrestricted_Access
))),
5240 Else_Statements
=> New_List
(
5241 Make_Assignment_Statement
(Sloc
(Elsex
),
5242 Name
=> New_Reference_To
(Cnn
, Sloc
(Elsex
)),
5244 Make_Attribute_Reference
(Loc
,
5245 Prefix
=> Relocate_Node
(Elsex
),
5246 Attribute_Name
=> Name_Unrestricted_Access
))));
5249 Make_Explicit_Dereference
(Loc
,
5250 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5252 -- For other types, we only need to expand if there are other actions
5253 -- associated with either branch.
5255 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5257 -- We now wrap the actions into the appropriate expression
5259 if Present
(Then_Actions
(N
)) then
5261 Make_Expression_With_Actions
(Sloc
(Thenx
),
5262 Actions
=> Then_Actions
(N
),
5263 Expression
=> Relocate_Node
(Thenx
)));
5265 Set_Then_Actions
(N
, No_List
);
5266 Analyze_And_Resolve
(Thenx
, Typ
);
5269 if Present
(Else_Actions
(N
)) then
5271 Make_Expression_With_Actions
(Sloc
(Elsex
),
5272 Actions
=> Else_Actions
(N
),
5273 Expression
=> Relocate_Node
(Elsex
)));
5275 Set_Else_Actions
(N
, No_List
);
5276 Analyze_And_Resolve
(Elsex
, Typ
);
5281 -- If no actions then no expansion needed, gigi will handle it using the
5282 -- same approach as a C conditional expression.
5288 -- Fall through here for either the limited expansion, or the case of
5289 -- inserting actions for non-limited types. In both these cases, we must
5290 -- move the SLOC of the parent If statement to the newly created one and
5291 -- change it to the SLOC of the expression which, after expansion, will
5292 -- correspond to what is being evaluated.
5294 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
5295 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5296 Set_Sloc
(Parent
(N
), Loc
);
5299 -- Make sure Then_Actions and Else_Actions are appropriately moved
5300 -- to the new if statement.
5302 if Present
(Then_Actions
(N
)) then
5304 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5307 if Present
(Else_Actions
(N
)) then
5309 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5312 Insert_Action
(N
, Decl
);
5313 Insert_Action
(N
, New_If
);
5315 Analyze_And_Resolve
(N
, Typ
);
5316 end Expand_N_If_Expression
;
5322 procedure Expand_N_In
(N
: Node_Id
) is
5323 Loc
: constant Source_Ptr
:= Sloc
(N
);
5324 Restyp
: constant Entity_Id
:= Etype
(N
);
5325 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5326 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5327 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5332 procedure Substitute_Valid_Check
;
5333 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5334 -- test for the left operand being in range of its subtype.
5336 ----------------------------
5337 -- Substitute_Valid_Check --
5338 ----------------------------
5340 procedure Substitute_Valid_Check
is
5343 Make_Attribute_Reference
(Loc
,
5344 Prefix
=> Relocate_Node
(Lop
),
5345 Attribute_Name
=> Name_Valid
));
5347 Analyze_And_Resolve
(N
, Restyp
);
5349 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5350 -- in which case, this usage makes sense, and in any case, we have
5351 -- actually eliminated the danger of optimization above.
5353 if Overflow_Check_Mode
not in Minimized_Or_Eliminated
then
5355 ("??explicit membership test may be optimized away", N
);
5356 Error_Msg_N
-- CODEFIX
5357 ("\??use ''Valid attribute instead", N
);
5361 end Substitute_Valid_Check
;
5363 -- Start of processing for Expand_N_In
5366 -- If set membership case, expand with separate procedure
5368 if Present
(Alternatives
(N
)) then
5369 Expand_Set_Membership
(N
);
5373 -- Not set membership, proceed with expansion
5375 Ltyp
:= Etype
(Left_Opnd
(N
));
5376 Rtyp
:= Etype
(Right_Opnd
(N
));
5378 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5379 -- type, then expand with a separate procedure. Note the use of the
5380 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5382 if Overflow_Check_Mode
in Minimized_Or_Eliminated
5383 and then Is_Signed_Integer_Type
(Ltyp
)
5384 and then not No_Minimize_Eliminate
(N
)
5386 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
5390 -- Check case of explicit test for an expression in range of its
5391 -- subtype. This is suspicious usage and we replace it with a 'Valid
5392 -- test and give a warning for scalar types.
5394 if Is_Scalar_Type
(Ltyp
)
5396 -- Only relevant for source comparisons
5398 and then Comes_From_Source
(N
)
5400 -- In floating-point this is a standard way to check for finite values
5401 -- and using 'Valid would typically be a pessimization.
5403 and then not Is_Floating_Point_Type
(Ltyp
)
5405 -- Don't give the message unless right operand is a type entity and
5406 -- the type of the left operand matches this type. Note that this
5407 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5408 -- checks have changed the type of the left operand.
5410 and then Nkind
(Rop
) in N_Has_Entity
5411 and then Ltyp
= Entity
(Rop
)
5413 -- Skip in VM mode, where we have no sense of invalid values. The
5414 -- warning still seems relevant, but not important enough to worry.
5416 and then VM_Target
= No_VM
5418 -- Skip this for predicated types, where such expressions are a
5419 -- reasonable way of testing if something meets the predicate.
5421 and then not Present
(Predicate_Function
(Ltyp
))
5423 Substitute_Valid_Check
;
5427 -- Do validity check on operands
5429 if Validity_Checks_On
and Validity_Check_Operands
then
5430 Ensure_Valid
(Left_Opnd
(N
));
5431 Validity_Check_Range
(Right_Opnd
(N
));
5434 -- Case of explicit range
5436 if Nkind
(Rop
) = N_Range
then
5438 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
5439 Hi
: constant Node_Id
:= High_Bound
(Rop
);
5441 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
5442 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
5444 Lcheck
: Compare_Result
;
5445 Ucheck
: Compare_Result
;
5447 Warn1
: constant Boolean :=
5448 Constant_Condition_Warnings
5449 and then Comes_From_Source
(N
)
5450 and then not In_Instance
;
5451 -- This must be true for any of the optimization warnings, we
5452 -- clearly want to give them only for source with the flag on. We
5453 -- also skip these warnings in an instance since it may be the
5454 -- case that different instantiations have different ranges.
5456 Warn2
: constant Boolean :=
5458 and then Nkind
(Original_Node
(Rop
)) = N_Range
5459 and then Is_Integer_Type
(Etype
(Lo
));
5460 -- For the case where only one bound warning is elided, we also
5461 -- insist on an explicit range and an integer type. The reason is
5462 -- that the use of enumeration ranges including an end point is
5463 -- common, as is the use of a subtype name, one of whose bounds is
5464 -- the same as the type of the expression.
5467 -- If test is explicit x'First .. x'Last, replace by valid check
5469 -- Could use some individual comments for this complex test ???
5471 if Is_Scalar_Type
(Ltyp
)
5473 -- And left operand is X'First where X matches left operand
5474 -- type (this eliminates cases of type mismatch, including
5475 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5476 -- type of the left operand.
5478 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
5479 and then Attribute_Name
(Lo_Orig
) = Name_First
5480 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
5481 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
5483 -- Same tests for right operand
5485 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
5486 and then Attribute_Name
(Hi_Orig
) = Name_Last
5487 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
5488 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
5490 -- Relevant only for source cases
5492 and then Comes_From_Source
(N
)
5494 -- Omit for VM cases, where we don't have invalid values
5496 and then VM_Target
= No_VM
5498 Substitute_Valid_Check
;
5502 -- If bounds of type are known at compile time, and the end points
5503 -- are known at compile time and identical, this is another case
5504 -- for substituting a valid test. We only do this for discrete
5505 -- types, since it won't arise in practice for float types.
5507 if Comes_From_Source
(N
)
5508 and then Is_Discrete_Type
(Ltyp
)
5509 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
5510 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
5511 and then Compile_Time_Known_Value
(Lo
)
5512 and then Compile_Time_Known_Value
(Hi
)
5513 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
5514 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
5516 -- Kill warnings in instances, since they may be cases where we
5517 -- have a test in the generic that makes sense with some types
5518 -- and not with other types.
5520 and then not In_Instance
5522 Substitute_Valid_Check
;
5526 -- If we have an explicit range, do a bit of optimization based on
5527 -- range analysis (we may be able to kill one or both checks).
5529 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
5530 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
5532 -- If either check is known to fail, replace result by False since
5533 -- the other check does not matter. Preserve the static flag for
5534 -- legality checks, because we are constant-folding beyond RM 4.9.
5536 if Lcheck
= LT
or else Ucheck
= GT
then
5538 Error_Msg_N
("?c?range test optimized away", N
);
5539 Error_Msg_N
("\?c?value is known to be out of range", N
);
5542 Rewrite
(N
, New_Reference_To
(Standard_False
, Loc
));
5543 Analyze_And_Resolve
(N
, Restyp
);
5544 Set_Is_Static_Expression
(N
, Static
);
5547 -- If both checks are known to succeed, replace result by True,
5548 -- since we know we are in range.
5550 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5552 Error_Msg_N
("?c?range test optimized away", N
);
5553 Error_Msg_N
("\?c?value is known to be in range", N
);
5556 Rewrite
(N
, New_Reference_To
(Standard_True
, Loc
));
5557 Analyze_And_Resolve
(N
, Restyp
);
5558 Set_Is_Static_Expression
(N
, Static
);
5561 -- If lower bound check succeeds and upper bound check is not
5562 -- known to succeed or fail, then replace the range check with
5563 -- a comparison against the upper bound.
5565 elsif Lcheck
in Compare_GE
then
5566 if Warn2
and then not In_Instance
then
5567 Error_Msg_N
("??lower bound test optimized away", Lo
);
5568 Error_Msg_N
("\??value is known to be in range", Lo
);
5574 Right_Opnd
=> High_Bound
(Rop
)));
5575 Analyze_And_Resolve
(N
, Restyp
);
5578 -- If upper bound check succeeds and lower bound check is not
5579 -- known to succeed or fail, then replace the range check with
5580 -- a comparison against the lower bound.
5582 elsif Ucheck
in Compare_LE
then
5583 if Warn2
and then not In_Instance
then
5584 Error_Msg_N
("??upper bound test optimized away", Hi
);
5585 Error_Msg_N
("\??value is known to be in range", Hi
);
5591 Right_Opnd
=> Low_Bound
(Rop
)));
5592 Analyze_And_Resolve
(N
, Restyp
);
5596 -- We couldn't optimize away the range check, but there is one
5597 -- more issue. If we are checking constant conditionals, then we
5598 -- see if we can determine the outcome assuming everything is
5599 -- valid, and if so give an appropriate warning.
5601 if Warn1
and then not Assume_No_Invalid_Values
then
5602 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
5603 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
5605 -- Result is out of range for valid value
5607 if Lcheck
= LT
or else Ucheck
= GT
then
5609 ("?c?value can only be in range if it is invalid", N
);
5611 -- Result is in range for valid value
5613 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5615 ("?c?value can only be out of range if it is invalid", N
);
5617 -- Lower bound check succeeds if value is valid
5619 elsif Warn2
and then Lcheck
in Compare_GE
then
5621 ("?c?lower bound check only fails if it is invalid", Lo
);
5623 -- Upper bound check succeeds if value is valid
5625 elsif Warn2
and then Ucheck
in Compare_LE
then
5627 ("?c?upper bound check only fails for invalid values", Hi
);
5632 -- For all other cases of an explicit range, nothing to be done
5636 -- Here right operand is a subtype mark
5640 Typ
: Entity_Id
:= Etype
(Rop
);
5641 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
5642 Cond
: Node_Id
:= Empty
;
5644 Obj
: Node_Id
:= Lop
;
5645 SCIL_Node
: Node_Id
;
5648 Remove_Side_Effects
(Obj
);
5650 -- For tagged type, do tagged membership operation
5652 if Is_Tagged_Type
(Typ
) then
5654 -- No expansion will be performed when VM_Target, as the VM
5655 -- back-ends will handle the membership tests directly (tags
5656 -- are not explicitly represented in Java objects, so the
5657 -- normal tagged membership expansion is not what we want).
5659 if Tagged_Type_Expansion
then
5660 Tagged_Membership
(N
, SCIL_Node
, New_N
);
5662 Analyze_And_Resolve
(N
, Restyp
);
5664 -- Update decoration of relocated node referenced by the
5667 if Generate_SCIL
and then Present
(SCIL_Node
) then
5668 Set_SCIL_Node
(N
, SCIL_Node
);
5674 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5675 -- This reason we do this is that the bounds may have the wrong
5676 -- type if they come from the original type definition. Also this
5677 -- way we get all the processing above for an explicit range.
5679 -- Don't do this for predicated types, since in this case we
5680 -- want to check the predicate!
5682 elsif Is_Scalar_Type
(Typ
) then
5683 if No
(Predicate_Function
(Typ
)) then
5687 Make_Attribute_Reference
(Loc
,
5688 Attribute_Name
=> Name_First
,
5689 Prefix
=> New_Reference_To
(Typ
, Loc
)),
5692 Make_Attribute_Reference
(Loc
,
5693 Attribute_Name
=> Name_Last
,
5694 Prefix
=> New_Reference_To
(Typ
, Loc
))));
5695 Analyze_And_Resolve
(N
, Restyp
);
5700 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5701 -- a membership test if the subtype mark denotes a constrained
5702 -- Unchecked_Union subtype and the expression lacks inferable
5705 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
5706 and then Is_Constrained
(Typ
)
5707 and then not Has_Inferable_Discriminants
(Lop
)
5710 Make_Raise_Program_Error
(Loc
,
5711 Reason
=> PE_Unchecked_Union_Restriction
));
5713 -- Prevent Gigi from generating incorrect code by rewriting the
5714 -- test as False. What is this undocumented thing about ???
5716 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5720 -- Here we have a non-scalar type
5723 Typ
:= Designated_Type
(Typ
);
5726 if not Is_Constrained
(Typ
) then
5727 Rewrite
(N
, New_Reference_To
(Standard_True
, Loc
));
5728 Analyze_And_Resolve
(N
, Restyp
);
5730 -- For the constrained array case, we have to check the subscripts
5731 -- for an exact match if the lengths are non-zero (the lengths
5732 -- must match in any case).
5734 elsif Is_Array_Type
(Typ
) then
5735 Check_Subscripts
: declare
5736 function Build_Attribute_Reference
5739 Dim
: Nat
) return Node_Id
;
5740 -- Build attribute reference E'Nam (Dim)
5742 -------------------------------
5743 -- Build_Attribute_Reference --
5744 -------------------------------
5746 function Build_Attribute_Reference
5749 Dim
: Nat
) return Node_Id
5753 Make_Attribute_Reference
(Loc
,
5755 Attribute_Name
=> Nam
,
5756 Expressions
=> New_List
(
5757 Make_Integer_Literal
(Loc
, Dim
)));
5758 end Build_Attribute_Reference
;
5760 -- Start of processing for Check_Subscripts
5763 for J
in 1 .. Number_Dimensions
(Typ
) loop
5764 Evolve_And_Then
(Cond
,
5767 Build_Attribute_Reference
5768 (Duplicate_Subexpr_No_Checks
(Obj
),
5771 Build_Attribute_Reference
5772 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
5774 Evolve_And_Then
(Cond
,
5777 Build_Attribute_Reference
5778 (Duplicate_Subexpr_No_Checks
(Obj
),
5781 Build_Attribute_Reference
5782 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
5791 Right_Opnd
=> Make_Null
(Loc
)),
5792 Right_Opnd
=> Cond
);
5796 Analyze_And_Resolve
(N
, Restyp
);
5797 end Check_Subscripts
;
5799 -- These are the cases where constraint checks may be required,
5800 -- e.g. records with possible discriminants
5803 -- Expand the test into a series of discriminant comparisons.
5804 -- The expression that is built is the negation of the one that
5805 -- is used for checking discriminant constraints.
5807 Obj
:= Relocate_Node
(Left_Opnd
(N
));
5809 if Has_Discriminants
(Typ
) then
5810 Cond
:= Make_Op_Not
(Loc
,
5811 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
5814 Cond
:= Make_Or_Else
(Loc
,
5818 Right_Opnd
=> Make_Null
(Loc
)),
5819 Right_Opnd
=> Cond
);
5823 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
5827 Analyze_And_Resolve
(N
, Restyp
);
5830 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5831 -- expression of an anonymous access type. This can involve an
5832 -- accessibility test and a tagged type membership test in the
5833 -- case of tagged designated types.
5835 if Ada_Version
>= Ada_2012
5837 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
5840 Expr_Entity
: Entity_Id
:= Empty
;
5842 Param_Level
: Node_Id
;
5843 Type_Level
: Node_Id
;
5846 if Is_Entity_Name
(Lop
) then
5847 Expr_Entity
:= Param_Entity
(Lop
);
5849 if not Present
(Expr_Entity
) then
5850 Expr_Entity
:= Entity
(Lop
);
5854 -- If a conversion of the anonymous access value to the
5855 -- tested type would be illegal, then the result is False.
5857 if not Valid_Conversion
5858 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
5860 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5861 Analyze_And_Resolve
(N
, Restyp
);
5863 -- Apply an accessibility check if the access object has an
5864 -- associated access level and when the level of the type is
5865 -- less deep than the level of the access parameter. This
5866 -- only occur for access parameters and stand-alone objects
5867 -- of an anonymous access type.
5870 if Present
(Expr_Entity
)
5873 (Effective_Extra_Accessibility
(Expr_Entity
))
5874 and then UI_Gt
(Object_Access_Level
(Lop
),
5875 Type_Access_Level
(Rtyp
))
5879 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
5882 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
5884 -- Return True only if the accessibility level of the
5885 -- expression entity is not deeper than the level of
5886 -- the tested access type.
5890 Left_Opnd
=> Relocate_Node
(N
),
5891 Right_Opnd
=> Make_Op_Le
(Loc
,
5892 Left_Opnd
=> Param_Level
,
5893 Right_Opnd
=> Type_Level
)));
5895 Analyze_And_Resolve
(N
);
5898 -- If the designated type is tagged, do tagged membership
5901 -- *** NOTE: we have to check not null before doing the
5902 -- tagged membership test (but maybe that can be done
5903 -- inside Tagged_Membership?).
5905 if Is_Tagged_Type
(Typ
) then
5908 Left_Opnd
=> Relocate_Node
(N
),
5912 Right_Opnd
=> Make_Null
(Loc
))));
5914 -- No expansion will be performed when VM_Target, as
5915 -- the VM back-ends will handle the membership tests
5916 -- directly (tags are not explicitly represented in
5917 -- Java objects, so the normal tagged membership
5918 -- expansion is not what we want).
5920 if Tagged_Type_Expansion
then
5922 -- Note that we have to pass Original_Node, because
5923 -- the membership test might already have been
5924 -- rewritten by earlier parts of membership test.
5927 (Original_Node
(N
), SCIL_Node
, New_N
);
5929 -- Update decoration of relocated node referenced
5930 -- by the SCIL node.
5932 if Generate_SCIL
and then Present
(SCIL_Node
) then
5933 Set_SCIL_Node
(New_N
, SCIL_Node
);
5938 Left_Opnd
=> Relocate_Node
(N
),
5939 Right_Opnd
=> New_N
));
5941 Analyze_And_Resolve
(N
, Restyp
);
5950 -- At this point, we have done the processing required for the basic
5951 -- membership test, but not yet dealt with the predicate.
5955 -- If a predicate is present, then we do the predicate test, but we
5956 -- most certainly want to omit this if we are within the predicate
5957 -- function itself, since otherwise we have an infinite recursion!
5958 -- The check should also not be emitted when testing against a range
5959 -- (the check is only done when the right operand is a subtype; see
5960 -- RM12-4.5.2 (28.1/3-30/3)).
5963 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
5967 and then Current_Scope
/= PFunc
5968 and then Nkind
(Rop
) /= N_Range
5972 Left_Opnd
=> Relocate_Node
(N
),
5973 Right_Opnd
=> Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True)));
5975 -- Analyze new expression, mark left operand as analyzed to
5976 -- avoid infinite recursion adding predicate calls. Similarly,
5977 -- suppress further range checks on the call.
5979 Set_Analyzed
(Left_Opnd
(N
));
5980 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
5982 -- All done, skip attempt at compile time determination of result
5989 --------------------------------
5990 -- Expand_N_Indexed_Component --
5991 --------------------------------
5993 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
5994 Loc
: constant Source_Ptr
:= Sloc
(N
);
5995 Typ
: constant Entity_Id
:= Etype
(N
);
5996 P
: constant Node_Id
:= Prefix
(N
);
5997 T
: constant Entity_Id
:= Etype
(P
);
6001 -- A special optimization, if we have an indexed component that is
6002 -- selecting from a slice, then we can eliminate the slice, since, for
6003 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6004 -- the range check required by the slice. The range check for the slice
6005 -- itself has already been generated. The range check for the
6006 -- subscripting operation is ensured by converting the subject to
6007 -- the subtype of the slice.
6009 -- This optimization not only generates better code, avoiding slice
6010 -- messing especially in the packed case, but more importantly bypasses
6011 -- some problems in handling this peculiar case, for example, the issue
6012 -- of dealing specially with object renamings.
6014 if Nkind
(P
) = N_Slice
then
6016 Make_Indexed_Component
(Loc
,
6017 Prefix
=> Prefix
(P
),
6018 Expressions
=> New_List
(
6020 (Etype
(First_Index
(Etype
(P
))),
6021 First
(Expressions
(N
))))));
6022 Analyze_And_Resolve
(N
, Typ
);
6026 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6027 -- function, then additional actuals must be passed.
6029 if Ada_Version
>= Ada_2005
6030 and then Is_Build_In_Place_Function_Call
(P
)
6032 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6035 -- If the prefix is an access type, then we unconditionally rewrite if
6036 -- as an explicit dereference. This simplifies processing for several
6037 -- cases, including packed array cases and certain cases in which checks
6038 -- must be generated. We used to try to do this only when it was
6039 -- necessary, but it cleans up the code to do it all the time.
6041 if Is_Access_Type
(T
) then
6042 Insert_Explicit_Dereference
(P
);
6043 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6044 Atp
:= Designated_Type
(T
);
6049 -- Generate index and validity checks
6051 Generate_Index_Checks
(N
);
6053 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6054 Apply_Subscript_Validity_Checks
(N
);
6057 -- If selecting from an array with atomic components, and atomic sync
6058 -- is not suppressed for this array type, set atomic sync flag.
6060 if (Has_Atomic_Components
(Atp
)
6061 and then not Atomic_Synchronization_Disabled
(Atp
))
6062 or else (Is_Atomic
(Typ
)
6063 and then not Atomic_Synchronization_Disabled
(Typ
))
6065 Activate_Atomic_Synchronization
(N
);
6068 -- All done for the non-packed case
6070 if not Is_Packed
(Etype
(Prefix
(N
))) then
6074 -- For packed arrays that are not bit-packed (i.e. the case of an array
6075 -- with one or more index types with a non-contiguous enumeration type),
6076 -- we can always use the normal packed element get circuit.
6078 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6079 Expand_Packed_Element_Reference
(N
);
6083 -- For a reference to a component of a bit packed array, we have to
6084 -- convert it to a reference to the corresponding Packed_Array_Type.
6085 -- We only want to do this for simple references, and not for:
6087 -- Left side of assignment, or prefix of left side of assignment, or
6088 -- prefix of the prefix, to handle packed arrays of packed arrays,
6089 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6091 -- Renaming objects in renaming associations
6092 -- This case is handled when a use of the renamed variable occurs
6094 -- Actual parameters for a procedure call
6095 -- This case is handled in Exp_Ch6.Expand_Actuals
6097 -- The second expression in a 'Read attribute reference
6099 -- The prefix of an address or bit or size attribute reference
6101 -- The following circuit detects these exceptions
6104 Child
: Node_Id
:= N
;
6105 Parnt
: Node_Id
:= Parent
(N
);
6109 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6112 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6113 N_Procedure_Call_Statement
)
6114 or else (Nkind
(Parnt
) = N_Parameter_Association
6116 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6120 elsif Nkind
(Parnt
) = N_Attribute_Reference
6121 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
6124 and then Prefix
(Parnt
) = Child
6128 elsif Nkind
(Parnt
) = N_Assignment_Statement
6129 and then Name
(Parnt
) = Child
6133 -- If the expression is an index of an indexed component, it must
6134 -- be expanded regardless of context.
6136 elsif Nkind
(Parnt
) = N_Indexed_Component
6137 and then Child
/= Prefix
(Parnt
)
6139 Expand_Packed_Element_Reference
(N
);
6142 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6143 and then Name
(Parent
(Parnt
)) = Parnt
6147 elsif Nkind
(Parnt
) = N_Attribute_Reference
6148 and then Attribute_Name
(Parnt
) = Name_Read
6149 and then Next
(First
(Expressions
(Parnt
))) = Child
6153 elsif Nkind_In
(Parnt
, N_Indexed_Component
, N_Selected_Component
)
6154 and then Prefix
(Parnt
) = Child
6159 Expand_Packed_Element_Reference
(N
);
6163 -- Keep looking up tree for unchecked expression, or if we are the
6164 -- prefix of a possible assignment left side.
6167 Parnt
:= Parent
(Child
);
6170 end Expand_N_Indexed_Component
;
6172 ---------------------
6173 -- Expand_N_Not_In --
6174 ---------------------
6176 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6177 -- can be done. This avoids needing to duplicate this expansion code.
6179 procedure Expand_N_Not_In
(N
: Node_Id
) is
6180 Loc
: constant Source_Ptr
:= Sloc
(N
);
6181 Typ
: constant Entity_Id
:= Etype
(N
);
6182 Cfs
: constant Boolean := Comes_From_Source
(N
);
6189 Left_Opnd
=> Left_Opnd
(N
),
6190 Right_Opnd
=> Right_Opnd
(N
))));
6192 -- If this is a set membership, preserve list of alternatives
6194 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6196 -- We want this to appear as coming from source if original does (see
6197 -- transformations in Expand_N_In).
6199 Set_Comes_From_Source
(N
, Cfs
);
6200 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6202 -- Now analyze transformed node
6204 Analyze_And_Resolve
(N
, Typ
);
6205 end Expand_N_Not_In
;
6211 -- The only replacement required is for the case of a null of a type that
6212 -- is an access to protected subprogram, or a subtype thereof. We represent
6213 -- such access values as a record, and so we must replace the occurrence of
6214 -- null by the equivalent record (with a null address and a null pointer in
6215 -- it), so that the backend creates the proper value.
6217 procedure Expand_N_Null
(N
: Node_Id
) is
6218 Loc
: constant Source_Ptr
:= Sloc
(N
);
6219 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6223 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6225 Make_Aggregate
(Loc
,
6226 Expressions
=> New_List
(
6227 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6231 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6233 -- For subsequent semantic analysis, the node must retain its type.
6234 -- Gigi in any case replaces this type by the corresponding record
6235 -- type before processing the node.
6241 when RE_Not_Available
=>
6245 ---------------------
6246 -- Expand_N_Op_Abs --
6247 ---------------------
6249 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6250 Loc
: constant Source_Ptr
:= Sloc
(N
);
6251 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6254 Unary_Op_Validity_Checks
(N
);
6256 -- Check for MINIMIZED/ELIMINATED overflow mode
6258 if Minimized_Eliminated_Overflow_Check
(N
) then
6259 Apply_Arithmetic_Overflow_Check
(N
);
6263 -- Deal with software overflow checking
6265 if not Backend_Overflow_Checks_On_Target
6266 and then Is_Signed_Integer_Type
(Etype
(N
))
6267 and then Do_Overflow_Check
(N
)
6269 -- The only case to worry about is when the argument is equal to the
6270 -- largest negative number, so what we do is to insert the check:
6272 -- [constraint_error when Expr = typ'Base'First]
6274 -- with the usual Duplicate_Subexpr use coding for expr
6277 Make_Raise_Constraint_Error
(Loc
,
6280 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6282 Make_Attribute_Reference
(Loc
,
6284 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6285 Attribute_Name
=> Name_First
)),
6286 Reason
=> CE_Overflow_Check_Failed
));
6289 -- Vax floating-point types case
6291 if Vax_Float
(Etype
(N
)) then
6292 Expand_Vax_Arith
(N
);
6294 end Expand_N_Op_Abs
;
6296 ---------------------
6297 -- Expand_N_Op_Add --
6298 ---------------------
6300 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6301 Typ
: constant Entity_Id
:= Etype
(N
);
6304 Binary_Op_Validity_Checks
(N
);
6306 -- Check for MINIMIZED/ELIMINATED overflow mode
6308 if Minimized_Eliminated_Overflow_Check
(N
) then
6309 Apply_Arithmetic_Overflow_Check
(N
);
6313 -- N + 0 = 0 + N = N for integer types
6315 if Is_Integer_Type
(Typ
) then
6316 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6317 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6319 Rewrite
(N
, Left_Opnd
(N
));
6322 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6323 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
6325 Rewrite
(N
, Right_Opnd
(N
));
6330 -- Arithmetic overflow checks for signed integer/fixed point types
6332 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
6333 Apply_Arithmetic_Overflow_Check
(N
);
6336 -- Vax floating-point types case
6338 elsif Vax_Float
(Typ
) then
6339 Expand_Vax_Arith
(N
);
6341 end Expand_N_Op_Add
;
6343 ---------------------
6344 -- Expand_N_Op_And --
6345 ---------------------
6347 procedure Expand_N_Op_And
(N
: Node_Id
) is
6348 Typ
: constant Entity_Id
:= Etype
(N
);
6351 Binary_Op_Validity_Checks
(N
);
6353 if Is_Array_Type
(Etype
(N
)) then
6354 Expand_Boolean_Operator
(N
);
6356 elsif Is_Boolean_Type
(Etype
(N
)) then
6357 Adjust_Condition
(Left_Opnd
(N
));
6358 Adjust_Condition
(Right_Opnd
(N
));
6359 Set_Etype
(N
, Standard_Boolean
);
6360 Adjust_Result_Type
(N
, Typ
);
6362 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
6363 Expand_Intrinsic_Call
(N
, Entity
(N
));
6366 end Expand_N_Op_And
;
6368 ------------------------
6369 -- Expand_N_Op_Concat --
6370 ------------------------
6372 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
6374 -- List of operands to be concatenated
6377 -- Node which is to be replaced by the result of concatenating the nodes
6378 -- in the list Opnds.
6381 -- Ensure validity of both operands
6383 Binary_Op_Validity_Checks
(N
);
6385 -- If we are the left operand of a concatenation higher up the tree,
6386 -- then do nothing for now, since we want to deal with a series of
6387 -- concatenations as a unit.
6389 if Nkind
(Parent
(N
)) = N_Op_Concat
6390 and then N
= Left_Opnd
(Parent
(N
))
6395 -- We get here with a concatenation whose left operand may be a
6396 -- concatenation itself with a consistent type. We need to process
6397 -- these concatenation operands from left to right, which means
6398 -- from the deepest node in the tree to the highest node.
6401 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
6402 Cnode
:= Left_Opnd
(Cnode
);
6405 -- Now Cnode is the deepest concatenation, and its parents are the
6406 -- concatenation nodes above, so now we process bottom up, doing the
6409 -- The outer loop runs more than once if more than one concatenation
6410 -- type is involved.
6413 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
6414 Set_Parent
(Opnds
, N
);
6416 -- The inner loop gathers concatenation operands
6418 Inner
: while Cnode
/= N
6419 and then Base_Type
(Etype
(Cnode
)) =
6420 Base_Type
(Etype
(Parent
(Cnode
)))
6422 Cnode
:= Parent
(Cnode
);
6423 Append
(Right_Opnd
(Cnode
), Opnds
);
6426 Expand_Concatenate
(Cnode
, Opnds
);
6428 exit Outer
when Cnode
= N
;
6429 Cnode
:= Parent
(Cnode
);
6431 end Expand_N_Op_Concat
;
6433 ------------------------
6434 -- Expand_N_Op_Divide --
6435 ------------------------
6437 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
6438 Loc
: constant Source_Ptr
:= Sloc
(N
);
6439 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
6440 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
6441 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
6442 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
6443 Typ
: Entity_Id
:= Etype
(N
);
6444 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
6446 Compile_Time_Known_Value
(Ropnd
);
6450 Binary_Op_Validity_Checks
(N
);
6452 -- Check for MINIMIZED/ELIMINATED overflow mode
6454 if Minimized_Eliminated_Overflow_Check
(N
) then
6455 Apply_Arithmetic_Overflow_Check
(N
);
6459 -- Otherwise proceed with expansion of division
6462 Rval
:= Expr_Value
(Ropnd
);
6465 -- N / 1 = N for integer types
6467 if Rknow
and then Rval
= Uint_1
then
6472 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6473 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6474 -- operand is an unsigned integer, as required for this to work.
6476 if Nkind
(Ropnd
) = N_Op_Expon
6477 and then Is_Power_Of_2_For_Shift
(Ropnd
)
6479 -- We cannot do this transformation in configurable run time mode if we
6480 -- have 64-bit integers and long shifts are not available.
6482 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
6485 Make_Op_Shift_Right
(Loc
,
6488 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
6489 Analyze_And_Resolve
(N
, Typ
);
6493 -- Do required fixup of universal fixed operation
6495 if Typ
= Universal_Fixed
then
6496 Fixup_Universal_Fixed_Operation
(N
);
6500 -- Divisions with fixed-point results
6502 if Is_Fixed_Point_Type
(Typ
) then
6504 -- No special processing if Treat_Fixed_As_Integer is set, since
6505 -- from a semantic point of view such operations are simply integer
6506 -- operations and will be treated that way.
6508 if not Treat_Fixed_As_Integer
(N
) then
6509 if Is_Integer_Type
(Rtyp
) then
6510 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
6512 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
6516 -- Other cases of division of fixed-point operands. Again we exclude the
6517 -- case where Treat_Fixed_As_Integer is set.
6519 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
6520 and then not Treat_Fixed_As_Integer
(N
)
6522 if Is_Integer_Type
(Typ
) then
6523 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
6525 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6526 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
6529 -- Mixed-mode operations can appear in a non-static universal context,
6530 -- in which case the integer argument must be converted explicitly.
6532 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
6534 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
6536 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
6538 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
6540 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
6542 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
6544 -- Non-fixed point cases, do integer zero divide and overflow checks
6546 elsif Is_Integer_Type
(Typ
) then
6547 Apply_Divide_Checks
(N
);
6549 -- Deal with Vax_Float
6551 elsif Vax_Float
(Typ
) then
6552 Expand_Vax_Arith
(N
);
6555 end Expand_N_Op_Divide
;
6557 --------------------
6558 -- Expand_N_Op_Eq --
6559 --------------------
6561 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
6562 Loc
: constant Source_Ptr
:= Sloc
(N
);
6563 Typ
: constant Entity_Id
:= Etype
(N
);
6564 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
6565 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
6566 Bodies
: constant List_Id
:= New_List
;
6567 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
6569 Typl
: Entity_Id
:= A_Typ
;
6570 Op_Name
: Entity_Id
;
6573 procedure Build_Equality_Call
(Eq
: Entity_Id
);
6574 -- If a constructed equality exists for the type or for its parent,
6575 -- build and analyze call, adding conversions if the operation is
6578 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
6579 -- Determines whether a type has a subcomponent of an unconstrained
6580 -- Unchecked_Union subtype. Typ is a record type.
6582 -------------------------
6583 -- Build_Equality_Call --
6584 -------------------------
6586 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
6587 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
6588 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
6589 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
6592 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
6593 and then not Is_Class_Wide_Type
(A_Typ
)
6595 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
6596 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
6599 -- If we have an Unchecked_Union, we need to add the inferred
6600 -- discriminant values as actuals in the function call. At this
6601 -- point, the expansion has determined that both operands have
6602 -- inferable discriminants.
6604 if Is_Unchecked_Union
(Op_Type
) then
6606 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
6607 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
6609 Lhs_Discr_Vals
: Elist_Id
;
6610 -- List of inferred discriminant values for left operand.
6612 Rhs_Discr_Vals
: Elist_Id
;
6613 -- List of inferred discriminant values for right operand.
6618 Lhs_Discr_Vals
:= New_Elmt_List
;
6619 Rhs_Discr_Vals
:= New_Elmt_List
;
6621 -- Per-object constrained selected components require special
6622 -- attention. If the enclosing scope of the component is an
6623 -- Unchecked_Union, we cannot reference its discriminants
6624 -- directly. This is why we use the extra parameters of the
6625 -- equality function of the enclosing Unchecked_Union.
6627 -- type UU_Type (Discr : Integer := 0) is
6630 -- pragma Unchecked_Union (UU_Type);
6632 -- 1. Unchecked_Union enclosing record:
6634 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6636 -- Comp : UU_Type (Discr);
6638 -- end Enclosing_UU_Type;
6639 -- pragma Unchecked_Union (Enclosing_UU_Type);
6641 -- Obj1 : Enclosing_UU_Type;
6642 -- Obj2 : Enclosing_UU_Type (1);
6644 -- [. . .] Obj1 = Obj2 [. . .]
6648 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6650 -- A and B are the formal parameters of the equality function
6651 -- of Enclosing_UU_Type. The function always has two extra
6652 -- formals to capture the inferred discriminant values for
6653 -- each discriminant of the type.
6655 -- 2. Non-Unchecked_Union enclosing record:
6658 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6661 -- Comp : UU_Type (Discr);
6663 -- end Enclosing_Non_UU_Type;
6665 -- Obj1 : Enclosing_Non_UU_Type;
6666 -- Obj2 : Enclosing_Non_UU_Type (1);
6668 -- ... Obj1 = Obj2 ...
6672 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6673 -- obj1.discr, obj2.discr)) then
6675 -- In this case we can directly reference the discriminants of
6676 -- the enclosing record.
6678 -- Process left operand of equality
6680 if Nkind
(Lhs
) = N_Selected_Component
6682 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
6684 -- If enclosing record is an Unchecked_Union, use formals
6685 -- corresponding to each discriminant. The name of the
6686 -- formal is that of the discriminant, with added suffix,
6687 -- see Exp_Ch3.Build_Record_Equality for details.
6689 if Is_Unchecked_Union
6690 (Scope
(Entity
(Selector_Name
(Lhs
))))
6694 (Scope
(Entity
(Selector_Name
(Lhs
))));
6695 while Present
(Discr
) loop
6697 Make_Identifier
(Loc
,
6698 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
6699 To
=> Lhs_Discr_Vals
);
6700 Next_Discriminant
(Discr
);
6703 -- If enclosing record is of a non-Unchecked_Union type, it
6704 -- is possible to reference its discriminants directly.
6707 Discr
:= First_Discriminant
(Lhs_Type
);
6708 while Present
(Discr
) loop
6710 Make_Selected_Component
(Loc
,
6711 Prefix
=> Prefix
(Lhs
),
6714 (Get_Discriminant_Value
(Discr
,
6716 Stored_Constraint
(Lhs_Type
)))),
6717 To
=> Lhs_Discr_Vals
);
6718 Next_Discriminant
(Discr
);
6722 -- Otherwise operand is on object with a constrained type.
6723 -- Infer the discriminant values from the constraint.
6727 Discr
:= First_Discriminant
(Lhs_Type
);
6728 while Present
(Discr
) loop
6731 (Get_Discriminant_Value
(Discr
,
6733 Stored_Constraint
(Lhs_Type
))),
6734 To
=> Lhs_Discr_Vals
);
6735 Next_Discriminant
(Discr
);
6739 -- Similar processing for right operand of equality
6741 if Nkind
(Rhs
) = N_Selected_Component
6743 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
6745 if Is_Unchecked_Union
6746 (Scope
(Entity
(Selector_Name
(Rhs
))))
6750 (Scope
(Entity
(Selector_Name
(Rhs
))));
6751 while Present
(Discr
) loop
6753 Make_Identifier
(Loc
,
6754 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
6755 To
=> Rhs_Discr_Vals
);
6756 Next_Discriminant
(Discr
);
6760 Discr
:= First_Discriminant
(Rhs_Type
);
6761 while Present
(Discr
) loop
6763 Make_Selected_Component
(Loc
,
6764 Prefix
=> Prefix
(Rhs
),
6766 New_Copy
(Get_Discriminant_Value
6769 Stored_Constraint
(Rhs_Type
)))),
6770 To
=> Rhs_Discr_Vals
);
6771 Next_Discriminant
(Discr
);
6776 Discr
:= First_Discriminant
(Rhs_Type
);
6777 while Present
(Discr
) loop
6779 New_Copy
(Get_Discriminant_Value
6782 Stored_Constraint
(Rhs_Type
))),
6783 To
=> Rhs_Discr_Vals
);
6784 Next_Discriminant
(Discr
);
6788 -- Now merge the list of discriminant values so that values
6789 -- of corresponding discriminants are adjacent.
6797 Params
:= New_List
(L_Exp
, R_Exp
);
6798 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
6799 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
6800 while Present
(L_Elmt
) loop
6801 Append_To
(Params
, Node
(L_Elmt
));
6802 Append_To
(Params
, Node
(R_Elmt
));
6808 Make_Function_Call
(Loc
,
6809 Name
=> New_Reference_To
(Eq
, Loc
),
6810 Parameter_Associations
=> Params
));
6814 -- Normal case, not an unchecked union
6818 Make_Function_Call
(Loc
,
6819 Name
=> New_Reference_To
(Eq
, Loc
),
6820 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
6823 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6824 end Build_Equality_Call
;
6826 ------------------------------------
6827 -- Has_Unconstrained_UU_Component --
6828 ------------------------------------
6830 function Has_Unconstrained_UU_Component
6831 (Typ
: Node_Id
) return Boolean
6833 Tdef
: constant Node_Id
:=
6834 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
6838 function Component_Is_Unconstrained_UU
6839 (Comp
: Node_Id
) return Boolean;
6840 -- Determines whether the subtype of the component is an
6841 -- unconstrained Unchecked_Union.
6843 function Variant_Is_Unconstrained_UU
6844 (Variant
: Node_Id
) return Boolean;
6845 -- Determines whether a component of the variant has an unconstrained
6846 -- Unchecked_Union subtype.
6848 -----------------------------------
6849 -- Component_Is_Unconstrained_UU --
6850 -----------------------------------
6852 function Component_Is_Unconstrained_UU
6853 (Comp
: Node_Id
) return Boolean
6856 if Nkind
(Comp
) /= N_Component_Declaration
then
6861 Sindic
: constant Node_Id
:=
6862 Subtype_Indication
(Component_Definition
(Comp
));
6865 -- Unconstrained nominal type. In the case of a constraint
6866 -- present, the node kind would have been N_Subtype_Indication.
6868 if Nkind
(Sindic
) = N_Identifier
then
6869 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
6874 end Component_Is_Unconstrained_UU
;
6876 ---------------------------------
6877 -- Variant_Is_Unconstrained_UU --
6878 ---------------------------------
6880 function Variant_Is_Unconstrained_UU
6881 (Variant
: Node_Id
) return Boolean
6883 Clist
: constant Node_Id
:= Component_List
(Variant
);
6886 if Is_Empty_List
(Component_Items
(Clist
)) then
6890 -- We only need to test one component
6893 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
6896 while Present
(Comp
) loop
6897 if Component_Is_Unconstrained_UU
(Comp
) then
6905 -- None of the components withing the variant were of
6906 -- unconstrained Unchecked_Union type.
6909 end Variant_Is_Unconstrained_UU
;
6911 -- Start of processing for Has_Unconstrained_UU_Component
6914 if Null_Present
(Tdef
) then
6918 Clist
:= Component_List
(Tdef
);
6919 Vpart
:= Variant_Part
(Clist
);
6921 -- Inspect available components
6923 if Present
(Component_Items
(Clist
)) then
6925 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
6928 while Present
(Comp
) loop
6930 -- One component is sufficient
6932 if Component_Is_Unconstrained_UU
(Comp
) then
6941 -- Inspect available components withing variants
6943 if Present
(Vpart
) then
6945 Variant
: Node_Id
:= First
(Variants
(Vpart
));
6948 while Present
(Variant
) loop
6950 -- One component within a variant is sufficient
6952 if Variant_Is_Unconstrained_UU
(Variant
) then
6961 -- Neither the available components, nor the components inside the
6962 -- variant parts were of an unconstrained Unchecked_Union subtype.
6965 end Has_Unconstrained_UU_Component
;
6967 -- Start of processing for Expand_N_Op_Eq
6970 Binary_Op_Validity_Checks
(N
);
6972 -- Deal with private types
6974 if Ekind
(Typl
) = E_Private_Type
then
6975 Typl
:= Underlying_Type
(Typl
);
6976 elsif Ekind
(Typl
) = E_Private_Subtype
then
6977 Typl
:= Underlying_Type
(Base_Type
(Typl
));
6982 -- It may happen in error situations that the underlying type is not
6983 -- set. The error will be detected later, here we just defend the
6990 Typl
:= Base_Type
(Typl
);
6992 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
6993 -- means we no longer have a comparison operation, we are all done.
6995 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
6997 if Nkind
(N
) /= N_Op_Eq
then
7001 -- Boolean types (requiring handling of non-standard case)
7003 if Is_Boolean_Type
(Typl
) then
7004 Adjust_Condition
(Left_Opnd
(N
));
7005 Adjust_Condition
(Right_Opnd
(N
));
7006 Set_Etype
(N
, Standard_Boolean
);
7007 Adjust_Result_Type
(N
, Typ
);
7011 elsif Is_Array_Type
(Typl
) then
7013 -- If we are doing full validity checking, and it is possible for the
7014 -- array elements to be invalid then expand out array comparisons to
7015 -- make sure that we check the array elements.
7017 if Validity_Check_Operands
7018 and then not Is_Known_Valid
(Component_Type
(Typl
))
7021 Save_Force_Validity_Checks
: constant Boolean :=
7022 Force_Validity_Checks
;
7024 Force_Validity_Checks
:= True;
7026 Expand_Array_Equality
7028 Relocate_Node
(Lhs
),
7029 Relocate_Node
(Rhs
),
7032 Insert_Actions
(N
, Bodies
);
7033 Analyze_And_Resolve
(N
, Standard_Boolean
);
7034 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7037 -- Packed case where both operands are known aligned
7039 elsif Is_Bit_Packed_Array
(Typl
)
7040 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7041 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7043 Expand_Packed_Eq
(N
);
7045 -- Where the component type is elementary we can use a block bit
7046 -- comparison (if supported on the target) exception in the case
7047 -- of floating-point (negative zero issues require element by
7048 -- element comparison), and atomic types (where we must be sure
7049 -- to load elements independently) and possibly unaligned arrays.
7051 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7052 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7053 and then not Is_Atomic
(Component_Type
(Typl
))
7054 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7055 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7056 and then Support_Composite_Compare_On_Target
7060 -- For composite and floating-point cases, expand equality loop to
7061 -- make sure of using proper comparisons for tagged types, and
7062 -- correctly handling the floating-point case.
7066 Expand_Array_Equality
7068 Relocate_Node
(Lhs
),
7069 Relocate_Node
(Rhs
),
7072 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7073 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7078 elsif Is_Record_Type
(Typl
) then
7080 -- For tagged types, use the primitive "="
7082 if Is_Tagged_Type
(Typl
) then
7084 -- No need to do anything else compiling under restriction
7085 -- No_Dispatching_Calls. During the semantic analysis we
7086 -- already notified such violation.
7088 if Restriction_Active
(No_Dispatching_Calls
) then
7092 -- If this is derived from an untagged private type completed with
7093 -- a tagged type, it does not have a full view, so we use the
7094 -- primitive operations of the private type. This check should no
7095 -- longer be necessary when these types get their full views???
7097 if Is_Private_Type
(A_Typ
)
7098 and then not Is_Tagged_Type
(A_Typ
)
7099 and then Is_Derived_Type
(A_Typ
)
7100 and then No
(Full_View
(A_Typ
))
7102 -- Search for equality operation, checking that the operands
7103 -- have the same type. Note that we must find a matching entry,
7104 -- or something is very wrong!
7106 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7108 while Present
(Prim
) loop
7109 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7110 and then Etype
(First_Formal
(Node
(Prim
))) =
7111 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7113 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7118 pragma Assert
(Present
(Prim
));
7119 Op_Name
:= Node
(Prim
);
7121 -- Find the type's predefined equality or an overriding
7122 -- user- defined equality. The reason for not simply calling
7123 -- Find_Prim_Op here is that there may be a user-defined
7124 -- overloaded equality op that precedes the equality that we want,
7125 -- so we have to explicitly search (e.g., there could be an
7126 -- equality with two different parameter types).
7129 if Is_Class_Wide_Type
(Typl
) then
7130 Typl
:= Root_Type
(Typl
);
7133 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7134 while Present
(Prim
) loop
7135 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7136 and then Etype
(First_Formal
(Node
(Prim
))) =
7137 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7139 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7144 pragma Assert
(Present
(Prim
));
7145 Op_Name
:= Node
(Prim
);
7148 Build_Equality_Call
(Op_Name
);
7150 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7151 -- predefined equality operator for a type which has a subcomponent
7152 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7154 elsif Has_Unconstrained_UU_Component
(Typl
) then
7156 Make_Raise_Program_Error
(Loc
,
7157 Reason
=> PE_Unchecked_Union_Restriction
));
7159 -- Prevent Gigi from generating incorrect code by rewriting the
7160 -- equality as a standard False. (is this documented somewhere???)
7163 New_Occurrence_Of
(Standard_False
, Loc
));
7165 elsif Is_Unchecked_Union
(Typl
) then
7167 -- If we can infer the discriminants of the operands, we make a
7168 -- call to the TSS equality function.
7170 if Has_Inferable_Discriminants
(Lhs
)
7172 Has_Inferable_Discriminants
(Rhs
)
7175 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7178 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7179 -- the predefined equality operator for an Unchecked_Union type
7180 -- if either of the operands lack inferable discriminants.
7183 Make_Raise_Program_Error
(Loc
,
7184 Reason
=> PE_Unchecked_Union_Restriction
));
7186 -- Prevent Gigi from generating incorrect code by rewriting
7187 -- the equality as a standard False (documented where???).
7190 New_Occurrence_Of
(Standard_False
, Loc
));
7194 -- If a type support function is present (for complex cases), use it
7196 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7198 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7200 -- When comparing two Bounded_Strings, use the primitive equality of
7201 -- the root Super_String type.
7203 elsif Is_Bounded_String
(Typl
) then
7205 First_Elmt
(Collect_Primitive_Operations
(Root_Type
(Typl
)));
7207 while Present
(Prim
) loop
7208 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7209 and then Etype
(First_Formal
(Node
(Prim
))) =
7210 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7211 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7216 -- A Super_String type should always have a primitive equality
7218 pragma Assert
(Present
(Prim
));
7219 Build_Equality_Call
(Node
(Prim
));
7221 -- Otherwise expand the component by component equality. Note that
7222 -- we never use block-bit comparisons for records, because of the
7223 -- problems with gaps. The backend will often be able to recombine
7224 -- the separate comparisons that we generate here.
7227 Remove_Side_Effects
(Lhs
);
7228 Remove_Side_Effects
(Rhs
);
7230 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7232 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7233 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7237 -- Test if result is known at compile time
7239 Rewrite_Comparison
(N
);
7241 -- If we still have comparison for Vax_Float, process it
7243 if Vax_Float
(Typl
) and then Nkind
(N
) in N_Op_Compare
then
7244 Expand_Vax_Comparison
(N
);
7248 Optimize_Length_Comparison
(N
);
7251 -----------------------
7252 -- Expand_N_Op_Expon --
7253 -----------------------
7255 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
7256 Loc
: constant Source_Ptr
:= Sloc
(N
);
7257 Typ
: constant Entity_Id
:= Etype
(N
);
7258 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
7259 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
7260 Bastyp
: constant Node_Id
:= Etype
(Base
);
7261 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
7262 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
7263 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
7272 Binary_Op_Validity_Checks
(N
);
7274 -- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node
7276 if CodePeer_Mode
or SPARK_Mode
then
7280 -- If either operand is of a private type, then we have the use of an
7281 -- intrinsic operator, and we get rid of the privateness, by using root
7282 -- types of underlying types for the actual operation. Otherwise the
7283 -- private types will cause trouble if we expand multiplications or
7284 -- shifts etc. We also do this transformation if the result type is
7285 -- different from the base type.
7287 if Is_Private_Type
(Etype
(Base
))
7288 or else Is_Private_Type
(Typ
)
7289 or else Is_Private_Type
(Exptyp
)
7290 or else Rtyp
/= Root_Type
(Bastyp
)
7293 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
7294 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
7298 Unchecked_Convert_To
(Typ
,
7300 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
7301 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
7302 Analyze_And_Resolve
(N
, Typ
);
7307 -- Check for MINIMIZED/ELIMINATED overflow mode
7309 if Minimized_Eliminated_Overflow_Check
(N
) then
7310 Apply_Arithmetic_Overflow_Check
(N
);
7314 -- Test for case of known right argument where we can replace the
7315 -- exponentiation by an equivalent expression using multiplication.
7317 if Compile_Time_Known_Value
(Exp
) then
7318 Expv
:= Expr_Value
(Exp
);
7320 -- We only fold small non-negative exponents. You might think we
7321 -- could fold small negative exponents for the real case, but we
7322 -- can't because we are required to raise Constraint_Error for
7323 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7324 -- See ACVC test C4A012B.
7326 if Expv
>= 0 and then Expv
<= 4 then
7328 -- X ** 0 = 1 (or 1.0)
7332 -- Call Remove_Side_Effects to ensure that any side effects
7333 -- in the ignored left operand (in particular function calls
7334 -- to user defined functions) are properly executed.
7336 Remove_Side_Effects
(Base
);
7338 if Ekind
(Typ
) in Integer_Kind
then
7339 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
7341 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
7353 Make_Op_Multiply
(Loc
,
7354 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7355 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7357 -- X ** 3 = X * X * X
7361 Make_Op_Multiply
(Loc
,
7363 Make_Op_Multiply
(Loc
,
7364 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7365 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
7366 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7371 -- En : constant base'type := base * base;
7376 pragma Assert
(Expv
= 4);
7377 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
7380 Make_Expression_With_Actions
(Loc
,
7381 Actions
=> New_List
(
7382 Make_Object_Declaration
(Loc
,
7383 Defining_Identifier
=> Temp
,
7384 Constant_Present
=> True,
7385 Object_Definition
=> New_Reference_To
(Typ
, Loc
),
7387 Make_Op_Multiply
(Loc
,
7389 Duplicate_Subexpr
(Base
),
7391 Duplicate_Subexpr_No_Checks
(Base
)))),
7394 Make_Op_Multiply
(Loc
,
7395 Left_Opnd
=> New_Reference_To
(Temp
, Loc
),
7396 Right_Opnd
=> New_Reference_To
(Temp
, Loc
)));
7400 Analyze_And_Resolve
(N
, Typ
);
7405 -- Case of (2 ** expression) appearing as an argument of an integer
7406 -- multiplication, or as the right argument of a division of a non-
7407 -- negative integer. In such cases we leave the node untouched, setting
7408 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
7409 -- of the higher level node converts it into a shift.
7411 -- Another case is 2 ** N in any other context. We simply convert
7412 -- this to 1 * 2 ** N, and then the above transformation applies.
7414 -- Note: this transformation is not applicable for a modular type with
7415 -- a non-binary modulus in the multiplication case, since we get a wrong
7416 -- result if the shift causes an overflow before the modular reduction.
7418 if Nkind
(Base
) = N_Integer_Literal
7419 and then Intval
(Base
) = 2
7420 and then Is_Integer_Type
(Root_Type
(Exptyp
))
7421 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
7422 and then Is_Unsigned_Type
(Exptyp
)
7425 -- First the multiply and divide cases
7427 if Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
) then
7429 P
: constant Node_Id
:= Parent
(N
);
7430 L
: constant Node_Id
:= Left_Opnd
(P
);
7431 R
: constant Node_Id
:= Right_Opnd
(P
);
7434 if (Nkind
(P
) = N_Op_Multiply
7435 and then not Non_Binary_Modulus
(Typ
)
7437 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
7439 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
7440 and then not Do_Overflow_Check
(P
))
7442 (Nkind
(P
) = N_Op_Divide
7443 and then Is_Integer_Type
(Etype
(L
))
7444 and then Is_Unsigned_Type
(Etype
(L
))
7446 and then not Do_Overflow_Check
(P
))
7448 Set_Is_Power_Of_2_For_Shift
(N
);
7453 -- Now the other cases
7455 elsif not Non_Binary_Modulus
(Typ
) then
7457 Make_Op_Multiply
(Loc
,
7458 Left_Opnd
=> Make_Integer_Literal
(Loc
, 1),
7459 Right_Opnd
=> Relocate_Node
(N
)));
7460 Analyze_And_Resolve
(N
, Typ
);
7465 -- Fall through if exponentiation must be done using a runtime routine
7467 -- First deal with modular case
7469 if Is_Modular_Integer_Type
(Rtyp
) then
7471 -- Non-binary case, we call the special exponentiation routine for
7472 -- the non-binary case, converting the argument to Long_Long_Integer
7473 -- and passing the modulus value. Then the result is converted back
7474 -- to the base type.
7476 if Non_Binary_Modulus
(Rtyp
) then
7479 Make_Function_Call
(Loc
,
7480 Name
=> New_Reference_To
(RTE
(RE_Exp_Modular
), Loc
),
7481 Parameter_Associations
=> New_List
(
7482 Convert_To
(Standard_Integer
, Base
),
7483 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
7486 -- Binary case, in this case, we call one of two routines, either the
7487 -- unsigned integer case, or the unsigned long long integer case,
7488 -- with a final "and" operation to do the required mod.
7491 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
7492 Ent
:= RTE
(RE_Exp_Unsigned
);
7494 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
7501 Make_Function_Call
(Loc
,
7502 Name
=> New_Reference_To
(Ent
, Loc
),
7503 Parameter_Associations
=> New_List
(
7504 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
7507 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
7511 -- Common exit point for modular type case
7513 Analyze_And_Resolve
(N
, Typ
);
7516 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7517 -- It is not worth having routines for Short_[Short_]Integer, since for
7518 -- most machines it would not help, and it would generate more code that
7519 -- might need certification when a certified run time is required.
7521 -- In the integer cases, we have two routines, one for when overflow
7522 -- checks are required, and one when they are not required, since there
7523 -- is a real gain in omitting checks on many machines.
7525 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
7526 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
7528 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
7529 or else Rtyp
= Universal_Integer
7531 Etyp
:= Standard_Long_Long_Integer
;
7534 Rent
:= RE_Exp_Long_Long_Integer
;
7536 Rent
:= RE_Exn_Long_Long_Integer
;
7539 elsif Is_Signed_Integer_Type
(Rtyp
) then
7540 Etyp
:= Standard_Integer
;
7543 Rent
:= RE_Exp_Integer
;
7545 Rent
:= RE_Exn_Integer
;
7548 -- Floating-point cases, always done using Long_Long_Float. We do not
7549 -- need separate routines for the overflow case here, since in the case
7550 -- of floating-point, we generate infinities anyway as a rule (either
7551 -- that or we automatically trap overflow), and if there is an infinity
7552 -- generated and a range check is required, the check will fail anyway.
7555 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
7556 Etyp
:= Standard_Long_Long_Float
;
7557 Rent
:= RE_Exn_Long_Long_Float
;
7560 -- Common processing for integer cases and floating-point cases.
7561 -- If we are in the right type, we can call runtime routine directly
7564 and then Rtyp
/= Universal_Integer
7565 and then Rtyp
/= Universal_Real
7568 Make_Function_Call
(Loc
,
7569 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
7570 Parameter_Associations
=> New_List
(Base
, Exp
)));
7572 -- Otherwise we have to introduce conversions (conversions are also
7573 -- required in the universal cases, since the runtime routine is
7574 -- typed using one of the standard types).
7579 Make_Function_Call
(Loc
,
7580 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
7581 Parameter_Associations
=> New_List
(
7582 Convert_To
(Etyp
, Base
),
7586 Analyze_And_Resolve
(N
, Typ
);
7590 when RE_Not_Available
=>
7592 end Expand_N_Op_Expon
;
7594 --------------------
7595 -- Expand_N_Op_Ge --
7596 --------------------
7598 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
7599 Typ
: constant Entity_Id
:= Etype
(N
);
7600 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7601 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7602 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7605 Binary_Op_Validity_Checks
(N
);
7607 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7608 -- means we no longer have a comparison operation, we are all done.
7610 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7612 if Nkind
(N
) /= N_Op_Ge
then
7618 if Is_Array_Type
(Typ1
) then
7619 Expand_Array_Comparison
(N
);
7623 -- Deal with boolean operands
7625 if Is_Boolean_Type
(Typ1
) then
7626 Adjust_Condition
(Op1
);
7627 Adjust_Condition
(Op2
);
7628 Set_Etype
(N
, Standard_Boolean
);
7629 Adjust_Result_Type
(N
, Typ
);
7632 Rewrite_Comparison
(N
);
7634 -- If we still have comparison, and Vax_Float type, process it
7636 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7637 Expand_Vax_Comparison
(N
);
7641 Optimize_Length_Comparison
(N
);
7644 --------------------
7645 -- Expand_N_Op_Gt --
7646 --------------------
7648 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
7649 Typ
: constant Entity_Id
:= Etype
(N
);
7650 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7651 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7652 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7655 Binary_Op_Validity_Checks
(N
);
7657 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7658 -- means we no longer have a comparison operation, we are all done.
7660 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7662 if Nkind
(N
) /= N_Op_Gt
then
7666 -- Deal with array type operands
7668 if Is_Array_Type
(Typ1
) then
7669 Expand_Array_Comparison
(N
);
7673 -- Deal with boolean type operands
7675 if Is_Boolean_Type
(Typ1
) then
7676 Adjust_Condition
(Op1
);
7677 Adjust_Condition
(Op2
);
7678 Set_Etype
(N
, Standard_Boolean
);
7679 Adjust_Result_Type
(N
, Typ
);
7682 Rewrite_Comparison
(N
);
7684 -- If we still have comparison, and Vax_Float type, process it
7686 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7687 Expand_Vax_Comparison
(N
);
7691 Optimize_Length_Comparison
(N
);
7694 --------------------
7695 -- Expand_N_Op_Le --
7696 --------------------
7698 procedure Expand_N_Op_Le
(N
: Node_Id
) is
7699 Typ
: constant Entity_Id
:= Etype
(N
);
7700 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7701 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7702 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7705 Binary_Op_Validity_Checks
(N
);
7707 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7708 -- means we no longer have a comparison operation, we are all done.
7710 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7712 if Nkind
(N
) /= N_Op_Le
then
7716 -- Deal with array type operands
7718 if Is_Array_Type
(Typ1
) then
7719 Expand_Array_Comparison
(N
);
7723 -- Deal with Boolean type operands
7725 if Is_Boolean_Type
(Typ1
) then
7726 Adjust_Condition
(Op1
);
7727 Adjust_Condition
(Op2
);
7728 Set_Etype
(N
, Standard_Boolean
);
7729 Adjust_Result_Type
(N
, Typ
);
7732 Rewrite_Comparison
(N
);
7734 -- If we still have comparison, and Vax_Float type, process it
7736 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7737 Expand_Vax_Comparison
(N
);
7741 Optimize_Length_Comparison
(N
);
7744 --------------------
7745 -- Expand_N_Op_Lt --
7746 --------------------
7748 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
7749 Typ
: constant Entity_Id
:= Etype
(N
);
7750 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7751 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7752 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7755 Binary_Op_Validity_Checks
(N
);
7757 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7758 -- means we no longer have a comparison operation, we are all done.
7760 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7762 if Nkind
(N
) /= N_Op_Lt
then
7766 -- Deal with array type operands
7768 if Is_Array_Type
(Typ1
) then
7769 Expand_Array_Comparison
(N
);
7773 -- Deal with Boolean type operands
7775 if Is_Boolean_Type
(Typ1
) then
7776 Adjust_Condition
(Op1
);
7777 Adjust_Condition
(Op2
);
7778 Set_Etype
(N
, Standard_Boolean
);
7779 Adjust_Result_Type
(N
, Typ
);
7782 Rewrite_Comparison
(N
);
7784 -- If we still have comparison, and Vax_Float type, process it
7786 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7787 Expand_Vax_Comparison
(N
);
7791 Optimize_Length_Comparison
(N
);
7794 -----------------------
7795 -- Expand_N_Op_Minus --
7796 -----------------------
7798 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
7799 Loc
: constant Source_Ptr
:= Sloc
(N
);
7800 Typ
: constant Entity_Id
:= Etype
(N
);
7803 Unary_Op_Validity_Checks
(N
);
7805 -- Check for MINIMIZED/ELIMINATED overflow mode
7807 if Minimized_Eliminated_Overflow_Check
(N
) then
7808 Apply_Arithmetic_Overflow_Check
(N
);
7812 if not Backend_Overflow_Checks_On_Target
7813 and then Is_Signed_Integer_Type
(Etype
(N
))
7814 and then Do_Overflow_Check
(N
)
7816 -- Software overflow checking expands -expr into (0 - expr)
7819 Make_Op_Subtract
(Loc
,
7820 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
7821 Right_Opnd
=> Right_Opnd
(N
)));
7823 Analyze_And_Resolve
(N
, Typ
);
7825 -- Vax floating-point types case
7827 elsif Vax_Float
(Etype
(N
)) then
7828 Expand_Vax_Arith
(N
);
7830 end Expand_N_Op_Minus
;
7832 ---------------------
7833 -- Expand_N_Op_Mod --
7834 ---------------------
7836 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
7837 Loc
: constant Source_Ptr
:= Sloc
(N
);
7838 Typ
: constant Entity_Id
:= Etype
(N
);
7839 DDC
: constant Boolean := Do_Division_Check
(N
);
7852 pragma Warnings
(Off
, Lhi
);
7855 Binary_Op_Validity_Checks
(N
);
7857 -- Check for MINIMIZED/ELIMINATED overflow mode
7859 if Minimized_Eliminated_Overflow_Check
(N
) then
7860 Apply_Arithmetic_Overflow_Check
(N
);
7864 if Is_Integer_Type
(Etype
(N
)) then
7865 Apply_Divide_Checks
(N
);
7867 -- All done if we don't have a MOD any more, which can happen as a
7868 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
7870 if Nkind
(N
) /= N_Op_Mod
then
7875 -- Proceed with expansion of mod operator
7877 Left
:= Left_Opnd
(N
);
7878 Right
:= Right_Opnd
(N
);
7880 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
7881 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
7883 -- Convert mod to rem if operands are known non-negative. We do this
7884 -- since it is quite likely that this will improve the quality of code,
7885 -- (the operation now corresponds to the hardware remainder), and it
7886 -- does not seem likely that it could be harmful.
7888 if LOK
and then Llo
>= 0 and then ROK
and then Rlo
>= 0 then
7890 Make_Op_Rem
(Sloc
(N
),
7891 Left_Opnd
=> Left_Opnd
(N
),
7892 Right_Opnd
=> Right_Opnd
(N
)));
7894 -- Instead of reanalyzing the node we do the analysis manually. This
7895 -- avoids anomalies when the replacement is done in an instance and
7896 -- is epsilon more efficient.
7898 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
7900 Set_Do_Division_Check
(N
, DDC
);
7901 Expand_N_Op_Rem
(N
);
7904 -- Otherwise, normal mod processing
7907 -- Apply optimization x mod 1 = 0. We don't really need that with
7908 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
7909 -- certainly harmless.
7911 if Is_Integer_Type
(Etype
(N
))
7912 and then Compile_Time_Known_Value
(Right
)
7913 and then Expr_Value
(Right
) = Uint_1
7915 -- Call Remove_Side_Effects to ensure that any side effects in
7916 -- the ignored left operand (in particular function calls to
7917 -- user defined functions) are properly executed.
7919 Remove_Side_Effects
(Left
);
7921 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
7922 Analyze_And_Resolve
(N
, Typ
);
7926 -- Deal with annoying case of largest negative number remainder
7927 -- minus one. Gigi may not handle this case correctly, because
7928 -- on some targets, the mod value is computed using a divide
7929 -- instruction which gives an overflow trap for this case.
7931 -- It would be a bit more efficient to figure out which targets
7932 -- this is really needed for, but in practice it is reasonable
7933 -- to do the following special check in all cases, since it means
7934 -- we get a clearer message, and also the overhead is minimal given
7935 -- that division is expensive in any case.
7937 -- In fact the check is quite easy, if the right operand is -1, then
7938 -- the mod value is always 0, and we can just ignore the left operand
7939 -- completely in this case.
7941 -- This only applies if we still have a mod operator. Skip if we
7942 -- have already rewritten this (e.g. in the case of eliminated
7943 -- overflow checks which have driven us into bignum mode).
7945 if Nkind
(N
) = N_Op_Mod
then
7947 -- The operand type may be private (e.g. in the expansion of an
7948 -- intrinsic operation) so we must use the underlying type to get
7949 -- the bounds, and convert the literals explicitly.
7953 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
7955 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
7956 and then ((not LOK
) or else (Llo
= LLB
))
7959 Make_If_Expression
(Loc
,
7960 Expressions
=> New_List
(
7962 Left_Opnd
=> Duplicate_Subexpr
(Right
),
7964 Unchecked_Convert_To
(Typ
,
7965 Make_Integer_Literal
(Loc
, -1))),
7966 Unchecked_Convert_To
(Typ
,
7967 Make_Integer_Literal
(Loc
, Uint_0
)),
7968 Relocate_Node
(N
))));
7970 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
7971 Analyze_And_Resolve
(N
, Typ
);
7975 end Expand_N_Op_Mod
;
7977 --------------------------
7978 -- Expand_N_Op_Multiply --
7979 --------------------------
7981 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
7982 Loc
: constant Source_Ptr
:= Sloc
(N
);
7983 Lop
: constant Node_Id
:= Left_Opnd
(N
);
7984 Rop
: constant Node_Id
:= Right_Opnd
(N
);
7986 Lp2
: constant Boolean :=
7987 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
7988 Rp2
: constant Boolean :=
7989 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
7991 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
7992 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
7993 Typ
: Entity_Id
:= Etype
(N
);
7996 Binary_Op_Validity_Checks
(N
);
7998 -- Check for MINIMIZED/ELIMINATED overflow mode
8000 if Minimized_Eliminated_Overflow_Check
(N
) then
8001 Apply_Arithmetic_Overflow_Check
(N
);
8005 -- Special optimizations for integer types
8007 if Is_Integer_Type
(Typ
) then
8009 -- N * 0 = 0 for integer types
8011 if Compile_Time_Known_Value
(Rop
)
8012 and then Expr_Value
(Rop
) = Uint_0
8014 -- Call Remove_Side_Effects to ensure that any side effects in
8015 -- the ignored left operand (in particular function calls to
8016 -- user defined functions) are properly executed.
8018 Remove_Side_Effects
(Lop
);
8020 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8021 Analyze_And_Resolve
(N
, Typ
);
8025 -- Similar handling for 0 * N = 0
8027 if Compile_Time_Known_Value
(Lop
)
8028 and then Expr_Value
(Lop
) = Uint_0
8030 Remove_Side_Effects
(Rop
);
8031 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8032 Analyze_And_Resolve
(N
, Typ
);
8036 -- N * 1 = 1 * N = N for integer types
8038 -- This optimisation is not done if we are going to
8039 -- rewrite the product 1 * 2 ** N to a shift.
8041 if Compile_Time_Known_Value
(Rop
)
8042 and then Expr_Value
(Rop
) = Uint_1
8048 elsif Compile_Time_Known_Value
(Lop
)
8049 and then Expr_Value
(Lop
) = Uint_1
8057 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8058 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8059 -- operand is an integer, as required for this to work.
8064 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8068 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
8071 Left_Opnd
=> Right_Opnd
(Lop
),
8072 Right_Opnd
=> Right_Opnd
(Rop
))));
8073 Analyze_And_Resolve
(N
, Typ
);
8078 Make_Op_Shift_Left
(Loc
,
8081 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
8082 Analyze_And_Resolve
(N
, Typ
);
8086 -- Same processing for the operands the other way round
8090 Make_Op_Shift_Left
(Loc
,
8093 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
8094 Analyze_And_Resolve
(N
, Typ
);
8098 -- Do required fixup of universal fixed operation
8100 if Typ
= Universal_Fixed
then
8101 Fixup_Universal_Fixed_Operation
(N
);
8105 -- Multiplications with fixed-point results
8107 if Is_Fixed_Point_Type
(Typ
) then
8109 -- No special processing if Treat_Fixed_As_Integer is set, since from
8110 -- a semantic point of view such operations are simply integer
8111 -- operations and will be treated that way.
8113 if not Treat_Fixed_As_Integer
(N
) then
8115 -- Case of fixed * integer => fixed
8117 if Is_Integer_Type
(Rtyp
) then
8118 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
8120 -- Case of integer * fixed => fixed
8122 elsif Is_Integer_Type
(Ltyp
) then
8123 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
8125 -- Case of fixed * fixed => fixed
8128 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
8132 -- Other cases of multiplication of fixed-point operands. Again we
8133 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8135 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
8136 and then not Treat_Fixed_As_Integer
(N
)
8138 if Is_Integer_Type
(Typ
) then
8139 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
8141 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8142 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
8145 -- Mixed-mode operations can appear in a non-static universal context,
8146 -- in which case the integer argument must be converted explicitly.
8148 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
8149 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
8150 Analyze_And_Resolve
(Rop
, Universal_Real
);
8152 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
8153 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
8154 Analyze_And_Resolve
(Lop
, Universal_Real
);
8156 -- Non-fixed point cases, check software overflow checking required
8158 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
8159 Apply_Arithmetic_Overflow_Check
(N
);
8161 -- Deal with VAX float case
8163 elsif Vax_Float
(Typ
) then
8164 Expand_Vax_Arith
(N
);
8167 end Expand_N_Op_Multiply
;
8169 --------------------
8170 -- Expand_N_Op_Ne --
8171 --------------------
8173 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
8174 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
8177 -- Case of elementary type with standard operator
8179 if Is_Elementary_Type
(Typ
)
8180 and then Sloc
(Entity
(N
)) = Standard_Location
8182 Binary_Op_Validity_Checks
(N
);
8184 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8185 -- means we no longer have a /= operation, we are all done.
8187 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8189 if Nkind
(N
) /= N_Op_Ne
then
8193 -- Boolean types (requiring handling of non-standard case)
8195 if Is_Boolean_Type
(Typ
) then
8196 Adjust_Condition
(Left_Opnd
(N
));
8197 Adjust_Condition
(Right_Opnd
(N
));
8198 Set_Etype
(N
, Standard_Boolean
);
8199 Adjust_Result_Type
(N
, Typ
);
8202 Rewrite_Comparison
(N
);
8204 -- If we still have comparison for Vax_Float, process it
8206 if Vax_Float
(Typ
) and then Nkind
(N
) in N_Op_Compare
then
8207 Expand_Vax_Comparison
(N
);
8211 -- For all cases other than elementary types, we rewrite node as the
8212 -- negation of an equality operation, and reanalyze. The equality to be
8213 -- used is defined in the same scope and has the same signature. This
8214 -- signature must be set explicitly since in an instance it may not have
8215 -- the same visibility as in the generic unit. This avoids duplicating
8216 -- or factoring the complex code for record/array equality tests etc.
8220 Loc
: constant Source_Ptr
:= Sloc
(N
);
8222 Ne
: constant Entity_Id
:= Entity
(N
);
8225 Binary_Op_Validity_Checks
(N
);
8231 Left_Opnd
=> Left_Opnd
(N
),
8232 Right_Opnd
=> Right_Opnd
(N
)));
8233 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
8235 if Scope
(Ne
) /= Standard_Standard
then
8236 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
8239 -- For navigation purposes, we want to treat the inequality as an
8240 -- implicit reference to the corresponding equality. Preserve the
8241 -- Comes_From_ source flag to generate proper Xref entries.
8243 Preserve_Comes_From_Source
(Neg
, N
);
8244 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
8246 Analyze_And_Resolve
(N
, Standard_Boolean
);
8250 Optimize_Length_Comparison
(N
);
8253 ---------------------
8254 -- Expand_N_Op_Not --
8255 ---------------------
8257 -- If the argument is other than a Boolean array type, there is no special
8258 -- expansion required, except for VMS operations on signed integers.
8260 -- For the packed case, we call the special routine in Exp_Pakd, except
8261 -- that if the component size is greater than one, we use the standard
8262 -- routine generating a gruesome loop (it is so peculiar to have packed
8263 -- arrays with non-standard Boolean representations anyway, so it does not
8264 -- matter that we do not handle this case efficiently).
8266 -- For the unpacked case (and for the special packed case where we have non
8267 -- standard Booleans, as discussed above), we generate and insert into the
8268 -- tree the following function definition:
8270 -- function Nnnn (A : arr) is
8273 -- for J in a'range loop
8274 -- B (J) := not A (J);
8279 -- Here arr is the actual subtype of the parameter (and hence always
8280 -- constrained). Then we replace the not with a call to this function.
8282 procedure Expand_N_Op_Not
(N
: Node_Id
) is
8283 Loc
: constant Source_Ptr
:= Sloc
(N
);
8284 Typ
: constant Entity_Id
:= Etype
(N
);
8293 Func_Name
: Entity_Id
;
8294 Loop_Statement
: Node_Id
;
8297 Unary_Op_Validity_Checks
(N
);
8299 -- For boolean operand, deal with non-standard booleans
8301 if Is_Boolean_Type
(Typ
) then
8302 Adjust_Condition
(Right_Opnd
(N
));
8303 Set_Etype
(N
, Standard_Boolean
);
8304 Adjust_Result_Type
(N
, Typ
);
8308 -- For the VMS "not" on signed integer types, use conversion to and from
8309 -- a predefined modular type.
8311 if Is_VMS_Operator
(Entity
(N
)) then
8317 -- If this is a derived type, retrieve original VMS type so that
8318 -- the proper sized type is used for intermediate values.
8320 if Is_Derived_Type
(Typ
) then
8321 Rtyp
:= First_Subtype
(Etype
(Typ
));
8326 -- The proper unsigned type must have a size compatible with the
8327 -- operand, to prevent misalignment.
8329 if RM_Size
(Rtyp
) <= 8 then
8330 Utyp
:= RTE
(RE_Unsigned_8
);
8332 elsif RM_Size
(Rtyp
) <= 16 then
8333 Utyp
:= RTE
(RE_Unsigned_16
);
8335 elsif RM_Size
(Rtyp
) = RM_Size
(Standard_Unsigned
) then
8336 Utyp
:= RTE
(RE_Unsigned_32
);
8339 Utyp
:= RTE
(RE_Long_Long_Unsigned
);
8343 Unchecked_Convert_To
(Typ
,
8345 Unchecked_Convert_To
(Utyp
, Right_Opnd
(N
)))));
8346 Analyze_And_Resolve
(N
, Typ
);
8351 -- Only array types need any other processing
8353 if not Is_Array_Type
(Typ
) then
8357 -- Case of array operand. If bit packed with a component size of 1,
8358 -- handle it in Exp_Pakd if the operand is known to be aligned.
8360 if Is_Bit_Packed_Array
(Typ
)
8361 and then Component_Size
(Typ
) = 1
8362 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
8364 Expand_Packed_Not
(N
);
8368 -- Case of array operand which is not bit-packed. If the context is
8369 -- a safe assignment, call in-place operation, If context is a larger
8370 -- boolean expression in the context of a safe assignment, expansion is
8371 -- done by enclosing operation.
8373 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
8374 Convert_To_Actual_Subtype
(Opnd
);
8375 Arr
:= Etype
(Opnd
);
8376 Ensure_Defined
(Arr
, N
);
8377 Silly_Boolean_Array_Not_Test
(N
, Arr
);
8379 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
8380 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
8381 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8384 -- Special case the negation of a binary operation
8386 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
8387 and then Safe_In_Place_Array_Op
8388 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
8390 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8394 elsif Nkind
(Parent
(N
)) in N_Binary_Op
8395 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
8398 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
8399 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
8400 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
8403 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
8405 -- (not A) op (not B) can be reduced to a single call
8407 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
8410 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
8413 -- A xor (not B) can also be special-cased
8415 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
8422 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
8423 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8424 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
8427 Make_Indexed_Component
(Loc
,
8428 Prefix
=> New_Reference_To
(A
, Loc
),
8429 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
8432 Make_Indexed_Component
(Loc
,
8433 Prefix
=> New_Reference_To
(B
, Loc
),
8434 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
8437 Make_Implicit_Loop_Statement
(N
,
8438 Identifier
=> Empty
,
8441 Make_Iteration_Scheme
(Loc
,
8442 Loop_Parameter_Specification
=>
8443 Make_Loop_Parameter_Specification
(Loc
,
8444 Defining_Identifier
=> J
,
8445 Discrete_Subtype_Definition
=>
8446 Make_Attribute_Reference
(Loc
,
8447 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
8448 Attribute_Name
=> Name_Range
))),
8450 Statements
=> New_List
(
8451 Make_Assignment_Statement
(Loc
,
8453 Expression
=> Make_Op_Not
(Loc
, A_J
))));
8455 Func_Name
:= Make_Temporary
(Loc
, 'N');
8456 Set_Is_Inlined
(Func_Name
);
8459 Make_Subprogram_Body
(Loc
,
8461 Make_Function_Specification
(Loc
,
8462 Defining_Unit_Name
=> Func_Name
,
8463 Parameter_Specifications
=> New_List
(
8464 Make_Parameter_Specification
(Loc
,
8465 Defining_Identifier
=> A
,
8466 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))),
8467 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
8469 Declarations
=> New_List
(
8470 Make_Object_Declaration
(Loc
,
8471 Defining_Identifier
=> B
,
8472 Object_Definition
=> New_Reference_To
(Arr
, Loc
))),
8474 Handled_Statement_Sequence
=>
8475 Make_Handled_Sequence_Of_Statements
(Loc
,
8476 Statements
=> New_List
(
8478 Make_Simple_Return_Statement
(Loc
,
8479 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
8482 Make_Function_Call
(Loc
,
8483 Name
=> New_Reference_To
(Func_Name
, Loc
),
8484 Parameter_Associations
=> New_List
(Opnd
)));
8486 Analyze_And_Resolve
(N
, Typ
);
8487 end Expand_N_Op_Not
;
8489 --------------------
8490 -- Expand_N_Op_Or --
8491 --------------------
8493 procedure Expand_N_Op_Or
(N
: Node_Id
) is
8494 Typ
: constant Entity_Id
:= Etype
(N
);
8497 Binary_Op_Validity_Checks
(N
);
8499 if Is_Array_Type
(Etype
(N
)) then
8500 Expand_Boolean_Operator
(N
);
8502 elsif Is_Boolean_Type
(Etype
(N
)) then
8503 Adjust_Condition
(Left_Opnd
(N
));
8504 Adjust_Condition
(Right_Opnd
(N
));
8505 Set_Etype
(N
, Standard_Boolean
);
8506 Adjust_Result_Type
(N
, Typ
);
8508 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8509 Expand_Intrinsic_Call
(N
, Entity
(N
));
8514 ----------------------
8515 -- Expand_N_Op_Plus --
8516 ----------------------
8518 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
8520 Unary_Op_Validity_Checks
(N
);
8522 -- Check for MINIMIZED/ELIMINATED overflow mode
8524 if Minimized_Eliminated_Overflow_Check
(N
) then
8525 Apply_Arithmetic_Overflow_Check
(N
);
8528 end Expand_N_Op_Plus
;
8530 ---------------------
8531 -- Expand_N_Op_Rem --
8532 ---------------------
8534 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
8535 Loc
: constant Source_Ptr
:= Sloc
(N
);
8536 Typ
: constant Entity_Id
:= Etype
(N
);
8547 -- Set if corresponding operand can be negative
8549 pragma Unreferenced
(Hi
);
8552 Binary_Op_Validity_Checks
(N
);
8554 -- Check for MINIMIZED/ELIMINATED overflow mode
8556 if Minimized_Eliminated_Overflow_Check
(N
) then
8557 Apply_Arithmetic_Overflow_Check
(N
);
8561 if Is_Integer_Type
(Etype
(N
)) then
8562 Apply_Divide_Checks
(N
);
8564 -- All done if we don't have a REM any more, which can happen as a
8565 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8567 if Nkind
(N
) /= N_Op_Rem
then
8572 -- Proceed with expansion of REM
8574 Left
:= Left_Opnd
(N
);
8575 Right
:= Right_Opnd
(N
);
8577 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
8578 -- but it is useful with other back ends (e.g. AAMP), and is certainly
8581 if Is_Integer_Type
(Etype
(N
))
8582 and then Compile_Time_Known_Value
(Right
)
8583 and then Expr_Value
(Right
) = Uint_1
8585 -- Call Remove_Side_Effects to ensure that any side effects in the
8586 -- ignored left operand (in particular function calls to user defined
8587 -- functions) are properly executed.
8589 Remove_Side_Effects
(Left
);
8591 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8592 Analyze_And_Resolve
(N
, Typ
);
8596 -- Deal with annoying case of largest negative number remainder minus
8597 -- one. Gigi may not handle this case correctly, because on some
8598 -- targets, the mod value is computed using a divide instruction
8599 -- which gives an overflow trap for this case.
8601 -- It would be a bit more efficient to figure out which targets this
8602 -- is really needed for, but in practice it is reasonable to do the
8603 -- following special check in all cases, since it means we get a clearer
8604 -- message, and also the overhead is minimal given that division is
8605 -- expensive in any case.
8607 -- In fact the check is quite easy, if the right operand is -1, then
8608 -- the remainder is always 0, and we can just ignore the left operand
8609 -- completely in this case.
8611 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8612 Lneg
:= (not OK
) or else Lo
< 0;
8614 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8615 Rneg
:= (not OK
) or else Lo
< 0;
8617 -- We won't mess with trying to find out if the left operand can really
8618 -- be the largest negative number (that's a pain in the case of private
8619 -- types and this is really marginal). We will just assume that we need
8620 -- the test if the left operand can be negative at all.
8622 if Lneg
and Rneg
then
8624 Make_If_Expression
(Loc
,
8625 Expressions
=> New_List
(
8627 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8629 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
8631 Unchecked_Convert_To
(Typ
,
8632 Make_Integer_Literal
(Loc
, Uint_0
)),
8634 Relocate_Node
(N
))));
8636 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8637 Analyze_And_Resolve
(N
, Typ
);
8639 end Expand_N_Op_Rem
;
8641 -----------------------------
8642 -- Expand_N_Op_Rotate_Left --
8643 -----------------------------
8645 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
8647 Binary_Op_Validity_Checks
(N
);
8648 end Expand_N_Op_Rotate_Left
;
8650 ------------------------------
8651 -- Expand_N_Op_Rotate_Right --
8652 ------------------------------
8654 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
8656 Binary_Op_Validity_Checks
(N
);
8657 end Expand_N_Op_Rotate_Right
;
8659 ----------------------------
8660 -- Expand_N_Op_Shift_Left --
8661 ----------------------------
8663 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
8665 Binary_Op_Validity_Checks
(N
);
8666 end Expand_N_Op_Shift_Left
;
8668 -----------------------------
8669 -- Expand_N_Op_Shift_Right --
8670 -----------------------------
8672 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
8674 Binary_Op_Validity_Checks
(N
);
8675 end Expand_N_Op_Shift_Right
;
8677 ----------------------------------------
8678 -- Expand_N_Op_Shift_Right_Arithmetic --
8679 ----------------------------------------
8681 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
8683 Binary_Op_Validity_Checks
(N
);
8684 end Expand_N_Op_Shift_Right_Arithmetic
;
8686 --------------------------
8687 -- Expand_N_Op_Subtract --
8688 --------------------------
8690 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
8691 Typ
: constant Entity_Id
:= Etype
(N
);
8694 Binary_Op_Validity_Checks
(N
);
8696 -- Check for MINIMIZED/ELIMINATED overflow mode
8698 if Minimized_Eliminated_Overflow_Check
(N
) then
8699 Apply_Arithmetic_Overflow_Check
(N
);
8703 -- N - 0 = N for integer types
8705 if Is_Integer_Type
(Typ
)
8706 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
8707 and then Expr_Value
(Right_Opnd
(N
)) = 0
8709 Rewrite
(N
, Left_Opnd
(N
));
8713 -- Arithmetic overflow checks for signed integer/fixed point types
8715 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
8716 Apply_Arithmetic_Overflow_Check
(N
);
8718 -- VAX floating-point types case
8720 elsif Vax_Float
(Typ
) then
8721 Expand_Vax_Arith
(N
);
8723 end Expand_N_Op_Subtract
;
8725 ---------------------
8726 -- Expand_N_Op_Xor --
8727 ---------------------
8729 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
8730 Typ
: constant Entity_Id
:= Etype
(N
);
8733 Binary_Op_Validity_Checks
(N
);
8735 if Is_Array_Type
(Etype
(N
)) then
8736 Expand_Boolean_Operator
(N
);
8738 elsif Is_Boolean_Type
(Etype
(N
)) then
8739 Adjust_Condition
(Left_Opnd
(N
));
8740 Adjust_Condition
(Right_Opnd
(N
));
8741 Set_Etype
(N
, Standard_Boolean
);
8742 Adjust_Result_Type
(N
, Typ
);
8744 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8745 Expand_Intrinsic_Call
(N
, Entity
(N
));
8748 end Expand_N_Op_Xor
;
8750 ----------------------
8751 -- Expand_N_Or_Else --
8752 ----------------------
8754 procedure Expand_N_Or_Else
(N
: Node_Id
)
8755 renames Expand_Short_Circuit_Operator
;
8757 -----------------------------------
8758 -- Expand_N_Qualified_Expression --
8759 -----------------------------------
8761 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
8762 Operand
: constant Node_Id
:= Expression
(N
);
8763 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
8766 -- Do validity check if validity checking operands
8768 if Validity_Checks_On
and Validity_Check_Operands
then
8769 Ensure_Valid
(Operand
);
8772 -- Apply possible constraint check
8774 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
8776 if Do_Range_Check
(Operand
) then
8777 Set_Do_Range_Check
(Operand
, False);
8778 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
8780 end Expand_N_Qualified_Expression
;
8782 ------------------------------------
8783 -- Expand_N_Quantified_Expression --
8784 ------------------------------------
8788 -- for all X in range => Cond
8793 -- for X in range loop
8800 -- Similarly, an existentially quantified expression:
8802 -- for some X in range => Cond
8807 -- for X in range loop
8814 -- In both cases, the iteration may be over a container in which case it is
8815 -- given by an iterator specification, not a loop parameter specification.
8817 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
8818 Actions
: constant List_Id
:= New_List
;
8819 For_All
: constant Boolean := All_Present
(N
);
8820 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
8821 Loc
: constant Source_Ptr
:= Sloc
(N
);
8822 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
8829 -- Create the declaration of the flag which tracks the status of the
8830 -- quantified expression. Generate:
8832 -- Flag : Boolean := (True | False);
8834 Flag
:= Make_Temporary
(Loc
, 'T', N
);
8837 Make_Object_Declaration
(Loc
,
8838 Defining_Identifier
=> Flag
,
8839 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8841 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
8843 -- Construct the circuitry which tracks the status of the quantified
8844 -- expression. Generate:
8846 -- if [not] Cond then
8847 -- Flag := (False | True);
8851 Cond
:= Relocate_Node
(Condition
(N
));
8854 Cond
:= Make_Op_Not
(Loc
, Cond
);
8858 Make_Implicit_If_Statement
(N
,
8860 Then_Statements
=> New_List
(
8861 Make_Assignment_Statement
(Loc
,
8862 Name
=> New_Occurrence_Of
(Flag
, Loc
),
8864 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
8865 Make_Exit_Statement
(Loc
))));
8867 -- Build the loop equivalent of the quantified expression
8869 if Present
(Iter_Spec
) then
8871 Make_Iteration_Scheme
(Loc
,
8872 Iterator_Specification
=> Iter_Spec
);
8875 Make_Iteration_Scheme
(Loc
,
8876 Loop_Parameter_Specification
=> Loop_Spec
);
8880 Make_Loop_Statement
(Loc
,
8881 Iteration_Scheme
=> Scheme
,
8882 Statements
=> Stmts
,
8883 End_Label
=> Empty
));
8885 -- Transform the quantified expression
8888 Make_Expression_With_Actions
(Loc
,
8889 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
8890 Actions
=> Actions
));
8891 Analyze_And_Resolve
(N
, Standard_Boolean
);
8892 end Expand_N_Quantified_Expression
;
8894 ---------------------------------
8895 -- Expand_N_Selected_Component --
8896 ---------------------------------
8898 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
8899 Loc
: constant Source_Ptr
:= Sloc
(N
);
8900 Par
: constant Node_Id
:= Parent
(N
);
8901 P
: constant Node_Id
:= Prefix
(N
);
8902 S
: constant Node_Id
:= Selector_Name
(N
);
8903 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
8909 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
8910 -- Gigi needs a temporary for prefixes that depend on a discriminant,
8911 -- unless the context of an assignment can provide size information.
8912 -- Don't we have a general routine that does this???
8914 function Is_Subtype_Declaration
return Boolean;
8915 -- The replacement of a discriminant reference by its value is required
8916 -- if this is part of the initialization of an temporary generated by a
8917 -- change of representation. This shows up as the construction of a
8918 -- discriminant constraint for a subtype declared at the same point as
8919 -- the entity in the prefix of the selected component. We recognize this
8920 -- case when the context of the reference is:
8921 -- subtype ST is T(Obj.D);
8922 -- where the entity for Obj comes from source, and ST has the same sloc.
8924 -----------------------
8925 -- In_Left_Hand_Side --
8926 -----------------------
8928 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
8930 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
8931 and then Comp
= Name
(Parent
(Comp
)))
8932 or else (Present
(Parent
(Comp
))
8933 and then Nkind
(Parent
(Comp
)) in N_Subexpr
8934 and then In_Left_Hand_Side
(Parent
(Comp
)));
8935 end In_Left_Hand_Side
;
8937 -----------------------------
8938 -- Is_Subtype_Declaration --
8939 -----------------------------
8941 function Is_Subtype_Declaration
return Boolean is
8942 Par
: constant Node_Id
:= Parent
(N
);
8945 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
8946 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
8947 and then Comes_From_Source
(Entity
(Prefix
(N
)))
8948 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
8949 end Is_Subtype_Declaration
;
8951 -- Start of processing for Expand_N_Selected_Component
8954 -- Insert explicit dereference if required
8956 if Is_Access_Type
(Ptyp
) then
8958 -- First set prefix type to proper access type, in case it currently
8959 -- has a private (non-access) view of this type.
8961 Set_Etype
(P
, Ptyp
);
8963 Insert_Explicit_Dereference
(P
);
8964 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
8966 if Ekind
(Etype
(P
)) = E_Private_Subtype
8967 and then Is_For_Access_Subtype
(Etype
(P
))
8969 Set_Etype
(P
, Base_Type
(Etype
(P
)));
8975 -- Deal with discriminant check required
8977 if Do_Discriminant_Check
(N
) then
8978 if Present
(Discriminant_Checking_Func
8979 (Original_Record_Component
(Entity
(S
))))
8981 -- Present the discriminant checking function to the backend, so
8982 -- that it can inline the call to the function.
8985 (Discriminant_Checking_Func
8986 (Original_Record_Component
(Entity
(S
))));
8988 -- Now reset the flag and generate the call
8990 Set_Do_Discriminant_Check
(N
, False);
8991 Generate_Discriminant_Check
(N
);
8993 -- In the case of Unchecked_Union, no discriminant checking is
8994 -- actually performed.
8997 Set_Do_Discriminant_Check
(N
, False);
9001 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9002 -- function, then additional actuals must be passed.
9004 if Ada_Version
>= Ada_2005
9005 and then Is_Build_In_Place_Function_Call
(P
)
9007 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
9010 -- Gigi cannot handle unchecked conversions that are the prefix of a
9011 -- selected component with discriminants. This must be checked during
9012 -- expansion, because during analysis the type of the selector is not
9013 -- known at the point the prefix is analyzed. If the conversion is the
9014 -- target of an assignment, then we cannot force the evaluation.
9016 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
9017 and then Has_Discriminants
(Etype
(N
))
9018 and then not In_Left_Hand_Side
(N
)
9020 Force_Evaluation
(Prefix
(N
));
9023 -- Remaining processing applies only if selector is a discriminant
9025 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
9027 -- If the selector is a discriminant of a constrained record type,
9028 -- we may be able to rewrite the expression with the actual value
9029 -- of the discriminant, a useful optimization in some cases.
9031 if Is_Record_Type
(Ptyp
)
9032 and then Has_Discriminants
(Ptyp
)
9033 and then Is_Constrained
(Ptyp
)
9035 -- Do this optimization for discrete types only, and not for
9036 -- access types (access discriminants get us into trouble!)
9038 if not Is_Discrete_Type
(Etype
(N
)) then
9041 -- Don't do this on the left hand of an assignment statement.
9042 -- Normally one would think that references like this would not
9043 -- occur, but they do in generated code, and mean that we really
9044 -- do want to assign the discriminant!
9046 elsif Nkind
(Par
) = N_Assignment_Statement
9047 and then Name
(Par
) = N
9051 -- Don't do this optimization for the prefix of an attribute or
9052 -- the name of an object renaming declaration since these are
9053 -- contexts where we do not want the value anyway.
9055 elsif (Nkind
(Par
) = N_Attribute_Reference
9056 and then Prefix
(Par
) = N
)
9057 or else Is_Renamed_Object
(N
)
9061 -- Don't do this optimization if we are within the code for a
9062 -- discriminant check, since the whole point of such a check may
9063 -- be to verify the condition on which the code below depends!
9065 elsif Is_In_Discriminant_Check
(N
) then
9068 -- Green light to see if we can do the optimization. There is
9069 -- still one condition that inhibits the optimization below but
9070 -- now is the time to check the particular discriminant.
9073 -- Loop through discriminants to find the matching discriminant
9074 -- constraint to see if we can copy it.
9076 Disc
:= First_Discriminant
(Ptyp
);
9077 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
9078 Discr_Loop
: while Present
(Dcon
) loop
9079 Dval
:= Node
(Dcon
);
9081 -- Check if this is the matching discriminant and if the
9082 -- discriminant value is simple enough to make sense to
9083 -- copy. We don't want to copy complex expressions, and
9084 -- indeed to do so can cause trouble (before we put in
9085 -- this guard, a discriminant expression containing an
9086 -- AND THEN was copied, causing problems for coverage
9089 -- However, if the reference is part of the initialization
9090 -- code generated for an object declaration, we must use
9091 -- the discriminant value from the subtype constraint,
9092 -- because the selected component may be a reference to the
9093 -- object being initialized, whose discriminant is not yet
9094 -- set. This only happens in complex cases involving changes
9095 -- or representation.
9097 if Disc
= Entity
(Selector_Name
(N
))
9098 and then (Is_Entity_Name
(Dval
)
9099 or else Compile_Time_Known_Value
(Dval
)
9100 or else Is_Subtype_Declaration
)
9102 -- Here we have the matching discriminant. Check for
9103 -- the case of a discriminant of a component that is
9104 -- constrained by an outer discriminant, which cannot
9105 -- be optimized away.
9107 if Denotes_Discriminant
9108 (Dval
, Check_Concurrent
=> True)
9112 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
9114 Denotes_Discriminant
9115 (Selector_Name
(Original_Node
(Dval
)), True)
9119 -- Do not retrieve value if constraint is not static. It
9120 -- is generally not useful, and the constraint may be a
9121 -- rewritten outer discriminant in which case it is in
9124 elsif Is_Entity_Name
(Dval
)
9126 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
9127 and then Present
(Expression
(Parent
(Entity
(Dval
))))
9129 Is_Static_Expression
9130 (Expression
(Parent
(Entity
(Dval
))))
9134 -- In the context of a case statement, the expression may
9135 -- have the base type of the discriminant, and we need to
9136 -- preserve the constraint to avoid spurious errors on
9139 elsif Nkind
(Parent
(N
)) = N_Case_Statement
9140 and then Etype
(Dval
) /= Etype
(Disc
)
9143 Make_Qualified_Expression
(Loc
,
9145 New_Occurrence_Of
(Etype
(Disc
), Loc
),
9147 New_Copy_Tree
(Dval
)));
9148 Analyze_And_Resolve
(N
, Etype
(Disc
));
9150 -- In case that comes out as a static expression,
9151 -- reset it (a selected component is never static).
9153 Set_Is_Static_Expression
(N
, False);
9156 -- Otherwise we can just copy the constraint, but the
9157 -- result is certainly not static! In some cases the
9158 -- discriminant constraint has been analyzed in the
9159 -- context of the original subtype indication, but for
9160 -- itypes the constraint might not have been analyzed
9161 -- yet, and this must be done now.
9164 Rewrite
(N
, New_Copy_Tree
(Dval
));
9165 Analyze_And_Resolve
(N
);
9166 Set_Is_Static_Expression
(N
, False);
9172 Next_Discriminant
(Disc
);
9173 end loop Discr_Loop
;
9175 -- Note: the above loop should always find a matching
9176 -- discriminant, but if it does not, we just missed an
9177 -- optimization due to some glitch (perhaps a previous
9178 -- error), so ignore.
9183 -- The only remaining processing is in the case of a discriminant of
9184 -- a concurrent object, where we rewrite the prefix to denote the
9185 -- corresponding record type. If the type is derived and has renamed
9186 -- discriminants, use corresponding discriminant, which is the one
9187 -- that appears in the corresponding record.
9189 if not Is_Concurrent_Type
(Ptyp
) then
9193 Disc
:= Entity
(Selector_Name
(N
));
9195 if Is_Derived_Type
(Ptyp
)
9196 and then Present
(Corresponding_Discriminant
(Disc
))
9198 Disc
:= Corresponding_Discriminant
(Disc
);
9202 Make_Selected_Component
(Loc
,
9204 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
9206 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
9212 -- Set Atomic_Sync_Required if necessary for atomic component
9214 if Nkind
(N
) = N_Selected_Component
then
9216 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
9220 -- If component is atomic, but type is not, setting depends on
9221 -- disable/enable state for the component.
9223 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
9224 Set
:= not Atomic_Synchronization_Disabled
(E
);
9226 -- If component is not atomic, but its type is atomic, setting
9227 -- depends on disable/enable state for the type.
9229 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9230 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
9232 -- If both component and type are atomic, we disable if either
9233 -- component or its type have sync disabled.
9235 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9236 Set
:= (not Atomic_Synchronization_Disabled
(E
))
9238 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
9244 -- Set flag if required
9247 Activate_Atomic_Synchronization
(N
);
9251 end Expand_N_Selected_Component
;
9253 --------------------
9254 -- Expand_N_Slice --
9255 --------------------
9257 procedure Expand_N_Slice
(N
: Node_Id
) is
9258 Loc
: constant Source_Ptr
:= Sloc
(N
);
9259 Typ
: constant Entity_Id
:= Etype
(N
);
9260 Pfx
: constant Node_Id
:= Prefix
(N
);
9261 Ptp
: Entity_Id
:= Etype
(Pfx
);
9263 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
9264 -- Check whether the argument is an actual for a procedure call, in
9265 -- which case the expansion of a bit-packed slice is deferred until the
9266 -- call itself is expanded. The reason this is required is that we might
9267 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9268 -- that copy out would be missed if we created a temporary here in
9269 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9270 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9271 -- is harmless to defer expansion in the IN case, since the call
9272 -- processing will still generate the appropriate copy in operation,
9273 -- which will take care of the slice.
9275 procedure Make_Temporary_For_Slice
;
9276 -- Create a named variable for the value of the slice, in cases where
9277 -- the back-end cannot handle it properly, e.g. when packed types or
9278 -- unaligned slices are involved.
9280 -------------------------
9281 -- Is_Procedure_Actual --
9282 -------------------------
9284 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
9285 Par
: Node_Id
:= Parent
(N
);
9289 -- If our parent is a procedure call we can return
9291 if Nkind
(Par
) = N_Procedure_Call_Statement
then
9294 -- If our parent is a type conversion, keep climbing the tree,
9295 -- since a type conversion can be a procedure actual. Also keep
9296 -- climbing if parameter association or a qualified expression,
9297 -- since these are additional cases that do can appear on
9298 -- procedure actuals.
9300 elsif Nkind_In
(Par
, N_Type_Conversion
,
9301 N_Parameter_Association
,
9302 N_Qualified_Expression
)
9304 Par
:= Parent
(Par
);
9306 -- Any other case is not what we are looking for
9312 end Is_Procedure_Actual
;
9314 ------------------------------
9315 -- Make_Temporary_For_Slice --
9316 ------------------------------
9318 procedure Make_Temporary_For_Slice
is
9320 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
9324 Make_Object_Declaration
(Loc
,
9325 Defining_Identifier
=> Ent
,
9326 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
9328 Set_No_Initialization
(Decl
);
9330 Insert_Actions
(N
, New_List
(
9332 Make_Assignment_Statement
(Loc
,
9333 Name
=> New_Occurrence_Of
(Ent
, Loc
),
9334 Expression
=> Relocate_Node
(N
))));
9336 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
9337 Analyze_And_Resolve
(N
, Typ
);
9338 end Make_Temporary_For_Slice
;
9340 -- Start of processing for Expand_N_Slice
9343 -- Special handling for access types
9345 if Is_Access_Type
(Ptp
) then
9347 Ptp
:= Designated_Type
(Ptp
);
9350 Make_Explicit_Dereference
(Sloc
(N
),
9351 Prefix
=> Relocate_Node
(Pfx
)));
9353 Analyze_And_Resolve
(Pfx
, Ptp
);
9356 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9357 -- function, then additional actuals must be passed.
9359 if Ada_Version
>= Ada_2005
9360 and then Is_Build_In_Place_Function_Call
(Pfx
)
9362 Make_Build_In_Place_Call_In_Anonymous_Context
(Pfx
);
9365 -- The remaining case to be handled is packed slices. We can leave
9366 -- packed slices as they are in the following situations:
9368 -- 1. Right or left side of an assignment (we can handle this
9369 -- situation correctly in the assignment statement expansion).
9371 -- 2. Prefix of indexed component (the slide is optimized away in this
9372 -- case, see the start of Expand_N_Slice.)
9374 -- 3. Object renaming declaration, since we want the name of the
9375 -- slice, not the value.
9377 -- 4. Argument to procedure call, since copy-in/copy-out handling may
9378 -- be required, and this is handled in the expansion of call
9381 -- 5. Prefix of an address attribute (this is an error which is caught
9382 -- elsewhere, and the expansion would interfere with generating the
9385 if not Is_Packed
(Typ
) then
9387 -- Apply transformation for actuals of a function call, where
9388 -- Expand_Actuals is not used.
9390 if Nkind
(Parent
(N
)) = N_Function_Call
9391 and then Is_Possibly_Unaligned_Slice
(N
)
9393 Make_Temporary_For_Slice
;
9396 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
9397 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9398 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
9402 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
9403 or else Is_Renamed_Object
(N
)
9404 or else Is_Procedure_Actual
(N
)
9408 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
9409 and then Attribute_Name
(Parent
(N
)) = Name_Address
9414 Make_Temporary_For_Slice
;
9418 ------------------------------
9419 -- Expand_N_Type_Conversion --
9420 ------------------------------
9422 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
9423 Loc
: constant Source_Ptr
:= Sloc
(N
);
9424 Operand
: constant Node_Id
:= Expression
(N
);
9425 Target_Type
: constant Entity_Id
:= Etype
(N
);
9426 Operand_Type
: Entity_Id
:= Etype
(Operand
);
9428 procedure Handle_Changed_Representation
;
9429 -- This is called in the case of record and array type conversions to
9430 -- see if there is a change of representation to be handled. Change of
9431 -- representation is actually handled at the assignment statement level,
9432 -- and what this procedure does is rewrite node N conversion as an
9433 -- assignment to temporary. If there is no change of representation,
9434 -- then the conversion node is unchanged.
9436 procedure Raise_Accessibility_Error
;
9437 -- Called when we know that an accessibility check will fail. Rewrites
9438 -- node N to an appropriate raise statement and outputs warning msgs.
9439 -- The Etype of the raise node is set to Target_Type.
9441 procedure Real_Range_Check
;
9442 -- Handles generation of range check for real target value
9444 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
9445 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
9446 -- evaluates to True.
9448 -----------------------------------
9449 -- Handle_Changed_Representation --
9450 -----------------------------------
9452 procedure Handle_Changed_Representation
is
9461 -- Nothing else to do if no change of representation
9463 if Same_Representation
(Operand_Type
, Target_Type
) then
9466 -- The real change of representation work is done by the assignment
9467 -- statement processing. So if this type conversion is appearing as
9468 -- the expression of an assignment statement, nothing needs to be
9469 -- done to the conversion.
9471 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9474 -- Otherwise we need to generate a temporary variable, and do the
9475 -- change of representation assignment into that temporary variable.
9476 -- The conversion is then replaced by a reference to this variable.
9481 -- If type is unconstrained we have to add a constraint, copied
9482 -- from the actual value of the left hand side.
9484 if not Is_Constrained
(Target_Type
) then
9485 if Has_Discriminants
(Operand_Type
) then
9486 Disc
:= First_Discriminant
(Operand_Type
);
9488 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
9489 Disc
:= First_Stored_Discriminant
(Operand_Type
);
9493 while Present
(Disc
) loop
9495 Make_Selected_Component
(Loc
,
9497 Duplicate_Subexpr_Move_Checks
(Operand
),
9499 Make_Identifier
(Loc
, Chars
(Disc
))));
9500 Next_Discriminant
(Disc
);
9503 elsif Is_Array_Type
(Operand_Type
) then
9504 N_Ix
:= First_Index
(Target_Type
);
9507 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
9509 -- We convert the bounds explicitly. We use an unchecked
9510 -- conversion because bounds checks are done elsewhere.
9515 Unchecked_Convert_To
(Etype
(N_Ix
),
9516 Make_Attribute_Reference
(Loc
,
9518 Duplicate_Subexpr_No_Checks
9519 (Operand
, Name_Req
=> True),
9520 Attribute_Name
=> Name_First
,
9521 Expressions
=> New_List
(
9522 Make_Integer_Literal
(Loc
, J
)))),
9525 Unchecked_Convert_To
(Etype
(N_Ix
),
9526 Make_Attribute_Reference
(Loc
,
9528 Duplicate_Subexpr_No_Checks
9529 (Operand
, Name_Req
=> True),
9530 Attribute_Name
=> Name_Last
,
9531 Expressions
=> New_List
(
9532 Make_Integer_Literal
(Loc
, J
))))));
9539 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
9541 if Present
(Cons
) then
9543 Make_Subtype_Indication
(Loc
,
9544 Subtype_Mark
=> Odef
,
9546 Make_Index_Or_Discriminant_Constraint
(Loc
,
9547 Constraints
=> Cons
));
9550 Temp
:= Make_Temporary
(Loc
, 'C');
9552 Make_Object_Declaration
(Loc
,
9553 Defining_Identifier
=> Temp
,
9554 Object_Definition
=> Odef
);
9556 Set_No_Initialization
(Decl
, True);
9558 -- Insert required actions. It is essential to suppress checks
9559 -- since we have suppressed default initialization, which means
9560 -- that the variable we create may have no discriminants.
9565 Make_Assignment_Statement
(Loc
,
9566 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9567 Expression
=> Relocate_Node
(N
))),
9568 Suppress
=> All_Checks
);
9570 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9573 end Handle_Changed_Representation
;
9575 -------------------------------
9576 -- Raise_Accessibility_Error --
9577 -------------------------------
9579 procedure Raise_Accessibility_Error
is
9582 Make_Raise_Program_Error
(Sloc
(N
),
9583 Reason
=> PE_Accessibility_Check_Failed
));
9584 Set_Etype
(N
, Target_Type
);
9587 ("??accessibility check failure", N
);
9589 ("\??& will be raised at run time", N
, Standard_Program_Error
);
9590 end Raise_Accessibility_Error
;
9592 ----------------------
9593 -- Real_Range_Check --
9594 ----------------------
9596 -- Case of conversions to floating-point or fixed-point. If range checks
9597 -- are enabled and the target type has a range constraint, we convert:
9603 -- Tnn : typ'Base := typ'Base (x);
9604 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
9607 -- This is necessary when there is a conversion of integer to float or
9608 -- to fixed-point to ensure that the correct checks are made. It is not
9609 -- necessary for float to float where it is enough to simply set the
9610 -- Do_Range_Check flag.
9612 procedure Real_Range_Check
is
9613 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
9614 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
9615 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
9616 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
9621 -- Nothing to do if conversion was rewritten
9623 if Nkind
(N
) /= N_Type_Conversion
then
9627 -- Nothing to do if range checks suppressed, or target has the same
9628 -- range as the base type (or is the base type).
9630 if Range_Checks_Suppressed
(Target_Type
)
9631 or else (Lo
= Type_Low_Bound
(Btyp
)
9633 Hi
= Type_High_Bound
(Btyp
))
9638 -- Nothing to do if expression is an entity on which checks have been
9641 if Is_Entity_Name
(Operand
)
9642 and then Range_Checks_Suppressed
(Entity
(Operand
))
9647 -- Nothing to do if bounds are all static and we can tell that the
9648 -- expression is within the bounds of the target. Note that if the
9649 -- operand is of an unconstrained floating-point type, then we do
9650 -- not trust it to be in range (might be infinite)
9653 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
9654 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
9657 if (not Is_Floating_Point_Type
(Xtyp
)
9658 or else Is_Constrained
(Xtyp
))
9659 and then Compile_Time_Known_Value
(S_Lo
)
9660 and then Compile_Time_Known_Value
(S_Hi
)
9661 and then Compile_Time_Known_Value
(Hi
)
9662 and then Compile_Time_Known_Value
(Lo
)
9665 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
9666 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
9671 if Is_Real_Type
(Xtyp
) then
9672 S_Lov
:= Expr_Value_R
(S_Lo
);
9673 S_Hiv
:= Expr_Value_R
(S_Hi
);
9675 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
9676 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
9680 and then S_Lov
>= D_Lov
9681 and then S_Hiv
<= D_Hiv
9683 Set_Do_Range_Check
(Operand
, False);
9690 -- For float to float conversions, we are done
9692 if Is_Floating_Point_Type
(Xtyp
)
9694 Is_Floating_Point_Type
(Btyp
)
9699 -- Otherwise rewrite the conversion as described above
9701 Conv
:= Relocate_Node
(N
);
9702 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
9703 Set_Etype
(Conv
, Btyp
);
9705 -- Enable overflow except for case of integer to float conversions,
9706 -- where it is never required, since we can never have overflow in
9709 if not Is_Integer_Type
(Etype
(Operand
)) then
9710 Enable_Overflow_Check
(Conv
);
9713 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
9715 Insert_Actions
(N
, New_List
(
9716 Make_Object_Declaration
(Loc
,
9717 Defining_Identifier
=> Tnn
,
9718 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
9719 Constant_Present
=> True,
9720 Expression
=> Conv
),
9722 Make_Raise_Constraint_Error
(Loc
,
9727 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9729 Make_Attribute_Reference
(Loc
,
9730 Attribute_Name
=> Name_First
,
9732 New_Occurrence_Of
(Target_Type
, Loc
))),
9736 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9738 Make_Attribute_Reference
(Loc
,
9739 Attribute_Name
=> Name_Last
,
9741 New_Occurrence_Of
(Target_Type
, Loc
)))),
9742 Reason
=> CE_Range_Check_Failed
)));
9744 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
9745 Analyze_And_Resolve
(N
, Btyp
);
9746 end Real_Range_Check
;
9748 -----------------------------
9749 -- Has_Extra_Accessibility --
9750 -----------------------------
9752 -- Returns true for a formal of an anonymous access type or for
9753 -- an Ada 2012-style stand-alone object of an anonymous access type.
9755 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
9757 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
9758 return Present
(Effective_Extra_Accessibility
(Id
));
9762 end Has_Extra_Accessibility
;
9764 -- Start of processing for Expand_N_Type_Conversion
9767 -- First remove check marks put by the semantic analysis on the type
9768 -- conversion between array types. We need these checks, and they will
9769 -- be generated by this expansion routine, but we do not depend on these
9770 -- flags being set, and since we do intend to expand the checks in the
9771 -- front end, we don't want them on the tree passed to the back end.
9773 if Is_Array_Type
(Target_Type
) then
9774 if Is_Constrained
(Target_Type
) then
9775 Set_Do_Length_Check
(N
, False);
9777 Set_Do_Range_Check
(Operand
, False);
9781 -- Nothing at all to do if conversion is to the identical type so remove
9782 -- the conversion completely, it is useless, except that it may carry
9783 -- an Assignment_OK attribute, which must be propagated to the operand.
9785 if Operand_Type
= Target_Type
then
9786 if Assignment_OK
(N
) then
9787 Set_Assignment_OK
(Operand
);
9790 Rewrite
(N
, Relocate_Node
(Operand
));
9794 -- Nothing to do if this is the second argument of read. This is a
9795 -- "backwards" conversion that will be handled by the specialized code
9796 -- in attribute processing.
9798 if Nkind
(Parent
(N
)) = N_Attribute_Reference
9799 and then Attribute_Name
(Parent
(N
)) = Name_Read
9800 and then Next
(First
(Expressions
(Parent
(N
)))) = N
9805 -- Check for case of converting to a type that has an invariant
9806 -- associated with it. This required an invariant check. We convert
9812 -- do invariant_check (typ (expr)) in typ (expr);
9814 -- using Duplicate_Subexpr to avoid multiple side effects
9816 -- Note: the Comes_From_Source check, and then the resetting of this
9817 -- flag prevents what would otherwise be an infinite recursion.
9819 if Has_Invariants
(Target_Type
)
9820 and then Present
(Invariant_Procedure
(Target_Type
))
9821 and then Comes_From_Source
(N
)
9823 Set_Comes_From_Source
(N
, False);
9825 Make_Expression_With_Actions
(Loc
,
9826 Actions
=> New_List
(
9827 Make_Invariant_Call
(Duplicate_Subexpr
(N
))),
9828 Expression
=> Duplicate_Subexpr_No_Checks
(N
)));
9829 Analyze_And_Resolve
(N
, Target_Type
);
9833 -- Here if we may need to expand conversion
9835 -- If the operand of the type conversion is an arithmetic operation on
9836 -- signed integers, and the based type of the signed integer type in
9837 -- question is smaller than Standard.Integer, we promote both of the
9838 -- operands to type Integer.
9840 -- For example, if we have
9842 -- target-type (opnd1 + opnd2)
9844 -- and opnd1 and opnd2 are of type short integer, then we rewrite
9847 -- target-type (integer(opnd1) + integer(opnd2))
9849 -- We do this because we are always allowed to compute in a larger type
9850 -- if we do the right thing with the result, and in this case we are
9851 -- going to do a conversion which will do an appropriate check to make
9852 -- sure that things are in range of the target type in any case. This
9853 -- avoids some unnecessary intermediate overflows.
9855 -- We might consider a similar transformation in the case where the
9856 -- target is a real type or a 64-bit integer type, and the operand
9857 -- is an arithmetic operation using a 32-bit integer type. However,
9858 -- we do not bother with this case, because it could cause significant
9859 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
9860 -- much cheaper, but we don't want different behavior on 32-bit and
9861 -- 64-bit machines. Note that the exclusion of the 64-bit case also
9862 -- handles the configurable run-time cases where 64-bit arithmetic
9863 -- may simply be unavailable.
9865 -- Note: this circuit is partially redundant with respect to the circuit
9866 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
9867 -- the processing here. Also we still need the Checks circuit, since we
9868 -- have to be sure not to generate junk overflow checks in the first
9869 -- place, since it would be trick to remove them here!
9871 if Integer_Promotion_Possible
(N
) then
9873 -- All conditions met, go ahead with transformation
9881 Make_Type_Conversion
(Loc
,
9882 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
9883 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
9885 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
9886 Set_Right_Opnd
(Opnd
, R
);
9888 if Nkind
(Operand
) in N_Binary_Op
then
9890 Make_Type_Conversion
(Loc
,
9891 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
9892 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
9894 Set_Left_Opnd
(Opnd
, L
);
9898 Make_Type_Conversion
(Loc
,
9899 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
9900 Expression
=> Opnd
));
9902 Analyze_And_Resolve
(N
, Target_Type
);
9907 -- Do validity check if validity checking operands
9909 if Validity_Checks_On
and Validity_Check_Operands
then
9910 Ensure_Valid
(Operand
);
9913 -- Special case of converting from non-standard boolean type
9915 if Is_Boolean_Type
(Operand_Type
)
9916 and then (Nonzero_Is_True
(Operand_Type
))
9918 Adjust_Condition
(Operand
);
9919 Set_Etype
(Operand
, Standard_Boolean
);
9920 Operand_Type
:= Standard_Boolean
;
9923 -- Case of converting to an access type
9925 if Is_Access_Type
(Target_Type
) then
9927 -- Apply an accessibility check when the conversion operand is an
9928 -- access parameter (or a renaming thereof), unless conversion was
9929 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
9930 -- Note that other checks may still need to be applied below (such
9931 -- as tagged type checks).
9933 if Is_Entity_Name
(Operand
)
9934 and then Has_Extra_Accessibility
(Entity
(Operand
))
9935 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
9936 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
9937 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
9939 Apply_Accessibility_Check
9940 (Operand
, Target_Type
, Insert_Node
=> Operand
);
9942 -- If the level of the operand type is statically deeper than the
9943 -- level of the target type, then force Program_Error. Note that this
9944 -- can only occur for cases where the attribute is within the body of
9945 -- an instantiation (otherwise the conversion will already have been
9946 -- rejected as illegal). Note: warnings are issued by the analyzer
9947 -- for the instance cases.
9949 elsif In_Instance_Body
9950 and then Type_Access_Level
(Operand_Type
) >
9951 Type_Access_Level
(Target_Type
)
9953 Raise_Accessibility_Error
;
9955 -- When the operand is a selected access discriminant the check needs
9956 -- to be made against the level of the object denoted by the prefix
9957 -- of the selected name. Force Program_Error for this case as well
9958 -- (this accessibility violation can only happen if within the body
9959 -- of an instantiation).
9961 elsif In_Instance_Body
9962 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
9963 and then Nkind
(Operand
) = N_Selected_Component
9964 and then Object_Access_Level
(Operand
) >
9965 Type_Access_Level
(Target_Type
)
9967 Raise_Accessibility_Error
;
9972 -- Case of conversions of tagged types and access to tagged types
9974 -- When needed, that is to say when the expression is class-wide, Add
9975 -- runtime a tag check for (strict) downward conversion by using the
9976 -- membership test, generating:
9978 -- [constraint_error when Operand not in Target_Type'Class]
9980 -- or in the access type case
9982 -- [constraint_error
9983 -- when Operand /= null
9984 -- and then Operand.all not in
9985 -- Designated_Type (Target_Type)'Class]
9987 if (Is_Access_Type
(Target_Type
)
9988 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
9989 or else Is_Tagged_Type
(Target_Type
)
9991 -- Do not do any expansion in the access type case if the parent is a
9992 -- renaming, since this is an error situation which will be caught by
9993 -- Sem_Ch8, and the expansion can interfere with this error check.
9995 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
9999 -- Otherwise, proceed with processing tagged conversion
10001 Tagged_Conversion
: declare
10002 Actual_Op_Typ
: Entity_Id
;
10003 Actual_Targ_Typ
: Entity_Id
;
10004 Make_Conversion
: Boolean := False;
10005 Root_Op_Typ
: Entity_Id
;
10007 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
10008 -- Create a membership check to test whether Operand is a member
10009 -- of Targ_Typ. If the original Target_Type is an access, include
10010 -- a test for null value. The check is inserted at N.
10012 --------------------
10013 -- Make_Tag_Check --
10014 --------------------
10016 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
10021 -- [Constraint_Error
10022 -- when Operand /= null
10023 -- and then Operand.all not in Targ_Typ]
10025 if Is_Access_Type
(Target_Type
) then
10027 Make_And_Then
(Loc
,
10030 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10031 Right_Opnd
=> Make_Null
(Loc
)),
10036 Make_Explicit_Dereference
(Loc
,
10037 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
10038 Right_Opnd
=> New_Reference_To
(Targ_Typ
, Loc
)));
10041 -- [Constraint_Error when Operand not in Targ_Typ]
10046 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10047 Right_Opnd
=> New_Reference_To
(Targ_Typ
, Loc
));
10051 Make_Raise_Constraint_Error
(Loc
,
10053 Reason
=> CE_Tag_Check_Failed
));
10054 end Make_Tag_Check
;
10056 -- Start of processing for Tagged_Conversion
10059 -- Handle entities from the limited view
10061 if Is_Access_Type
(Operand_Type
) then
10063 Available_View
(Designated_Type
(Operand_Type
));
10065 Actual_Op_Typ
:= Operand_Type
;
10068 if Is_Access_Type
(Target_Type
) then
10070 Available_View
(Designated_Type
(Target_Type
));
10072 Actual_Targ_Typ
:= Target_Type
;
10075 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
10077 -- Ada 2005 (AI-251): Handle interface type conversion
10079 if Is_Interface
(Actual_Op_Typ
) then
10080 Expand_Interface_Conversion
(N
);
10084 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
10086 -- Create a runtime tag check for a downward class-wide type
10089 if Is_Class_Wide_Type
(Actual_Op_Typ
)
10090 and then Actual_Op_Typ
/= Actual_Targ_Typ
10091 and then Root_Op_Typ
/= Actual_Targ_Typ
10092 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
10093 Use_Full_View
=> True)
10095 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
10096 Make_Conversion
:= True;
10099 -- AI05-0073: If the result subtype of the function is defined
10100 -- by an access_definition designating a specific tagged type
10101 -- T, a check is made that the result value is null or the tag
10102 -- of the object designated by the result value identifies T.
10103 -- Constraint_Error is raised if this check fails.
10105 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
10108 Func_Typ
: Entity_Id
;
10111 -- Climb scope stack looking for the enclosing function
10113 Func
:= Current_Scope
;
10114 while Present
(Func
)
10115 and then Ekind
(Func
) /= E_Function
10117 Func
:= Scope
(Func
);
10120 -- The function's return subtype must be defined using
10121 -- an access definition.
10123 if Nkind
(Result_Definition
(Parent
(Func
))) =
10124 N_Access_Definition
10126 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
10128 -- The return subtype denotes a specific tagged type,
10129 -- in other words, a non class-wide type.
10131 if Is_Tagged_Type
(Func_Typ
)
10132 and then not Is_Class_Wide_Type
(Func_Typ
)
10134 Make_Tag_Check
(Actual_Targ_Typ
);
10135 Make_Conversion
:= True;
10141 -- We have generated a tag check for either a class-wide type
10142 -- conversion or for AI05-0073.
10144 if Make_Conversion
then
10149 Make_Unchecked_Type_Conversion
(Loc
,
10150 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
10151 Expression
=> Relocate_Node
(Expression
(N
)));
10153 Analyze_And_Resolve
(N
, Target_Type
);
10157 end Tagged_Conversion
;
10159 -- Case of other access type conversions
10161 elsif Is_Access_Type
(Target_Type
) then
10162 Apply_Constraint_Check
(Operand
, Target_Type
);
10164 -- Case of conversions from a fixed-point type
10166 -- These conversions require special expansion and processing, found in
10167 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10168 -- since from a semantic point of view, these are simple integer
10169 -- conversions, which do not need further processing.
10171 elsif Is_Fixed_Point_Type
(Operand_Type
)
10172 and then not Conversion_OK
(N
)
10174 -- We should never see universal fixed at this case, since the
10175 -- expansion of the constituent divide or multiply should have
10176 -- eliminated the explicit mention of universal fixed.
10178 pragma Assert
(Operand_Type
/= Universal_Fixed
);
10180 -- Check for special case of the conversion to universal real that
10181 -- occurs as a result of the use of a round attribute. In this case,
10182 -- the real type for the conversion is taken from the target type of
10183 -- the Round attribute and the result must be marked as rounded.
10185 if Target_Type
= Universal_Real
10186 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
10187 and then Attribute_Name
(Parent
(N
)) = Name_Round
10189 Set_Rounded_Result
(N
);
10190 Set_Etype
(N
, Etype
(Parent
(N
)));
10193 -- Otherwise do correct fixed-conversion, but skip these if the
10194 -- Conversion_OK flag is set, because from a semantic point of view
10195 -- these are simple integer conversions needing no further processing
10196 -- (the backend will simply treat them as integers).
10198 if not Conversion_OK
(N
) then
10199 if Is_Fixed_Point_Type
(Etype
(N
)) then
10200 Expand_Convert_Fixed_To_Fixed
(N
);
10203 elsif Is_Integer_Type
(Etype
(N
)) then
10204 Expand_Convert_Fixed_To_Integer
(N
);
10207 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
10208 Expand_Convert_Fixed_To_Float
(N
);
10213 -- Case of conversions to a fixed-point type
10215 -- These conversions require special expansion and processing, found in
10216 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10217 -- since from a semantic point of view, these are simple integer
10218 -- conversions, which do not need further processing.
10220 elsif Is_Fixed_Point_Type
(Target_Type
)
10221 and then not Conversion_OK
(N
)
10223 if Is_Integer_Type
(Operand_Type
) then
10224 Expand_Convert_Integer_To_Fixed
(N
);
10227 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
10228 Expand_Convert_Float_To_Fixed
(N
);
10232 -- Case of float-to-integer conversions
10234 -- We also handle float-to-fixed conversions with Conversion_OK set
10235 -- since semantically the fixed-point target is treated as though it
10236 -- were an integer in such cases.
10238 elsif Is_Floating_Point_Type
(Operand_Type
)
10240 (Is_Integer_Type
(Target_Type
)
10242 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
10244 -- One more check here, gcc is still not able to do conversions of
10245 -- this type with proper overflow checking, and so gigi is doing an
10246 -- approximation of what is required by doing floating-point compares
10247 -- with the end-point. But that can lose precision in some cases, and
10248 -- give a wrong result. Converting the operand to Universal_Real is
10249 -- helpful, but still does not catch all cases with 64-bit integers
10250 -- on targets with only 64-bit floats.
10252 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10253 -- Can this code be removed ???
10255 if Do_Range_Check
(Operand
) then
10257 Make_Type_Conversion
(Loc
,
10259 New_Occurrence_Of
(Universal_Real
, Loc
),
10261 Relocate_Node
(Operand
)));
10263 Set_Etype
(Operand
, Universal_Real
);
10264 Enable_Range_Check
(Operand
);
10265 Set_Do_Range_Check
(Expression
(Operand
), False);
10268 -- Case of array conversions
10270 -- Expansion of array conversions, add required length/range checks but
10271 -- only do this if there is no change of representation. For handling of
10272 -- this case, see Handle_Changed_Representation.
10274 elsif Is_Array_Type
(Target_Type
) then
10275 if Is_Constrained
(Target_Type
) then
10276 Apply_Length_Check
(Operand
, Target_Type
);
10278 Apply_Range_Check
(Operand
, Target_Type
);
10281 Handle_Changed_Representation
;
10283 -- Case of conversions of discriminated types
10285 -- Add required discriminant checks if target is constrained. Again this
10286 -- change is skipped if we have a change of representation.
10288 elsif Has_Discriminants
(Target_Type
)
10289 and then Is_Constrained
(Target_Type
)
10291 Apply_Discriminant_Check
(Operand
, Target_Type
);
10292 Handle_Changed_Representation
;
10294 -- Case of all other record conversions. The only processing required
10295 -- is to check for a change of representation requiring the special
10296 -- assignment processing.
10298 elsif Is_Record_Type
(Target_Type
) then
10300 -- Ada 2005 (AI-216): Program_Error is raised when converting from
10301 -- a derived Unchecked_Union type to an unconstrained type that is
10302 -- not Unchecked_Union if the operand lacks inferable discriminants.
10304 if Is_Derived_Type
(Operand_Type
)
10305 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
10306 and then not Is_Constrained
(Target_Type
)
10307 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
10308 and then not Has_Inferable_Discriminants
(Operand
)
10310 -- To prevent Gigi from generating illegal code, we generate a
10311 -- Program_Error node, but we give it the target type of the
10312 -- conversion (is this requirement documented somewhere ???)
10315 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
10316 Reason
=> PE_Unchecked_Union_Restriction
);
10319 Set_Etype
(PE
, Target_Type
);
10324 Handle_Changed_Representation
;
10327 -- Case of conversions of enumeration types
10329 elsif Is_Enumeration_Type
(Target_Type
) then
10331 -- Special processing is required if there is a change of
10332 -- representation (from enumeration representation clauses).
10334 if not Same_Representation
(Target_Type
, Operand_Type
) then
10336 -- Convert: x(y) to x'val (ytyp'val (y))
10339 Make_Attribute_Reference
(Loc
,
10340 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
10341 Attribute_Name
=> Name_Val
,
10342 Expressions
=> New_List
(
10343 Make_Attribute_Reference
(Loc
,
10344 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
10345 Attribute_Name
=> Name_Pos
,
10346 Expressions
=> New_List
(Operand
)))));
10348 Analyze_And_Resolve
(N
, Target_Type
);
10351 -- Case of conversions to floating-point
10353 elsif Is_Floating_Point_Type
(Target_Type
) then
10357 -- At this stage, either the conversion node has been transformed into
10358 -- some other equivalent expression, or left as a conversion that can be
10359 -- handled by Gigi, in the following cases:
10361 -- Conversions with no change of representation or type
10363 -- Numeric conversions involving integer, floating- and fixed-point
10364 -- values. Fixed-point values are allowed only if Conversion_OK is
10365 -- set, i.e. if the fixed-point values are to be treated as integers.
10367 -- No other conversions should be passed to Gigi
10369 -- Check: are these rules stated in sinfo??? if so, why restate here???
10371 -- The only remaining step is to generate a range check if we still have
10372 -- a type conversion at this stage and Do_Range_Check is set. For now we
10373 -- do this only for conversions of discrete types.
10375 if Nkind
(N
) = N_Type_Conversion
10376 and then Is_Discrete_Type
(Etype
(N
))
10379 Expr
: constant Node_Id
:= Expression
(N
);
10384 if Do_Range_Check
(Expr
)
10385 and then Is_Discrete_Type
(Etype
(Expr
))
10387 Set_Do_Range_Check
(Expr
, False);
10389 -- Before we do a range check, we have to deal with treating a
10390 -- fixed-point operand as an integer. The way we do this is
10391 -- simply to do an unchecked conversion to an appropriate
10392 -- integer type large enough to hold the result.
10394 -- This code is not active yet, because we are only dealing
10395 -- with discrete types so far ???
10397 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
10398 and then Treat_Fixed_As_Integer
(Expr
)
10400 Ftyp
:= Base_Type
(Etype
(Expr
));
10402 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
10403 Ityp
:= Standard_Long_Long_Integer
;
10405 Ityp
:= Standard_Integer
;
10408 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
10411 -- Reset overflow flag, since the range check will include
10412 -- dealing with possible overflow, and generate the check. If
10413 -- Address is either a source type or target type, suppress
10414 -- range check to avoid typing anomalies when it is a visible
10417 Set_Do_Overflow_Check
(N
, False);
10418 if not Is_Descendent_Of_Address
(Etype
(Expr
))
10419 and then not Is_Descendent_Of_Address
(Target_Type
)
10421 Generate_Range_Check
10422 (Expr
, Target_Type
, CE_Range_Check_Failed
);
10428 -- Final step, if the result is a type conversion involving Vax_Float
10429 -- types, then it is subject for further special processing.
10431 if Nkind
(N
) = N_Type_Conversion
10432 and then (Vax_Float
(Operand_Type
) or else Vax_Float
(Target_Type
))
10434 Expand_Vax_Conversion
(N
);
10438 -- Here at end of processing
10441 -- Apply predicate check if required. Note that we can't just call
10442 -- Apply_Predicate_Check here, because the type looks right after
10443 -- the conversion and it would omit the check. The Comes_From_Source
10444 -- guard is necessary to prevent infinite recursions when we generate
10445 -- internal conversions for the purpose of checking predicates.
10447 if Present
(Predicate_Function
(Target_Type
))
10448 and then Target_Type
/= Operand_Type
10449 and then Comes_From_Source
(N
)
10452 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
10455 -- Avoid infinite recursion on the subsequent expansion of
10456 -- of the copy of the original type conversion.
10458 Set_Comes_From_Source
(New_Expr
, False);
10459 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
10462 end Expand_N_Type_Conversion
;
10464 -----------------------------------
10465 -- Expand_N_Unchecked_Expression --
10466 -----------------------------------
10468 -- Remove the unchecked expression node from the tree. Its job was simply
10469 -- to make sure that its constituent expression was handled with checks
10470 -- off, and now that that is done, we can remove it from the tree, and
10471 -- indeed must, since Gigi does not expect to see these nodes.
10473 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
10474 Exp
: constant Node_Id
:= Expression
(N
);
10476 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
10478 end Expand_N_Unchecked_Expression
;
10480 ----------------------------------------
10481 -- Expand_N_Unchecked_Type_Conversion --
10482 ----------------------------------------
10484 -- If this cannot be handled by Gigi and we haven't already made a
10485 -- temporary for it, do it now.
10487 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
10488 Target_Type
: constant Entity_Id
:= Etype
(N
);
10489 Operand
: constant Node_Id
:= Expression
(N
);
10490 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
10493 -- Nothing at all to do if conversion is to the identical type so remove
10494 -- the conversion completely, it is useless, except that it may carry
10495 -- an Assignment_OK indication which must be propagated to the operand.
10497 if Operand_Type
= Target_Type
then
10499 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
10501 if Assignment_OK
(N
) then
10502 Set_Assignment_OK
(Operand
);
10505 Rewrite
(N
, Relocate_Node
(Operand
));
10509 -- If we have a conversion of a compile time known value to a target
10510 -- type and the value is in range of the target type, then we can simply
10511 -- replace the construct by an integer literal of the correct type. We
10512 -- only apply this to integer types being converted. Possibly it may
10513 -- apply in other cases, but it is too much trouble to worry about.
10515 -- Note that we do not do this transformation if the Kill_Range_Check
10516 -- flag is set, since then the value may be outside the expected range.
10517 -- This happens in the Normalize_Scalars case.
10519 -- We also skip this if either the target or operand type is biased
10520 -- because in this case, the unchecked conversion is supposed to
10521 -- preserve the bit pattern, not the integer value.
10523 if Is_Integer_Type
(Target_Type
)
10524 and then not Has_Biased_Representation
(Target_Type
)
10525 and then Is_Integer_Type
(Operand_Type
)
10526 and then not Has_Biased_Representation
(Operand_Type
)
10527 and then Compile_Time_Known_Value
(Operand
)
10528 and then not Kill_Range_Check
(N
)
10531 Val
: constant Uint
:= Expr_Value
(Operand
);
10534 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
10536 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
10538 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
10540 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
10542 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
10544 -- If Address is the target type, just set the type to avoid a
10545 -- spurious type error on the literal when Address is a visible
10548 if Is_Descendent_Of_Address
(Target_Type
) then
10549 Set_Etype
(N
, Target_Type
);
10551 Analyze_And_Resolve
(N
, Target_Type
);
10559 -- Nothing to do if conversion is safe
10561 if Safe_Unchecked_Type_Conversion
(N
) then
10565 -- Otherwise force evaluation unless Assignment_OK flag is set (this
10566 -- flag indicates ??? More comments needed here)
10568 if Assignment_OK
(N
) then
10571 Force_Evaluation
(N
);
10573 end Expand_N_Unchecked_Type_Conversion
;
10575 ----------------------------
10576 -- Expand_Record_Equality --
10577 ----------------------------
10579 -- For non-variant records, Equality is expanded when needed into:
10581 -- and then Lhs.Discr1 = Rhs.Discr1
10583 -- and then Lhs.Discrn = Rhs.Discrn
10584 -- and then Lhs.Cmp1 = Rhs.Cmp1
10586 -- and then Lhs.Cmpn = Rhs.Cmpn
10588 -- The expression is folded by the back-end for adjacent fields. This
10589 -- function is called for tagged record in only one occasion: for imple-
10590 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
10591 -- otherwise the primitive "=" is used directly.
10593 function Expand_Record_Equality
10598 Bodies
: List_Id
) return Node_Id
10600 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
10605 First_Time
: Boolean := True;
10607 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
10608 -- Return the next discriminant or component to compare, starting with
10609 -- C, skipping inherited components.
10611 ------------------------
10612 -- Element_To_Compare --
10613 ------------------------
10615 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
10621 -- Exit loop when the next element to be compared is found, or
10622 -- there is no more such element.
10624 exit when No
(Comp
);
10626 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
10629 -- Skip inherited components
10631 -- Note: for a tagged type, we always generate the "=" primitive
10632 -- for the base type (not on the first subtype), so the test for
10633 -- Comp /= Original_Record_Component (Comp) is True for
10634 -- inherited components only.
10636 (Is_Tagged_Type
(Typ
)
10637 and then Comp
/= Original_Record_Component
(Comp
))
10641 or else Chars
(Comp
) = Name_uTag
10643 -- The .NET/JVM version of type Root_Controlled contains two
10644 -- fields which should not be considered part of the object. To
10645 -- achieve proper equiality between two controlled objects on
10646 -- .NET/JVM, skip _Parent whenever it has type Root_Controlled.
10648 or else (Chars
(Comp
) = Name_uParent
10649 and then VM_Target
/= No_VM
10650 and then Etype
(Comp
) = RTE
(RE_Root_Controlled
))
10652 -- Skip interface elements (secondary tags???)
10654 or else Is_Interface
(Etype
(Comp
)));
10656 Next_Entity
(Comp
);
10660 end Element_To_Compare
;
10662 -- Start of processing for Expand_Record_Equality
10665 -- Generates the following code: (assuming that Typ has one Discr and
10666 -- component C2 is also a record)
10669 -- and then Lhs.Discr1 = Rhs.Discr1
10670 -- and then Lhs.C1 = Rhs.C1
10671 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
10673 -- and then Lhs.Cmpn = Rhs.Cmpn
10675 Result
:= New_Reference_To
(Standard_True
, Loc
);
10676 C
:= Element_To_Compare
(First_Entity
(Typ
));
10677 while Present
(C
) loop
10685 First_Time
:= False;
10689 New_Lhs
:= New_Copy_Tree
(Lhs
);
10690 New_Rhs
:= New_Copy_Tree
(Rhs
);
10694 Expand_Composite_Equality
(Nod
, Etype
(C
),
10696 Make_Selected_Component
(Loc
,
10698 Selector_Name
=> New_Reference_To
(C
, Loc
)),
10700 Make_Selected_Component
(Loc
,
10702 Selector_Name
=> New_Reference_To
(C
, Loc
)),
10705 -- If some (sub)component is an unchecked_union, the whole
10706 -- operation will raise program error.
10708 if Nkind
(Check
) = N_Raise_Program_Error
then
10710 Set_Etype
(Result
, Standard_Boolean
);
10714 Make_And_Then
(Loc
,
10715 Left_Opnd
=> Result
,
10716 Right_Opnd
=> Check
);
10720 C
:= Element_To_Compare
(Next_Entity
(C
));
10724 end Expand_Record_Equality
;
10726 ---------------------------
10727 -- Expand_Set_Membership --
10728 ---------------------------
10730 procedure Expand_Set_Membership
(N
: Node_Id
) is
10731 Lop
: constant Node_Id
:= Left_Opnd
(N
);
10735 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
10736 -- If the alternative is a subtype mark, create a simple membership
10737 -- test. Otherwise create an equality test for it.
10743 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
10745 L
: constant Node_Id
:= New_Copy
(Lop
);
10746 R
: constant Node_Id
:= Relocate_Node
(Alt
);
10749 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
10750 or else Nkind
(Alt
) = N_Range
10753 Make_In
(Sloc
(Alt
),
10758 Make_Op_Eq
(Sloc
(Alt
),
10766 -- Start of processing for Expand_Set_Membership
10769 Remove_Side_Effects
(Lop
);
10771 Alt
:= Last
(Alternatives
(N
));
10772 Res
:= Make_Cond
(Alt
);
10775 while Present
(Alt
) loop
10777 Make_Or_Else
(Sloc
(Alt
),
10778 Left_Opnd
=> Make_Cond
(Alt
),
10779 Right_Opnd
=> Res
);
10784 Analyze_And_Resolve
(N
, Standard_Boolean
);
10785 end Expand_Set_Membership
;
10787 -----------------------------------
10788 -- Expand_Short_Circuit_Operator --
10789 -----------------------------------
10791 -- Deal with special expansion if actions are present for the right operand
10792 -- and deal with optimizing case of arguments being True or False. We also
10793 -- deal with the special case of non-standard boolean values.
10795 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
10796 Loc
: constant Source_Ptr
:= Sloc
(N
);
10797 Typ
: constant Entity_Id
:= Etype
(N
);
10798 Left
: constant Node_Id
:= Left_Opnd
(N
);
10799 Right
: constant Node_Id
:= Right_Opnd
(N
);
10800 LocR
: constant Source_Ptr
:= Sloc
(Right
);
10803 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
10804 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
10805 -- If Left = Shortcut_Value then Right need not be evaluated
10808 -- Deal with non-standard booleans
10810 if Is_Boolean_Type
(Typ
) then
10811 Adjust_Condition
(Left
);
10812 Adjust_Condition
(Right
);
10813 Set_Etype
(N
, Standard_Boolean
);
10816 -- Check for cases where left argument is known to be True or False
10818 if Compile_Time_Known_Value
(Left
) then
10820 -- Mark SCO for left condition as compile time known
10822 if Generate_SCO
and then Comes_From_Source
(Left
) then
10823 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
10826 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
10827 -- Any actions associated with Right will be executed unconditionally
10828 -- and can thus be inserted into the tree unconditionally.
10830 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
10831 if Present
(Actions
(N
)) then
10832 Insert_Actions
(N
, Actions
(N
));
10835 Rewrite
(N
, Right
);
10837 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
10838 -- In this case we can forget the actions associated with Right,
10839 -- since they will never be executed.
10842 Kill_Dead_Code
(Right
);
10843 Kill_Dead_Code
(Actions
(N
));
10844 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
10847 Adjust_Result_Type
(N
, Typ
);
10851 -- If Actions are present for the right operand, we have to do some
10852 -- special processing. We can't just let these actions filter back into
10853 -- code preceding the short circuit (which is what would have happened
10854 -- if we had not trapped them in the short-circuit form), since they
10855 -- must only be executed if the right operand of the short circuit is
10856 -- executed and not otherwise.
10858 if Present
(Actions
(N
)) then
10859 Actlist
:= Actions
(N
);
10861 -- We now use an Expression_With_Actions node for the right operand
10862 -- of the short-circuit form. Note that this solves the traceability
10863 -- problems for coverage analysis.
10866 Make_Expression_With_Actions
(LocR
,
10867 Expression
=> Relocate_Node
(Right
),
10868 Actions
=> Actlist
));
10869 Set_Actions
(N
, No_List
);
10870 Analyze_And_Resolve
(Right
, Standard_Boolean
);
10872 Adjust_Result_Type
(N
, Typ
);
10876 -- No actions present, check for cases of right argument True/False
10878 if Compile_Time_Known_Value
(Right
) then
10880 -- Mark SCO for left condition as compile time known
10882 if Generate_SCO
and then Comes_From_Source
(Right
) then
10883 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
10886 -- Change (Left and then True), (Left or else False) to Left.
10887 -- Note that we know there are no actions associated with the right
10888 -- operand, since we just checked for this case above.
10890 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
10893 -- Change (Left and then False), (Left or else True) to Right,
10894 -- making sure to preserve any side effects associated with the Left
10898 Remove_Side_Effects
(Left
);
10899 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
10903 Adjust_Result_Type
(N
, Typ
);
10904 end Expand_Short_Circuit_Operator
;
10906 -------------------------------------
10907 -- Fixup_Universal_Fixed_Operation --
10908 -------------------------------------
10910 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
10911 Conv
: constant Node_Id
:= Parent
(N
);
10914 -- We must have a type conversion immediately above us
10916 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
10918 -- Normally the type conversion gives our target type. The exception
10919 -- occurs in the case of the Round attribute, where the conversion
10920 -- will be to universal real, and our real type comes from the Round
10921 -- attribute (as well as an indication that we must round the result)
10923 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
10924 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
10926 Set_Etype
(N
, Etype
(Parent
(Conv
)));
10927 Set_Rounded_Result
(N
);
10929 -- Normal case where type comes from conversion above us
10932 Set_Etype
(N
, Etype
(Conv
));
10934 end Fixup_Universal_Fixed_Operation
;
10936 ---------------------------------
10937 -- Has_Inferable_Discriminants --
10938 ---------------------------------
10940 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
10942 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
10943 -- Determines whether the left-most prefix of a selected component is a
10944 -- formal parameter in a subprogram. Assumes N is a selected component.
10946 --------------------------------
10947 -- Prefix_Is_Formal_Parameter --
10948 --------------------------------
10950 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
10951 Sel_Comp
: Node_Id
;
10954 -- Move to the left-most prefix by climbing up the tree
10957 while Present
(Parent
(Sel_Comp
))
10958 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
10960 Sel_Comp
:= Parent
(Sel_Comp
);
10963 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
10964 end Prefix_Is_Formal_Parameter
;
10966 -- Start of processing for Has_Inferable_Discriminants
10969 -- For selected components, the subtype of the selector must be a
10970 -- constrained Unchecked_Union. If the component is subject to a
10971 -- per-object constraint, then the enclosing object must have inferable
10974 if Nkind
(N
) = N_Selected_Component
then
10975 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
10977 -- A small hack. If we have a per-object constrained selected
10978 -- component of a formal parameter, return True since we do not
10979 -- know the actual parameter association yet.
10981 if Prefix_Is_Formal_Parameter
(N
) then
10984 -- Otherwise, check the enclosing object and the selector
10987 return Has_Inferable_Discriminants
(Prefix
(N
))
10988 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
10991 -- The call to Has_Inferable_Discriminants will determine whether
10992 -- the selector has a constrained Unchecked_Union nominal type.
10995 return Has_Inferable_Discriminants
(Selector_Name
(N
));
10998 -- A qualified expression has inferable discriminants if its subtype
10999 -- mark is a constrained Unchecked_Union subtype.
11001 elsif Nkind
(N
) = N_Qualified_Expression
then
11002 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
11003 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
11005 -- For all other names, it is sufficient to have a constrained
11006 -- Unchecked_Union nominal subtype.
11009 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
11010 and then Is_Constrained
(Etype
(N
));
11012 end Has_Inferable_Discriminants
;
11014 -------------------------------
11015 -- Insert_Dereference_Action --
11016 -------------------------------
11018 procedure Insert_Dereference_Action
(N
: Node_Id
) is
11020 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
11021 -- Return true if type of P is derived from Checked_Pool;
11023 -----------------------------
11024 -- Is_Checked_Storage_Pool --
11025 -----------------------------
11027 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
11036 while T
/= Etype
(T
) loop
11037 if Is_RTE
(T
, RE_Checked_Pool
) then
11045 end Is_Checked_Storage_Pool
;
11049 Typ
: constant Entity_Id
:= Etype
(N
);
11050 Desig
: constant Entity_Id
:= Available_View
(Designated_Type
(Typ
));
11051 Loc
: constant Source_Ptr
:= Sloc
(N
);
11052 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
11053 Pnod
: constant Node_Id
:= Parent
(N
);
11061 -- Start of processing for Insert_Dereference_Action
11064 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
11066 -- Do not re-expand a dereference which has already been processed by
11069 if Has_Dereference_Action
(Pnod
) then
11072 -- Do not perform this type of expansion for internally-generated
11075 elsif not Comes_From_Source
(Original_Node
(Pnod
)) then
11078 -- A dereference action is only applicable to objects which have been
11079 -- allocated on a checked pool.
11081 elsif not Is_Checked_Storage_Pool
(Pool
) then
11085 -- Extract the address of the dereferenced object. Generate:
11087 -- Addr : System.Address := <N>'Pool_Address;
11089 Addr
:= Make_Temporary
(Loc
, 'P');
11092 Make_Object_Declaration
(Loc
,
11093 Defining_Identifier
=> Addr
,
11094 Object_Definition
=>
11095 New_Reference_To
(RTE
(RE_Address
), Loc
),
11097 Make_Attribute_Reference
(Loc
,
11098 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
11099 Attribute_Name
=> Name_Pool_Address
)));
11101 -- Calculate the size of the dereferenced object. Generate:
11103 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11106 Make_Explicit_Dereference
(Loc
,
11107 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11108 Set_Has_Dereference_Action
(Deref
);
11110 Size
:= Make_Temporary
(Loc
, 'S');
11113 Make_Object_Declaration
(Loc
,
11114 Defining_Identifier
=> Size
,
11116 Object_Definition
=>
11117 New_Reference_To
(RTE
(RE_Storage_Count
), Loc
),
11120 Make_Op_Divide
(Loc
,
11122 Make_Attribute_Reference
(Loc
,
11124 Attribute_Name
=> Name_Size
),
11126 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
11128 -- Calculate the alignment of the dereferenced object. Generate:
11129 -- Alig : constant Storage_Count := <N>.all'Alignment;
11132 Make_Explicit_Dereference
(Loc
,
11133 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11134 Set_Has_Dereference_Action
(Deref
);
11136 Alig
:= Make_Temporary
(Loc
, 'A');
11139 Make_Object_Declaration
(Loc
,
11140 Defining_Identifier
=> Alig
,
11141 Object_Definition
=>
11142 New_Reference_To
(RTE
(RE_Storage_Count
), Loc
),
11144 Make_Attribute_Reference
(Loc
,
11146 Attribute_Name
=> Name_Alignment
)));
11148 -- A dereference of a controlled object requires special processing. The
11149 -- finalization machinery requests additional space from the underlying
11150 -- pool to allocate and hide two pointers. As a result, a checked pool
11151 -- may mark the wrong memory as valid. Since checked pools do not have
11152 -- knowledge of hidden pointers, we have to bring the two pointers back
11153 -- in view in order to restore the original state of the object.
11155 if Needs_Finalization
(Desig
) then
11157 -- Adjust the address and size of the dereferenced object. Generate:
11158 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11161 Make_Procedure_Call_Statement
(Loc
,
11163 New_Reference_To
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
11164 Parameter_Associations
=> New_List
(
11165 New_Reference_To
(Addr
, Loc
),
11166 New_Reference_To
(Size
, Loc
),
11167 New_Reference_To
(Alig
, Loc
)));
11169 -- Class-wide types complicate things because we cannot determine
11170 -- statically whether the actual object is truly controlled. We must
11171 -- generate a runtime check to detect this property. Generate:
11173 -- if Needs_Finalization (<N>.all'Tag) then
11177 if Is_Class_Wide_Type
(Desig
) then
11179 Make_Explicit_Dereference
(Loc
,
11180 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11181 Set_Has_Dereference_Action
(Deref
);
11184 Make_Implicit_If_Statement
(N
,
11186 Make_Function_Call
(Loc
,
11188 New_Reference_To
(RTE
(RE_Needs_Finalization
), Loc
),
11189 Parameter_Associations
=> New_List
(
11190 Make_Attribute_Reference
(Loc
,
11192 Attribute_Name
=> Name_Tag
))),
11193 Then_Statements
=> New_List
(Stmt
));
11196 Insert_Action
(N
, Stmt
);
11200 -- Dereference (Pool, Addr, Size, Alig);
11203 Make_Procedure_Call_Statement
(Loc
,
11206 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
11207 Parameter_Associations
=> New_List
(
11208 New_Reference_To
(Pool
, Loc
),
11209 New_Reference_To
(Addr
, Loc
),
11210 New_Reference_To
(Size
, Loc
),
11211 New_Reference_To
(Alig
, Loc
))));
11213 -- Mark the explicit dereference as processed to avoid potential
11214 -- infinite expansion.
11216 Set_Has_Dereference_Action
(Pnod
);
11219 when RE_Not_Available
=>
11221 end Insert_Dereference_Action
;
11223 --------------------------------
11224 -- Integer_Promotion_Possible --
11225 --------------------------------
11227 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
11228 Operand
: constant Node_Id
:= Expression
(N
);
11229 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11230 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
11233 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
11237 -- We only do the transformation for source constructs. We assume
11238 -- that the expander knows what it is doing when it generates code.
11240 Comes_From_Source
(N
)
11242 -- If the operand type is Short_Integer or Short_Short_Integer,
11243 -- then we will promote to Integer, which is available on all
11244 -- targets, and is sufficient to ensure no intermediate overflow.
11245 -- Furthermore it is likely to be as efficient or more efficient
11246 -- than using the smaller type for the computation so we do this
11247 -- unconditionally.
11250 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
11252 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
11254 -- Test for interesting operation, which includes addition,
11255 -- division, exponentiation, multiplication, subtraction, absolute
11256 -- value and unary negation. Unary "+" is omitted since it is a
11257 -- no-op and thus can't overflow.
11259 and then Nkind_In
(Operand
, N_Op_Abs
,
11266 end Integer_Promotion_Possible
;
11268 ------------------------------
11269 -- Make_Array_Comparison_Op --
11270 ------------------------------
11272 -- This is a hand-coded expansion of the following generic function:
11275 -- type elem is (<>);
11276 -- type index is (<>);
11277 -- type a is array (index range <>) of elem;
11279 -- function Gnnn (X : a; Y: a) return boolean is
11280 -- J : index := Y'first;
11283 -- if X'length = 0 then
11286 -- elsif Y'length = 0 then
11290 -- for I in X'range loop
11291 -- if X (I) = Y (J) then
11292 -- if J = Y'last then
11295 -- J := index'succ (J);
11299 -- return X (I) > Y (J);
11303 -- return X'length > Y'length;
11307 -- Note that since we are essentially doing this expansion by hand, we
11308 -- do not need to generate an actual or formal generic part, just the
11309 -- instantiated function itself.
11311 function Make_Array_Comparison_Op
11313 Nod
: Node_Id
) return Node_Id
11315 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11317 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
11318 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
11319 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
11320 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
11322 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
11324 Loop_Statement
: Node_Id
;
11325 Loop_Body
: Node_Id
;
11327 Inner_If
: Node_Id
;
11328 Final_Expr
: Node_Id
;
11329 Func_Body
: Node_Id
;
11330 Func_Name
: Entity_Id
;
11336 -- if J = Y'last then
11339 -- J := index'succ (J);
11343 Make_Implicit_If_Statement
(Nod
,
11346 Left_Opnd
=> New_Reference_To
(J
, Loc
),
11348 Make_Attribute_Reference
(Loc
,
11349 Prefix
=> New_Reference_To
(Y
, Loc
),
11350 Attribute_Name
=> Name_Last
)),
11352 Then_Statements
=> New_List
(
11353 Make_Exit_Statement
(Loc
)),
11357 Make_Assignment_Statement
(Loc
,
11358 Name
=> New_Reference_To
(J
, Loc
),
11360 Make_Attribute_Reference
(Loc
,
11361 Prefix
=> New_Reference_To
(Index
, Loc
),
11362 Attribute_Name
=> Name_Succ
,
11363 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))))));
11365 -- if X (I) = Y (J) then
11368 -- return X (I) > Y (J);
11372 Make_Implicit_If_Statement
(Nod
,
11376 Make_Indexed_Component
(Loc
,
11377 Prefix
=> New_Reference_To
(X
, Loc
),
11378 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
11381 Make_Indexed_Component
(Loc
,
11382 Prefix
=> New_Reference_To
(Y
, Loc
),
11383 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)))),
11385 Then_Statements
=> New_List
(Inner_If
),
11387 Else_Statements
=> New_List
(
11388 Make_Simple_Return_Statement
(Loc
,
11392 Make_Indexed_Component
(Loc
,
11393 Prefix
=> New_Reference_To
(X
, Loc
),
11394 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
11397 Make_Indexed_Component
(Loc
,
11398 Prefix
=> New_Reference_To
(Y
, Loc
),
11399 Expressions
=> New_List
(
11400 New_Reference_To
(J
, Loc
)))))));
11402 -- for I in X'range loop
11407 Make_Implicit_Loop_Statement
(Nod
,
11408 Identifier
=> Empty
,
11410 Iteration_Scheme
=>
11411 Make_Iteration_Scheme
(Loc
,
11412 Loop_Parameter_Specification
=>
11413 Make_Loop_Parameter_Specification
(Loc
,
11414 Defining_Identifier
=> I
,
11415 Discrete_Subtype_Definition
=>
11416 Make_Attribute_Reference
(Loc
,
11417 Prefix
=> New_Reference_To
(X
, Loc
),
11418 Attribute_Name
=> Name_Range
))),
11420 Statements
=> New_List
(Loop_Body
));
11422 -- if X'length = 0 then
11424 -- elsif Y'length = 0 then
11427 -- for ... loop ... end loop;
11428 -- return X'length > Y'length;
11432 Make_Attribute_Reference
(Loc
,
11433 Prefix
=> New_Reference_To
(X
, Loc
),
11434 Attribute_Name
=> Name_Length
);
11437 Make_Attribute_Reference
(Loc
,
11438 Prefix
=> New_Reference_To
(Y
, Loc
),
11439 Attribute_Name
=> Name_Length
);
11443 Left_Opnd
=> Length1
,
11444 Right_Opnd
=> Length2
);
11447 Make_Implicit_If_Statement
(Nod
,
11451 Make_Attribute_Reference
(Loc
,
11452 Prefix
=> New_Reference_To
(X
, Loc
),
11453 Attribute_Name
=> Name_Length
),
11455 Make_Integer_Literal
(Loc
, 0)),
11459 Make_Simple_Return_Statement
(Loc
,
11460 Expression
=> New_Reference_To
(Standard_False
, Loc
))),
11462 Elsif_Parts
=> New_List
(
11463 Make_Elsif_Part
(Loc
,
11467 Make_Attribute_Reference
(Loc
,
11468 Prefix
=> New_Reference_To
(Y
, Loc
),
11469 Attribute_Name
=> Name_Length
),
11471 Make_Integer_Literal
(Loc
, 0)),
11475 Make_Simple_Return_Statement
(Loc
,
11476 Expression
=> New_Reference_To
(Standard_True
, Loc
))))),
11478 Else_Statements
=> New_List
(
11480 Make_Simple_Return_Statement
(Loc
,
11481 Expression
=> Final_Expr
)));
11485 Formals
:= New_List
(
11486 Make_Parameter_Specification
(Loc
,
11487 Defining_Identifier
=> X
,
11488 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
11490 Make_Parameter_Specification
(Loc
,
11491 Defining_Identifier
=> Y
,
11492 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
11494 -- function Gnnn (...) return boolean is
11495 -- J : index := Y'first;
11500 Func_Name
:= Make_Temporary
(Loc
, 'G');
11503 Make_Subprogram_Body
(Loc
,
11505 Make_Function_Specification
(Loc
,
11506 Defining_Unit_Name
=> Func_Name
,
11507 Parameter_Specifications
=> Formals
,
11508 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
11510 Declarations
=> New_List
(
11511 Make_Object_Declaration
(Loc
,
11512 Defining_Identifier
=> J
,
11513 Object_Definition
=> New_Reference_To
(Index
, Loc
),
11515 Make_Attribute_Reference
(Loc
,
11516 Prefix
=> New_Reference_To
(Y
, Loc
),
11517 Attribute_Name
=> Name_First
))),
11519 Handled_Statement_Sequence
=>
11520 Make_Handled_Sequence_Of_Statements
(Loc
,
11521 Statements
=> New_List
(If_Stat
)));
11524 end Make_Array_Comparison_Op
;
11526 ---------------------------
11527 -- Make_Boolean_Array_Op --
11528 ---------------------------
11530 -- For logical operations on boolean arrays, expand in line the following,
11531 -- replacing 'and' with 'or' or 'xor' where needed:
11533 -- function Annn (A : typ; B: typ) return typ is
11536 -- for J in A'range loop
11537 -- C (J) := A (J) op B (J);
11542 -- Here typ is the boolean array type
11544 function Make_Boolean_Array_Op
11546 N
: Node_Id
) return Node_Id
11548 Loc
: constant Source_Ptr
:= Sloc
(N
);
11550 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
11551 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
11552 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
11553 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
11561 Func_Name
: Entity_Id
;
11562 Func_Body
: Node_Id
;
11563 Loop_Statement
: Node_Id
;
11567 Make_Indexed_Component
(Loc
,
11568 Prefix
=> New_Reference_To
(A
, Loc
),
11569 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11572 Make_Indexed_Component
(Loc
,
11573 Prefix
=> New_Reference_To
(B
, Loc
),
11574 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11577 Make_Indexed_Component
(Loc
,
11578 Prefix
=> New_Reference_To
(C
, Loc
),
11579 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11581 if Nkind
(N
) = N_Op_And
then
11585 Right_Opnd
=> B_J
);
11587 elsif Nkind
(N
) = N_Op_Or
then
11591 Right_Opnd
=> B_J
);
11597 Right_Opnd
=> B_J
);
11601 Make_Implicit_Loop_Statement
(N
,
11602 Identifier
=> Empty
,
11604 Iteration_Scheme
=>
11605 Make_Iteration_Scheme
(Loc
,
11606 Loop_Parameter_Specification
=>
11607 Make_Loop_Parameter_Specification
(Loc
,
11608 Defining_Identifier
=> J
,
11609 Discrete_Subtype_Definition
=>
11610 Make_Attribute_Reference
(Loc
,
11611 Prefix
=> New_Reference_To
(A
, Loc
),
11612 Attribute_Name
=> Name_Range
))),
11614 Statements
=> New_List
(
11615 Make_Assignment_Statement
(Loc
,
11617 Expression
=> Op
)));
11619 Formals
:= New_List
(
11620 Make_Parameter_Specification
(Loc
,
11621 Defining_Identifier
=> A
,
11622 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
11624 Make_Parameter_Specification
(Loc
,
11625 Defining_Identifier
=> B
,
11626 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
11628 Func_Name
:= Make_Temporary
(Loc
, 'A');
11629 Set_Is_Inlined
(Func_Name
);
11632 Make_Subprogram_Body
(Loc
,
11634 Make_Function_Specification
(Loc
,
11635 Defining_Unit_Name
=> Func_Name
,
11636 Parameter_Specifications
=> Formals
,
11637 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
11639 Declarations
=> New_List
(
11640 Make_Object_Declaration
(Loc
,
11641 Defining_Identifier
=> C
,
11642 Object_Definition
=> New_Reference_To
(Typ
, Loc
))),
11644 Handled_Statement_Sequence
=>
11645 Make_Handled_Sequence_Of_Statements
(Loc
,
11646 Statements
=> New_List
(
11648 Make_Simple_Return_Statement
(Loc
,
11649 Expression
=> New_Reference_To
(C
, Loc
)))));
11652 end Make_Boolean_Array_Op
;
11654 -----------------------------------------
11655 -- Minimized_Eliminated_Overflow_Check --
11656 -----------------------------------------
11658 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
11661 Is_Signed_Integer_Type
(Etype
(N
))
11662 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
11663 end Minimized_Eliminated_Overflow_Check
;
11665 --------------------------------
11666 -- Optimize_Length_Comparison --
11667 --------------------------------
11669 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
11670 Loc
: constant Source_Ptr
:= Sloc
(N
);
11671 Typ
: constant Entity_Id
:= Etype
(N
);
11676 -- First and Last attribute reference nodes, which end up as left and
11677 -- right operands of the optimized result.
11680 -- True for comparison operand of zero
11683 -- Comparison operand, set only if Is_Zero is false
11686 -- Entity whose length is being compared
11689 -- Integer_Literal node for length attribute expression, or Empty
11690 -- if there is no such expression present.
11693 -- Type of array index to which 'Length is applied
11695 Op
: Node_Kind
:= Nkind
(N
);
11696 -- Kind of comparison operator, gets flipped if operands backwards
11698 function Is_Optimizable
(N
: Node_Id
) return Boolean;
11699 -- Tests N to see if it is an optimizable comparison value (defined as
11700 -- constant zero or one, or something else where the value is known to
11701 -- be positive and in the range of 32-bits, and where the corresponding
11702 -- Length value is also known to be 32-bits. If result is true, sets
11703 -- Is_Zero, Ityp, and Comp accordingly.
11705 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
11706 -- Tests if N is a length attribute applied to a simple entity. If so,
11707 -- returns True, and sets Ent to the entity, and Index to the integer
11708 -- literal provided as an attribute expression, or to Empty if none.
11709 -- Also returns True if the expression is a generated type conversion
11710 -- whose expression is of the desired form. This latter case arises
11711 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
11712 -- to check for being in range, which is not needed in this context.
11713 -- Returns False if neither condition holds.
11715 function Prepare_64
(N
: Node_Id
) return Node_Id
;
11716 -- Given a discrete expression, returns a Long_Long_Integer typed
11717 -- expression representing the underlying value of the expression.
11718 -- This is done with an unchecked conversion to the result type. We
11719 -- use unchecked conversion to handle the enumeration type case.
11721 ----------------------
11722 -- Is_Entity_Length --
11723 ----------------------
11725 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
11727 if Nkind
(N
) = N_Attribute_Reference
11728 and then Attribute_Name
(N
) = Name_Length
11729 and then Is_Entity_Name
(Prefix
(N
))
11731 Ent
:= Entity
(Prefix
(N
));
11733 if Present
(Expressions
(N
)) then
11734 Index
:= First
(Expressions
(N
));
11741 elsif Nkind
(N
) = N_Type_Conversion
11742 and then not Comes_From_Source
(N
)
11744 return Is_Entity_Length
(Expression
(N
));
11749 end Is_Entity_Length
;
11751 --------------------
11752 -- Is_Optimizable --
11753 --------------------
11755 function Is_Optimizable
(N
: Node_Id
) return Boolean is
11763 if Compile_Time_Known_Value
(N
) then
11764 Val
:= Expr_Value
(N
);
11766 if Val
= Uint_0
then
11771 elsif Val
= Uint_1
then
11778 -- Here we have to make sure of being within 32-bits
11780 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
11783 or else Lo
< Uint_1
11784 or else Hi
> UI_From_Int
(Int
'Last)
11789 -- Comparison value was within range, so now we must check the index
11790 -- value to make sure it is also within 32-bits.
11792 Indx
:= First_Index
(Etype
(Ent
));
11794 if Present
(Index
) then
11795 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
11800 Ityp
:= Etype
(Indx
);
11802 if Esize
(Ityp
) > 32 then
11809 end Is_Optimizable
;
11815 function Prepare_64
(N
: Node_Id
) return Node_Id
is
11817 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
11820 -- Start of processing for Optimize_Length_Comparison
11823 -- Nothing to do if not a comparison
11825 if Op
not in N_Op_Compare
then
11829 -- Nothing to do if special -gnatd.P debug flag set
11831 if Debug_Flag_Dot_PP
then
11835 -- Ent'Length op 0/1
11837 if Is_Entity_Length
(Left_Opnd
(N
))
11838 and then Is_Optimizable
(Right_Opnd
(N
))
11842 -- 0/1 op Ent'Length
11844 elsif Is_Entity_Length
(Right_Opnd
(N
))
11845 and then Is_Optimizable
(Left_Opnd
(N
))
11847 -- Flip comparison to opposite sense
11850 when N_Op_Lt
=> Op
:= N_Op_Gt
;
11851 when N_Op_Le
=> Op
:= N_Op_Ge
;
11852 when N_Op_Gt
=> Op
:= N_Op_Lt
;
11853 when N_Op_Ge
=> Op
:= N_Op_Le
;
11854 when others => null;
11857 -- Else optimization not possible
11863 -- Fall through if we will do the optimization
11865 -- Cases to handle:
11867 -- X'Length = 0 => X'First > X'Last
11868 -- X'Length = 1 => X'First = X'Last
11869 -- X'Length = n => X'First + (n - 1) = X'Last
11871 -- X'Length /= 0 => X'First <= X'Last
11872 -- X'Length /= 1 => X'First /= X'Last
11873 -- X'Length /= n => X'First + (n - 1) /= X'Last
11875 -- X'Length >= 0 => always true, warn
11876 -- X'Length >= 1 => X'First <= X'Last
11877 -- X'Length >= n => X'First + (n - 1) <= X'Last
11879 -- X'Length > 0 => X'First <= X'Last
11880 -- X'Length > 1 => X'First < X'Last
11881 -- X'Length > n => X'First + (n - 1) < X'Last
11883 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
11884 -- X'Length <= 1 => X'First >= X'Last
11885 -- X'Length <= n => X'First + (n - 1) >= X'Last
11887 -- X'Length < 0 => always false (warn)
11888 -- X'Length < 1 => X'First > X'Last
11889 -- X'Length < n => X'First + (n - 1) > X'Last
11891 -- Note: for the cases of n (not constant 0,1), we require that the
11892 -- corresponding index type be integer or shorter (i.e. not 64-bit),
11893 -- and the same for the comparison value. Then we do the comparison
11894 -- using 64-bit arithmetic (actually long long integer), so that we
11895 -- cannot have overflow intefering with the result.
11897 -- First deal with warning cases
11906 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
11907 Analyze_And_Resolve
(N
, Typ
);
11908 Warn_On_Known_Condition
(N
);
11915 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
11916 Analyze_And_Resolve
(N
, Typ
);
11917 Warn_On_Known_Condition
(N
);
11921 if Constant_Condition_Warnings
11922 and then Comes_From_Source
(Original_Node
(N
))
11924 Error_Msg_N
("could replace by ""'=""?c?", N
);
11934 -- Build the First reference we will use
11937 Make_Attribute_Reference
(Loc
,
11938 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
11939 Attribute_Name
=> Name_First
);
11941 if Present
(Index
) then
11942 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
11945 -- If general value case, then do the addition of (n - 1), and
11946 -- also add the needed conversions to type Long_Long_Integer.
11948 if Present
(Comp
) then
11951 Left_Opnd
=> Prepare_64
(Left
),
11953 Make_Op_Subtract
(Loc
,
11954 Left_Opnd
=> Prepare_64
(Comp
),
11955 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
11958 -- Build the Last reference we will use
11961 Make_Attribute_Reference
(Loc
,
11962 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
11963 Attribute_Name
=> Name_Last
);
11965 if Present
(Index
) then
11966 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
11969 -- If general operand, convert Last reference to Long_Long_Integer
11971 if Present
(Comp
) then
11972 Right
:= Prepare_64
(Right
);
11975 -- Check for cases to optimize
11977 -- X'Length = 0 => X'First > X'Last
11978 -- X'Length < 1 => X'First > X'Last
11979 -- X'Length < n => X'First + (n - 1) > X'Last
11981 if (Is_Zero
and then Op
= N_Op_Eq
)
11982 or else (not Is_Zero
and then Op
= N_Op_Lt
)
11987 Right_Opnd
=> Right
);
11989 -- X'Length = 1 => X'First = X'Last
11990 -- X'Length = n => X'First + (n - 1) = X'Last
11992 elsif not Is_Zero
and then Op
= N_Op_Eq
then
11996 Right_Opnd
=> Right
);
11998 -- X'Length /= 0 => X'First <= X'Last
11999 -- X'Length > 0 => X'First <= X'Last
12001 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
12005 Right_Opnd
=> Right
);
12007 -- X'Length /= 1 => X'First /= X'Last
12008 -- X'Length /= n => X'First + (n - 1) /= X'Last
12010 elsif not Is_Zero
and then Op
= N_Op_Ne
then
12014 Right_Opnd
=> Right
);
12016 -- X'Length >= 1 => X'First <= X'Last
12017 -- X'Length >= n => X'First + (n - 1) <= X'Last
12019 elsif not Is_Zero
and then Op
= N_Op_Ge
then
12023 Right_Opnd
=> Right
);
12025 -- X'Length > 1 => X'First < X'Last
12026 -- X'Length > n => X'First + (n = 1) < X'Last
12028 elsif not Is_Zero
and then Op
= N_Op_Gt
then
12032 Right_Opnd
=> Right
);
12034 -- X'Length <= 1 => X'First >= X'Last
12035 -- X'Length <= n => X'First + (n - 1) >= X'Last
12037 elsif not Is_Zero
and then Op
= N_Op_Le
then
12041 Right_Opnd
=> Right
);
12043 -- Should not happen at this stage
12046 raise Program_Error
;
12049 -- Rewrite and finish up
12051 Rewrite
(N
, Result
);
12052 Analyze_And_Resolve
(N
, Typ
);
12054 end Optimize_Length_Comparison
;
12056 ------------------------------
12057 -- Process_Transient_Object --
12058 ------------------------------
12060 procedure Process_Transient_Object
12062 Rel_Node
: Node_Id
)
12064 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
;
12065 -- Find the logical context where N appears. The context is chosen such
12066 -- that it is possible to insert before and after it.
12068 ----------------------------
12069 -- Find_Enclosing_Context --
12070 ----------------------------
12072 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
is
12077 -- When the node is inside a case/if expression, the lifetime of any
12078 -- temporary controlled object is extended. Find a suitable insertion
12079 -- node by locating the topmost case or if expressions.
12081 if Within_Case_Or_If_Expression
(N
) then
12084 while Present
(Par
) loop
12085 if Nkind_In
(Original_Node
(Par
), N_Case_Expression
,
12090 -- Prevent the search from going too far
12092 elsif Is_Body_Or_Package_Declaration
(Par
) then
12096 Par
:= Parent
(Par
);
12099 -- The topmost case or if expression is now recovered, but it may
12100 -- still not be the correct place to add generated code. Climb to
12101 -- find a parent that is part of a declarative or statement list.
12104 while Present
(Par
) loop
12105 if Is_List_Member
(Par
)
12106 and then not Nkind_In
(Par
, N_Component_Association
,
12107 N_Discriminant_Association
,
12108 N_Parameter_Association
,
12109 N_Pragma_Argument_Association
)
12113 -- Prevent the search from going too far
12115 elsif Is_Body_Or_Package_Declaration
(Par
) then
12119 Par
:= Parent
(Par
);
12124 -- Short circuit operators in complex expressions are converted into
12125 -- expression_with_actions.
12128 -- Handle the case where the node is buried deep inside an if
12129 -- statement. The temporary controlled object must be finalized
12130 -- before the then, elsif or else statements are evaluated.
12133 -- and then Ctrl_Func_Call
12135 -- <result must be finalized at this point>
12139 -- To achieve this, find the topmost logical operator. Generated
12140 -- actions are then inserted before/after it.
12143 while Present
(Par
) loop
12145 -- Keep climbing past various operators
12147 if Nkind
(Parent
(Par
)) in N_Op
12148 or else Nkind_In
(Parent
(Par
), N_And_Then
, N_Or_Else
)
12150 Par
:= Parent
(Par
);
12158 -- The node may be located in a pragma in which case return the
12161 -- pragma Precondition (... and then Ctrl_Func_Call ...);
12163 -- Similar case occurs when the node is related to an object
12164 -- declaration or assignment:
12166 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
12168 -- Another case to consider is when the node is part of a return
12171 -- return ... and then Ctrl_Func_Call ...;
12173 -- Another case is when the node acts as a formal in a procedure
12176 -- Proc (... and then Ctrl_Func_Call ...);
12178 while Present
(Par
) loop
12179 if Nkind_In
(Par
, N_Assignment_Statement
,
12180 N_Object_Declaration
,
12182 N_Procedure_Call_Statement
,
12183 N_Simple_Return_Statement
)
12187 -- Prevent the search from going too far
12189 elsif Is_Body_Or_Package_Declaration
(Par
) then
12193 Par
:= Parent
(Par
);
12196 -- Return the topmost short circuit operator
12200 end Find_Enclosing_Context
;
12204 Context
: constant Node_Id
:= Find_Enclosing_Context
(Rel_Node
);
12205 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
12206 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
12207 Obj_Typ
: constant Node_Id
:= Etype
(Obj_Id
);
12208 Desig_Typ
: Entity_Id
;
12210 Fin_Call
: Node_Id
;
12211 Ptr_Id
: Entity_Id
;
12212 Temp_Id
: Entity_Id
;
12214 -- Start of processing for Process_Transient_Object
12217 -- Step 1: Create the access type which provides a reference to the
12218 -- transient controlled object.
12220 if Is_Access_Type
(Obj_Typ
) then
12221 Desig_Typ
:= Directly_Designated_Type
(Obj_Typ
);
12223 Desig_Typ
:= Obj_Typ
;
12226 Desig_Typ
:= Base_Type
(Desig_Typ
);
12229 -- Ann : access [all] <Desig_Typ>;
12231 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
12233 Insert_Action
(Context
,
12234 Make_Full_Type_Declaration
(Loc
,
12235 Defining_Identifier
=> Ptr_Id
,
12237 Make_Access_To_Object_Definition
(Loc
,
12238 All_Present
=> Ekind
(Obj_Typ
) = E_General_Access_Type
,
12239 Subtype_Indication
=> New_Reference_To
(Desig_Typ
, Loc
))));
12241 -- Step 2: Create a temporary which acts as a hook to the transient
12242 -- controlled object. Generate:
12244 -- Temp : Ptr_Id := null;
12246 Temp_Id
:= Make_Temporary
(Loc
, 'T');
12248 Insert_Action
(Context
,
12249 Make_Object_Declaration
(Loc
,
12250 Defining_Identifier
=> Temp_Id
,
12251 Object_Definition
=> New_Reference_To
(Ptr_Id
, Loc
)));
12253 -- Mark the temporary as created for the purposes of exporting the
12254 -- transient controlled object out of the expression_with_action or if
12255 -- expression. This signals the machinery in Build_Finalizer to treat
12256 -- this case specially.
12258 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Decl
);
12260 -- Step 3: Hook the transient object to the temporary
12262 -- The use of unchecked conversion / unrestricted access is needed to
12263 -- avoid an accessibility violation. Note that the finalization code is
12264 -- structured in such a way that the "hook" is processed only when it
12265 -- points to an existing object.
12267 if Is_Access_Type
(Obj_Typ
) then
12268 Expr
:= Unchecked_Convert_To
(Ptr_Id
, New_Reference_To
(Obj_Id
, Loc
));
12271 Make_Attribute_Reference
(Loc
,
12272 Prefix
=> New_Reference_To
(Obj_Id
, Loc
),
12273 Attribute_Name
=> Name_Unrestricted_Access
);
12277 -- Temp := Ptr_Id (Obj_Id);
12279 -- Temp := Obj_Id'Unrestricted_Access;
12281 Insert_After_And_Analyze
(Decl
,
12282 Make_Assignment_Statement
(Loc
,
12283 Name
=> New_Reference_To
(Temp_Id
, Loc
),
12284 Expression
=> Expr
));
12286 -- Step 4: Finalize the transient controlled object after the context
12287 -- has been evaluated/elaborated. Generate:
12289 -- if Temp /= null then
12290 -- [Deep_]Finalize (Temp.all);
12294 -- When the node is part of a return statement, there is no need to
12295 -- insert a finalization call, as the general finalization mechanism
12296 -- (see Build_Finalizer) would take care of the transient controlled
12297 -- object on subprogram exit. Note that it would also be impossible to
12298 -- insert the finalization code after the return statement as this will
12299 -- render it unreachable.
12301 if Nkind
(Context
) /= N_Simple_Return_Statement
then
12303 Make_Implicit_If_Statement
(Decl
,
12306 Left_Opnd
=> New_Reference_To
(Temp_Id
, Loc
),
12307 Right_Opnd
=> Make_Null
(Loc
)),
12309 Then_Statements
=> New_List
(
12312 Make_Explicit_Dereference
(Loc
,
12313 Prefix
=> New_Reference_To
(Temp_Id
, Loc
)),
12316 Make_Assignment_Statement
(Loc
,
12317 Name
=> New_Reference_To
(Temp_Id
, Loc
),
12318 Expression
=> Make_Null
(Loc
))));
12320 -- Use the Actions list of logical operators when inserting the
12321 -- finalization call. This ensures that all transient controlled
12322 -- objects are finalized after the operators are evaluated.
12324 if Nkind_In
(Context
, N_And_Then
, N_Or_Else
) then
12325 Insert_Action
(Context
, Fin_Call
);
12327 Insert_Action_After
(Context
, Fin_Call
);
12330 end Process_Transient_Object
;
12332 ------------------------
12333 -- Rewrite_Comparison --
12334 ------------------------
12336 procedure Rewrite_Comparison
(N
: Node_Id
) is
12337 Warning_Generated
: Boolean := False;
12338 -- Set to True if first pass with Assume_Valid generates a warning in
12339 -- which case we skip the second pass to avoid warning overloaded.
12342 -- Set to Standard_True or Standard_False
12345 if Nkind
(N
) = N_Type_Conversion
then
12346 Rewrite_Comparison
(Expression
(N
));
12349 elsif Nkind
(N
) not in N_Op_Compare
then
12353 -- Now start looking at the comparison in detail. We potentially go
12354 -- through this loop twice. The first time, Assume_Valid is set False
12355 -- in the call to Compile_Time_Compare. If this call results in a
12356 -- clear result of always True or Always False, that's decisive and
12357 -- we are done. Otherwise we repeat the processing with Assume_Valid
12358 -- set to True to generate additional warnings. We can skip that step
12359 -- if Constant_Condition_Warnings is False.
12361 for AV
in False .. True loop
12363 Typ
: constant Entity_Id
:= Etype
(N
);
12364 Op1
: constant Node_Id
:= Left_Opnd
(N
);
12365 Op2
: constant Node_Id
:= Right_Opnd
(N
);
12367 Res
: constant Compare_Result
:=
12368 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
12369 -- Res indicates if compare outcome can be compile time determined
12371 True_Result
: Boolean;
12372 False_Result
: Boolean;
12375 case N_Op_Compare
(Nkind
(N
)) is
12377 True_Result
:= Res
= EQ
;
12378 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
12381 True_Result
:= Res
in Compare_GE
;
12382 False_Result
:= Res
= LT
;
12385 and then Constant_Condition_Warnings
12386 and then Comes_From_Source
(Original_Node
(N
))
12387 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
12388 and then not In_Instance
12389 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12390 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12393 ("can never be greater than, could replace by ""'=""?c?",
12395 Warning_Generated
:= True;
12399 True_Result
:= Res
= GT
;
12400 False_Result
:= Res
in Compare_LE
;
12403 True_Result
:= Res
= LT
;
12404 False_Result
:= Res
in Compare_GE
;
12407 True_Result
:= Res
in Compare_LE
;
12408 False_Result
:= Res
= GT
;
12411 and then Constant_Condition_Warnings
12412 and then Comes_From_Source
(Original_Node
(N
))
12413 and then Nkind
(Original_Node
(N
)) = N_Op_Le
12414 and then not In_Instance
12415 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12416 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12419 ("can never be less than, could replace by ""'=""?c?", N
);
12420 Warning_Generated
:= True;
12424 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
12425 False_Result
:= Res
= EQ
;
12428 -- If this is the first iteration, then we actually convert the
12429 -- comparison into True or False, if the result is certain.
12432 if True_Result
or False_Result
then
12433 Result
:= Boolean_Literals
(True_Result
);
12436 New_Occurrence_Of
(Result
, Sloc
(N
))));
12437 Analyze_And_Resolve
(N
, Typ
);
12438 Warn_On_Known_Condition
(N
);
12442 -- If this is the second iteration (AV = True), and the original
12443 -- node comes from source and we are not in an instance, then give
12444 -- a warning if we know result would be True or False. Note: we
12445 -- know Constant_Condition_Warnings is set if we get here.
12447 elsif Comes_From_Source
(Original_Node
(N
))
12448 and then not In_Instance
12450 if True_Result
then
12452 ("condition can only be False if invalid values present??",
12454 elsif False_Result
then
12456 ("condition can only be True if invalid values present??",
12462 -- Skip second iteration if not warning on constant conditions or
12463 -- if the first iteration already generated a warning of some kind or
12464 -- if we are in any case assuming all values are valid (so that the
12465 -- first iteration took care of the valid case).
12467 exit when not Constant_Condition_Warnings
;
12468 exit when Warning_Generated
;
12469 exit when Assume_No_Invalid_Values
;
12471 end Rewrite_Comparison
;
12473 ----------------------------
12474 -- Safe_In_Place_Array_Op --
12475 ----------------------------
12477 function Safe_In_Place_Array_Op
12480 Op2
: Node_Id
) return Boolean
12482 Target
: Entity_Id
;
12484 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
12485 -- Operand is safe if it cannot overlap part of the target of the
12486 -- operation. If the operand and the target are identical, the operand
12487 -- is safe. The operand can be empty in the case of negation.
12489 function Is_Unaliased
(N
: Node_Id
) return Boolean;
12490 -- Check that N is a stand-alone entity
12496 function Is_Unaliased
(N
: Node_Id
) return Boolean is
12500 and then No
(Address_Clause
(Entity
(N
)))
12501 and then No
(Renamed_Object
(Entity
(N
)));
12504 ---------------------
12505 -- Is_Safe_Operand --
12506 ---------------------
12508 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
12513 elsif Is_Entity_Name
(Op
) then
12514 return Is_Unaliased
(Op
);
12516 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
12517 return Is_Unaliased
(Prefix
(Op
));
12519 elsif Nkind
(Op
) = N_Slice
then
12521 Is_Unaliased
(Prefix
(Op
))
12522 and then Entity
(Prefix
(Op
)) /= Target
;
12524 elsif Nkind
(Op
) = N_Op_Not
then
12525 return Is_Safe_Operand
(Right_Opnd
(Op
));
12530 end Is_Safe_Operand
;
12532 -- Start of processing for Safe_In_Place_Array_Op
12535 -- Skip this processing if the component size is different from system
12536 -- storage unit (since at least for NOT this would cause problems).
12538 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
12541 -- Cannot do in place stuff on VM_Target since cannot pass addresses
12543 elsif VM_Target
/= No_VM
then
12546 -- Cannot do in place stuff if non-standard Boolean representation
12548 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
12551 elsif not Is_Unaliased
(Lhs
) then
12555 Target
:= Entity
(Lhs
);
12556 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
12558 end Safe_In_Place_Array_Op
;
12560 -----------------------
12561 -- Tagged_Membership --
12562 -----------------------
12564 -- There are two different cases to consider depending on whether the right
12565 -- operand is a class-wide type or not. If not we just compare the actual
12566 -- tag of the left expr to the target type tag:
12568 -- Left_Expr.Tag = Right_Type'Tag;
12570 -- If it is a class-wide type we use the RT function CW_Membership which is
12571 -- usually implemented by looking in the ancestor tables contained in the
12572 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
12574 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
12575 -- function IW_Membership which is usually implemented by looking in the
12576 -- table of abstract interface types plus the ancestor table contained in
12577 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
12579 procedure Tagged_Membership
12581 SCIL_Node
: out Node_Id
;
12582 Result
: out Node_Id
)
12584 Left
: constant Node_Id
:= Left_Opnd
(N
);
12585 Right
: constant Node_Id
:= Right_Opnd
(N
);
12586 Loc
: constant Source_Ptr
:= Sloc
(N
);
12588 Full_R_Typ
: Entity_Id
;
12589 Left_Type
: Entity_Id
;
12590 New_Node
: Node_Id
;
12591 Right_Type
: Entity_Id
;
12595 SCIL_Node
:= Empty
;
12597 -- Handle entities from the limited view
12599 Left_Type
:= Available_View
(Etype
(Left
));
12600 Right_Type
:= Available_View
(Etype
(Right
));
12602 -- In the case where the type is an access type, the test is applied
12603 -- using the designated types (needed in Ada 2012 for implicit anonymous
12604 -- access conversions, for AI05-0149).
12606 if Is_Access_Type
(Right_Type
) then
12607 Left_Type
:= Designated_Type
(Left_Type
);
12608 Right_Type
:= Designated_Type
(Right_Type
);
12611 if Is_Class_Wide_Type
(Left_Type
) then
12612 Left_Type
:= Root_Type
(Left_Type
);
12615 if Is_Class_Wide_Type
(Right_Type
) then
12616 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
12618 Full_R_Typ
:= Underlying_Type
(Right_Type
);
12622 Make_Selected_Component
(Loc
,
12623 Prefix
=> Relocate_Node
(Left
),
12625 New_Reference_To
(First_Tag_Component
(Left_Type
), Loc
));
12627 if Is_Class_Wide_Type
(Right_Type
) then
12629 -- No need to issue a run-time check if we statically know that the
12630 -- result of this membership test is always true. For example,
12631 -- considering the following declarations:
12633 -- type Iface is interface;
12634 -- type T is tagged null record;
12635 -- type DT is new T and Iface with null record;
12640 -- These membership tests are always true:
12643 -- Obj2 in T'Class;
12644 -- Obj2 in Iface'Class;
12646 -- We do not need to handle cases where the membership is illegal.
12649 -- Obj1 in DT'Class; -- Compile time error
12650 -- Obj1 in Iface'Class; -- Compile time error
12652 if not Is_Class_Wide_Type
(Left_Type
)
12653 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
12654 Use_Full_View
=> True)
12655 or else (Is_Interface
(Etype
(Right_Type
))
12656 and then Interface_Present_In_Ancestor
12658 Iface
=> Etype
(Right_Type
))))
12660 Result
:= New_Reference_To
(Standard_True
, Loc
);
12664 -- Ada 2005 (AI-251): Class-wide applied to interfaces
12666 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
12668 -- Support to: "Iface_CW_Typ in Typ'Class"
12670 or else Is_Interface
(Left_Type
)
12672 -- Issue error if IW_Membership operation not available in a
12673 -- configurable run time setting.
12675 if not RTE_Available
(RE_IW_Membership
) then
12677 ("dynamic membership test on interface types", N
);
12683 Make_Function_Call
(Loc
,
12684 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
12685 Parameter_Associations
=> New_List
(
12686 Make_Attribute_Reference
(Loc
,
12688 Attribute_Name
=> Name_Address
),
12690 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
12693 -- Ada 95: Normal case
12696 Build_CW_Membership
(Loc
,
12697 Obj_Tag_Node
=> Obj_Tag
,
12700 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
12702 New_Node
=> New_Node
);
12704 -- Generate the SCIL node for this class-wide membership test.
12705 -- Done here because the previous call to Build_CW_Membership
12706 -- relocates Obj_Tag.
12708 if Generate_SCIL
then
12709 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
12710 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
12711 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
12714 Result
:= New_Node
;
12717 -- Right_Type is not a class-wide type
12720 -- No need to check the tag of the object if Right_Typ is abstract
12722 if Is_Abstract_Type
(Right_Type
) then
12723 Result
:= New_Reference_To
(Standard_False
, Loc
);
12728 Left_Opnd
=> Obj_Tag
,
12731 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
12734 end Tagged_Membership
;
12736 ------------------------------
12737 -- Unary_Op_Validity_Checks --
12738 ------------------------------
12740 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
12742 if Validity_Checks_On
and Validity_Check_Operands
then
12743 Ensure_Valid
(Right_Opnd
(N
));
12745 end Unary_Op_Validity_Checks
;