1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 with Do_Overflow_Check set when the
217 -- current overflow mode is MINIMIZED or ELIMINATED, we need to make a
218 -- call to Apply_Arithmetic_Overflow_Checks as the first thing we do. We
219 -- then return. We count on the recursive apparatus for overflow checks
220 -- to call us back with an equivalent operation that does not have the
221 -- Do_Overflow_Check flag set, and that is when we will proceed with the
222 -- expansion of the operator (e.g. converting X+0 to X, or X**2 to X*X).
223 -- We cannot do these optimizations without first making this check, since
224 -- there may be operands further down the tree that are relying on the
225 -- recursive calls triggered by the top level nodes to properly process
226 -- overflow checking and remaining expansion on these nodes. Note that
227 -- this call back may be skipped if the operation is done in Bignum mode
228 -- but that's fine, since the Bignum call takes care of everything.
230 procedure Optimize_Length_Comparison
(N
: Node_Id
);
231 -- Given an expression, if it is of the form X'Length op N (or the other
232 -- way round), where N is known at compile time to be 0 or 1, and X is a
233 -- simple entity, and op is a comparison operator, optimizes it into a
234 -- comparison of First and Last.
236 procedure Rewrite_Comparison
(N
: Node_Id
);
237 -- If N is the node for a comparison whose outcome can be determined at
238 -- compile time, then the node N can be rewritten with True or False. If
239 -- the outcome cannot be determined at compile time, the call has no
240 -- effect. If N is a type conversion, then this processing is applied to
241 -- its expression. If N is neither comparison nor a type conversion, the
242 -- call has no effect.
244 procedure Tagged_Membership
246 SCIL_Node
: out Node_Id
;
247 Result
: out Node_Id
);
248 -- Construct the expression corresponding to the tagged membership test.
249 -- Deals with a second operand being (or not) a class-wide type.
251 function Safe_In_Place_Array_Op
254 Op2
: Node_Id
) return Boolean;
255 -- In the context of an assignment, where the right-hand side is a boolean
256 -- operation on arrays, check whether operation can be performed in place.
258 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
259 pragma Inline
(Unary_Op_Validity_Checks
);
260 -- Performs validity checks for a unary operator
262 -------------------------------
263 -- Binary_Op_Validity_Checks --
264 -------------------------------
266 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
268 if Validity_Checks_On
and Validity_Check_Operands
then
269 Ensure_Valid
(Left_Opnd
(N
));
270 Ensure_Valid
(Right_Opnd
(N
));
272 end Binary_Op_Validity_Checks
;
274 ------------------------------------
275 -- Build_Boolean_Array_Proc_Call --
276 ------------------------------------
278 procedure Build_Boolean_Array_Proc_Call
283 Loc
: constant Source_Ptr
:= Sloc
(N
);
284 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
285 Target
: constant Node_Id
:=
286 Make_Attribute_Reference
(Loc
,
288 Attribute_Name
=> Name_Address
);
290 Arg1
: Node_Id
:= Op1
;
291 Arg2
: Node_Id
:= Op2
;
293 Proc_Name
: Entity_Id
;
296 if Kind
= N_Op_Not
then
297 if Nkind
(Op1
) in N_Binary_Op
then
299 -- Use negated version of the binary operators
301 if Nkind
(Op1
) = N_Op_And
then
302 Proc_Name
:= RTE
(RE_Vector_Nand
);
304 elsif Nkind
(Op1
) = N_Op_Or
then
305 Proc_Name
:= RTE
(RE_Vector_Nor
);
307 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
308 Proc_Name
:= RTE
(RE_Vector_Xor
);
312 Make_Procedure_Call_Statement
(Loc
,
313 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
315 Parameter_Associations
=> New_List
(
317 Make_Attribute_Reference
(Loc
,
318 Prefix
=> Left_Opnd
(Op1
),
319 Attribute_Name
=> Name_Address
),
321 Make_Attribute_Reference
(Loc
,
322 Prefix
=> Right_Opnd
(Op1
),
323 Attribute_Name
=> Name_Address
),
325 Make_Attribute_Reference
(Loc
,
326 Prefix
=> Left_Opnd
(Op1
),
327 Attribute_Name
=> Name_Length
)));
330 Proc_Name
:= RTE
(RE_Vector_Not
);
333 Make_Procedure_Call_Statement
(Loc
,
334 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
335 Parameter_Associations
=> New_List
(
338 Make_Attribute_Reference
(Loc
,
340 Attribute_Name
=> Name_Address
),
342 Make_Attribute_Reference
(Loc
,
344 Attribute_Name
=> Name_Length
)));
348 -- We use the following equivalences:
350 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
351 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
352 -- (not X) xor (not Y) = X xor Y
353 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
355 if Nkind
(Op1
) = N_Op_Not
then
356 Arg1
:= Right_Opnd
(Op1
);
357 Arg2
:= Right_Opnd
(Op2
);
358 if Kind
= N_Op_And
then
359 Proc_Name
:= RTE
(RE_Vector_Nor
);
360 elsif Kind
= N_Op_Or
then
361 Proc_Name
:= RTE
(RE_Vector_Nand
);
363 Proc_Name
:= RTE
(RE_Vector_Xor
);
367 if Kind
= N_Op_And
then
368 Proc_Name
:= RTE
(RE_Vector_And
);
369 elsif Kind
= N_Op_Or
then
370 Proc_Name
:= RTE
(RE_Vector_Or
);
371 elsif Nkind
(Op2
) = N_Op_Not
then
372 Proc_Name
:= RTE
(RE_Vector_Nxor
);
373 Arg2
:= Right_Opnd
(Op2
);
375 Proc_Name
:= RTE
(RE_Vector_Xor
);
380 Make_Procedure_Call_Statement
(Loc
,
381 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
382 Parameter_Associations
=> New_List
(
384 Make_Attribute_Reference
(Loc
,
386 Attribute_Name
=> Name_Address
),
387 Make_Attribute_Reference
(Loc
,
389 Attribute_Name
=> Name_Address
),
390 Make_Attribute_Reference
(Loc
,
392 Attribute_Name
=> Name_Length
)));
395 Rewrite
(N
, Call_Node
);
399 when RE_Not_Available
=>
401 end Build_Boolean_Array_Proc_Call
;
403 ------------------------------
404 -- Current_Anonymous_Master --
405 ------------------------------
407 function Current_Anonymous_Master
return Entity_Id
is
415 Unit_Id
:= Cunit_Entity
(Current_Sem_Unit
);
417 -- Find the entity of the current unit
419 if Ekind
(Unit_Id
) = E_Subprogram_Body
then
421 -- When processing subprogram bodies, the proper scope is always that
424 Subp_Body
:= Unit_Id
;
425 while Present
(Subp_Body
)
426 and then Nkind
(Subp_Body
) /= N_Subprogram_Body
428 Subp_Body
:= Parent
(Subp_Body
);
431 Unit_Id
:= Corresponding_Spec
(Subp_Body
);
434 Loc
:= Sloc
(Unit_Id
);
435 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
437 -- Find the declarations list of the current unit
439 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
440 Unit_Decl
:= Specification
(Unit_Decl
);
441 Decls
:= Visible_Declarations
(Unit_Decl
);
444 Decls
:= New_List
(Make_Null_Statement
(Loc
));
445 Set_Visible_Declarations
(Unit_Decl
, Decls
);
447 elsif Is_Empty_List
(Decls
) then
448 Append_To
(Decls
, Make_Null_Statement
(Loc
));
452 Decls
:= Declarations
(Unit_Decl
);
455 Decls
:= New_List
(Make_Null_Statement
(Loc
));
456 Set_Declarations
(Unit_Decl
, Decls
);
458 elsif Is_Empty_List
(Decls
) then
459 Append_To
(Decls
, Make_Null_Statement
(Loc
));
463 -- The current unit has an existing anonymous master, traverse its
464 -- declarations and locate the entity.
466 if Has_Anonymous_Master
(Unit_Id
) then
469 Fin_Mas_Id
: Entity_Id
;
472 Decl
:= First
(Decls
);
473 while Present
(Decl
) loop
475 -- Look for the first variable in the declarations whole type
476 -- is Finalization_Master.
478 if Nkind
(Decl
) = N_Object_Declaration
then
479 Fin_Mas_Id
:= Defining_Identifier
(Decl
);
481 if Ekind
(Fin_Mas_Id
) = E_Variable
482 and then Etype
(Fin_Mas_Id
) = RTE
(RE_Finalization_Master
)
491 -- The master was not found even though the unit was labeled as
497 -- Create a new anonymous master
501 First_Decl
: constant Node_Id
:= First
(Decls
);
503 Fin_Mas_Id
: Entity_Id
;
506 -- Since the master and its associated initialization is inserted
507 -- at top level, use the scope of the unit when analyzing.
509 Push_Scope
(Unit_Id
);
511 -- Create the finalization master
514 Make_Defining_Identifier
(Loc
,
515 Chars
=> New_External_Name
(Chars
(Unit_Id
), "AM"));
518 -- <Fin_Mas_Id> : Finalization_Master;
521 Make_Object_Declaration
(Loc
,
522 Defining_Identifier
=> Fin_Mas_Id
,
524 New_Reference_To
(RTE
(RE_Finalization_Master
), Loc
));
526 Insert_Before_And_Analyze
(First_Decl
, Action
);
528 -- Mark the unit to prevent the generation of multiple masters
530 Set_Has_Anonymous_Master
(Unit_Id
);
532 -- Do not set the base pool and mode of operation on .NET/JVM
533 -- since those targets do not support pools and all VM masters
534 -- are heterogeneous by default.
536 if VM_Target
= No_VM
then
540 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
543 Make_Procedure_Call_Statement
(Loc
,
545 New_Reference_To
(RTE
(RE_Set_Base_Pool
), Loc
),
547 Parameter_Associations
=> New_List
(
548 New_Reference_To
(Fin_Mas_Id
, Loc
),
549 Make_Attribute_Reference
(Loc
,
551 New_Reference_To
(RTE
(RE_Global_Pool_Object
), Loc
),
552 Attribute_Name
=> Name_Unrestricted_Access
)));
554 Insert_Before_And_Analyze
(First_Decl
, Action
);
557 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
560 Make_Procedure_Call_Statement
(Loc
,
562 New_Reference_To
(RTE
(RE_Set_Is_Heterogeneous
), Loc
),
563 Parameter_Associations
=> New_List
(
564 New_Reference_To
(Fin_Mas_Id
, Loc
)));
566 Insert_Before_And_Analyze
(First_Decl
, Action
);
569 -- Restore the original state of the scope stack
576 end Current_Anonymous_Master
;
578 --------------------------------
579 -- Displace_Allocator_Pointer --
580 --------------------------------
582 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
583 Loc
: constant Source_Ptr
:= Sloc
(N
);
584 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
590 -- Do nothing in case of VM targets: the virtual machine will handle
591 -- interfaces directly.
593 if not Tagged_Type_Expansion
then
597 pragma Assert
(Nkind
(N
) = N_Identifier
598 and then Nkind
(Orig_Node
) = N_Allocator
);
600 PtrT
:= Etype
(Orig_Node
);
601 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
602 Etyp
:= Etype
(Expression
(Orig_Node
));
604 if Is_Class_Wide_Type
(Dtyp
)
605 and then Is_Interface
(Dtyp
)
607 -- If the type of the allocator expression is not an interface type
608 -- we can generate code to reference the record component containing
609 -- the pointer to the secondary dispatch table.
611 if not Is_Interface
(Etyp
) then
613 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
616 -- 1) Get access to the allocated object
619 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
623 -- 2) Add the conversion to displace the pointer to reference
624 -- the secondary dispatch table.
626 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
627 Analyze_And_Resolve
(N
, Dtyp
);
629 -- 3) The 'access to the secondary dispatch table will be used
630 -- as the value returned by the allocator.
633 Make_Attribute_Reference
(Loc
,
634 Prefix
=> Relocate_Node
(N
),
635 Attribute_Name
=> Name_Access
));
636 Set_Etype
(N
, Saved_Typ
);
640 -- If the type of the allocator expression is an interface type we
641 -- generate a run-time call to displace "this" to reference the
642 -- component containing the pointer to the secondary dispatch table
643 -- or else raise Constraint_Error if the actual object does not
644 -- implement the target interface. This case corresponds with the
645 -- following example:
647 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
649 -- return new Iface_2'Class'(Obj);
654 Unchecked_Convert_To
(PtrT
,
655 Make_Function_Call
(Loc
,
656 Name
=> New_Reference_To
(RTE
(RE_Displace
), Loc
),
657 Parameter_Associations
=> New_List
(
658 Unchecked_Convert_To
(RTE
(RE_Address
),
664 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
666 Analyze_And_Resolve
(N
, PtrT
);
669 end Displace_Allocator_Pointer
;
671 ---------------------------------
672 -- Expand_Allocator_Expression --
673 ---------------------------------
675 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
676 Loc
: constant Source_Ptr
:= Sloc
(N
);
677 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
678 PtrT
: constant Entity_Id
:= Etype
(N
);
679 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
681 procedure Apply_Accessibility_Check
683 Built_In_Place
: Boolean := False);
684 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
685 -- type, generate an accessibility check to verify that the level of the
686 -- type of the created object is not deeper than the level of the access
687 -- type. If the type of the qualified expression is class-wide, then
688 -- always generate the check (except in the case where it is known to be
689 -- unnecessary, see comment below). Otherwise, only generate the check
690 -- if the level of the qualified expression type is statically deeper
691 -- than the access type.
693 -- Although the static accessibility will generally have been performed
694 -- as a legality check, it won't have been done in cases where the
695 -- allocator appears in generic body, so a run-time check is needed in
696 -- general. One special case is when the access type is declared in the
697 -- same scope as the class-wide allocator, in which case the check can
698 -- never fail, so it need not be generated.
700 -- As an open issue, there seem to be cases where the static level
701 -- associated with the class-wide object's underlying type is not
702 -- sufficient to perform the proper accessibility check, such as for
703 -- allocators in nested subprograms or accept statements initialized by
704 -- class-wide formals when the actual originates outside at a deeper
705 -- static level. The nested subprogram case might require passing
706 -- accessibility levels along with class-wide parameters, and the task
707 -- case seems to be an actual gap in the language rules that needs to
708 -- be fixed by the ARG. ???
710 -------------------------------
711 -- Apply_Accessibility_Check --
712 -------------------------------
714 procedure Apply_Accessibility_Check
716 Built_In_Place
: Boolean := False)
718 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
725 if Ada_Version
>= Ada_2005
726 and then Is_Class_Wide_Type
(DesigT
)
727 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
729 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
731 (Is_Class_Wide_Type
(Etype
(Exp
))
732 and then Scope
(PtrT
) /= Current_Scope
))
733 and then (Tagged_Type_Expansion
or else VM_Target
/= No_VM
)
735 -- If the allocator was built in place, Ref is already a reference
736 -- to the access object initialized to the result of the allocator
737 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
738 -- Remove_Side_Effects for cases where the build-in-place call may
739 -- still be the prefix of the reference (to avoid generating
740 -- duplicate calls). Otherwise, it is the entity associated with
741 -- the object containing the address of the allocated object.
743 if Built_In_Place
then
744 Remove_Side_Effects
(Ref
);
745 Obj_Ref
:= New_Copy
(Ref
);
747 Obj_Ref
:= New_Reference_To
(Ref
, Loc
);
750 -- Step 1: Create the object clean up code
754 -- Create an explicit free statement to clean up the allocated
755 -- object in case the accessibility check fails. Generate:
759 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy
(Obj_Ref
));
760 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
762 Append_To
(Stmts
, Free_Stmt
);
764 -- Finalize the object (if applicable), but wrap the call inside
765 -- a block to ensure that the object would still be deallocated in
766 -- case the finalization fails. Generate:
769 -- [Deep_]Finalize (Obj_Ref.all);
776 if Needs_Finalization
(DesigT
) then
778 Make_Block_Statement
(Loc
,
779 Handled_Statement_Sequence
=>
780 Make_Handled_Sequence_Of_Statements
(Loc
,
781 Statements
=> New_List
(
784 Make_Explicit_Dereference
(Loc
,
785 Prefix
=> New_Copy
(Obj_Ref
)),
788 Exception_Handlers
=> New_List
(
789 Make_Exception_Handler
(Loc
,
790 Exception_Choices
=> New_List
(
791 Make_Others_Choice
(Loc
)),
792 Statements
=> New_List
(
793 New_Copy_Tree
(Free_Stmt
),
794 Make_Raise_Statement
(Loc
)))))));
797 -- Signal the accessibility failure through a Program_Error
800 Make_Raise_Program_Error
(Loc
,
801 Condition
=> New_Reference_To
(Standard_True
, Loc
),
802 Reason
=> PE_Accessibility_Check_Failed
));
804 -- Step 2: Create the accessibility comparison
810 Make_Attribute_Reference
(Loc
,
812 Attribute_Name
=> Name_Tag
);
814 -- For tagged types, determine the accessibility level by looking
815 -- at the type specific data of the dispatch table. Generate:
817 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
819 if Tagged_Type_Expansion
then
820 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
822 -- Use a runtime call to determine the accessibility level when
823 -- compiling on virtual machine targets. Generate:
825 -- Get_Access_Level (Ref'Tag)
829 Make_Function_Call
(Loc
,
831 New_Reference_To
(RTE
(RE_Get_Access_Level
), Loc
),
832 Parameter_Associations
=> New_List
(Obj_Ref
));
839 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
841 -- Due to the complexity and side effects of the check, utilize an
842 -- if statement instead of the regular Program_Error circuitry.
845 Make_If_Statement
(Loc
,
847 Then_Statements
=> Stmts
));
849 end Apply_Accessibility_Check
;
853 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
854 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
855 T
: constant Entity_Id
:= Entity
(Indic
);
857 Tag_Assign
: Node_Id
;
861 TagT
: Entity_Id
:= Empty
;
862 -- Type used as source for tag assignment
864 TagR
: Node_Id
:= Empty
;
865 -- Target reference for tag assignment
867 -- Start of processing for Expand_Allocator_Expression
870 -- Handle call to C++ constructor
872 if Is_CPP_Constructor_Call
(Exp
) then
873 Make_CPP_Constructor_Call_In_Allocator
875 Function_Call
=> Exp
);
879 -- In the case of an Ada 2012 allocator whose initial value comes from a
880 -- function call, pass "the accessibility level determined by the point
881 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
882 -- Expand_Call but it couldn't be done there (because the Etype of the
883 -- allocator wasn't set then) so we generate the parameter here. See
884 -- the Boolean variable Defer in (a block within) Expand_Call.
886 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
891 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
892 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
894 Subp
:= Entity
(Name
(Exp
));
897 Subp
:= Ultimate_Alias
(Subp
);
899 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
900 Add_Extra_Actual_To_Call
901 (Subprogram_Call
=> Exp
,
902 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
903 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
908 -- Case of tagged type or type requiring finalization
910 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
912 -- Ada 2005 (AI-318-02): If the initialization expression is a call
913 -- to a build-in-place function, then access to the allocated object
914 -- must be passed to the function. Currently we limit such functions
915 -- to those with constrained limited result subtypes, but eventually
916 -- we plan to expand the allowed forms of functions that are treated
917 -- as build-in-place.
919 if Ada_Version
>= Ada_2005
920 and then Is_Build_In_Place_Function_Call
(Exp
)
922 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
923 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
927 -- Actions inserted before:
928 -- Temp : constant ptr_T := new T'(Expression);
929 -- Temp._tag = T'tag; -- when not class-wide
930 -- [Deep_]Adjust (Temp.all);
932 -- We analyze by hand the new internal allocator to avoid any
933 -- recursion and inappropriate call to Initialize
935 -- We don't want to remove side effects when the expression must be
936 -- built in place. In the case of a build-in-place function call,
937 -- that could lead to a duplication of the call, which was already
938 -- substituted for the allocator.
940 if not Aggr_In_Place
then
941 Remove_Side_Effects
(Exp
);
944 Temp
:= Make_Temporary
(Loc
, 'P', N
);
946 -- For a class wide allocation generate the following code:
948 -- type Equiv_Record is record ... end record;
949 -- implicit subtype CW is <Class_Wide_Subytpe>;
950 -- temp : PtrT := new CW'(CW!(expr));
952 if Is_Class_Wide_Type
(T
) then
953 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
955 -- Ada 2005 (AI-251): If the expression is a class-wide interface
956 -- object we generate code to move up "this" to reference the
957 -- base of the object before allocating the new object.
959 -- Note that Exp'Address is recursively expanded into a call
960 -- to Base_Address (Exp.Tag)
962 if Is_Class_Wide_Type
(Etype
(Exp
))
963 and then Is_Interface
(Etype
(Exp
))
964 and then Tagged_Type_Expansion
968 Unchecked_Convert_To
(Entity
(Indic
),
969 Make_Explicit_Dereference
(Loc
,
970 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
971 Make_Attribute_Reference
(Loc
,
973 Attribute_Name
=> Name_Address
)))));
977 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
980 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
983 -- Processing for allocators returning non-interface types
985 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
986 if Aggr_In_Place
then
988 Make_Object_Declaration
(Loc
,
989 Defining_Identifier
=> Temp
,
990 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
994 New_Reference_To
(Etype
(Exp
), Loc
)));
996 -- Copy the Comes_From_Source flag for the allocator we just
997 -- built, since logically this allocator is a replacement of
998 -- the original allocator node. This is for proper handling of
999 -- restriction No_Implicit_Heap_Allocations.
1001 Set_Comes_From_Source
1002 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1004 Set_No_Initialization
(Expression
(Temp_Decl
));
1005 Insert_Action
(N
, Temp_Decl
);
1007 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1008 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1010 -- Attach the object to the associated finalization master.
1011 -- This is done manually on .NET/JVM since those compilers do
1012 -- no support pools and can't benefit from internally generated
1013 -- Allocate / Deallocate procedures.
1015 if VM_Target
/= No_VM
1016 and then Is_Controlled
(DesigT
)
1017 and then Present
(Finalization_Master
(PtrT
))
1022 New_Reference_To
(Temp
, Loc
),
1027 Node
:= Relocate_Node
(N
);
1028 Set_Analyzed
(Node
);
1031 Make_Object_Declaration
(Loc
,
1032 Defining_Identifier
=> Temp
,
1033 Constant_Present
=> True,
1034 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1035 Expression
=> Node
);
1037 Insert_Action
(N
, Temp_Decl
);
1038 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1040 -- Attach the object to the associated finalization master.
1041 -- This is done manually on .NET/JVM since those compilers do
1042 -- no support pools and can't benefit from internally generated
1043 -- Allocate / Deallocate procedures.
1045 if VM_Target
/= No_VM
1046 and then Is_Controlled
(DesigT
)
1047 and then Present
(Finalization_Master
(PtrT
))
1052 New_Reference_To
(Temp
, Loc
),
1057 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1058 -- interface type. In this case we use the type of the qualified
1059 -- expression to allocate the object.
1063 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1068 Make_Full_Type_Declaration
(Loc
,
1069 Defining_Identifier
=> Def_Id
,
1071 Make_Access_To_Object_Definition
(Loc
,
1072 All_Present
=> True,
1073 Null_Exclusion_Present
=> False,
1075 Is_Access_Constant
(Etype
(N
)),
1076 Subtype_Indication
=>
1077 New_Reference_To
(Etype
(Exp
), Loc
)));
1079 Insert_Action
(N
, New_Decl
);
1081 -- Inherit the allocation-related attributes from the original
1084 Set_Finalization_Master
(Def_Id
, Finalization_Master
(PtrT
));
1086 Set_Associated_Storage_Pool
(Def_Id
,
1087 Associated_Storage_Pool
(PtrT
));
1089 -- Declare the object using the previous type declaration
1091 if Aggr_In_Place
then
1093 Make_Object_Declaration
(Loc
,
1094 Defining_Identifier
=> Temp
,
1095 Object_Definition
=> New_Reference_To
(Def_Id
, Loc
),
1097 Make_Allocator
(Loc
,
1098 New_Reference_To
(Etype
(Exp
), Loc
)));
1100 -- Copy the Comes_From_Source flag for the allocator we just
1101 -- built, since logically this allocator is a replacement of
1102 -- the original allocator node. This is for proper handling
1103 -- of restriction No_Implicit_Heap_Allocations.
1105 Set_Comes_From_Source
1106 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1108 Set_No_Initialization
(Expression
(Temp_Decl
));
1109 Insert_Action
(N
, Temp_Decl
);
1111 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1112 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1115 Node
:= Relocate_Node
(N
);
1116 Set_Analyzed
(Node
);
1119 Make_Object_Declaration
(Loc
,
1120 Defining_Identifier
=> Temp
,
1121 Constant_Present
=> True,
1122 Object_Definition
=> New_Reference_To
(Def_Id
, Loc
),
1123 Expression
=> Node
);
1125 Insert_Action
(N
, Temp_Decl
);
1126 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1129 -- Generate an additional object containing the address of the
1130 -- returned object. The type of this second object declaration
1131 -- is the correct type required for the common processing that
1132 -- is still performed by this subprogram. The displacement of
1133 -- this pointer to reference the component associated with the
1134 -- interface type will be done at the end of common processing.
1137 Make_Object_Declaration
(Loc
,
1138 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
1139 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1141 Unchecked_Convert_To
(PtrT
,
1142 New_Reference_To
(Temp
, Loc
)));
1144 Insert_Action
(N
, New_Decl
);
1146 Temp_Decl
:= New_Decl
;
1147 Temp
:= Defining_Identifier
(New_Decl
);
1151 Apply_Accessibility_Check
(Temp
);
1153 -- Generate the tag assignment
1155 -- Suppress the tag assignment when VM_Target because VM tags are
1156 -- represented implicitly in objects.
1158 if not Tagged_Type_Expansion
then
1161 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1162 -- interface objects because in this case the tag does not change.
1164 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
1165 pragma Assert
(Is_Class_Wide_Type
1166 (Directly_Designated_Type
(Etype
(N
))));
1169 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
1171 TagR
:= New_Reference_To
(Temp
, Loc
);
1173 elsif Is_Private_Type
(T
)
1174 and then Is_Tagged_Type
(Underlying_Type
(T
))
1176 TagT
:= Underlying_Type
(T
);
1178 Unchecked_Convert_To
(Underlying_Type
(T
),
1179 Make_Explicit_Dereference
(Loc
,
1180 Prefix
=> New_Reference_To
(Temp
, Loc
)));
1183 if Present
(TagT
) then
1185 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1188 Make_Assignment_Statement
(Loc
,
1190 Make_Selected_Component
(Loc
,
1193 New_Reference_To
(First_Tag_Component
(Full_T
), Loc
)),
1195 Unchecked_Convert_To
(RTE
(RE_Tag
),
1198 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1201 -- The previous assignment has to be done in any case
1203 Set_Assignment_OK
(Name
(Tag_Assign
));
1204 Insert_Action
(N
, Tag_Assign
);
1207 if Needs_Finalization
(DesigT
)
1208 and then Needs_Finalization
(T
)
1210 -- Generate an Adjust call if the object will be moved. In Ada
1211 -- 2005, the object may be inherently limited, in which case
1212 -- there is no Adjust procedure, and the object is built in
1213 -- place. In Ada 95, the object can be limited but not
1214 -- inherently limited if this allocator came from a return
1215 -- statement (we're allocating the result on the secondary
1216 -- stack). In that case, the object will be moved, so we _do_
1219 if not Aggr_In_Place
1220 and then not Is_Immutably_Limited_Type
(T
)
1226 -- An unchecked conversion is needed in the classwide
1227 -- case because the designated type can be an ancestor
1228 -- of the subtype mark of the allocator.
1230 Unchecked_Convert_To
(T
,
1231 Make_Explicit_Dereference
(Loc
,
1232 Prefix
=> New_Reference_To
(Temp
, Loc
))),
1237 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1239 -- Do not generate this call in the following cases:
1241 -- * .NET/JVM - these targets do not support address arithmetic
1242 -- and unchecked conversion, key elements of Finalize_Address.
1244 -- * Alfa mode - the call is useless and results in unwanted
1247 -- * CodePeer mode - TSS primitive Finalize_Address is not
1248 -- created in this mode.
1250 if VM_Target
= No_VM
1251 and then not Alfa_Mode
1252 and then not CodePeer_Mode
1253 and then Present
(Finalization_Master
(PtrT
))
1254 and then Present
(Temp_Decl
)
1255 and then Nkind
(Expression
(Temp_Decl
)) = N_Allocator
1258 Make_Set_Finalize_Address_Call
1265 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1266 Analyze_And_Resolve
(N
, PtrT
);
1268 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1269 -- component containing the secondary dispatch table of the interface
1272 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1273 Displace_Allocator_Pointer
(N
);
1276 elsif Aggr_In_Place
then
1277 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1279 Make_Object_Declaration
(Loc
,
1280 Defining_Identifier
=> Temp
,
1281 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1283 Make_Allocator
(Loc
,
1284 Expression
=> New_Reference_To
(Etype
(Exp
), Loc
)));
1286 -- Copy the Comes_From_Source flag for the allocator we just built,
1287 -- since logically this allocator is a replacement of the original
1288 -- allocator node. This is for proper handling of restriction
1289 -- No_Implicit_Heap_Allocations.
1291 Set_Comes_From_Source
1292 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1294 Set_No_Initialization
(Expression
(Temp_Decl
));
1295 Insert_Action
(N
, Temp_Decl
);
1297 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1298 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1300 -- Attach the object to the associated finalization master. Thisis
1301 -- done manually on .NET/JVM since those compilers do no support
1302 -- pools and cannot benefit from internally generated Allocate and
1303 -- Deallocate procedures.
1305 if VM_Target
/= No_VM
1306 and then Is_Controlled
(DesigT
)
1307 and then Present
(Finalization_Master
(PtrT
))
1311 (Obj_Ref
=> New_Reference_To
(Temp
, Loc
),
1315 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1316 Analyze_And_Resolve
(N
, PtrT
);
1318 elsif Is_Access_Type
(T
)
1319 and then Can_Never_Be_Null
(T
)
1321 Install_Null_Excluding_Check
(Exp
);
1323 elsif Is_Access_Type
(DesigT
)
1324 and then Nkind
(Exp
) = N_Allocator
1325 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1327 -- Apply constraint to designated subtype indication
1329 Apply_Constraint_Check
(Expression
(Exp
),
1330 Designated_Type
(DesigT
),
1331 No_Sliding
=> True);
1333 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1335 -- Propagate constraint_error to enclosing allocator
1337 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1341 Build_Allocate_Deallocate_Proc
(N
, True);
1344 -- type A is access T1;
1345 -- X : A := new T2'(...);
1346 -- T1 and T2 can be different subtypes, and we might need to check
1347 -- both constraints. First check against the type of the qualified
1350 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1352 if Do_Range_Check
(Exp
) then
1353 Set_Do_Range_Check
(Exp
, False);
1354 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1357 -- A check is also needed in cases where the designated subtype is
1358 -- constrained and differs from the subtype given in the qualified
1359 -- expression. Note that the check on the qualified expression does
1360 -- not allow sliding, but this check does (a relaxation from Ada 83).
1362 if Is_Constrained
(DesigT
)
1363 and then not Subtypes_Statically_Match
(T
, DesigT
)
1365 Apply_Constraint_Check
1366 (Exp
, DesigT
, No_Sliding
=> False);
1368 if Do_Range_Check
(Exp
) then
1369 Set_Do_Range_Check
(Exp
, False);
1370 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1374 -- For an access to unconstrained packed array, GIGI needs to see an
1375 -- expression with a constrained subtype in order to compute the
1376 -- proper size for the allocator.
1378 if Is_Array_Type
(T
)
1379 and then not Is_Constrained
(T
)
1380 and then Is_Packed
(T
)
1383 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1384 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1387 Make_Subtype_Declaration
(Loc
,
1388 Defining_Identifier
=> ConstrT
,
1389 Subtype_Indication
=>
1390 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1391 Freeze_Itype
(ConstrT
, Exp
);
1392 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1396 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1397 -- to a build-in-place function, then access to the allocated object
1398 -- must be passed to the function. Currently we limit such functions
1399 -- to those with constrained limited result subtypes, but eventually
1400 -- we plan to expand the allowed forms of functions that are treated
1401 -- as build-in-place.
1403 if Ada_Version
>= Ada_2005
1404 and then Is_Build_In_Place_Function_Call
(Exp
)
1406 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1411 when RE_Not_Available
=>
1413 end Expand_Allocator_Expression
;
1415 -----------------------------
1416 -- Expand_Array_Comparison --
1417 -----------------------------
1419 -- Expansion is only required in the case of array types. For the unpacked
1420 -- case, an appropriate runtime routine is called. For packed cases, and
1421 -- also in some other cases where a runtime routine cannot be called, the
1422 -- form of the expansion is:
1424 -- [body for greater_nn; boolean_expression]
1426 -- The body is built by Make_Array_Comparison_Op, and the form of the
1427 -- Boolean expression depends on the operator involved.
1429 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1430 Loc
: constant Source_Ptr
:= Sloc
(N
);
1431 Op1
: Node_Id
:= Left_Opnd
(N
);
1432 Op2
: Node_Id
:= Right_Opnd
(N
);
1433 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1434 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1437 Func_Body
: Node_Id
;
1438 Func_Name
: Entity_Id
;
1442 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1443 -- True for byte addressable target
1445 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1446 -- Returns True if the length of the given operand is known to be less
1447 -- than 4. Returns False if this length is known to be four or greater
1448 -- or is not known at compile time.
1450 ------------------------
1451 -- Length_Less_Than_4 --
1452 ------------------------
1454 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1455 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1458 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1459 return String_Literal_Length
(Otyp
) < 4;
1463 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1464 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1465 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1470 if Compile_Time_Known_Value
(Lo
) then
1471 Lov
:= Expr_Value
(Lo
);
1476 if Compile_Time_Known_Value
(Hi
) then
1477 Hiv
:= Expr_Value
(Hi
);
1482 return Hiv
< Lov
+ 3;
1485 end Length_Less_Than_4
;
1487 -- Start of processing for Expand_Array_Comparison
1490 -- Deal first with unpacked case, where we can call a runtime routine
1491 -- except that we avoid this for targets for which are not addressable
1492 -- by bytes, and for the JVM/CIL, since they do not support direct
1493 -- addressing of array components.
1495 if not Is_Bit_Packed_Array
(Typ1
)
1496 and then Byte_Addressable
1497 and then VM_Target
= No_VM
1499 -- The call we generate is:
1501 -- Compare_Array_xn[_Unaligned]
1502 -- (left'address, right'address, left'length, right'length) <op> 0
1504 -- x = U for unsigned, S for signed
1505 -- n = 8,16,32,64 for component size
1506 -- Add _Unaligned if length < 4 and component size is 8.
1507 -- <op> is the standard comparison operator
1509 if Component_Size
(Typ1
) = 8 then
1510 if Length_Less_Than_4
(Op1
)
1512 Length_Less_Than_4
(Op2
)
1514 if Is_Unsigned_Type
(Ctyp
) then
1515 Comp
:= RE_Compare_Array_U8_Unaligned
;
1517 Comp
:= RE_Compare_Array_S8_Unaligned
;
1521 if Is_Unsigned_Type
(Ctyp
) then
1522 Comp
:= RE_Compare_Array_U8
;
1524 Comp
:= RE_Compare_Array_S8
;
1528 elsif Component_Size
(Typ1
) = 16 then
1529 if Is_Unsigned_Type
(Ctyp
) then
1530 Comp
:= RE_Compare_Array_U16
;
1532 Comp
:= RE_Compare_Array_S16
;
1535 elsif Component_Size
(Typ1
) = 32 then
1536 if Is_Unsigned_Type
(Ctyp
) then
1537 Comp
:= RE_Compare_Array_U32
;
1539 Comp
:= RE_Compare_Array_S32
;
1542 else pragma Assert
(Component_Size
(Typ1
) = 64);
1543 if Is_Unsigned_Type
(Ctyp
) then
1544 Comp
:= RE_Compare_Array_U64
;
1546 Comp
:= RE_Compare_Array_S64
;
1550 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1551 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1554 Make_Function_Call
(Sloc
(Op1
),
1555 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1557 Parameter_Associations
=> New_List
(
1558 Make_Attribute_Reference
(Loc
,
1559 Prefix
=> Relocate_Node
(Op1
),
1560 Attribute_Name
=> Name_Address
),
1562 Make_Attribute_Reference
(Loc
,
1563 Prefix
=> Relocate_Node
(Op2
),
1564 Attribute_Name
=> Name_Address
),
1566 Make_Attribute_Reference
(Loc
,
1567 Prefix
=> Relocate_Node
(Op1
),
1568 Attribute_Name
=> Name_Length
),
1570 Make_Attribute_Reference
(Loc
,
1571 Prefix
=> Relocate_Node
(Op2
),
1572 Attribute_Name
=> Name_Length
))));
1575 Make_Integer_Literal
(Sloc
(Op2
),
1578 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1579 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1583 -- Cases where we cannot make runtime call
1585 -- For (a <= b) we convert to not (a > b)
1587 if Chars
(N
) = Name_Op_Le
then
1593 Right_Opnd
=> Op2
)));
1594 Analyze_And_Resolve
(N
, Standard_Boolean
);
1597 -- For < the Boolean expression is
1598 -- greater__nn (op2, op1)
1600 elsif Chars
(N
) = Name_Op_Lt
then
1601 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1605 Op1
:= Right_Opnd
(N
);
1606 Op2
:= Left_Opnd
(N
);
1608 -- For (a >= b) we convert to not (a < b)
1610 elsif Chars
(N
) = Name_Op_Ge
then
1616 Right_Opnd
=> Op2
)));
1617 Analyze_And_Resolve
(N
, Standard_Boolean
);
1620 -- For > the Boolean expression is
1621 -- greater__nn (op1, op2)
1624 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1625 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1628 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1630 Make_Function_Call
(Loc
,
1631 Name
=> New_Reference_To
(Func_Name
, Loc
),
1632 Parameter_Associations
=> New_List
(Op1
, Op2
));
1634 Insert_Action
(N
, Func_Body
);
1636 Analyze_And_Resolve
(N
, Standard_Boolean
);
1639 when RE_Not_Available
=>
1641 end Expand_Array_Comparison
;
1643 ---------------------------
1644 -- Expand_Array_Equality --
1645 ---------------------------
1647 -- Expand an equality function for multi-dimensional arrays. Here is an
1648 -- example of such a function for Nb_Dimension = 2
1650 -- function Enn (A : atyp; B : btyp) return boolean is
1652 -- if (A'length (1) = 0 or else A'length (2) = 0)
1654 -- (B'length (1) = 0 or else B'length (2) = 0)
1656 -- return True; -- RM 4.5.2(22)
1659 -- if A'length (1) /= B'length (1)
1661 -- A'length (2) /= B'length (2)
1663 -- return False; -- RM 4.5.2(23)
1667 -- A1 : Index_T1 := A'first (1);
1668 -- B1 : Index_T1 := B'first (1);
1672 -- A2 : Index_T2 := A'first (2);
1673 -- B2 : Index_T2 := B'first (2);
1676 -- if A (A1, A2) /= B (B1, B2) then
1680 -- exit when A2 = A'last (2);
1681 -- A2 := Index_T2'succ (A2);
1682 -- B2 := Index_T2'succ (B2);
1686 -- exit when A1 = A'last (1);
1687 -- A1 := Index_T1'succ (A1);
1688 -- B1 := Index_T1'succ (B1);
1695 -- Note on the formal types used (atyp and btyp). If either of the arrays
1696 -- is of a private type, we use the underlying type, and do an unchecked
1697 -- conversion of the actual. If either of the arrays has a bound depending
1698 -- on a discriminant, then we use the base type since otherwise we have an
1699 -- escaped discriminant in the function.
1701 -- If both arrays are constrained and have the same bounds, we can generate
1702 -- a loop with an explicit iteration scheme using a 'Range attribute over
1705 function Expand_Array_Equality
1710 Typ
: Entity_Id
) return Node_Id
1712 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1713 Decls
: constant List_Id
:= New_List
;
1714 Index_List1
: constant List_Id
:= New_List
;
1715 Index_List2
: constant List_Id
:= New_List
;
1719 Func_Name
: Entity_Id
;
1720 Func_Body
: Node_Id
;
1722 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1723 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1727 -- The parameter types to be used for the formals
1732 Num
: Int
) return Node_Id
;
1733 -- This builds the attribute reference Arr'Nam (Expr)
1735 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1736 -- Create one statement to compare corresponding components, designated
1737 -- by a full set of indexes.
1739 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1740 -- Given one of the arguments, computes the appropriate type to be used
1741 -- for that argument in the corresponding function formal
1743 function Handle_One_Dimension
1745 Index
: Node_Id
) return Node_Id
;
1746 -- This procedure returns the following code
1749 -- Bn : Index_T := B'First (N);
1753 -- exit when An = A'Last (N);
1754 -- An := Index_T'Succ (An)
1755 -- Bn := Index_T'Succ (Bn)
1759 -- If both indexes are constrained and identical, the procedure
1760 -- returns a simpler loop:
1762 -- for An in A'Range (N) loop
1766 -- N is the dimension for which we are generating a loop. Index is the
1767 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1768 -- xxx statement is either the loop or declare for the next dimension
1769 -- or if this is the last dimension the comparison of corresponding
1770 -- components of the arrays.
1772 -- The actual way the code works is to return the comparison of
1773 -- corresponding components for the N+1 call. That's neater!
1775 function Test_Empty_Arrays
return Node_Id
;
1776 -- This function constructs the test for both arrays being empty
1777 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1779 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1781 function Test_Lengths_Correspond
return Node_Id
;
1782 -- This function constructs the test for arrays having different lengths
1783 -- in at least one index position, in which case the resulting code is:
1785 -- A'length (1) /= B'length (1)
1787 -- A'length (2) /= B'length (2)
1798 Num
: Int
) return Node_Id
1802 Make_Attribute_Reference
(Loc
,
1803 Attribute_Name
=> Nam
,
1804 Prefix
=> New_Reference_To
(Arr
, Loc
),
1805 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1808 ------------------------
1809 -- Component_Equality --
1810 ------------------------
1812 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1817 -- if a(i1...) /= b(j1...) then return false; end if;
1820 Make_Indexed_Component
(Loc
,
1821 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1822 Expressions
=> Index_List1
);
1825 Make_Indexed_Component
(Loc
,
1826 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1827 Expressions
=> Index_List2
);
1829 Test
:= Expand_Composite_Equality
1830 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1832 -- If some (sub)component is an unchecked_union, the whole operation
1833 -- will raise program error.
1835 if Nkind
(Test
) = N_Raise_Program_Error
then
1837 -- This node is going to be inserted at a location where a
1838 -- statement is expected: clear its Etype so analysis will set
1839 -- it to the expected Standard_Void_Type.
1841 Set_Etype
(Test
, Empty
);
1846 Make_Implicit_If_Statement
(Nod
,
1847 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1848 Then_Statements
=> New_List
(
1849 Make_Simple_Return_Statement
(Loc
,
1850 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1852 end Component_Equality
;
1858 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1869 T
:= Underlying_Type
(T
);
1871 X
:= First_Index
(T
);
1872 while Present
(X
) loop
1873 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1875 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1888 --------------------------
1889 -- Handle_One_Dimension --
1890 ---------------------------
1892 function Handle_One_Dimension
1894 Index
: Node_Id
) return Node_Id
1896 Need_Separate_Indexes
: constant Boolean :=
1898 or else not Is_Constrained
(Ltyp
);
1899 -- If the index types are identical, and we are working with
1900 -- constrained types, then we can use the same index for both
1903 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1906 Index_T
: Entity_Id
;
1911 if N
> Number_Dimensions
(Ltyp
) then
1912 return Component_Equality
(Ltyp
);
1915 -- Case where we generate a loop
1917 Index_T
:= Base_Type
(Etype
(Index
));
1919 if Need_Separate_Indexes
then
1920 Bn
:= Make_Temporary
(Loc
, 'B');
1925 Append
(New_Reference_To
(An
, Loc
), Index_List1
);
1926 Append
(New_Reference_To
(Bn
, Loc
), Index_List2
);
1928 Stm_List
:= New_List
(
1929 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1931 if Need_Separate_Indexes
then
1933 -- Generate guard for loop, followed by increments of indexes
1935 Append_To
(Stm_List
,
1936 Make_Exit_Statement
(Loc
,
1939 Left_Opnd
=> New_Reference_To
(An
, Loc
),
1940 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1942 Append_To
(Stm_List
,
1943 Make_Assignment_Statement
(Loc
,
1944 Name
=> New_Reference_To
(An
, Loc
),
1946 Make_Attribute_Reference
(Loc
,
1947 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1948 Attribute_Name
=> Name_Succ
,
1949 Expressions
=> New_List
(New_Reference_To
(An
, Loc
)))));
1951 Append_To
(Stm_List
,
1952 Make_Assignment_Statement
(Loc
,
1953 Name
=> New_Reference_To
(Bn
, Loc
),
1955 Make_Attribute_Reference
(Loc
,
1956 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1957 Attribute_Name
=> Name_Succ
,
1958 Expressions
=> New_List
(New_Reference_To
(Bn
, Loc
)))));
1961 -- If separate indexes, we need a declare block for An and Bn, and a
1962 -- loop without an iteration scheme.
1964 if Need_Separate_Indexes
then
1966 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1969 Make_Block_Statement
(Loc
,
1970 Declarations
=> New_List
(
1971 Make_Object_Declaration
(Loc
,
1972 Defining_Identifier
=> An
,
1973 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1974 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1976 Make_Object_Declaration
(Loc
,
1977 Defining_Identifier
=> Bn
,
1978 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1979 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1981 Handled_Statement_Sequence
=>
1982 Make_Handled_Sequence_Of_Statements
(Loc
,
1983 Statements
=> New_List
(Loop_Stm
)));
1985 -- If no separate indexes, return loop statement with explicit
1986 -- iteration scheme on its own
1990 Make_Implicit_Loop_Statement
(Nod
,
1991 Statements
=> Stm_List
,
1993 Make_Iteration_Scheme
(Loc
,
1994 Loop_Parameter_Specification
=>
1995 Make_Loop_Parameter_Specification
(Loc
,
1996 Defining_Identifier
=> An
,
1997 Discrete_Subtype_Definition
=>
1998 Arr_Attr
(A
, Name_Range
, N
))));
2001 end Handle_One_Dimension
;
2003 -----------------------
2004 -- Test_Empty_Arrays --
2005 -----------------------
2007 function Test_Empty_Arrays
return Node_Id
is
2017 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2020 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2021 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2025 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
2026 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2035 Left_Opnd
=> Relocate_Node
(Alist
),
2036 Right_Opnd
=> Atest
);
2040 Left_Opnd
=> Relocate_Node
(Blist
),
2041 Right_Opnd
=> Btest
);
2048 Right_Opnd
=> Blist
);
2049 end Test_Empty_Arrays
;
2051 -----------------------------
2052 -- Test_Lengths_Correspond --
2053 -----------------------------
2055 function Test_Lengths_Correspond
return Node_Id
is
2061 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
2064 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
2065 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
2072 Left_Opnd
=> Relocate_Node
(Result
),
2073 Right_Opnd
=> Rtest
);
2078 end Test_Lengths_Correspond
;
2080 -- Start of processing for Expand_Array_Equality
2083 Ltyp
:= Get_Arg_Type
(Lhs
);
2084 Rtyp
:= Get_Arg_Type
(Rhs
);
2086 -- For now, if the argument types are not the same, go to the base type,
2087 -- since the code assumes that the formals have the same type. This is
2088 -- fixable in future ???
2090 if Ltyp
/= Rtyp
then
2091 Ltyp
:= Base_Type
(Ltyp
);
2092 Rtyp
:= Base_Type
(Rtyp
);
2093 pragma Assert
(Ltyp
= Rtyp
);
2096 -- Build list of formals for function
2098 Formals
:= New_List
(
2099 Make_Parameter_Specification
(Loc
,
2100 Defining_Identifier
=> A
,
2101 Parameter_Type
=> New_Reference_To
(Ltyp
, Loc
)),
2103 Make_Parameter_Specification
(Loc
,
2104 Defining_Identifier
=> B
,
2105 Parameter_Type
=> New_Reference_To
(Rtyp
, Loc
)));
2107 Func_Name
:= Make_Temporary
(Loc
, 'E');
2109 -- Build statement sequence for function
2112 Make_Subprogram_Body
(Loc
,
2114 Make_Function_Specification
(Loc
,
2115 Defining_Unit_Name
=> Func_Name
,
2116 Parameter_Specifications
=> Formals
,
2117 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
2119 Declarations
=> Decls
,
2121 Handled_Statement_Sequence
=>
2122 Make_Handled_Sequence_Of_Statements
(Loc
,
2123 Statements
=> New_List
(
2125 Make_Implicit_If_Statement
(Nod
,
2126 Condition
=> Test_Empty_Arrays
,
2127 Then_Statements
=> New_List
(
2128 Make_Simple_Return_Statement
(Loc
,
2130 New_Occurrence_Of
(Standard_True
, Loc
)))),
2132 Make_Implicit_If_Statement
(Nod
,
2133 Condition
=> Test_Lengths_Correspond
,
2134 Then_Statements
=> New_List
(
2135 Make_Simple_Return_Statement
(Loc
,
2137 New_Occurrence_Of
(Standard_False
, Loc
)))),
2139 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
2141 Make_Simple_Return_Statement
(Loc
,
2142 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2144 Set_Has_Completion
(Func_Name
, True);
2145 Set_Is_Inlined
(Func_Name
);
2147 -- If the array type is distinct from the type of the arguments, it
2148 -- is the full view of a private type. Apply an unchecked conversion
2149 -- to insure that analysis of the call succeeds.
2159 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
2161 L
:= OK_Convert_To
(Ltyp
, Lhs
);
2165 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
2167 R
:= OK_Convert_To
(Rtyp
, Rhs
);
2170 Actuals
:= New_List
(L
, R
);
2173 Append_To
(Bodies
, Func_Body
);
2176 Make_Function_Call
(Loc
,
2177 Name
=> New_Reference_To
(Func_Name
, Loc
),
2178 Parameter_Associations
=> Actuals
);
2179 end Expand_Array_Equality
;
2181 -----------------------------
2182 -- Expand_Boolean_Operator --
2183 -----------------------------
2185 -- Note that we first get the actual subtypes of the operands, since we
2186 -- always want to deal with types that have bounds.
2188 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
2189 Typ
: constant Entity_Id
:= Etype
(N
);
2192 -- Special case of bit packed array where both operands are known to be
2193 -- properly aligned. In this case we use an efficient run time routine
2194 -- to carry out the operation (see System.Bit_Ops).
2196 if Is_Bit_Packed_Array
(Typ
)
2197 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
2198 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
2200 Expand_Packed_Boolean_Operator
(N
);
2204 -- For the normal non-packed case, the general expansion is to build
2205 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2206 -- and then inserting it into the tree. The original operator node is
2207 -- then rewritten as a call to this function. We also use this in the
2208 -- packed case if either operand is a possibly unaligned object.
2211 Loc
: constant Source_Ptr
:= Sloc
(N
);
2212 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2213 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2214 Func_Body
: Node_Id
;
2215 Func_Name
: Entity_Id
;
2218 Convert_To_Actual_Subtype
(L
);
2219 Convert_To_Actual_Subtype
(R
);
2220 Ensure_Defined
(Etype
(L
), N
);
2221 Ensure_Defined
(Etype
(R
), N
);
2222 Apply_Length_Check
(R
, Etype
(L
));
2224 if Nkind
(N
) = N_Op_Xor
then
2225 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2228 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2229 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2231 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2233 elsif Nkind
(Parent
(N
)) = N_Op_Not
2234 and then Nkind
(N
) = N_Op_And
2236 Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2241 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2242 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2243 Insert_Action
(N
, Func_Body
);
2245 -- Now rewrite the expression with a call
2248 Make_Function_Call
(Loc
,
2249 Name
=> New_Reference_To
(Func_Name
, Loc
),
2250 Parameter_Associations
=>
2253 Make_Type_Conversion
2254 (Loc
, New_Reference_To
(Etype
(L
), Loc
), R
))));
2256 Analyze_And_Resolve
(N
, Typ
);
2259 end Expand_Boolean_Operator
;
2261 ------------------------------------------------
2262 -- Expand_Compare_Minimize_Eliminate_Overflow --
2263 ------------------------------------------------
2265 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2266 Loc
: constant Source_Ptr
:= Sloc
(N
);
2268 Result_Type
: constant Entity_Id
:= Etype
(N
);
2269 -- Capture result type (could be a derived boolean type)
2274 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2275 -- Entity for Long_Long_Integer'Base
2277 Check
: constant Overflow_Check_Type
:= Overflow_Check_Mode
(Empty
);
2278 -- Current checking mode
2281 procedure Set_False
;
2282 -- These procedures rewrite N with an occurrence of Standard_True or
2283 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2289 procedure Set_False
is
2291 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2292 Warn_On_Known_Condition
(N
);
2299 procedure Set_True
is
2301 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2302 Warn_On_Known_Condition
(N
);
2305 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2308 -- Nothing to do unless we have a comparison operator with operands
2309 -- that are signed integer types, and we are operating in either
2310 -- MINIMIZED or ELIMINATED overflow checking mode.
2312 if Nkind
(N
) not in N_Op_Compare
2313 or else Check
not in Minimized_Or_Eliminated
2314 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2319 -- OK, this is the case we are interested in. First step is to process
2320 -- our operands using the Minimize_Eliminate circuitry which applies
2321 -- this processing to the two operand subtrees.
2323 Minimize_Eliminate_Overflow_Checks
2324 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2325 Minimize_Eliminate_Overflow_Checks
2326 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2328 -- See if the range information decides the result of the comparison.
2329 -- We can only do this if we in fact have full range information (which
2330 -- won't be the case if either operand is bignum at this stage).
2332 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2333 case N_Op_Compare
(Nkind
(N
)) is
2335 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2337 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2344 elsif Lhi
< Rlo
then
2351 elsif Lhi
<= Rlo
then
2358 elsif Lhi
<= Rlo
then
2365 elsif Lhi
< Rlo
then
2370 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2372 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2377 -- All done if we did the rewrite
2379 if Nkind
(N
) not in N_Op_Compare
then
2384 -- Otherwise, time to do the comparison
2387 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2388 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2391 -- If the two operands have the same signed integer type we are
2392 -- all set, nothing more to do. This is the case where either
2393 -- both operands were unchanged, or we rewrote both of them to
2394 -- be Long_Long_Integer.
2396 -- Note: Entity for the comparison may be wrong, but it's not worth
2397 -- the effort to change it, since the back end does not use it.
2399 if Is_Signed_Integer_Type
(Ltype
)
2400 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2404 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2406 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2408 Left
: Node_Id
:= Left_Opnd
(N
);
2409 Right
: Node_Id
:= Right_Opnd
(N
);
2410 -- Bignum references for left and right operands
2413 if not Is_RTE
(Ltype
, RE_Bignum
) then
2414 Left
:= Convert_To_Bignum
(Left
);
2415 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2416 Right
:= Convert_To_Bignum
(Right
);
2419 -- We rewrite our node with:
2422 -- Bnn : Result_Type;
2424 -- M : Mark_Id := SS_Mark;
2426 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2434 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2435 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2439 case N_Op_Compare
(Nkind
(N
)) is
2440 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2441 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2442 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2443 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2444 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2445 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2448 -- Insert assignment to Bnn into the bignum block
2451 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2452 Make_Assignment_Statement
(Loc
,
2453 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2455 Make_Function_Call
(Loc
,
2457 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2458 Parameter_Associations
=> New_List
(Left
, Right
))));
2460 -- Now do the rewrite with expression actions
2463 Make_Expression_With_Actions
(Loc
,
2464 Actions
=> New_List
(
2465 Make_Object_Declaration
(Loc
,
2466 Defining_Identifier
=> Bnn
,
2467 Object_Definition
=>
2468 New_Occurrence_Of
(Result_Type
, Loc
)),
2470 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2471 Analyze_And_Resolve
(N
, Result_Type
);
2475 -- No bignums involved, but types are different, so we must have
2476 -- rewritten one of the operands as a Long_Long_Integer but not
2479 -- If left operand is Long_Long_Integer, convert right operand
2480 -- and we are done (with a comparison of two Long_Long_Integers).
2482 elsif Ltype
= LLIB
then
2483 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2484 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2487 -- If right operand is Long_Long_Integer, convert left operand
2488 -- and we are done (with a comparison of two Long_Long_Integers).
2490 -- This is the only remaining possibility
2492 else pragma Assert
(Rtype
= LLIB
);
2493 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2494 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2498 end Expand_Compare_Minimize_Eliminate_Overflow
;
2500 -------------------------------
2501 -- Expand_Composite_Equality --
2502 -------------------------------
2504 -- This function is only called for comparing internal fields of composite
2505 -- types when these fields are themselves composites. This is a special
2506 -- case because it is not possible to respect normal Ada visibility rules.
2508 function Expand_Composite_Equality
2513 Bodies
: List_Id
) return Node_Id
2515 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2516 Full_Type
: Entity_Id
;
2520 function Find_Primitive_Eq
return Node_Id
;
2521 -- AI05-0123: Locate primitive equality for type if it exists, and
2522 -- build the corresponding call. If operation is abstract, replace
2523 -- call with an explicit raise. Return Empty if there is no primitive.
2525 -----------------------
2526 -- Find_Primitive_Eq --
2527 -----------------------
2529 function Find_Primitive_Eq
return Node_Id
is
2534 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2535 while Present
(Prim_E
) loop
2536 Prim
:= Node
(Prim_E
);
2538 -- Locate primitive equality with the right signature
2540 if Chars
(Prim
) = Name_Op_Eq
2541 and then Etype
(First_Formal
(Prim
)) =
2542 Etype
(Next_Formal
(First_Formal
(Prim
)))
2543 and then Etype
(Prim
) = Standard_Boolean
2545 if Is_Abstract_Subprogram
(Prim
) then
2547 Make_Raise_Program_Error
(Loc
,
2548 Reason
=> PE_Explicit_Raise
);
2552 Make_Function_Call
(Loc
,
2553 Name
=> New_Reference_To
(Prim
, Loc
),
2554 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2561 -- If not found, predefined operation will be used
2564 end Find_Primitive_Eq
;
2566 -- Start of processing for Expand_Composite_Equality
2569 if Is_Private_Type
(Typ
) then
2570 Full_Type
:= Underlying_Type
(Typ
);
2575 -- Defense against malformed private types with no completion the error
2576 -- will be diagnosed later by check_completion
2578 if No
(Full_Type
) then
2579 return New_Reference_To
(Standard_False
, Loc
);
2582 Full_Type
:= Base_Type
(Full_Type
);
2584 if Is_Array_Type
(Full_Type
) then
2586 -- If the operand is an elementary type other than a floating-point
2587 -- type, then we can simply use the built-in block bitwise equality,
2588 -- since the predefined equality operators always apply and bitwise
2589 -- equality is fine for all these cases.
2591 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2592 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2594 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2596 -- For composite component types, and floating-point types, use the
2597 -- expansion. This deals with tagged component types (where we use
2598 -- the applicable equality routine) and floating-point, (where we
2599 -- need to worry about negative zeroes), and also the case of any
2600 -- composite type recursively containing such fields.
2603 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2606 elsif Is_Tagged_Type
(Full_Type
) then
2608 -- Call the primitive operation "=" of this type
2610 if Is_Class_Wide_Type
(Full_Type
) then
2611 Full_Type
:= Root_Type
(Full_Type
);
2614 -- If this is derived from an untagged private type completed with a
2615 -- tagged type, it does not have a full view, so we use the primitive
2616 -- operations of the private type. This check should no longer be
2617 -- necessary when these types receive their full views ???
2619 if Is_Private_Type
(Typ
)
2620 and then not Is_Tagged_Type
(Typ
)
2621 and then not Is_Controlled
(Typ
)
2622 and then Is_Derived_Type
(Typ
)
2623 and then No
(Full_View
(Typ
))
2625 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2627 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2631 Eq_Op
:= Node
(Prim
);
2632 exit when Chars
(Eq_Op
) = Name_Op_Eq
2633 and then Etype
(First_Formal
(Eq_Op
)) =
2634 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2635 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2637 pragma Assert
(Present
(Prim
));
2640 Eq_Op
:= Node
(Prim
);
2643 Make_Function_Call
(Loc
,
2644 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2645 Parameter_Associations
=>
2647 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2648 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2650 elsif Is_Record_Type
(Full_Type
) then
2651 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2653 if Present
(Eq_Op
) then
2654 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2656 -- Inherited equality from parent type. Convert the actuals to
2657 -- match signature of operation.
2660 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2664 Make_Function_Call
(Loc
,
2665 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2666 Parameter_Associations
=> New_List
(
2667 OK_Convert_To
(T
, Lhs
),
2668 OK_Convert_To
(T
, Rhs
)));
2672 -- Comparison between Unchecked_Union components
2674 if Is_Unchecked_Union
(Full_Type
) then
2676 Lhs_Type
: Node_Id
:= Full_Type
;
2677 Rhs_Type
: Node_Id
:= Full_Type
;
2678 Lhs_Discr_Val
: Node_Id
;
2679 Rhs_Discr_Val
: Node_Id
;
2684 if Nkind
(Lhs
) = N_Selected_Component
then
2685 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2690 if Nkind
(Rhs
) = N_Selected_Component
then
2691 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2694 -- Lhs of the composite equality
2696 if Is_Constrained
(Lhs_Type
) then
2698 -- Since the enclosing record type can never be an
2699 -- Unchecked_Union (this code is executed for records
2700 -- that do not have variants), we may reference its
2703 if Nkind
(Lhs
) = N_Selected_Component
2704 and then Has_Per_Object_Constraint
(
2705 Entity
(Selector_Name
(Lhs
)))
2708 Make_Selected_Component
(Loc
,
2709 Prefix
=> Prefix
(Lhs
),
2712 (Get_Discriminant_Value
2713 (First_Discriminant
(Lhs_Type
),
2715 Stored_Constraint
(Lhs_Type
))));
2720 (Get_Discriminant_Value
2721 (First_Discriminant
(Lhs_Type
),
2723 Stored_Constraint
(Lhs_Type
)));
2727 -- It is not possible to infer the discriminant since
2728 -- the subtype is not constrained.
2731 Make_Raise_Program_Error
(Loc
,
2732 Reason
=> PE_Unchecked_Union_Restriction
);
2735 -- Rhs of the composite equality
2737 if Is_Constrained
(Rhs_Type
) then
2738 if Nkind
(Rhs
) = N_Selected_Component
2739 and then Has_Per_Object_Constraint
2740 (Entity
(Selector_Name
(Rhs
)))
2743 Make_Selected_Component
(Loc
,
2744 Prefix
=> Prefix
(Rhs
),
2747 (Get_Discriminant_Value
2748 (First_Discriminant
(Rhs_Type
),
2750 Stored_Constraint
(Rhs_Type
))));
2755 (Get_Discriminant_Value
2756 (First_Discriminant
(Rhs_Type
),
2758 Stored_Constraint
(Rhs_Type
)));
2763 Make_Raise_Program_Error
(Loc
,
2764 Reason
=> PE_Unchecked_Union_Restriction
);
2767 -- Call the TSS equality function with the inferred
2768 -- discriminant values.
2771 Make_Function_Call
(Loc
,
2772 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2773 Parameter_Associations
=> New_List
(
2782 Make_Function_Call
(Loc
,
2783 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2784 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2788 -- Equality composes in Ada 2012 for untagged record types. It also
2789 -- composes for bounded strings, because they are part of the
2790 -- predefined environment. We could make it compose for bounded
2791 -- strings by making them tagged, or by making sure all subcomponents
2792 -- are set to the same value, even when not used. Instead, we have
2793 -- this special case in the compiler, because it's more efficient.
2795 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2797 -- if no TSS has been created for the type, check whether there is
2798 -- a primitive equality declared for it.
2801 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2804 -- Use user-defined primitive if it exists, otherwise use
2805 -- predefined equality.
2807 if Present
(Op
) then
2810 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2815 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2819 -- If not array or record type, it is predefined equality.
2821 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2823 end Expand_Composite_Equality
;
2825 ------------------------
2826 -- Expand_Concatenate --
2827 ------------------------
2829 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2830 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2832 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2833 -- Result type of concatenation
2835 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2836 -- Component type. Elements of this component type can appear as one
2837 -- of the operands of concatenation as well as arrays.
2839 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2842 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2843 -- Index type. This is the base type of the index subtype, and is used
2844 -- for all computed bounds (which may be out of range of Istyp in the
2845 -- case of null ranges).
2848 -- This is the type we use to do arithmetic to compute the bounds and
2849 -- lengths of operands. The choice of this type is a little subtle and
2850 -- is discussed in a separate section at the start of the body code.
2852 Concatenation_Error
: exception;
2853 -- Raised if concatenation is sure to raise a CE
2855 Result_May_Be_Null
: Boolean := True;
2856 -- Reset to False if at least one operand is encountered which is known
2857 -- at compile time to be non-null. Used for handling the special case
2858 -- of setting the high bound to the last operand high bound for a null
2859 -- result, thus ensuring a proper high bound in the super-flat case.
2861 N
: constant Nat
:= List_Length
(Opnds
);
2862 -- Number of concatenation operands including possibly null operands
2865 -- Number of operands excluding any known to be null, except that the
2866 -- last operand is always retained, in case it provides the bounds for
2870 -- Current operand being processed in the loop through operands. After
2871 -- this loop is complete, always contains the last operand (which is not
2872 -- the same as Operands (NN), since null operands are skipped).
2874 -- Arrays describing the operands, only the first NN entries of each
2875 -- array are set (NN < N when we exclude known null operands).
2877 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2878 -- True if length of corresponding operand known at compile time
2880 Operands
: array (1 .. N
) of Node_Id
;
2881 -- Set to the corresponding entry in the Opnds list (but note that null
2882 -- operands are excluded, so not all entries in the list are stored).
2884 Fixed_Length
: array (1 .. N
) of Uint
;
2885 -- Set to length of operand. Entries in this array are set only if the
2886 -- corresponding entry in Is_Fixed_Length is True.
2888 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2889 -- Set to lower bound of operand. Either an integer literal in the case
2890 -- where the bound is known at compile time, else actual lower bound.
2891 -- The operand low bound is of type Ityp.
2893 Var_Length
: array (1 .. N
) of Entity_Id
;
2894 -- Set to an entity of type Natural that contains the length of an
2895 -- operand whose length is not known at compile time. Entries in this
2896 -- array are set only if the corresponding entry in Is_Fixed_Length
2897 -- is False. The entity is of type Artyp.
2899 Aggr_Length
: array (0 .. N
) of Node_Id
;
2900 -- The J'th entry in an expression node that represents the total length
2901 -- of operands 1 through J. It is either an integer literal node, or a
2902 -- reference to a constant entity with the right value, so it is fine
2903 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2904 -- entry always is set to zero. The length is of type Artyp.
2906 Low_Bound
: Node_Id
;
2907 -- A tree node representing the low bound of the result (of type Ityp).
2908 -- This is either an integer literal node, or an identifier reference to
2909 -- a constant entity initialized to the appropriate value.
2911 Last_Opnd_Low_Bound
: Node_Id
;
2912 -- A tree node representing the low bound of the last operand. This
2913 -- need only be set if the result could be null. It is used for the
2914 -- special case of setting the right low bound for a null result.
2915 -- This is of type Ityp.
2917 Last_Opnd_High_Bound
: Node_Id
;
2918 -- A tree node representing the high bound of the last operand. This
2919 -- need only be set if the result could be null. It is used for the
2920 -- special case of setting the right high bound for a null result.
2921 -- This is of type Ityp.
2923 High_Bound
: Node_Id
;
2924 -- A tree node representing the high bound of the result (of type Ityp)
2927 -- Result of the concatenation (of type Ityp)
2929 Actions
: constant List_Id
:= New_List
;
2930 -- Collect actions to be inserted
2932 Known_Non_Null_Operand_Seen
: Boolean;
2933 -- Set True during generation of the assignments of operands into
2934 -- result once an operand known to be non-null has been seen.
2936 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2937 -- This function makes an N_Integer_Literal node that is returned in
2938 -- analyzed form with the type set to Artyp. Importantly this literal
2939 -- is not flagged as static, so that if we do computations with it that
2940 -- result in statically detected out of range conditions, we will not
2941 -- generate error messages but instead warning messages.
2943 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2944 -- Given a node of type Ityp, returns the corresponding value of type
2945 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2946 -- For enum types, the Pos of the value is returned.
2948 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2949 -- The inverse function (uses Val in the case of enumeration types)
2951 ------------------------
2952 -- Make_Artyp_Literal --
2953 ------------------------
2955 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2956 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2958 Set_Etype
(Result
, Artyp
);
2959 Set_Analyzed
(Result
, True);
2960 Set_Is_Static_Expression
(Result
, False);
2962 end Make_Artyp_Literal
;
2968 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2970 if Ityp
= Base_Type
(Artyp
) then
2973 elsif Is_Enumeration_Type
(Ityp
) then
2975 Make_Attribute_Reference
(Loc
,
2976 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2977 Attribute_Name
=> Name_Pos
,
2978 Expressions
=> New_List
(X
));
2981 return Convert_To
(Artyp
, X
);
2989 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2991 if Is_Enumeration_Type
(Ityp
) then
2993 Make_Attribute_Reference
(Loc
,
2994 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2995 Attribute_Name
=> Name_Val
,
2996 Expressions
=> New_List
(X
));
2998 -- Case where we will do a type conversion
3001 if Ityp
= Base_Type
(Artyp
) then
3004 return Convert_To
(Ityp
, X
);
3009 -- Local Declarations
3011 Opnd_Typ
: Entity_Id
;
3018 -- Start of processing for Expand_Concatenate
3021 -- Choose an appropriate computational type
3023 -- We will be doing calculations of lengths and bounds in this routine
3024 -- and computing one from the other in some cases, e.g. getting the high
3025 -- bound by adding the length-1 to the low bound.
3027 -- We can't just use the index type, or even its base type for this
3028 -- purpose for two reasons. First it might be an enumeration type which
3029 -- is not suitable for computations of any kind, and second it may
3030 -- simply not have enough range. For example if the index type is
3031 -- -128..+127 then lengths can be up to 256, which is out of range of
3034 -- For enumeration types, we can simply use Standard_Integer, this is
3035 -- sufficient since the actual number of enumeration literals cannot
3036 -- possibly exceed the range of integer (remember we will be doing the
3037 -- arithmetic with POS values, not representation values).
3039 if Is_Enumeration_Type
(Ityp
) then
3040 Artyp
:= Standard_Integer
;
3042 -- If index type is Positive, we use the standard unsigned type, to give
3043 -- more room on the top of the range, obviating the need for an overflow
3044 -- check when creating the upper bound. This is needed to avoid junk
3045 -- overflow checks in the common case of String types.
3047 -- ??? Disabled for now
3049 -- elsif Istyp = Standard_Positive then
3050 -- Artyp := Standard_Unsigned;
3052 -- For modular types, we use a 32-bit modular type for types whose size
3053 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3054 -- identity type, and for larger unsigned types we use 64-bits.
3056 elsif Is_Modular_Integer_Type
(Ityp
) then
3057 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
3058 Artyp
:= Standard_Unsigned
;
3059 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
3062 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
3065 -- Similar treatment for signed types
3068 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
3069 Artyp
:= Standard_Integer
;
3070 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
3073 Artyp
:= Standard_Long_Long_Integer
;
3077 -- Supply dummy entry at start of length array
3079 Aggr_Length
(0) := Make_Artyp_Literal
(0);
3081 -- Go through operands setting up the above arrays
3085 Opnd
:= Remove_Head
(Opnds
);
3086 Opnd_Typ
:= Etype
(Opnd
);
3088 -- The parent got messed up when we put the operands in a list,
3089 -- so now put back the proper parent for the saved operand, that
3090 -- is to say the concatenation node, to make sure that each operand
3091 -- is seen as a subexpression, e.g. if actions must be inserted.
3093 Set_Parent
(Opnd
, Cnode
);
3095 -- Set will be True when we have setup one entry in the array
3099 -- Singleton element (or character literal) case
3101 if Base_Type
(Opnd_Typ
) = Ctyp
then
3103 Operands
(NN
) := Opnd
;
3104 Is_Fixed_Length
(NN
) := True;
3105 Fixed_Length
(NN
) := Uint_1
;
3106 Result_May_Be_Null
:= False;
3108 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3109 -- since we know that the result cannot be null).
3111 Opnd_Low_Bound
(NN
) :=
3112 Make_Attribute_Reference
(Loc
,
3113 Prefix
=> New_Reference_To
(Istyp
, Loc
),
3114 Attribute_Name
=> Name_First
);
3118 -- String literal case (can only occur for strings of course)
3120 elsif Nkind
(Opnd
) = N_String_Literal
then
3121 Len
:= String_Literal_Length
(Opnd_Typ
);
3124 Result_May_Be_Null
:= False;
3127 -- Capture last operand low and high bound if result could be null
3129 if J
= N
and then Result_May_Be_Null
then
3130 Last_Opnd_Low_Bound
:=
3131 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3133 Last_Opnd_High_Bound
:=
3134 Make_Op_Subtract
(Loc
,
3136 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
3137 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
3140 -- Skip null string literal
3142 if J
< N
and then Len
= 0 then
3147 Operands
(NN
) := Opnd
;
3148 Is_Fixed_Length
(NN
) := True;
3150 -- Set length and bounds
3152 Fixed_Length
(NN
) := Len
;
3154 Opnd_Low_Bound
(NN
) :=
3155 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
3162 -- Check constrained case with known bounds
3164 if Is_Constrained
(Opnd_Typ
) then
3166 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
3167 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
3168 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
3169 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
3172 -- Fixed length constrained array type with known at compile
3173 -- time bounds is last case of fixed length operand.
3175 if Compile_Time_Known_Value
(Lo
)
3177 Compile_Time_Known_Value
(Hi
)
3180 Loval
: constant Uint
:= Expr_Value
(Lo
);
3181 Hival
: constant Uint
:= Expr_Value
(Hi
);
3182 Len
: constant Uint
:=
3183 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3187 Result_May_Be_Null
:= False;
3190 -- Capture last operand bounds if result could be null
3192 if J
= N
and then Result_May_Be_Null
then
3193 Last_Opnd_Low_Bound
:=
3195 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3197 Last_Opnd_High_Bound
:=
3199 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3202 -- Exclude null length case unless last operand
3204 if J
< N
and then Len
= 0 then
3209 Operands
(NN
) := Opnd
;
3210 Is_Fixed_Length
(NN
) := True;
3211 Fixed_Length
(NN
) := Len
;
3213 Opnd_Low_Bound
(NN
) :=
3215 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3222 -- All cases where the length is not known at compile time, or the
3223 -- special case of an operand which is known to be null but has a
3224 -- lower bound other than 1 or is other than a string type.
3229 -- Capture operand bounds
3231 Opnd_Low_Bound
(NN
) :=
3232 Make_Attribute_Reference
(Loc
,
3234 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3235 Attribute_Name
=> Name_First
);
3237 -- Capture last operand bounds if result could be null
3239 if J
= N
and Result_May_Be_Null
then
3240 Last_Opnd_Low_Bound
:=
3242 Make_Attribute_Reference
(Loc
,
3244 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3245 Attribute_Name
=> Name_First
));
3247 Last_Opnd_High_Bound
:=
3249 Make_Attribute_Reference
(Loc
,
3251 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3252 Attribute_Name
=> Name_Last
));
3255 -- Capture length of operand in entity
3257 Operands
(NN
) := Opnd
;
3258 Is_Fixed_Length
(NN
) := False;
3260 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3263 Make_Object_Declaration
(Loc
,
3264 Defining_Identifier
=> Var_Length
(NN
),
3265 Constant_Present
=> True,
3266 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3268 Make_Attribute_Reference
(Loc
,
3270 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3271 Attribute_Name
=> Name_Length
)));
3275 -- Set next entry in aggregate length array
3277 -- For first entry, make either integer literal for fixed length
3278 -- or a reference to the saved length for variable length.
3281 if Is_Fixed_Length
(1) then
3282 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3284 Aggr_Length
(1) := New_Reference_To
(Var_Length
(1), Loc
);
3287 -- If entry is fixed length and only fixed lengths so far, make
3288 -- appropriate new integer literal adding new length.
3290 elsif Is_Fixed_Length
(NN
)
3291 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3294 Make_Integer_Literal
(Loc
,
3295 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3297 -- All other cases, construct an addition node for the length and
3298 -- create an entity initialized to this length.
3301 Ent
:= Make_Temporary
(Loc
, 'L');
3303 if Is_Fixed_Length
(NN
) then
3304 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3306 Clen
:= New_Reference_To
(Var_Length
(NN
), Loc
);
3310 Make_Object_Declaration
(Loc
,
3311 Defining_Identifier
=> Ent
,
3312 Constant_Present
=> True,
3313 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3316 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
3317 Right_Opnd
=> Clen
)));
3319 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3326 -- If we have only skipped null operands, return the last operand
3333 -- If we have only one non-null operand, return it and we are done.
3334 -- There is one case in which this cannot be done, and that is when
3335 -- the sole operand is of the element type, in which case it must be
3336 -- converted to an array, and the easiest way of doing that is to go
3337 -- through the normal general circuit.
3340 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
3342 Result
:= Operands
(1);
3346 -- Cases where we have a real concatenation
3348 -- Next step is to find the low bound for the result array that we
3349 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3351 -- If the ultimate ancestor of the index subtype is a constrained array
3352 -- definition, then the lower bound is that of the index subtype as
3353 -- specified by (RM 4.5.3(6)).
3355 -- The right test here is to go to the root type, and then the ultimate
3356 -- ancestor is the first subtype of this root type.
3358 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3360 Make_Attribute_Reference
(Loc
,
3362 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3363 Attribute_Name
=> Name_First
);
3365 -- If the first operand in the list has known length we know that
3366 -- the lower bound of the result is the lower bound of this operand.
3368 elsif Is_Fixed_Length
(1) then
3369 Low_Bound
:= Opnd_Low_Bound
(1);
3371 -- OK, we don't know the lower bound, we have to build a horrible
3372 -- if expression node of the form
3374 -- if Cond1'Length /= 0 then
3377 -- if Opnd2'Length /= 0 then
3382 -- The nesting ends either when we hit an operand whose length is known
3383 -- at compile time, or on reaching the last operand, whose low bound we
3384 -- take unconditionally whether or not it is null. It's easiest to do
3385 -- this with a recursive procedure:
3389 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3390 -- Returns the lower bound determined by operands J .. NN
3392 ---------------------
3393 -- Get_Known_Bound --
3394 ---------------------
3396 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3398 if Is_Fixed_Length
(J
) or else J
= NN
then
3399 return New_Copy
(Opnd_Low_Bound
(J
));
3403 Make_If_Expression
(Loc
,
3404 Expressions
=> New_List
(
3407 Left_Opnd
=> New_Reference_To
(Var_Length
(J
), Loc
),
3408 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3410 New_Copy
(Opnd_Low_Bound
(J
)),
3411 Get_Known_Bound
(J
+ 1)));
3413 end Get_Known_Bound
;
3416 Ent
:= Make_Temporary
(Loc
, 'L');
3419 Make_Object_Declaration
(Loc
,
3420 Defining_Identifier
=> Ent
,
3421 Constant_Present
=> True,
3422 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3423 Expression
=> Get_Known_Bound
(1)));
3425 Low_Bound
:= New_Reference_To
(Ent
, Loc
);
3429 -- Now we can safely compute the upper bound, normally
3430 -- Low_Bound + Length - 1.
3435 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3437 Make_Op_Subtract
(Loc
,
3438 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3439 Right_Opnd
=> Make_Artyp_Literal
(1))));
3441 -- Note that calculation of the high bound may cause overflow in some
3442 -- very weird cases, so in the general case we need an overflow check on
3443 -- the high bound. We can avoid this for the common case of string types
3444 -- and other types whose index is Positive, since we chose a wider range
3445 -- for the arithmetic type.
3447 if Istyp
/= Standard_Positive
then
3448 Activate_Overflow_Check
(High_Bound
);
3451 -- Handle the exceptional case where the result is null, in which case
3452 -- case the bounds come from the last operand (so that we get the proper
3453 -- bounds if the last operand is super-flat).
3455 if Result_May_Be_Null
then
3457 Make_If_Expression
(Loc
,
3458 Expressions
=> New_List
(
3460 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3461 Right_Opnd
=> Make_Artyp_Literal
(0)),
3462 Last_Opnd_Low_Bound
,
3466 Make_If_Expression
(Loc
,
3467 Expressions
=> New_List
(
3469 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3470 Right_Opnd
=> Make_Artyp_Literal
(0)),
3471 Last_Opnd_High_Bound
,
3475 -- Here is where we insert the saved up actions
3477 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3479 -- Now we construct an array object with appropriate bounds. We mark
3480 -- the target as internal to prevent useless initialization when
3481 -- Initialize_Scalars is enabled. Also since this is the actual result
3482 -- entity, we make sure we have debug information for the result.
3484 Ent
:= Make_Temporary
(Loc
, 'S');
3485 Set_Is_Internal
(Ent
);
3486 Set_Needs_Debug_Info
(Ent
);
3488 -- If the bound is statically known to be out of range, we do not want
3489 -- to abort, we want a warning and a runtime constraint error. Note that
3490 -- we have arranged that the result will not be treated as a static
3491 -- constant, so we won't get an illegality during this insertion.
3493 Insert_Action
(Cnode
,
3494 Make_Object_Declaration
(Loc
,
3495 Defining_Identifier
=> Ent
,
3496 Object_Definition
=>
3497 Make_Subtype_Indication
(Loc
,
3498 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3500 Make_Index_Or_Discriminant_Constraint
(Loc
,
3501 Constraints
=> New_List
(
3503 Low_Bound
=> Low_Bound
,
3504 High_Bound
=> High_Bound
))))),
3505 Suppress
=> All_Checks
);
3507 -- If the result of the concatenation appears as the initializing
3508 -- expression of an object declaration, we can just rename the
3509 -- result, rather than copying it.
3511 Set_OK_To_Rename
(Ent
);
3513 -- Catch the static out of range case now
3515 if Raises_Constraint_Error
(High_Bound
) then
3516 raise Concatenation_Error
;
3519 -- Now we will generate the assignments to do the actual concatenation
3521 -- There is one case in which we will not do this, namely when all the
3522 -- following conditions are met:
3524 -- The result type is Standard.String
3526 -- There are nine or fewer retained (non-null) operands
3528 -- The optimization level is -O0
3530 -- The corresponding System.Concat_n.Str_Concat_n routine is
3531 -- available in the run time.
3533 -- The debug flag gnatd.c is not set
3535 -- If all these conditions are met then we generate a call to the
3536 -- relevant concatenation routine. The purpose of this is to avoid
3537 -- undesirable code bloat at -O0.
3539 if Atyp
= Standard_String
3540 and then NN
in 2 .. 9
3541 and then (Opt
.Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3542 and then not Debug_Flag_Dot_C
3545 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3556 if RTE_Available
(RR
(NN
)) then
3558 Opnds
: constant List_Id
:=
3559 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3562 for J
in 1 .. NN
loop
3563 if Is_List_Member
(Operands
(J
)) then
3564 Remove
(Operands
(J
));
3567 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3569 Make_Aggregate
(Loc
,
3570 Component_Associations
=> New_List
(
3571 Make_Component_Association
(Loc
,
3572 Choices
=> New_List
(
3573 Make_Integer_Literal
(Loc
, 1)),
3574 Expression
=> Operands
(J
)))));
3577 Append_To
(Opnds
, Operands
(J
));
3581 Insert_Action
(Cnode
,
3582 Make_Procedure_Call_Statement
(Loc
,
3583 Name
=> New_Reference_To
(RTE
(RR
(NN
)), Loc
),
3584 Parameter_Associations
=> Opnds
));
3586 Result
:= New_Reference_To
(Ent
, Loc
);
3593 -- Not special case so generate the assignments
3595 Known_Non_Null_Operand_Seen
:= False;
3597 for J
in 1 .. NN
loop
3599 Lo
: constant Node_Id
:=
3601 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3602 Right_Opnd
=> Aggr_Length
(J
- 1));
3604 Hi
: constant Node_Id
:=
3606 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3608 Make_Op_Subtract
(Loc
,
3609 Left_Opnd
=> Aggr_Length
(J
),
3610 Right_Opnd
=> Make_Artyp_Literal
(1)));
3613 -- Singleton case, simple assignment
3615 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3616 Known_Non_Null_Operand_Seen
:= True;
3617 Insert_Action
(Cnode
,
3618 Make_Assignment_Statement
(Loc
,
3620 Make_Indexed_Component
(Loc
,
3621 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3622 Expressions
=> New_List
(To_Ityp
(Lo
))),
3623 Expression
=> Operands
(J
)),
3624 Suppress
=> All_Checks
);
3626 -- Array case, slice assignment, skipped when argument is fixed
3627 -- length and known to be null.
3629 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3632 Make_Assignment_Statement
(Loc
,
3636 New_Occurrence_Of
(Ent
, Loc
),
3639 Low_Bound
=> To_Ityp
(Lo
),
3640 High_Bound
=> To_Ityp
(Hi
))),
3641 Expression
=> Operands
(J
));
3643 if Is_Fixed_Length
(J
) then
3644 Known_Non_Null_Operand_Seen
:= True;
3646 elsif not Known_Non_Null_Operand_Seen
then
3648 -- Here if operand length is not statically known and no
3649 -- operand known to be non-null has been processed yet.
3650 -- If operand length is 0, we do not need to perform the
3651 -- assignment, and we must avoid the evaluation of the
3652 -- high bound of the slice, since it may underflow if the
3653 -- low bound is Ityp'First.
3656 Make_Implicit_If_Statement
(Cnode
,
3660 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3661 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3662 Then_Statements
=> New_List
(Assign
));
3665 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3671 -- Finally we build the result, which is a reference to the array object
3673 Result
:= New_Reference_To
(Ent
, Loc
);
3676 Rewrite
(Cnode
, Result
);
3677 Analyze_And_Resolve
(Cnode
, Atyp
);
3680 when Concatenation_Error
=>
3682 -- Kill warning generated for the declaration of the static out of
3683 -- range high bound, and instead generate a Constraint_Error with
3684 -- an appropriate specific message.
3686 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3687 Apply_Compile_Time_Constraint_Error
3689 Msg
=> "concatenation result upper bound out of range?",
3690 Reason
=> CE_Range_Check_Failed
);
3691 end Expand_Concatenate
;
3693 ---------------------------------------------------
3694 -- Expand_Membership_Minimize_Eliminate_Overflow --
3695 ---------------------------------------------------
3697 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3698 pragma Assert
(Nkind
(N
) = N_In
);
3699 -- Despite the name, this routine applies only to N_In, not to
3700 -- N_Not_In. The latter is always rewritten as not (X in Y).
3702 Result_Type
: constant Entity_Id
:= Etype
(N
);
3703 -- Capture result type, may be a derived boolean type
3705 Loc
: constant Source_Ptr
:= Sloc
(N
);
3706 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3707 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3709 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3710 -- is thus tempting to capture these values, but due to the rewrites
3711 -- that occur as a result of overflow checking, these values change
3712 -- as we go along, and it is safe just to always use Etype explicitly.
3714 Restype
: constant Entity_Id
:= Etype
(N
);
3718 -- Bounds in Minimize calls, not used yet ???
3720 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3721 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3724 Minimize_Eliminate_Overflow_Checks
(Lop
, Lo
, Hi
, Top_Level
=> False);
3726 -- If right operand is a subtype name, and the subtype name has no
3727 -- predicate, then we can just replace the right operand with an
3728 -- explicit range T'First .. T'Last, and use the explicit range code.
3730 if Nkind
(Rop
) /= N_Range
3731 and then No
(Predicate_Function
(Etype
(Rop
)))
3734 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3739 Make_Attribute_Reference
(Loc
,
3740 Attribute_Name
=> Name_First
,
3741 Prefix
=> New_Reference_To
(Rtyp
, Loc
)),
3743 Make_Attribute_Reference
(Loc
,
3744 Attribute_Name
=> Name_Last
,
3745 Prefix
=> New_Reference_To
(Rtyp
, Loc
))));
3746 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3750 -- Here for the explicit range case. Note that the bounds of the range
3751 -- have not been processed for minimized or eliminated checks.
3753 if Nkind
(Rop
) = N_Range
then
3754 Minimize_Eliminate_Overflow_Checks
3755 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3756 Minimize_Eliminate_Overflow_Checks
3757 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3759 -- We have A in B .. C, treated as A >= B and then A <= C
3763 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3764 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3765 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3768 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3769 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3770 L
: constant Entity_Id
:=
3771 Make_Defining_Identifier
(Loc
, Name_uL
);
3772 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3773 Lbound
: constant Node_Id
:=
3774 Convert_To_Bignum
(Low_Bound
(Rop
));
3775 Hbound
: constant Node_Id
:=
3776 Convert_To_Bignum
(High_Bound
(Rop
));
3778 -- Now we rewrite the membership test node to look like
3781 -- Bnn : Result_Type;
3783 -- M : Mark_Id := SS_Mark;
3784 -- L : Bignum := Lopnd;
3786 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3794 -- Insert declaration of L into declarations of bignum block
3797 (Last
(Declarations
(Blk
)),
3798 Make_Object_Declaration
(Loc
,
3799 Defining_Identifier
=> L
,
3800 Object_Definition
=>
3801 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3802 Expression
=> Lopnd
));
3804 -- Insert assignment to Bnn into expressions of bignum block
3807 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3808 Make_Assignment_Statement
(Loc
,
3809 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3813 Make_Function_Call
(Loc
,
3815 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3816 Parameter_Associations
=> New_List
(
3817 New_Occurrence_Of
(L
, Loc
),
3820 Make_Function_Call
(Loc
,
3822 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3823 Parameter_Associations
=> New_List
(
3824 New_Occurrence_Of
(L
, Loc
),
3827 -- Now rewrite the node
3830 Make_Expression_With_Actions
(Loc
,
3831 Actions
=> New_List
(
3832 Make_Object_Declaration
(Loc
,
3833 Defining_Identifier
=> Bnn
,
3834 Object_Definition
=>
3835 New_Occurrence_Of
(Result_Type
, Loc
)),
3837 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3838 Analyze_And_Resolve
(N
, Result_Type
);
3842 -- Here if no bignums around
3845 -- Case where types are all the same
3847 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3849 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3853 -- If types are not all the same, it means that we have rewritten
3854 -- at least one of them to be of type Long_Long_Integer, and we
3855 -- will convert the other operands to Long_Long_Integer.
3858 Convert_To_And_Rewrite
(LLIB
, Lop
);
3859 Set_Analyzed
(Lop
, False);
3860 Analyze_And_Resolve
(Lop
, LLIB
);
3862 -- For the right operand, avoid unnecessary recursion into
3863 -- this routine, we know that overflow is not possible.
3865 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3866 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3867 Set_Analyzed
(Rop
, False);
3868 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3871 -- Now the three operands are of the same signed integer type,
3872 -- so we can use the normal expansion routine for membership,
3873 -- setting the flag to prevent recursion into this procedure.
3875 Set_No_Minimize_Eliminate
(N
);
3879 -- Right operand is a subtype name and the subtype has a predicate. We
3880 -- have to make sure predicate is checked, and for that we need to use
3881 -- the standard N_In circuitry with appropriate types.
3884 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3886 -- If types are "right", just call Expand_N_In preventing recursion
3888 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3889 Set_No_Minimize_Eliminate
(N
);
3894 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3896 -- For X in T, we want to rewrite our node as
3899 -- Bnn : Result_Type;
3902 -- M : Mark_Id := SS_Mark;
3903 -- Lnn : Long_Long_Integer'Base
3909 -- if not Bignum_In_LLI_Range (Nnn) then
3912 -- Lnn := From_Bignum (Nnn);
3914 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3915 -- and then T'Base (Lnn) in T;
3924 -- A bit gruesome, but here goes.
3927 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3928 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3929 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3930 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3931 T
: constant Entity_Id
:= Etype
(Rop
);
3932 TB
: constant Entity_Id
:= Base_Type
(T
);
3936 -- Mark the last membership operation to prevent recursion
3941 Convert_To
(Base_Type
(Etype
(Rop
)),
3942 New_Occurrence_Of
(Lnn
, Loc
)),
3943 Right_Opnd
=> New_Occurrence_Of
(Etype
(Rop
), Loc
));
3944 Set_No_Minimize_Eliminate
(Nin
);
3946 -- Now decorate the block
3949 (Last
(Declarations
(Blk
)),
3950 Make_Object_Declaration
(Loc
,
3951 Defining_Identifier
=> Lnn
,
3952 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3955 (Last
(Declarations
(Blk
)),
3956 Make_Object_Declaration
(Loc
,
3957 Defining_Identifier
=> Nnn
,
3958 Object_Definition
=>
3959 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3962 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3964 Make_Assignment_Statement
(Loc
,
3965 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3966 Expression
=> Relocate_Node
(Lop
)),
3968 Make_If_Statement
(Loc
,
3972 Make_Function_Call
(Loc
,
3975 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3976 Parameter_Associations
=> New_List
(
3977 New_Occurrence_Of
(Nnn
, Loc
)))),
3979 Then_Statements
=> New_List
(
3980 Make_Assignment_Statement
(Loc
,
3981 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3983 New_Occurrence_Of
(Standard_False
, Loc
))),
3985 Else_Statements
=> New_List
(
3986 Make_Assignment_Statement
(Loc
,
3987 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3989 Make_Function_Call
(Loc
,
3991 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3992 Parameter_Associations
=> New_List
(
3993 New_Occurrence_Of
(Nnn
, Loc
)))),
3995 Make_Assignment_Statement
(Loc
,
3996 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
4001 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
4006 Make_Attribute_Reference
(Loc
,
4007 Attribute_Name
=> Name_First
,
4009 New_Occurrence_Of
(TB
, Loc
))),
4013 Make_Attribute_Reference
(Loc
,
4014 Attribute_Name
=> Name_Last
,
4016 New_Occurrence_Of
(TB
, Loc
))))),
4018 Right_Opnd
=> Nin
))))));
4020 -- Now we can do the rewrite
4023 Make_Expression_With_Actions
(Loc
,
4024 Actions
=> New_List
(
4025 Make_Object_Declaration
(Loc
,
4026 Defining_Identifier
=> Bnn
,
4027 Object_Definition
=>
4028 New_Occurrence_Of
(Result_Type
, Loc
)),
4030 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
4031 Analyze_And_Resolve
(N
, Result_Type
);
4035 -- Not bignum case, but types don't match (this means we rewrote the
4036 -- left operand to be Long_Long_Integer).
4039 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
4041 -- We rewrite the membership test as (where T is the type with
4042 -- the predicate, i.e. the type of the right operand)
4044 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4045 -- and then T'Base (Lop) in T
4048 T
: constant Entity_Id
:= Etype
(Rop
);
4049 TB
: constant Entity_Id
:= Base_Type
(T
);
4053 -- The last membership test is marked to prevent recursion
4057 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
4058 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
4059 Set_No_Minimize_Eliminate
(Nin
);
4061 -- Now do the rewrite
4072 Make_Attribute_Reference
(Loc
,
4073 Attribute_Name
=> Name_First
,
4074 Prefix
=> New_Occurrence_Of
(TB
, Loc
))),
4077 Make_Attribute_Reference
(Loc
,
4078 Attribute_Name
=> Name_Last
,
4079 Prefix
=> New_Occurrence_Of
(TB
, Loc
))))),
4080 Right_Opnd
=> Nin
));
4081 Set_Analyzed
(N
, False);
4082 Analyze_And_Resolve
(N
, Restype
);
4086 end Expand_Membership_Minimize_Eliminate_Overflow
;
4088 ------------------------
4089 -- Expand_N_Allocator --
4090 ------------------------
4092 procedure Expand_N_Allocator
(N
: Node_Id
) is
4093 PtrT
: constant Entity_Id
:= Etype
(N
);
4094 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4095 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4096 Loc
: constant Source_Ptr
:= Sloc
(N
);
4102 procedure Rewrite_Coextension
(N
: Node_Id
);
4103 -- Static coextensions have the same lifetime as the entity they
4104 -- constrain. Such occurrences can be rewritten as aliased objects
4105 -- and their unrestricted access used instead of the coextension.
4107 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4108 -- Given a constrained array type E, returns a node representing the
4109 -- code to compute the size in storage elements for the given type.
4110 -- This is done without using the attribute (which malfunctions for
4113 -------------------------
4114 -- Rewrite_Coextension --
4115 -------------------------
4117 procedure Rewrite_Coextension
(N
: Node_Id
) is
4118 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4119 Temp_Decl
: Node_Id
;
4123 -- Cnn : aliased Etyp;
4126 Make_Object_Declaration
(Loc
,
4127 Defining_Identifier
=> Temp_Id
,
4128 Aliased_Present
=> True,
4129 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4131 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4132 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4135 Insert_Action
(N
, Temp_Decl
);
4137 Make_Attribute_Reference
(Loc
,
4138 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4139 Attribute_Name
=> Name_Unrestricted_Access
));
4141 Analyze_And_Resolve
(N
, PtrT
);
4142 end Rewrite_Coextension
;
4144 ------------------------------
4145 -- Size_In_Storage_Elements --
4146 ------------------------------
4148 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4150 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4151 -- However, the reason for the existence of this function is
4152 -- to construct a test for sizes too large, which means near the
4153 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4154 -- is that we get overflows when sizes are greater than 2**31.
4156 -- So what we end up doing for array types is to use the expression:
4158 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4160 -- which avoids this problem. All this is a bit bogus, but it does
4161 -- mean we catch common cases of trying to allocate arrays that
4162 -- are too large, and which in the absence of a check results in
4163 -- undetected chaos ???
4170 for J
in 1 .. Number_Dimensions
(E
) loop
4172 Make_Attribute_Reference
(Loc
,
4173 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4174 Attribute_Name
=> Name_Length
,
4175 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4182 Make_Op_Multiply
(Loc
,
4189 Make_Op_Multiply
(Loc
,
4192 Make_Attribute_Reference
(Loc
,
4193 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4194 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4196 end Size_In_Storage_Elements
;
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
4216 (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4217 and then Needs_Finalization
(Dtyp
)
4219 -- Anonymous access-to-controlled types allocate on the global pool.
4220 -- Do not set this attribute on .NET/JVM since those targets do not
4223 if No
(Associated_Storage_Pool
(PtrT
)) and then VM_Target
= No_VM
then
4224 Set_Associated_Storage_Pool
4225 (PtrT
, Get_Global_Pool_For_Access_Type
(PtrT
));
4228 -- The finalization master must be inserted and analyzed as part of
4229 -- the current semantic unit. This form of expansion is not carried
4230 -- out in Alfa mode because it is useless. Note that the master is
4231 -- updated when analysis changes current units.
4233 if not Alfa_Mode
then
4234 Set_Finalization_Master
(PtrT
, Current_Anonymous_Master
);
4238 -- Set the storage pool and find the appropriate version of Allocate to
4239 -- call. Do not overwrite the storage pool if it is already set, which
4240 -- can happen for build-in-place function returns (see
4241 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4243 if No
(Storage_Pool
(N
)) then
4244 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4246 if Present
(Pool
) then
4247 Set_Storage_Pool
(N
, Pool
);
4249 if Is_RTE
(Pool
, RE_SS_Pool
) then
4250 if VM_Target
= No_VM
then
4251 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4254 -- In the case of an allocator for a simple storage pool, locate
4255 -- and save a reference to the pool type's Allocate routine.
4257 elsif Present
(Get_Rep_Pragma
4258 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4261 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4262 Alloc_Op
: Entity_Id
;
4264 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4265 while Present
(Alloc_Op
) loop
4266 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4267 and then Present
(First_Formal
(Alloc_Op
))
4268 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4270 Set_Procedure_To_Call
(N
, Alloc_Op
);
4273 Alloc_Op
:= Homonym
(Alloc_Op
);
4278 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4279 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4282 Set_Procedure_To_Call
(N
,
4283 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4288 -- Under certain circumstances we can replace an allocator by an access
4289 -- to statically allocated storage. The conditions, as noted in AARM
4290 -- 3.10 (10c) are as follows:
4292 -- Size and initial value is known at compile time
4293 -- Access type is access-to-constant
4295 -- The allocator is not part of a constraint on a record component,
4296 -- because in that case the inserted actions are delayed until the
4297 -- record declaration is fully analyzed, which is too late for the
4298 -- analysis of the rewritten allocator.
4300 if Is_Access_Constant
(PtrT
)
4301 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4302 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4303 and then Size_Known_At_Compile_Time
4304 (Etype
(Expression
(Expression
(N
))))
4305 and then not Is_Record_Type
(Current_Scope
)
4307 -- Here we can do the optimization. For the allocator
4311 -- We insert an object declaration
4313 -- Tnn : aliased x := y;
4315 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4316 -- marked as requiring static allocation.
4318 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4319 Desig
:= Subtype_Mark
(Expression
(N
));
4321 -- If context is constrained, use constrained subtype directly,
4322 -- so that the constant is not labelled as having a nominally
4323 -- unconstrained subtype.
4325 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4326 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4330 Make_Object_Declaration
(Loc
,
4331 Defining_Identifier
=> Temp
,
4332 Aliased_Present
=> True,
4333 Constant_Present
=> Is_Access_Constant
(PtrT
),
4334 Object_Definition
=> Desig
,
4335 Expression
=> Expression
(Expression
(N
))));
4338 Make_Attribute_Reference
(Loc
,
4339 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4340 Attribute_Name
=> Name_Unrestricted_Access
));
4342 Analyze_And_Resolve
(N
, PtrT
);
4344 -- We set the variable as statically allocated, since we don't want
4345 -- it going on the stack of the current procedure!
4347 Set_Is_Statically_Allocated
(Temp
);
4351 -- Same if the allocator is an access discriminant for a local object:
4352 -- instead of an allocator we create a local value and constrain the
4353 -- enclosing object with the corresponding access attribute.
4355 if Is_Static_Coextension
(N
) then
4356 Rewrite_Coextension
(N
);
4360 -- Check for size too large, we do this because the back end misses
4361 -- proper checks here and can generate rubbish allocation calls when
4362 -- we are near the limit. We only do this for the 32-bit address case
4363 -- since that is from a practical point of view where we see a problem.
4365 if System_Address_Size
= 32
4366 and then not Storage_Checks_Suppressed
(PtrT
)
4367 and then not Storage_Checks_Suppressed
(Dtyp
)
4368 and then not Storage_Checks_Suppressed
(Etyp
)
4370 -- The check we want to generate should look like
4372 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4373 -- raise Storage_Error;
4376 -- where 3.5 gigabytes is a constant large enough to accommodate any
4377 -- reasonable request for. But we can't do it this way because at
4378 -- least at the moment we don't compute this attribute right, and
4379 -- can silently give wrong results when the result gets large. Since
4380 -- this is all about large results, that's bad, so instead we only
4381 -- apply the check for constrained arrays, and manually compute the
4382 -- value of the attribute ???
4384 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4386 Make_Raise_Storage_Error
(Loc
,
4389 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4391 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4392 Reason
=> SE_Object_Too_Large
));
4396 -- Handle case of qualified expression (other than optimization above)
4397 -- First apply constraint checks, because the bounds or discriminants
4398 -- in the aggregate might not match the subtype mark in the allocator.
4400 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4401 Apply_Constraint_Check
4402 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
4404 Expand_Allocator_Expression
(N
);
4408 -- If the allocator is for a type which requires initialization, and
4409 -- there is no initial value (i.e. operand is a subtype indication
4410 -- rather than a qualified expression), then we must generate a call to
4411 -- the initialization routine using an expressions action node:
4413 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4415 -- Here ptr_T is the pointer type for the allocator, and T is the
4416 -- subtype of the allocator. A special case arises if the designated
4417 -- type of the access type is a task or contains tasks. In this case
4418 -- the call to Init (Temp.all ...) is replaced by code that ensures
4419 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4420 -- for details). In addition, if the type T is a task T, then the
4421 -- first argument to Init must be converted to the task record type.
4424 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4430 Init_Arg1
: Node_Id
;
4431 Temp_Decl
: Node_Id
;
4432 Temp_Type
: Entity_Id
;
4435 if No_Initialization
(N
) then
4437 -- Even though this might be a simple allocation, create a custom
4438 -- Allocate if the context requires it. Since .NET/JVM compilers
4439 -- do not support pools, this step is skipped.
4441 if VM_Target
= No_VM
4442 and then Present
(Finalization_Master
(PtrT
))
4444 Build_Allocate_Deallocate_Proc
4446 Is_Allocate
=> True);
4449 -- Case of no initialization procedure present
4451 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4453 -- Case of simple initialization required
4455 if Needs_Simple_Initialization
(T
) then
4456 Check_Restriction
(No_Default_Initialization
, N
);
4457 Rewrite
(Expression
(N
),
4458 Make_Qualified_Expression
(Loc
,
4459 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4460 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4462 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4463 Analyze_And_Resolve
(Expression
(N
), T
);
4464 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4465 Expand_N_Allocator
(N
);
4467 -- No initialization required
4473 -- Case of initialization procedure present, must be called
4476 Check_Restriction
(No_Default_Initialization
, N
);
4478 if not Restriction_Active
(No_Default_Initialization
) then
4479 Init
:= Base_Init_Proc
(T
);
4481 Temp
:= Make_Temporary
(Loc
, 'P');
4483 -- Construct argument list for the initialization routine call
4486 Make_Explicit_Dereference
(Loc
,
4488 New_Reference_To
(Temp
, Loc
));
4490 Set_Assignment_OK
(Init_Arg1
);
4493 -- The initialization procedure expects a specific type. if the
4494 -- context is access to class wide, indicate that the object
4495 -- being allocated has the right specific type.
4497 if Is_Class_Wide_Type
(Dtyp
) then
4498 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4501 -- If designated type is a concurrent type or if it is private
4502 -- type whose definition is a concurrent type, the first
4503 -- argument in the Init routine has to be unchecked conversion
4504 -- to the corresponding record type. If the designated type is
4505 -- a derived type, also convert the argument to its root type.
4507 if Is_Concurrent_Type
(T
) then
4509 Unchecked_Convert_To
(
4510 Corresponding_Record_Type
(T
), Init_Arg1
);
4512 elsif Is_Private_Type
(T
)
4513 and then Present
(Full_View
(T
))
4514 and then Is_Concurrent_Type
(Full_View
(T
))
4517 Unchecked_Convert_To
4518 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4520 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4522 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4525 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4526 Set_Etype
(Init_Arg1
, Ftyp
);
4530 Args
:= New_List
(Init_Arg1
);
4532 -- For the task case, pass the Master_Id of the access type as
4533 -- the value of the _Master parameter, and _Chain as the value
4534 -- of the _Chain parameter (_Chain will be defined as part of
4535 -- the generated code for the allocator).
4537 -- In Ada 2005, the context may be a function that returns an
4538 -- anonymous access type. In that case the Master_Id has been
4539 -- created when expanding the function declaration.
4541 if Has_Task
(T
) then
4542 if No
(Master_Id
(Base_Type
(PtrT
))) then
4544 -- The designated type was an incomplete type, and the
4545 -- access type did not get expanded. Salvage it now.
4547 if not Restriction_Active
(No_Task_Hierarchy
) then
4548 pragma Assert
(Present
(Parent
(Base_Type
(PtrT
))));
4549 Expand_N_Full_Type_Declaration
4550 (Parent
(Base_Type
(PtrT
)));
4554 -- If the context of the allocator is a declaration or an
4555 -- assignment, we can generate a meaningful image for it,
4556 -- even though subsequent assignments might remove the
4557 -- connection between task and entity. We build this image
4558 -- when the left-hand side is a simple variable, a simple
4559 -- indexed assignment or a simple selected component.
4561 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4563 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4566 if Is_Entity_Name
(Nam
) then
4568 Build_Task_Image_Decls
4571 (Entity
(Nam
), Sloc
(Nam
)), T
);
4573 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4574 N_Selected_Component
)
4575 and then Is_Entity_Name
(Prefix
(Nam
))
4578 Build_Task_Image_Decls
4579 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4581 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4585 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4587 Build_Task_Image_Decls
4588 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4591 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4594 if Restriction_Active
(No_Task_Hierarchy
) then
4596 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4600 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4603 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4605 Decl
:= Last
(Decls
);
4607 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4609 -- Has_Task is false, Decls not used
4615 -- Add discriminants if discriminated type
4618 Dis
: Boolean := False;
4622 if Has_Discriminants
(T
) then
4626 elsif Is_Private_Type
(T
)
4627 and then Present
(Full_View
(T
))
4628 and then Has_Discriminants
(Full_View
(T
))
4631 Typ
:= Full_View
(T
);
4636 -- If the allocated object will be constrained by the
4637 -- default values for discriminants, then build a subtype
4638 -- with those defaults, and change the allocated subtype
4639 -- to that. Note that this happens in fewer cases in Ada
4642 if not Is_Constrained
(Typ
)
4643 and then Present
(Discriminant_Default_Value
4644 (First_Discriminant
(Typ
)))
4645 and then (Ada_Version
< Ada_2005
4647 Effectively_Has_Constrained_Partial_View
4649 Scop
=> Current_Scope
))
4651 Typ
:= Build_Default_Subtype
(Typ
, N
);
4652 Set_Expression
(N
, New_Reference_To
(Typ
, Loc
));
4655 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4656 while Present
(Discr
) loop
4657 Nod
:= Node
(Discr
);
4658 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4660 -- AI-416: when the discriminant constraint is an
4661 -- anonymous access type make sure an accessibility
4662 -- check is inserted if necessary (3.10.2(22.q/2))
4664 if Ada_Version
>= Ada_2005
4666 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4668 Apply_Accessibility_Check
4669 (Nod
, Typ
, Insert_Node
=> Nod
);
4677 -- We set the allocator as analyzed so that when we analyze
4678 -- the if expression node, we do not get an unwanted recursive
4679 -- expansion of the allocator expression.
4681 Set_Analyzed
(N
, True);
4682 Nod
:= Relocate_Node
(N
);
4684 -- Here is the transformation:
4685 -- input: new Ctrl_Typ
4686 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4687 -- Ctrl_TypIP (Temp.all, ...);
4688 -- [Deep_]Initialize (Temp.all);
4690 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4691 -- is the subtype of the allocator.
4694 Make_Object_Declaration
(Loc
,
4695 Defining_Identifier
=> Temp
,
4696 Constant_Present
=> True,
4697 Object_Definition
=> New_Reference_To
(Temp_Type
, Loc
),
4700 Set_Assignment_OK
(Temp_Decl
);
4701 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4703 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
4705 -- If the designated type is a task type or contains tasks,
4706 -- create block to activate created tasks, and insert
4707 -- declaration for Task_Image variable ahead of call.
4709 if Has_Task
(T
) then
4711 L
: constant List_Id
:= New_List
;
4714 Build_Task_Allocate_Block
(L
, Nod
, Args
);
4716 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
4717 Insert_Actions
(N
, L
);
4722 Make_Procedure_Call_Statement
(Loc
,
4723 Name
=> New_Reference_To
(Init
, Loc
),
4724 Parameter_Associations
=> Args
));
4727 if Needs_Finalization
(T
) then
4730 -- [Deep_]Initialize (Init_Arg1);
4734 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4737 if Present
(Finalization_Master
(PtrT
)) then
4739 -- Special processing for .NET/JVM, the allocated object
4740 -- is attached to the finalization master. Generate:
4742 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4744 -- Types derived from [Limited_]Controlled are the only
4745 -- ones considered since they have fields Prev and Next.
4747 if VM_Target
/= No_VM
then
4748 if Is_Controlled
(T
) then
4751 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4755 -- Default case, generate:
4757 -- Set_Finalize_Address
4758 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
4760 -- Do not generate this call in the following cases:
4762 -- * Alfa mode - the call is useless and results in
4763 -- unwanted expansion.
4765 -- * CodePeer mode - TSS primitive Finalize_Address is
4766 -- not created in this mode.
4769 and then not CodePeer_Mode
4772 Make_Set_Finalize_Address_Call
4780 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
4781 Analyze_And_Resolve
(N
, PtrT
);
4786 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4787 -- object that has been rewritten as a reference, we displace "this"
4788 -- to reference properly its secondary dispatch table.
4790 if Nkind
(N
) = N_Identifier
4791 and then Is_Interface
(Dtyp
)
4793 Displace_Allocator_Pointer
(N
);
4797 when RE_Not_Available
=>
4799 end Expand_N_Allocator
;
4801 -----------------------
4802 -- Expand_N_And_Then --
4803 -----------------------
4805 procedure Expand_N_And_Then
(N
: Node_Id
)
4806 renames Expand_Short_Circuit_Operator
;
4808 ------------------------------
4809 -- Expand_N_Case_Expression --
4810 ------------------------------
4812 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4813 Loc
: constant Source_Ptr
:= Sloc
(N
);
4814 Typ
: constant Entity_Id
:= Etype
(N
);
4824 -- Check for MINIMIZED/ELIMINATED overflow mode
4826 if Minimized_Eliminated_Overflow_Check
(N
) then
4827 Apply_Arithmetic_Overflow_Check
(N
);
4833 -- case X is when A => AX, when B => BX ...
4848 -- However, this expansion is wrong for limited types, and also
4849 -- wrong for unconstrained types (since the bounds may not be the
4850 -- same in all branches). Furthermore it involves an extra copy
4851 -- for large objects. So we take care of this by using the following
4852 -- modified expansion for non-elementary types:
4855 -- type Pnn is access all typ;
4859 -- T := AX'Unrestricted_Access;
4861 -- T := BX'Unrestricted_Access;
4867 Make_Case_Statement
(Loc
,
4868 Expression
=> Expression
(N
),
4869 Alternatives
=> New_List
);
4871 Actions
:= New_List
;
4875 if Is_Elementary_Type
(Typ
) then
4879 Pnn
:= Make_Temporary
(Loc
, 'P');
4881 Make_Full_Type_Declaration
(Loc
,
4882 Defining_Identifier
=> Pnn
,
4884 Make_Access_To_Object_Definition
(Loc
,
4885 All_Present
=> True,
4886 Subtype_Indication
=>
4887 New_Reference_To
(Typ
, Loc
))));
4891 Tnn
:= Make_Temporary
(Loc
, 'T');
4893 Make_Object_Declaration
(Loc
,
4894 Defining_Identifier
=> Tnn
,
4895 Object_Definition
=> New_Occurrence_Of
(Ttyp
, Loc
)));
4897 -- Now process the alternatives
4899 Alt
:= First
(Alternatives
(N
));
4900 while Present
(Alt
) loop
4902 Aexp
: Node_Id
:= Expression
(Alt
);
4903 Aloc
: constant Source_Ptr
:= Sloc
(Aexp
);
4907 -- As described above, take Unrestricted_Access for case of non-
4908 -- scalar types, to avoid big copies, and special cases.
4910 if not Is_Elementary_Type
(Typ
) then
4912 Make_Attribute_Reference
(Aloc
,
4913 Prefix
=> Relocate_Node
(Aexp
),
4914 Attribute_Name
=> Name_Unrestricted_Access
);
4918 Make_Assignment_Statement
(Aloc
,
4919 Name
=> New_Occurrence_Of
(Tnn
, Loc
),
4920 Expression
=> Aexp
));
4922 -- Propagate declarations inserted in the node by Insert_Actions
4923 -- (for example, temporaries generated to remove side effects).
4924 -- These actions must remain attached to the alternative, given
4925 -- that they are generated by the corresponding expression.
4927 if Present
(Sinfo
.Actions
(Alt
)) then
4928 Prepend_List
(Sinfo
.Actions
(Alt
), Stats
);
4932 (Alternatives
(Cstmt
),
4933 Make_Case_Statement_Alternative
(Sloc
(Alt
),
4934 Discrete_Choices
=> Discrete_Choices
(Alt
),
4935 Statements
=> Stats
));
4941 Append_To
(Actions
, Cstmt
);
4943 -- Construct and return final expression with actions
4945 if Is_Elementary_Type
(Typ
) then
4946 Fexp
:= New_Occurrence_Of
(Tnn
, Loc
);
4949 Make_Explicit_Dereference
(Loc
,
4950 Prefix
=> New_Occurrence_Of
(Tnn
, Loc
));
4954 Make_Expression_With_Actions
(Loc
,
4956 Actions
=> Actions
));
4958 Analyze_And_Resolve
(N
, Typ
);
4959 end Expand_N_Case_Expression
;
4961 -----------------------------------
4962 -- Expand_N_Explicit_Dereference --
4963 -----------------------------------
4965 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
4967 -- Insert explicit dereference call for the checked storage pool case
4969 Insert_Dereference_Action
(Prefix
(N
));
4971 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
4972 -- we set the atomic sync flag.
4974 if Is_Atomic
(Etype
(N
))
4975 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
4977 Activate_Atomic_Synchronization
(N
);
4979 end Expand_N_Explicit_Dereference
;
4981 --------------------------------------
4982 -- Expand_N_Expression_With_Actions --
4983 --------------------------------------
4985 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
4987 procedure Process_Transient_Object
(Decl
: Node_Id
);
4988 -- Given the declaration of a controlled transient declared inside the
4989 -- Actions list of an Expression_With_Actions, generate all necessary
4990 -- types and hooks in order to properly finalize the transient. This
4991 -- mechanism works in conjunction with Build_Finalizer.
4993 ------------------------------
4994 -- Process_Transient_Object --
4995 ------------------------------
4997 procedure Process_Transient_Object
(Decl
: Node_Id
) is
4999 function Find_Insertion_Node
return Node_Id
;
5000 -- Complex conditions in if statements may be converted into nested
5001 -- EWAs. In this case, any generated code must be inserted before the
5002 -- if statement to ensure proper visibility of the hook objects. This
5003 -- routine returns the top most short circuit operator or the parent
5004 -- of the EWA if no nesting was detected.
5006 -------------------------
5007 -- Find_Insertion_Node --
5008 -------------------------
5010 function Find_Insertion_Node
return Node_Id
is
5014 -- Climb up the branches of a complex condition
5017 while Nkind_In
(Parent
(Par
), N_And_Then
, N_Op_Not
, N_Or_Else
) loop
5018 Par
:= Parent
(Par
);
5022 end Find_Insertion_Node
;
5026 Ins_Node
: constant Node_Id
:= Find_Insertion_Node
;
5027 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
5028 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
5029 Obj_Typ
: constant Entity_Id
:= Etype
(Obj_Id
);
5030 Desig_Typ
: Entity_Id
;
5034 Temp_Decl
: Node_Id
;
5037 -- Start of processing for Process_Transient_Object
5040 -- Step 1: Create the access type which provides a reference to the
5041 -- transient object.
5043 if Is_Access_Type
(Obj_Typ
) then
5044 Desig_Typ
:= Directly_Designated_Type
(Obj_Typ
);
5046 Desig_Typ
:= Obj_Typ
;
5050 -- Ann : access [all] <Desig_Typ>;
5052 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
5055 Make_Full_Type_Declaration
(Loc
,
5056 Defining_Identifier
=> Ptr_Id
,
5058 Make_Access_To_Object_Definition
(Loc
,
5060 Ekind
(Obj_Typ
) = E_General_Access_Type
,
5061 Subtype_Indication
=> New_Reference_To
(Desig_Typ
, Loc
)));
5063 Insert_Action
(Ins_Node
, Ptr_Decl
);
5066 -- Step 2: Create a temporary which acts as a hook to the transient
5067 -- object. Generate:
5069 -- Temp : Ptr_Id := null;
5071 Temp_Id
:= Make_Temporary
(Loc
, 'T');
5074 Make_Object_Declaration
(Loc
,
5075 Defining_Identifier
=> Temp_Id
,
5076 Object_Definition
=> New_Reference_To
(Ptr_Id
, Loc
));
5078 Insert_Action
(Ins_Node
, Temp_Decl
);
5079 Analyze
(Temp_Decl
);
5081 -- Mark this temporary as created for the purposes of exporting the
5082 -- transient declaration out of the Actions list. This signals the
5083 -- machinery in Build_Finalizer to recognize this special case.
5085 Set_Status_Flag_Or_Transient_Decl
(Temp_Id
, Decl
);
5087 -- Step 3: Hook the transient object to the temporary
5089 if Is_Access_Type
(Obj_Typ
) then
5090 Expr
:= Convert_To
(Ptr_Id
, New_Reference_To
(Obj_Id
, Loc
));
5093 Make_Attribute_Reference
(Loc
,
5094 Prefix
=> New_Reference_To
(Obj_Id
, Loc
),
5095 Attribute_Name
=> Name_Unrestricted_Access
);
5099 -- Temp := Ptr_Id (Obj_Id);
5101 -- Temp := Obj_Id'Unrestricted_Access;
5103 Insert_After_And_Analyze
(Decl
,
5104 Make_Assignment_Statement
(Loc
,
5105 Name
=> New_Reference_To
(Temp_Id
, Loc
),
5106 Expression
=> Expr
));
5107 end Process_Transient_Object
;
5113 -- Start of processing for Expand_N_Expression_With_Actions
5116 Decl
:= First
(Actions
(N
));
5117 while Present
(Decl
) loop
5118 if Nkind
(Decl
) = N_Object_Declaration
5119 and then Is_Finalizable_Transient
(Decl
, N
)
5121 Process_Transient_Object
(Decl
);
5126 end Expand_N_Expression_With_Actions
;
5128 ----------------------------
5129 -- Expand_N_If_Expression --
5130 ----------------------------
5132 -- Deal with limited types and condition actions
5134 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5135 function Create_Alternative
5137 Temp_Id
: Entity_Id
;
5138 Flag_Id
: Entity_Id
;
5139 Expr
: Node_Id
) return List_Id
;
5140 -- Build the statements of a "then" or "else" dependent expression
5141 -- alternative. Temp_Id is the if expression result, Flag_Id is a
5142 -- finalization flag created to service expression Expr.
5144 function Is_Controlled_Function_Call
(Expr
: Node_Id
) return Boolean;
5145 -- Determine if expression Expr is a rewritten controlled function call
5147 ------------------------
5148 -- Create_Alternative --
5149 ------------------------
5151 function Create_Alternative
5153 Temp_Id
: Entity_Id
;
5154 Flag_Id
: Entity_Id
;
5155 Expr
: Node_Id
) return List_Id
5157 Result
: constant List_Id
:= New_List
;
5163 if Present
(Flag_Id
)
5164 and then not Is_Controlled_Function_Call
(Expr
)
5167 Make_Assignment_Statement
(Loc
,
5168 Name
=> New_Reference_To
(Flag_Id
, Loc
),
5169 Expression
=> New_Reference_To
(Standard_True
, Loc
)));
5173 -- Cnn := <expr>'Unrestricted_Access;
5176 Make_Assignment_Statement
(Loc
,
5177 Name
=> New_Reference_To
(Temp_Id
, Loc
),
5179 Make_Attribute_Reference
(Loc
,
5180 Prefix
=> Relocate_Node
(Expr
),
5181 Attribute_Name
=> Name_Unrestricted_Access
)));
5184 end Create_Alternative
;
5186 ---------------------------------
5187 -- Is_Controlled_Function_Call --
5188 ---------------------------------
5190 function Is_Controlled_Function_Call
(Expr
: Node_Id
) return Boolean is
5193 Nkind
(Original_Node
(Expr
)) = N_Function_Call
5194 and then Needs_Finalization
(Etype
(Expr
));
5195 end Is_Controlled_Function_Call
;
5199 Loc
: constant Source_Ptr
:= Sloc
(N
);
5200 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5201 Thenx
: constant Node_Id
:= Next
(Cond
);
5202 Elsex
: constant Node_Id
:= Next
(Thenx
);
5203 Typ
: constant Entity_Id
:= Etype
(N
);
5213 -- Check for MINIMIZED/ELIMINATED overflow mode
5215 if Minimized_Eliminated_Overflow_Check
(N
) then
5216 Apply_Arithmetic_Overflow_Check
(N
);
5220 -- Fold at compile time if condition known. We have already folded
5221 -- static if expressions, but it is possible to fold any case in which
5222 -- the condition is known at compile time, even though the result is
5225 -- Note that we don't do the fold of such cases in Sem_Elab because
5226 -- it can cause infinite loops with the expander adding a conditional
5227 -- expression, and Sem_Elab circuitry removing it repeatedly.
5229 if Compile_Time_Known_Value
(Cond
) then
5230 if Is_True
(Expr_Value
(Cond
)) then
5232 Actions
:= Then_Actions
(N
);
5235 Actions
:= Else_Actions
(N
);
5240 if Present
(Actions
) then
5242 -- If we are not allowed to use Expression_With_Actions, just skip
5243 -- the optimization, it is not critical for correctness.
5245 if not Use_Expression_With_Actions
then
5246 goto Skip_Optimization
;
5250 Make_Expression_With_Actions
(Loc
,
5251 Expression
=> Relocate_Node
(Expr
),
5252 Actions
=> Actions
));
5253 Analyze_And_Resolve
(N
, Typ
);
5256 Rewrite
(N
, Relocate_Node
(Expr
));
5259 -- Note that the result is never static (legitimate cases of static
5260 -- if expressions were folded in Sem_Eval).
5262 Set_Is_Static_Expression
(N
, False);
5266 <<Skip_Optimization
>>
5268 -- If the type is limited or unconstrained, we expand as follows to
5269 -- avoid any possibility of improper copies.
5271 -- Note: it may be possible to avoid this special processing if the
5272 -- back end uses its own mechanisms for handling by-reference types ???
5274 -- type Ptr is access all Typ;
5278 -- Cnn := then-expr'Unrestricted_Access;
5281 -- Cnn := else-expr'Unrestricted_Access;
5284 -- and replace the if expression by a reference to Cnn.all.
5286 -- This special case can be skipped if the back end handles limited
5287 -- types properly and ensures that no incorrect copies are made.
5289 if Is_By_Reference_Type
(Typ
)
5290 and then not Back_End_Handles_Limited_Types
5293 Flag_Id
: Entity_Id
;
5294 Ptr_Typ
: Entity_Id
;
5299 -- At least one of the if expression dependent expressions uses a
5300 -- controlled function to provide the result. Create a status flag
5301 -- to signal the finalization machinery that Cnn needs special
5304 if Is_Controlled_Function_Call
(Thenx
)
5306 Is_Controlled_Function_Call
(Elsex
)
5308 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5311 Make_Object_Declaration
(Loc
,
5312 Defining_Identifier
=> Flag_Id
,
5313 Object_Definition
=>
5314 New_Reference_To
(Standard_Boolean
, Loc
),
5316 New_Reference_To
(Standard_False
, Loc
)));
5320 -- type Ann is access all Typ;
5322 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5325 Make_Full_Type_Declaration
(Loc
,
5326 Defining_Identifier
=> Ptr_Typ
,
5328 Make_Access_To_Object_Definition
(Loc
,
5329 All_Present
=> True,
5330 Subtype_Indication
=> New_Reference_To
(Typ
, Loc
))));
5335 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5336 Set_Ekind
(Cnn
, E_Variable
);
5337 Set_Status_Flag_Or_Transient_Decl
(Cnn
, Flag_Id
);
5340 Make_Object_Declaration
(Loc
,
5341 Defining_Identifier
=> Cnn
,
5342 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5345 Make_Implicit_If_Statement
(N
,
5346 Condition
=> Relocate_Node
(Cond
),
5348 Create_Alternative
(Sloc
(Thenx
), Cnn
, Flag_Id
, Thenx
),
5350 Create_Alternative
(Sloc
(Elsex
), Cnn
, Flag_Id
, Elsex
));
5353 Make_Explicit_Dereference
(Loc
,
5354 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5357 -- For other types, we only need to expand if there are other actions
5358 -- associated with either branch.
5360 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5362 -- We have two approaches to handling this. If we are allowed to use
5363 -- N_Expression_With_Actions, then we can just wrap the actions into
5364 -- the appropriate expression.
5366 if Use_Expression_With_Actions
then
5367 if Present
(Then_Actions
(N
)) then
5369 Make_Expression_With_Actions
(Sloc
(Thenx
),
5370 Actions
=> Then_Actions
(N
),
5371 Expression
=> Relocate_Node
(Thenx
)));
5372 Set_Then_Actions
(N
, No_List
);
5373 Analyze_And_Resolve
(Thenx
, Typ
);
5376 if Present
(Else_Actions
(N
)) then
5378 Make_Expression_With_Actions
(Sloc
(Elsex
),
5379 Actions
=> Else_Actions
(N
),
5380 Expression
=> Relocate_Node
(Elsex
)));
5381 Set_Else_Actions
(N
, No_List
);
5382 Analyze_And_Resolve
(Elsex
, Typ
);
5387 -- if we can't use N_Expression_With_Actions nodes, then we insert
5388 -- the following sequence of actions (using Insert_Actions):
5393 -- Cnn := then-expr;
5399 -- and replace the if expression by a reference to Cnn
5402 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5405 Make_Object_Declaration
(Loc
,
5406 Defining_Identifier
=> Cnn
,
5407 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
5410 Make_Implicit_If_Statement
(N
,
5411 Condition
=> Relocate_Node
(Cond
),
5413 Then_Statements
=> New_List
(
5414 Make_Assignment_Statement
(Sloc
(Thenx
),
5415 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5416 Expression
=> Relocate_Node
(Thenx
))),
5418 Else_Statements
=> New_List
(
5419 Make_Assignment_Statement
(Sloc
(Elsex
),
5420 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5421 Expression
=> Relocate_Node
(Elsex
))));
5423 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
5424 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
5426 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
5429 -- If no actions then no expansion needed, gigi will handle it using
5430 -- the same approach as a C conditional expression.
5436 -- Fall through here for either the limited expansion, or the case of
5437 -- inserting actions for non-limited types. In both these cases, we must
5438 -- move the SLOC of the parent If statement to the newly created one and
5439 -- change it to the SLOC of the expression which, after expansion, will
5440 -- correspond to what is being evaluated.
5442 if Present
(Parent
(N
))
5443 and then Nkind
(Parent
(N
)) = N_If_Statement
5445 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5446 Set_Sloc
(Parent
(N
), Loc
);
5449 -- Make sure Then_Actions and Else_Actions are appropriately moved
5450 -- to the new if statement.
5452 if Present
(Then_Actions
(N
)) then
5454 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5457 if Present
(Else_Actions
(N
)) then
5459 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5462 Insert_Action
(N
, Decl
);
5463 Insert_Action
(N
, New_If
);
5465 Analyze_And_Resolve
(N
, Typ
);
5466 end Expand_N_If_Expression
;
5472 procedure Expand_N_In
(N
: Node_Id
) is
5473 Loc
: constant Source_Ptr
:= Sloc
(N
);
5474 Restyp
: constant Entity_Id
:= Etype
(N
);
5475 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5476 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5477 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5482 procedure Substitute_Valid_Check
;
5483 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5484 -- test for the left operand being in range of its subtype.
5486 ----------------------------
5487 -- Substitute_Valid_Check --
5488 ----------------------------
5490 procedure Substitute_Valid_Check
is
5493 Make_Attribute_Reference
(Loc
,
5494 Prefix
=> Relocate_Node
(Lop
),
5495 Attribute_Name
=> Name_Valid
));
5497 Analyze_And_Resolve
(N
, Restyp
);
5499 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5500 -- in which case, this usage makes sense, and in any case, we have
5501 -- actually eliminated the danger of optimization above.
5503 if Overflow_Check_Mode
(Restyp
) not in Minimized_Or_Eliminated
then
5504 Error_Msg_N
("?explicit membership test may be optimized away", N
);
5505 Error_Msg_N
-- CODEFIX
5506 ("\?use ''Valid attribute instead", N
);
5510 end Substitute_Valid_Check
;
5512 -- Start of processing for Expand_N_In
5515 -- If set membership case, expand with separate procedure
5517 if Present
(Alternatives
(N
)) then
5518 Expand_Set_Membership
(N
);
5522 -- Not set membership, proceed with expansion
5524 Ltyp
:= Etype
(Left_Opnd
(N
));
5525 Rtyp
:= Etype
(Right_Opnd
(N
));
5527 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5528 -- type, then expand with a separate procedure. Note the use of the
5529 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5531 if Overflow_Check_Mode
(Empty
) in Minimized_Or_Eliminated
5532 and then Is_Signed_Integer_Type
(Ltyp
)
5533 and then not No_Minimize_Eliminate
(N
)
5535 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
5539 -- Check case of explicit test for an expression in range of its
5540 -- subtype. This is suspicious usage and we replace it with a 'Valid
5541 -- test and give a warning for scalar types.
5543 if Is_Scalar_Type
(Ltyp
)
5545 -- Only relevant for source comparisons
5547 and then Comes_From_Source
(N
)
5549 -- In floating-point this is a standard way to check for finite values
5550 -- and using 'Valid would typically be a pessimization.
5552 and then not Is_Floating_Point_Type
(Ltyp
)
5554 -- Don't give the message unless right operand is a type entity and
5555 -- the type of the left operand matches this type. Note that this
5556 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5557 -- checks have changed the type of the left operand.
5559 and then Nkind
(Rop
) in N_Has_Entity
5560 and then Ltyp
= Entity
(Rop
)
5562 -- Skip in VM mode, where we have no sense of invalid values. The
5563 -- warning still seems relevant, but not important enough to worry.
5565 and then VM_Target
= No_VM
5567 -- Skip this for predicated types, where such expressions are a
5568 -- reasonable way of testing if something meets the predicate.
5570 and then not (Is_Discrete_Type
(Ltyp
)
5571 and then Present
(Predicate_Function
(Ltyp
)))
5573 Substitute_Valid_Check
;
5577 -- Do validity check on operands
5579 if Validity_Checks_On
and Validity_Check_Operands
then
5580 Ensure_Valid
(Left_Opnd
(N
));
5581 Validity_Check_Range
(Right_Opnd
(N
));
5584 -- Case of explicit range
5586 if Nkind
(Rop
) = N_Range
then
5588 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
5589 Hi
: constant Node_Id
:= High_Bound
(Rop
);
5591 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
5592 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
5594 Lcheck
: Compare_Result
;
5595 Ucheck
: Compare_Result
;
5597 Warn1
: constant Boolean :=
5598 Constant_Condition_Warnings
5599 and then Comes_From_Source
(N
)
5600 and then not In_Instance
;
5601 -- This must be true for any of the optimization warnings, we
5602 -- clearly want to give them only for source with the flag on. We
5603 -- also skip these warnings in an instance since it may be the
5604 -- case that different instantiations have different ranges.
5606 Warn2
: constant Boolean :=
5608 and then Nkind
(Original_Node
(Rop
)) = N_Range
5609 and then Is_Integer_Type
(Etype
(Lo
));
5610 -- For the case where only one bound warning is elided, we also
5611 -- insist on an explicit range and an integer type. The reason is
5612 -- that the use of enumeration ranges including an end point is
5613 -- common, as is the use of a subtype name, one of whose bounds is
5614 -- the same as the type of the expression.
5617 -- If test is explicit x'First .. x'Last, replace by valid check
5619 -- Could use some individual comments for this complex test ???
5621 if Is_Scalar_Type
(Ltyp
)
5623 -- And left operand is X'First where X matches left operand
5624 -- type (this eliminates cases of type mismatch, including
5625 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5626 -- type of the left operand.
5628 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
5629 and then Attribute_Name
(Lo_Orig
) = Name_First
5630 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
5631 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
5633 -- Same tests for right operand
5635 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
5636 and then Attribute_Name
(Hi_Orig
) = Name_Last
5637 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
5638 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
5640 -- Relevant only for source cases
5642 and then Comes_From_Source
(N
)
5644 -- Omit for VM cases, where we don't have invalid values
5646 and then VM_Target
= No_VM
5648 Substitute_Valid_Check
;
5652 -- If bounds of type are known at compile time, and the end points
5653 -- are known at compile time and identical, this is another case
5654 -- for substituting a valid test. We only do this for discrete
5655 -- types, since it won't arise in practice for float types.
5657 if Comes_From_Source
(N
)
5658 and then Is_Discrete_Type
(Ltyp
)
5659 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
5660 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
5661 and then Compile_Time_Known_Value
(Lo
)
5662 and then Compile_Time_Known_Value
(Hi
)
5663 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
5664 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
5666 -- Kill warnings in instances, since they may be cases where we
5667 -- have a test in the generic that makes sense with some types
5668 -- and not with other types.
5670 and then not In_Instance
5672 Substitute_Valid_Check
;
5676 -- If we have an explicit range, do a bit of optimization based on
5677 -- range analysis (we may be able to kill one or both checks).
5679 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
5680 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
5682 -- If either check is known to fail, replace result by False since
5683 -- the other check does not matter. Preserve the static flag for
5684 -- legality checks, because we are constant-folding beyond RM 4.9.
5686 if Lcheck
= LT
or else Ucheck
= GT
then
5688 Error_Msg_N
("?range test optimized away", N
);
5689 Error_Msg_N
("\?value is known to be out of range", N
);
5692 Rewrite
(N
, New_Reference_To
(Standard_False
, Loc
));
5693 Analyze_And_Resolve
(N
, Restyp
);
5694 Set_Is_Static_Expression
(N
, Static
);
5697 -- If both checks are known to succeed, replace result by True,
5698 -- since we know we are in range.
5700 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5702 Error_Msg_N
("?range test optimized away", N
);
5703 Error_Msg_N
("\?value is known to be in range", N
);
5706 Rewrite
(N
, New_Reference_To
(Standard_True
, Loc
));
5707 Analyze_And_Resolve
(N
, Restyp
);
5708 Set_Is_Static_Expression
(N
, Static
);
5711 -- If lower bound check succeeds and upper bound check is not
5712 -- known to succeed or fail, then replace the range check with
5713 -- a comparison against the upper bound.
5715 elsif Lcheck
in Compare_GE
then
5716 if Warn2
and then not In_Instance
then
5717 Error_Msg_N
("?lower bound test optimized away", Lo
);
5718 Error_Msg_N
("\?value is known to be in range", Lo
);
5724 Right_Opnd
=> High_Bound
(Rop
)));
5725 Analyze_And_Resolve
(N
, Restyp
);
5728 -- If upper bound check succeeds and lower bound check is not
5729 -- known to succeed or fail, then replace the range check with
5730 -- a comparison against the lower bound.
5732 elsif Ucheck
in Compare_LE
then
5733 if Warn2
and then not In_Instance
then
5734 Error_Msg_N
("?upper bound test optimized away", Hi
);
5735 Error_Msg_N
("\?value is known to be in range", Hi
);
5741 Right_Opnd
=> Low_Bound
(Rop
)));
5742 Analyze_And_Resolve
(N
, Restyp
);
5746 -- We couldn't optimize away the range check, but there is one
5747 -- more issue. If we are checking constant conditionals, then we
5748 -- see if we can determine the outcome assuming everything is
5749 -- valid, and if so give an appropriate warning.
5751 if Warn1
and then not Assume_No_Invalid_Values
then
5752 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
5753 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
5755 -- Result is out of range for valid value
5757 if Lcheck
= LT
or else Ucheck
= GT
then
5759 ("?value can only be in range if it is invalid", N
);
5761 -- Result is in range for valid value
5763 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5765 ("?value can only be out of range if it is invalid", N
);
5767 -- Lower bound check succeeds if value is valid
5769 elsif Warn2
and then Lcheck
in Compare_GE
then
5771 ("?lower bound check only fails if it is invalid", Lo
);
5773 -- Upper bound check succeeds if value is valid
5775 elsif Warn2
and then Ucheck
in Compare_LE
then
5777 ("?upper bound check only fails for invalid values", Hi
);
5782 -- For all other cases of an explicit range, nothing to be done
5786 -- Here right operand is a subtype mark
5790 Typ
: Entity_Id
:= Etype
(Rop
);
5791 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
5792 Cond
: Node_Id
:= Empty
;
5794 Obj
: Node_Id
:= Lop
;
5795 SCIL_Node
: Node_Id
;
5798 Remove_Side_Effects
(Obj
);
5800 -- For tagged type, do tagged membership operation
5802 if Is_Tagged_Type
(Typ
) then
5804 -- No expansion will be performed when VM_Target, as the VM
5805 -- back-ends will handle the membership tests directly (tags
5806 -- are not explicitly represented in Java objects, so the
5807 -- normal tagged membership expansion is not what we want).
5809 if Tagged_Type_Expansion
then
5810 Tagged_Membership
(N
, SCIL_Node
, New_N
);
5812 Analyze_And_Resolve
(N
, Restyp
);
5814 -- Update decoration of relocated node referenced by the
5817 if Generate_SCIL
and then Present
(SCIL_Node
) then
5818 Set_SCIL_Node
(N
, SCIL_Node
);
5824 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5825 -- This reason we do this is that the bounds may have the wrong
5826 -- type if they come from the original type definition. Also this
5827 -- way we get all the processing above for an explicit range.
5829 -- Don't do this for predicated types, since in this case we
5830 -- want to check the predicate!
5832 elsif Is_Scalar_Type
(Typ
) then
5833 if No
(Predicate_Function
(Typ
)) then
5837 Make_Attribute_Reference
(Loc
,
5838 Attribute_Name
=> Name_First
,
5839 Prefix
=> New_Reference_To
(Typ
, Loc
)),
5842 Make_Attribute_Reference
(Loc
,
5843 Attribute_Name
=> Name_Last
,
5844 Prefix
=> New_Reference_To
(Typ
, Loc
))));
5845 Analyze_And_Resolve
(N
, Restyp
);
5850 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5851 -- a membership test if the subtype mark denotes a constrained
5852 -- Unchecked_Union subtype and the expression lacks inferable
5855 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
5856 and then Is_Constrained
(Typ
)
5857 and then not Has_Inferable_Discriminants
(Lop
)
5860 Make_Raise_Program_Error
(Loc
,
5861 Reason
=> PE_Unchecked_Union_Restriction
));
5863 -- Prevent Gigi from generating incorrect code by rewriting the
5864 -- test as False. What is this undocumented thing about ???
5866 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5870 -- Here we have a non-scalar type
5873 Typ
:= Designated_Type
(Typ
);
5876 if not Is_Constrained
(Typ
) then
5877 Rewrite
(N
, New_Reference_To
(Standard_True
, Loc
));
5878 Analyze_And_Resolve
(N
, Restyp
);
5880 -- For the constrained array case, we have to check the subscripts
5881 -- for an exact match if the lengths are non-zero (the lengths
5882 -- must match in any case).
5884 elsif Is_Array_Type
(Typ
) then
5885 Check_Subscripts
: declare
5886 function Build_Attribute_Reference
5889 Dim
: Nat
) return Node_Id
;
5890 -- Build attribute reference E'Nam (Dim)
5892 -------------------------------
5893 -- Build_Attribute_Reference --
5894 -------------------------------
5896 function Build_Attribute_Reference
5899 Dim
: Nat
) return Node_Id
5903 Make_Attribute_Reference
(Loc
,
5905 Attribute_Name
=> Nam
,
5906 Expressions
=> New_List
(
5907 Make_Integer_Literal
(Loc
, Dim
)));
5908 end Build_Attribute_Reference
;
5910 -- Start of processing for Check_Subscripts
5913 for J
in 1 .. Number_Dimensions
(Typ
) loop
5914 Evolve_And_Then
(Cond
,
5917 Build_Attribute_Reference
5918 (Duplicate_Subexpr_No_Checks
(Obj
),
5921 Build_Attribute_Reference
5922 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
5924 Evolve_And_Then
(Cond
,
5927 Build_Attribute_Reference
5928 (Duplicate_Subexpr_No_Checks
(Obj
),
5931 Build_Attribute_Reference
5932 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
5941 Right_Opnd
=> Make_Null
(Loc
)),
5942 Right_Opnd
=> Cond
);
5946 Analyze_And_Resolve
(N
, Restyp
);
5947 end Check_Subscripts
;
5949 -- These are the cases where constraint checks may be required,
5950 -- e.g. records with possible discriminants
5953 -- Expand the test into a series of discriminant comparisons.
5954 -- The expression that is built is the negation of the one that
5955 -- is used for checking discriminant constraints.
5957 Obj
:= Relocate_Node
(Left_Opnd
(N
));
5959 if Has_Discriminants
(Typ
) then
5960 Cond
:= Make_Op_Not
(Loc
,
5961 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
5964 Cond
:= Make_Or_Else
(Loc
,
5968 Right_Opnd
=> Make_Null
(Loc
)),
5969 Right_Opnd
=> Cond
);
5973 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
5977 Analyze_And_Resolve
(N
, Restyp
);
5980 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5981 -- expression of an anonymous access type. This can involve an
5982 -- accessibility test and a tagged type membership test in the
5983 -- case of tagged designated types.
5985 if Ada_Version
>= Ada_2012
5987 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
5990 Expr_Entity
: Entity_Id
:= Empty
;
5992 Param_Level
: Node_Id
;
5993 Type_Level
: Node_Id
;
5996 if Is_Entity_Name
(Lop
) then
5997 Expr_Entity
:= Param_Entity
(Lop
);
5999 if not Present
(Expr_Entity
) then
6000 Expr_Entity
:= Entity
(Lop
);
6004 -- If a conversion of the anonymous access value to the
6005 -- tested type would be illegal, then the result is False.
6007 if not Valid_Conversion
6008 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6010 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6011 Analyze_And_Resolve
(N
, Restyp
);
6013 -- Apply an accessibility check if the access object has an
6014 -- associated access level and when the level of the type is
6015 -- less deep than the level of the access parameter. This
6016 -- only occur for access parameters and stand-alone objects
6017 -- of an anonymous access type.
6020 if Present
(Expr_Entity
)
6023 (Effective_Extra_Accessibility
(Expr_Entity
))
6024 and then UI_Gt
(Object_Access_Level
(Lop
),
6025 Type_Access_Level
(Rtyp
))
6029 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
6032 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6034 -- Return True only if the accessibility level of the
6035 -- expression entity is not deeper than the level of
6036 -- the tested access type.
6040 Left_Opnd
=> Relocate_Node
(N
),
6041 Right_Opnd
=> Make_Op_Le
(Loc
,
6042 Left_Opnd
=> Param_Level
,
6043 Right_Opnd
=> Type_Level
)));
6045 Analyze_And_Resolve
(N
);
6048 -- If the designated type is tagged, do tagged membership
6051 -- *** NOTE: we have to check not null before doing the
6052 -- tagged membership test (but maybe that can be done
6053 -- inside Tagged_Membership?).
6055 if Is_Tagged_Type
(Typ
) then
6058 Left_Opnd
=> Relocate_Node
(N
),
6062 Right_Opnd
=> Make_Null
(Loc
))));
6064 -- No expansion will be performed when VM_Target, as
6065 -- the VM back-ends will handle the membership tests
6066 -- directly (tags are not explicitly represented in
6067 -- Java objects, so the normal tagged membership
6068 -- expansion is not what we want).
6070 if Tagged_Type_Expansion
then
6072 -- Note that we have to pass Original_Node, because
6073 -- the membership test might already have been
6074 -- rewritten by earlier parts of membership test.
6077 (Original_Node
(N
), SCIL_Node
, New_N
);
6079 -- Update decoration of relocated node referenced
6080 -- by the SCIL node.
6082 if Generate_SCIL
and then Present
(SCIL_Node
) then
6083 Set_SCIL_Node
(New_N
, SCIL_Node
);
6088 Left_Opnd
=> Relocate_Node
(N
),
6089 Right_Opnd
=> New_N
));
6091 Analyze_And_Resolve
(N
, Restyp
);
6100 -- At this point, we have done the processing required for the basic
6101 -- membership test, but not yet dealt with the predicate.
6105 -- If a predicate is present, then we do the predicate test, but we
6106 -- most certainly want to omit this if we are within the predicate
6107 -- function itself, since otherwise we have an infinite recursion!
6110 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6114 and then Current_Scope
/= PFunc
6118 Left_Opnd
=> Relocate_Node
(N
),
6119 Right_Opnd
=> Make_Predicate_Call
(Rtyp
, Lop
)));
6121 -- Analyze new expression, mark left operand as analyzed to
6122 -- avoid infinite recursion adding predicate calls. Similarly,
6123 -- suppress further range checks on the call.
6125 Set_Analyzed
(Left_Opnd
(N
));
6126 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6128 -- All done, skip attempt at compile time determination of result
6135 --------------------------------
6136 -- Expand_N_Indexed_Component --
6137 --------------------------------
6139 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6140 Loc
: constant Source_Ptr
:= Sloc
(N
);
6141 Typ
: constant Entity_Id
:= Etype
(N
);
6142 P
: constant Node_Id
:= Prefix
(N
);
6143 T
: constant Entity_Id
:= Etype
(P
);
6147 -- A special optimization, if we have an indexed component that is
6148 -- selecting from a slice, then we can eliminate the slice, since, for
6149 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6150 -- the range check required by the slice. The range check for the slice
6151 -- itself has already been generated. The range check for the
6152 -- subscripting operation is ensured by converting the subject to
6153 -- the subtype of the slice.
6155 -- This optimization not only generates better code, avoiding slice
6156 -- messing especially in the packed case, but more importantly bypasses
6157 -- some problems in handling this peculiar case, for example, the issue
6158 -- of dealing specially with object renamings.
6160 if Nkind
(P
) = N_Slice
then
6162 Make_Indexed_Component
(Loc
,
6163 Prefix
=> Prefix
(P
),
6164 Expressions
=> New_List
(
6166 (Etype
(First_Index
(Etype
(P
))),
6167 First
(Expressions
(N
))))));
6168 Analyze_And_Resolve
(N
, Typ
);
6172 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6173 -- function, then additional actuals must be passed.
6175 if Ada_Version
>= Ada_2005
6176 and then Is_Build_In_Place_Function_Call
(P
)
6178 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6181 -- If the prefix is an access type, then we unconditionally rewrite if
6182 -- as an explicit dereference. This simplifies processing for several
6183 -- cases, including packed array cases and certain cases in which checks
6184 -- must be generated. We used to try to do this only when it was
6185 -- necessary, but it cleans up the code to do it all the time.
6187 if Is_Access_Type
(T
) then
6188 Insert_Explicit_Dereference
(P
);
6189 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6190 Atp
:= Designated_Type
(T
);
6195 -- Generate index and validity checks
6197 Generate_Index_Checks
(N
);
6199 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6200 Apply_Subscript_Validity_Checks
(N
);
6203 -- If selecting from an array with atomic components, and atomic sync
6204 -- is not suppressed for this array type, set atomic sync flag.
6206 if (Has_Atomic_Components
(Atp
)
6207 and then not Atomic_Synchronization_Disabled
(Atp
))
6208 or else (Is_Atomic
(Typ
)
6209 and then not Atomic_Synchronization_Disabled
(Typ
))
6211 Activate_Atomic_Synchronization
(N
);
6214 -- All done for the non-packed case
6216 if not Is_Packed
(Etype
(Prefix
(N
))) then
6220 -- For packed arrays that are not bit-packed (i.e. the case of an array
6221 -- with one or more index types with a non-contiguous enumeration type),
6222 -- we can always use the normal packed element get circuit.
6224 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6225 Expand_Packed_Element_Reference
(N
);
6229 -- For a reference to a component of a bit packed array, we have to
6230 -- convert it to a reference to the corresponding Packed_Array_Type.
6231 -- We only want to do this for simple references, and not for:
6233 -- Left side of assignment, or prefix of left side of assignment, or
6234 -- prefix of the prefix, to handle packed arrays of packed arrays,
6235 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6237 -- Renaming objects in renaming associations
6238 -- This case is handled when a use of the renamed variable occurs
6240 -- Actual parameters for a procedure call
6241 -- This case is handled in Exp_Ch6.Expand_Actuals
6243 -- The second expression in a 'Read attribute reference
6245 -- The prefix of an address or bit or size attribute reference
6247 -- The following circuit detects these exceptions
6250 Child
: Node_Id
:= N
;
6251 Parnt
: Node_Id
:= Parent
(N
);
6255 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6258 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6259 N_Procedure_Call_Statement
)
6260 or else (Nkind
(Parnt
) = N_Parameter_Association
6262 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6266 elsif Nkind
(Parnt
) = N_Attribute_Reference
6267 and then (Attribute_Name
(Parnt
) = Name_Address
6269 Attribute_Name
(Parnt
) = Name_Bit
6271 Attribute_Name
(Parnt
) = Name_Size
)
6272 and then Prefix
(Parnt
) = Child
6276 elsif Nkind
(Parnt
) = N_Assignment_Statement
6277 and then Name
(Parnt
) = Child
6281 -- If the expression is an index of an indexed component, it must
6282 -- be expanded regardless of context.
6284 elsif Nkind
(Parnt
) = N_Indexed_Component
6285 and then Child
/= Prefix
(Parnt
)
6287 Expand_Packed_Element_Reference
(N
);
6290 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6291 and then Name
(Parent
(Parnt
)) = Parnt
6295 elsif Nkind
(Parnt
) = N_Attribute_Reference
6296 and then Attribute_Name
(Parnt
) = Name_Read
6297 and then Next
(First
(Expressions
(Parnt
))) = Child
6301 elsif Nkind_In
(Parnt
, N_Indexed_Component
, N_Selected_Component
)
6302 and then Prefix
(Parnt
) = Child
6307 Expand_Packed_Element_Reference
(N
);
6311 -- Keep looking up tree for unchecked expression, or if we are the
6312 -- prefix of a possible assignment left side.
6315 Parnt
:= Parent
(Child
);
6318 end Expand_N_Indexed_Component
;
6320 ---------------------
6321 -- Expand_N_Not_In --
6322 ---------------------
6324 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6325 -- can be done. This avoids needing to duplicate this expansion code.
6327 procedure Expand_N_Not_In
(N
: Node_Id
) is
6328 Loc
: constant Source_Ptr
:= Sloc
(N
);
6329 Typ
: constant Entity_Id
:= Etype
(N
);
6330 Cfs
: constant Boolean := Comes_From_Source
(N
);
6337 Left_Opnd
=> Left_Opnd
(N
),
6338 Right_Opnd
=> Right_Opnd
(N
))));
6340 -- If this is a set membership, preserve list of alternatives
6342 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6344 -- We want this to appear as coming from source if original does (see
6345 -- transformations in Expand_N_In).
6347 Set_Comes_From_Source
(N
, Cfs
);
6348 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6350 -- Now analyze transformed node
6352 Analyze_And_Resolve
(N
, Typ
);
6353 end Expand_N_Not_In
;
6359 -- The only replacement required is for the case of a null of a type that
6360 -- is an access to protected subprogram, or a subtype thereof. We represent
6361 -- such access values as a record, and so we must replace the occurrence of
6362 -- null by the equivalent record (with a null address and a null pointer in
6363 -- it), so that the backend creates the proper value.
6365 procedure Expand_N_Null
(N
: Node_Id
) is
6366 Loc
: constant Source_Ptr
:= Sloc
(N
);
6367 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6371 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6373 Make_Aggregate
(Loc
,
6374 Expressions
=> New_List
(
6375 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6379 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6381 -- For subsequent semantic analysis, the node must retain its type.
6382 -- Gigi in any case replaces this type by the corresponding record
6383 -- type before processing the node.
6389 when RE_Not_Available
=>
6393 ---------------------
6394 -- Expand_N_Op_Abs --
6395 ---------------------
6397 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6398 Loc
: constant Source_Ptr
:= Sloc
(N
);
6399 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6402 Unary_Op_Validity_Checks
(N
);
6404 -- Check for MINIMIZED/ELIMINATED overflow mode
6406 if Minimized_Eliminated_Overflow_Check
(N
) then
6407 Apply_Arithmetic_Overflow_Check
(N
);
6411 -- Deal with software overflow checking
6413 if not Backend_Overflow_Checks_On_Target
6414 and then Is_Signed_Integer_Type
(Etype
(N
))
6415 and then Do_Overflow_Check
(N
)
6417 -- The only case to worry about is when the argument is equal to the
6418 -- largest negative number, so what we do is to insert the check:
6420 -- [constraint_error when Expr = typ'Base'First]
6422 -- with the usual Duplicate_Subexpr use coding for expr
6425 Make_Raise_Constraint_Error
(Loc
,
6428 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6430 Make_Attribute_Reference
(Loc
,
6432 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6433 Attribute_Name
=> Name_First
)),
6434 Reason
=> CE_Overflow_Check_Failed
));
6437 -- Vax floating-point types case
6439 if Vax_Float
(Etype
(N
)) then
6440 Expand_Vax_Arith
(N
);
6442 end Expand_N_Op_Abs
;
6444 ---------------------
6445 -- Expand_N_Op_Add --
6446 ---------------------
6448 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6449 Typ
: constant Entity_Id
:= Etype
(N
);
6452 Binary_Op_Validity_Checks
(N
);
6454 -- Check for MINIMIZED/ELIMINATED overflow mode
6456 if Minimized_Eliminated_Overflow_Check
(N
) then
6457 Apply_Arithmetic_Overflow_Check
(N
);
6461 -- N + 0 = 0 + N = N for integer types
6463 if Is_Integer_Type
(Typ
) then
6464 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6465 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6467 Rewrite
(N
, Left_Opnd
(N
));
6470 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6471 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
6473 Rewrite
(N
, Right_Opnd
(N
));
6478 -- Arithmetic overflow checks for signed integer/fixed point types
6480 if Is_Signed_Integer_Type
(Typ
)
6481 or else Is_Fixed_Point_Type
(Typ
)
6483 Apply_Arithmetic_Overflow_Check
(N
);
6486 -- Vax floating-point types case
6488 elsif Vax_Float
(Typ
) then
6489 Expand_Vax_Arith
(N
);
6491 end Expand_N_Op_Add
;
6493 ---------------------
6494 -- Expand_N_Op_And --
6495 ---------------------
6497 procedure Expand_N_Op_And
(N
: Node_Id
) is
6498 Typ
: constant Entity_Id
:= Etype
(N
);
6501 Binary_Op_Validity_Checks
(N
);
6503 if Is_Array_Type
(Etype
(N
)) then
6504 Expand_Boolean_Operator
(N
);
6506 elsif Is_Boolean_Type
(Etype
(N
)) then
6507 Adjust_Condition
(Left_Opnd
(N
));
6508 Adjust_Condition
(Right_Opnd
(N
));
6509 Set_Etype
(N
, Standard_Boolean
);
6510 Adjust_Result_Type
(N
, Typ
);
6512 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
6513 Expand_Intrinsic_Call
(N
, Entity
(N
));
6516 end Expand_N_Op_And
;
6518 ------------------------
6519 -- Expand_N_Op_Concat --
6520 ------------------------
6522 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
6524 -- List of operands to be concatenated
6527 -- Node which is to be replaced by the result of concatenating the nodes
6528 -- in the list Opnds.
6531 -- Ensure validity of both operands
6533 Binary_Op_Validity_Checks
(N
);
6535 -- If we are the left operand of a concatenation higher up the tree,
6536 -- then do nothing for now, since we want to deal with a series of
6537 -- concatenations as a unit.
6539 if Nkind
(Parent
(N
)) = N_Op_Concat
6540 and then N
= Left_Opnd
(Parent
(N
))
6545 -- We get here with a concatenation whose left operand may be a
6546 -- concatenation itself with a consistent type. We need to process
6547 -- these concatenation operands from left to right, which means
6548 -- from the deepest node in the tree to the highest node.
6551 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
6552 Cnode
:= Left_Opnd
(Cnode
);
6555 -- Now Cnode is the deepest concatenation, and its parents are the
6556 -- concatenation nodes above, so now we process bottom up, doing the
6557 -- operations. We gather a string that is as long as possible up to five
6560 -- The outer loop runs more than once if more than one concatenation
6561 -- type is involved.
6564 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
6565 Set_Parent
(Opnds
, N
);
6567 -- The inner loop gathers concatenation operands
6569 Inner
: while Cnode
/= N
6570 and then Base_Type
(Etype
(Cnode
)) =
6571 Base_Type
(Etype
(Parent
(Cnode
)))
6573 Cnode
:= Parent
(Cnode
);
6574 Append
(Right_Opnd
(Cnode
), Opnds
);
6577 Expand_Concatenate
(Cnode
, Opnds
);
6579 exit Outer
when Cnode
= N
;
6580 Cnode
:= Parent
(Cnode
);
6582 end Expand_N_Op_Concat
;
6584 ------------------------
6585 -- Expand_N_Op_Divide --
6586 ------------------------
6588 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
6589 Loc
: constant Source_Ptr
:= Sloc
(N
);
6590 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
6591 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
6592 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
6593 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
6594 Typ
: Entity_Id
:= Etype
(N
);
6595 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
6597 Compile_Time_Known_Value
(Ropnd
);
6601 Binary_Op_Validity_Checks
(N
);
6603 -- Check for MINIMIZED/ELIMINATED overflow mode
6605 if Minimized_Eliminated_Overflow_Check
(N
) then
6606 Apply_Arithmetic_Overflow_Check
(N
);
6610 -- Otherwise proceed with expansion of division
6613 Rval
:= Expr_Value
(Ropnd
);
6616 -- N / 1 = N for integer types
6618 if Rknow
and then Rval
= Uint_1
then
6623 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6624 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6625 -- operand is an unsigned integer, as required for this to work.
6627 if Nkind
(Ropnd
) = N_Op_Expon
6628 and then Is_Power_Of_2_For_Shift
(Ropnd
)
6630 -- We cannot do this transformation in configurable run time mode if we
6631 -- have 64-bit integers and long shifts are not available.
6635 or else Support_Long_Shifts_On_Target
)
6638 Make_Op_Shift_Right
(Loc
,
6641 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
6642 Analyze_And_Resolve
(N
, Typ
);
6646 -- Do required fixup of universal fixed operation
6648 if Typ
= Universal_Fixed
then
6649 Fixup_Universal_Fixed_Operation
(N
);
6653 -- Divisions with fixed-point results
6655 if Is_Fixed_Point_Type
(Typ
) then
6657 -- No special processing if Treat_Fixed_As_Integer is set, since
6658 -- from a semantic point of view such operations are simply integer
6659 -- operations and will be treated that way.
6661 if not Treat_Fixed_As_Integer
(N
) then
6662 if Is_Integer_Type
(Rtyp
) then
6663 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
6665 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
6669 -- Other cases of division of fixed-point operands. Again we exclude the
6670 -- case where Treat_Fixed_As_Integer is set.
6672 elsif (Is_Fixed_Point_Type
(Ltyp
) or else
6673 Is_Fixed_Point_Type
(Rtyp
))
6674 and then not Treat_Fixed_As_Integer
(N
)
6676 if Is_Integer_Type
(Typ
) then
6677 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
6679 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6680 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
6683 -- Mixed-mode operations can appear in a non-static universal context,
6684 -- in which case the integer argument must be converted explicitly.
6686 elsif Typ
= Universal_Real
6687 and then Is_Integer_Type
(Rtyp
)
6690 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
6692 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
6694 elsif Typ
= Universal_Real
6695 and then Is_Integer_Type
(Ltyp
)
6698 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
6700 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
6702 -- Non-fixed point cases, do integer zero divide and overflow checks
6704 elsif Is_Integer_Type
(Typ
) then
6705 Apply_Divide_Checks
(N
);
6707 -- Deal with Vax_Float
6709 elsif Vax_Float
(Typ
) then
6710 Expand_Vax_Arith
(N
);
6713 end Expand_N_Op_Divide
;
6715 --------------------
6716 -- Expand_N_Op_Eq --
6717 --------------------
6719 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
6720 Loc
: constant Source_Ptr
:= Sloc
(N
);
6721 Typ
: constant Entity_Id
:= Etype
(N
);
6722 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
6723 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
6724 Bodies
: constant List_Id
:= New_List
;
6725 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
6727 Typl
: Entity_Id
:= A_Typ
;
6728 Op_Name
: Entity_Id
;
6731 procedure Build_Equality_Call
(Eq
: Entity_Id
);
6732 -- If a constructed equality exists for the type or for its parent,
6733 -- build and analyze call, adding conversions if the operation is
6736 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
6737 -- Determines whether a type has a subcomponent of an unconstrained
6738 -- Unchecked_Union subtype. Typ is a record type.
6740 -------------------------
6741 -- Build_Equality_Call --
6742 -------------------------
6744 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
6745 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
6746 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
6747 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
6750 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
6751 and then not Is_Class_Wide_Type
(A_Typ
)
6753 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
6754 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
6757 -- If we have an Unchecked_Union, we need to add the inferred
6758 -- discriminant values as actuals in the function call. At this
6759 -- point, the expansion has determined that both operands have
6760 -- inferable discriminants.
6762 if Is_Unchecked_Union
(Op_Type
) then
6764 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
6765 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
6766 Lhs_Discr_Val
: Node_Id
;
6767 Rhs_Discr_Val
: Node_Id
;
6770 -- Per-object constrained selected components require special
6771 -- attention. If the enclosing scope of the component is an
6772 -- Unchecked_Union, we cannot reference its discriminants
6773 -- directly. This is why we use the two extra parameters of
6774 -- the equality function of the enclosing Unchecked_Union.
6776 -- type UU_Type (Discr : Integer := 0) is
6779 -- pragma Unchecked_Union (UU_Type);
6781 -- 1. Unchecked_Union enclosing record:
6783 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6785 -- Comp : UU_Type (Discr);
6787 -- end Enclosing_UU_Type;
6788 -- pragma Unchecked_Union (Enclosing_UU_Type);
6790 -- Obj1 : Enclosing_UU_Type;
6791 -- Obj2 : Enclosing_UU_Type (1);
6793 -- [. . .] Obj1 = Obj2 [. . .]
6797 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6799 -- A and B are the formal parameters of the equality function
6800 -- of Enclosing_UU_Type. The function always has two extra
6801 -- formals to capture the inferred discriminant values.
6803 -- 2. Non-Unchecked_Union enclosing record:
6806 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6809 -- Comp : UU_Type (Discr);
6811 -- end Enclosing_Non_UU_Type;
6813 -- Obj1 : Enclosing_Non_UU_Type;
6814 -- Obj2 : Enclosing_Non_UU_Type (1);
6816 -- ... Obj1 = Obj2 ...
6820 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6821 -- obj1.discr, obj2.discr)) then
6823 -- In this case we can directly reference the discriminants of
6824 -- the enclosing record.
6828 if Nkind
(Lhs
) = N_Selected_Component
6829 and then Has_Per_Object_Constraint
6830 (Entity
(Selector_Name
(Lhs
)))
6832 -- Enclosing record is an Unchecked_Union, use formal A
6834 if Is_Unchecked_Union
6835 (Scope
(Entity
(Selector_Name
(Lhs
))))
6837 Lhs_Discr_Val
:= Make_Identifier
(Loc
, Name_A
);
6839 -- Enclosing record is of a non-Unchecked_Union type, it is
6840 -- possible to reference the discriminant.
6844 Make_Selected_Component
(Loc
,
6845 Prefix
=> Prefix
(Lhs
),
6848 (Get_Discriminant_Value
6849 (First_Discriminant
(Lhs_Type
),
6851 Stored_Constraint
(Lhs_Type
))));
6854 -- Comment needed here ???
6857 -- Infer the discriminant value
6861 (Get_Discriminant_Value
6862 (First_Discriminant
(Lhs_Type
),
6864 Stored_Constraint
(Lhs_Type
)));
6869 if Nkind
(Rhs
) = N_Selected_Component
6870 and then Has_Per_Object_Constraint
6871 (Entity
(Selector_Name
(Rhs
)))
6873 if Is_Unchecked_Union
6874 (Scope
(Entity
(Selector_Name
(Rhs
))))
6876 Rhs_Discr_Val
:= Make_Identifier
(Loc
, Name_B
);
6880 Make_Selected_Component
(Loc
,
6881 Prefix
=> Prefix
(Rhs
),
6883 New_Copy
(Get_Discriminant_Value
(
6884 First_Discriminant
(Rhs_Type
),
6886 Stored_Constraint
(Rhs_Type
))));
6891 New_Copy
(Get_Discriminant_Value
(
6892 First_Discriminant
(Rhs_Type
),
6894 Stored_Constraint
(Rhs_Type
)));
6899 Make_Function_Call
(Loc
,
6900 Name
=> New_Reference_To
(Eq
, Loc
),
6901 Parameter_Associations
=> New_List
(
6908 -- Normal case, not an unchecked union
6912 Make_Function_Call
(Loc
,
6913 Name
=> New_Reference_To
(Eq
, Loc
),
6914 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
6917 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6918 end Build_Equality_Call
;
6920 ------------------------------------
6921 -- Has_Unconstrained_UU_Component --
6922 ------------------------------------
6924 function Has_Unconstrained_UU_Component
6925 (Typ
: Node_Id
) return Boolean
6927 Tdef
: constant Node_Id
:=
6928 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
6932 function Component_Is_Unconstrained_UU
6933 (Comp
: Node_Id
) return Boolean;
6934 -- Determines whether the subtype of the component is an
6935 -- unconstrained Unchecked_Union.
6937 function Variant_Is_Unconstrained_UU
6938 (Variant
: Node_Id
) return Boolean;
6939 -- Determines whether a component of the variant has an unconstrained
6940 -- Unchecked_Union subtype.
6942 -----------------------------------
6943 -- Component_Is_Unconstrained_UU --
6944 -----------------------------------
6946 function Component_Is_Unconstrained_UU
6947 (Comp
: Node_Id
) return Boolean
6950 if Nkind
(Comp
) /= N_Component_Declaration
then
6955 Sindic
: constant Node_Id
:=
6956 Subtype_Indication
(Component_Definition
(Comp
));
6959 -- Unconstrained nominal type. In the case of a constraint
6960 -- present, the node kind would have been N_Subtype_Indication.
6962 if Nkind
(Sindic
) = N_Identifier
then
6963 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
6968 end Component_Is_Unconstrained_UU
;
6970 ---------------------------------
6971 -- Variant_Is_Unconstrained_UU --
6972 ---------------------------------
6974 function Variant_Is_Unconstrained_UU
6975 (Variant
: Node_Id
) return Boolean
6977 Clist
: constant Node_Id
:= Component_List
(Variant
);
6980 if Is_Empty_List
(Component_Items
(Clist
)) then
6984 -- We only need to test one component
6987 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
6990 while Present
(Comp
) loop
6991 if Component_Is_Unconstrained_UU
(Comp
) then
6999 -- None of the components withing the variant were of
7000 -- unconstrained Unchecked_Union type.
7003 end Variant_Is_Unconstrained_UU
;
7005 -- Start of processing for Has_Unconstrained_UU_Component
7008 if Null_Present
(Tdef
) then
7012 Clist
:= Component_List
(Tdef
);
7013 Vpart
:= Variant_Part
(Clist
);
7015 -- Inspect available components
7017 if Present
(Component_Items
(Clist
)) then
7019 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7022 while Present
(Comp
) loop
7024 -- One component is sufficient
7026 if Component_Is_Unconstrained_UU
(Comp
) then
7035 -- Inspect available components withing variants
7037 if Present
(Vpart
) then
7039 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7042 while Present
(Variant
) loop
7044 -- One component within a variant is sufficient
7046 if Variant_Is_Unconstrained_UU
(Variant
) then
7055 -- Neither the available components, nor the components inside the
7056 -- variant parts were of an unconstrained Unchecked_Union subtype.
7059 end Has_Unconstrained_UU_Component
;
7061 -- Start of processing for Expand_N_Op_Eq
7064 Binary_Op_Validity_Checks
(N
);
7066 -- Deal with private types
7068 if Ekind
(Typl
) = E_Private_Type
then
7069 Typl
:= Underlying_Type
(Typl
);
7070 elsif Ekind
(Typl
) = E_Private_Subtype
then
7071 Typl
:= Underlying_Type
(Base_Type
(Typl
));
7076 -- It may happen in error situations that the underlying type is not
7077 -- set. The error will be detected later, here we just defend the
7084 Typl
:= Base_Type
(Typl
);
7086 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7087 -- means we no longer have a comparison operation, we are all done.
7089 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7091 if Nkind
(N
) /= N_Op_Eq
then
7095 -- Boolean types (requiring handling of non-standard case)
7097 if Is_Boolean_Type
(Typl
) then
7098 Adjust_Condition
(Left_Opnd
(N
));
7099 Adjust_Condition
(Right_Opnd
(N
));
7100 Set_Etype
(N
, Standard_Boolean
);
7101 Adjust_Result_Type
(N
, Typ
);
7105 elsif Is_Array_Type
(Typl
) then
7107 -- If we are doing full validity checking, and it is possible for the
7108 -- array elements to be invalid then expand out array comparisons to
7109 -- make sure that we check the array elements.
7111 if Validity_Check_Operands
7112 and then not Is_Known_Valid
(Component_Type
(Typl
))
7115 Save_Force_Validity_Checks
: constant Boolean :=
7116 Force_Validity_Checks
;
7118 Force_Validity_Checks
:= True;
7120 Expand_Array_Equality
7122 Relocate_Node
(Lhs
),
7123 Relocate_Node
(Rhs
),
7126 Insert_Actions
(N
, Bodies
);
7127 Analyze_And_Resolve
(N
, Standard_Boolean
);
7128 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7131 -- Packed case where both operands are known aligned
7133 elsif Is_Bit_Packed_Array
(Typl
)
7134 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7135 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7137 Expand_Packed_Eq
(N
);
7139 -- Where the component type is elementary we can use a block bit
7140 -- comparison (if supported on the target) exception in the case
7141 -- of floating-point (negative zero issues require element by
7142 -- element comparison), and atomic types (where we must be sure
7143 -- to load elements independently) and possibly unaligned arrays.
7145 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7146 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7147 and then not Is_Atomic
(Component_Type
(Typl
))
7148 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7149 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7150 and then Support_Composite_Compare_On_Target
7154 -- For composite and floating-point cases, expand equality loop to
7155 -- make sure of using proper comparisons for tagged types, and
7156 -- correctly handling the floating-point case.
7160 Expand_Array_Equality
7162 Relocate_Node
(Lhs
),
7163 Relocate_Node
(Rhs
),
7166 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7167 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7172 elsif Is_Record_Type
(Typl
) then
7174 -- For tagged types, use the primitive "="
7176 if Is_Tagged_Type
(Typl
) then
7178 -- No need to do anything else compiling under restriction
7179 -- No_Dispatching_Calls. During the semantic analysis we
7180 -- already notified such violation.
7182 if Restriction_Active
(No_Dispatching_Calls
) then
7186 -- If this is derived from an untagged private type completed with
7187 -- a tagged type, it does not have a full view, so we use the
7188 -- primitive operations of the private type. This check should no
7189 -- longer be necessary when these types get their full views???
7191 if Is_Private_Type
(A_Typ
)
7192 and then not Is_Tagged_Type
(A_Typ
)
7193 and then Is_Derived_Type
(A_Typ
)
7194 and then No
(Full_View
(A_Typ
))
7196 -- Search for equality operation, checking that the operands
7197 -- have the same type. Note that we must find a matching entry,
7198 -- or something is very wrong!
7200 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7202 while Present
(Prim
) loop
7203 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7204 and then Etype
(First_Formal
(Node
(Prim
))) =
7205 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7207 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7212 pragma Assert
(Present
(Prim
));
7213 Op_Name
:= Node
(Prim
);
7215 -- Find the type's predefined equality or an overriding
7216 -- user- defined equality. The reason for not simply calling
7217 -- Find_Prim_Op here is that there may be a user-defined
7218 -- overloaded equality op that precedes the equality that we want,
7219 -- so we have to explicitly search (e.g., there could be an
7220 -- equality with two different parameter types).
7223 if Is_Class_Wide_Type
(Typl
) then
7224 Typl
:= Root_Type
(Typl
);
7227 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7228 while Present
(Prim
) loop
7229 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7230 and then Etype
(First_Formal
(Node
(Prim
))) =
7231 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7233 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7238 pragma Assert
(Present
(Prim
));
7239 Op_Name
:= Node
(Prim
);
7242 Build_Equality_Call
(Op_Name
);
7244 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7245 -- predefined equality operator for a type which has a subcomponent
7246 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7248 elsif Has_Unconstrained_UU_Component
(Typl
) then
7250 Make_Raise_Program_Error
(Loc
,
7251 Reason
=> PE_Unchecked_Union_Restriction
));
7253 -- Prevent Gigi from generating incorrect code by rewriting the
7254 -- equality as a standard False. (is this documented somewhere???)
7257 New_Occurrence_Of
(Standard_False
, Loc
));
7259 elsif Is_Unchecked_Union
(Typl
) then
7261 -- If we can infer the discriminants of the operands, we make a
7262 -- call to the TSS equality function.
7264 if Has_Inferable_Discriminants
(Lhs
)
7266 Has_Inferable_Discriminants
(Rhs
)
7269 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7272 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7273 -- the predefined equality operator for an Unchecked_Union type
7274 -- if either of the operands lack inferable discriminants.
7277 Make_Raise_Program_Error
(Loc
,
7278 Reason
=> PE_Unchecked_Union_Restriction
));
7280 -- Prevent Gigi from generating incorrect code by rewriting
7281 -- the equality as a standard False (documented where???).
7284 New_Occurrence_Of
(Standard_False
, Loc
));
7288 -- If a type support function is present (for complex cases), use it
7290 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7292 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7294 -- Otherwise expand the component by component equality. Note that
7295 -- we never use block-bit comparisons for records, because of the
7296 -- problems with gaps. The backend will often be able to recombine
7297 -- the separate comparisons that we generate here.
7300 Remove_Side_Effects
(Lhs
);
7301 Remove_Side_Effects
(Rhs
);
7303 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7305 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7306 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7310 -- Test if result is known at compile time
7312 Rewrite_Comparison
(N
);
7314 -- If we still have comparison for Vax_Float, process it
7316 if Vax_Float
(Typl
) and then Nkind
(N
) in N_Op_Compare
then
7317 Expand_Vax_Comparison
(N
);
7321 Optimize_Length_Comparison
(N
);
7324 -----------------------
7325 -- Expand_N_Op_Expon --
7326 -----------------------
7328 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
7329 Loc
: constant Source_Ptr
:= Sloc
(N
);
7330 Typ
: constant Entity_Id
:= Etype
(N
);
7331 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
7332 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
7333 Bastyp
: constant Node_Id
:= Etype
(Base
);
7334 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
7335 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
7336 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
7345 Binary_Op_Validity_Checks
(N
);
7347 -- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node
7349 if CodePeer_Mode
or Alfa_Mode
then
7353 -- If either operand is of a private type, then we have the use of an
7354 -- intrinsic operator, and we get rid of the privateness, by using root
7355 -- types of underlying types for the actual operation. Otherwise the
7356 -- private types will cause trouble if we expand multiplications or
7357 -- shifts etc. We also do this transformation if the result type is
7358 -- different from the base type.
7360 if Is_Private_Type
(Etype
(Base
))
7361 or else Is_Private_Type
(Typ
)
7362 or else Is_Private_Type
(Exptyp
)
7363 or else Rtyp
/= Root_Type
(Bastyp
)
7366 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
7367 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
7371 Unchecked_Convert_To
(Typ
,
7373 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
7374 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
7375 Analyze_And_Resolve
(N
, Typ
);
7380 -- Check for MINIMIZED/ELIMINATED overflow mode
7382 if Minimized_Eliminated_Overflow_Check
(N
) then
7383 Apply_Arithmetic_Overflow_Check
(N
);
7387 -- Test for case of known right argument where we can replace the
7388 -- exponentiation by an equivalent expression using multiplication.
7390 if Compile_Time_Known_Value
(Exp
) then
7391 Expv
:= Expr_Value
(Exp
);
7393 -- We only fold small non-negative exponents. You might think we
7394 -- could fold small negative exponents for the real case, but we
7395 -- can't because we are required to raise Constraint_Error for
7396 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7397 -- See ACVC test C4A012B.
7399 if Expv
>= 0 and then Expv
<= 4 then
7401 -- X ** 0 = 1 (or 1.0)
7405 -- Call Remove_Side_Effects to ensure that any side effects
7406 -- in the ignored left operand (in particular function calls
7407 -- to user defined functions) are properly executed.
7409 Remove_Side_Effects
(Base
);
7411 if Ekind
(Typ
) in Integer_Kind
then
7412 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
7414 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
7426 Make_Op_Multiply
(Loc
,
7427 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7428 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7430 -- X ** 3 = X * X * X
7434 Make_Op_Multiply
(Loc
,
7436 Make_Op_Multiply
(Loc
,
7437 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7438 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
7439 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
7444 -- En : constant base'type := base * base;
7449 pragma Assert
(Expv
= 4);
7450 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
7453 Make_Expression_With_Actions
(Loc
,
7454 Actions
=> New_List
(
7455 Make_Object_Declaration
(Loc
,
7456 Defining_Identifier
=> Temp
,
7457 Constant_Present
=> True,
7458 Object_Definition
=> New_Reference_To
(Typ
, Loc
),
7460 Make_Op_Multiply
(Loc
,
7462 Duplicate_Subexpr
(Base
),
7464 Duplicate_Subexpr_No_Checks
(Base
)))),
7467 Make_Op_Multiply
(Loc
,
7468 Left_Opnd
=> New_Reference_To
(Temp
, Loc
),
7469 Right_Opnd
=> New_Reference_To
(Temp
, Loc
)));
7473 Analyze_And_Resolve
(N
, Typ
);
7478 -- Case of (2 ** expression) appearing as an argument of an integer
7479 -- multiplication, or as the right argument of a division of a non-
7480 -- negative integer. In such cases we leave the node untouched, setting
7481 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
7482 -- of the higher level node converts it into a shift.
7484 -- Another case is 2 ** N in any other context. We simply convert
7485 -- this to 1 * 2 ** N, and then the above transformation applies.
7487 -- Note: this transformation is not applicable for a modular type with
7488 -- a non-binary modulus in the multiplication case, since we get a wrong
7489 -- result if the shift causes an overflow before the modular reduction.
7491 if Nkind
(Base
) = N_Integer_Literal
7492 and then Intval
(Base
) = 2
7493 and then Is_Integer_Type
(Root_Type
(Exptyp
))
7494 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
7495 and then Is_Unsigned_Type
(Exptyp
)
7498 -- First the multiply and divide cases
7500 if Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
) then
7502 P
: constant Node_Id
:= Parent
(N
);
7503 L
: constant Node_Id
:= Left_Opnd
(P
);
7504 R
: constant Node_Id
:= Right_Opnd
(P
);
7507 if (Nkind
(P
) = N_Op_Multiply
7508 and then not Non_Binary_Modulus
(Typ
)
7510 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
7512 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
7513 and then not Do_Overflow_Check
(P
))
7515 (Nkind
(P
) = N_Op_Divide
7516 and then Is_Integer_Type
(Etype
(L
))
7517 and then Is_Unsigned_Type
(Etype
(L
))
7519 and then not Do_Overflow_Check
(P
))
7521 Set_Is_Power_Of_2_For_Shift
(N
);
7526 -- Now the other cases
7528 elsif not Non_Binary_Modulus
(Typ
) then
7530 Make_Op_Multiply
(Loc
,
7531 Left_Opnd
=> Make_Integer_Literal
(Loc
, 1),
7532 Right_Opnd
=> Relocate_Node
(N
)));
7533 Analyze_And_Resolve
(N
, Typ
);
7538 -- Fall through if exponentiation must be done using a runtime routine
7540 -- First deal with modular case
7542 if Is_Modular_Integer_Type
(Rtyp
) then
7544 -- Non-binary case, we call the special exponentiation routine for
7545 -- the non-binary case, converting the argument to Long_Long_Integer
7546 -- and passing the modulus value. Then the result is converted back
7547 -- to the base type.
7549 if Non_Binary_Modulus
(Rtyp
) then
7552 Make_Function_Call
(Loc
,
7553 Name
=> New_Reference_To
(RTE
(RE_Exp_Modular
), Loc
),
7554 Parameter_Associations
=> New_List
(
7555 Convert_To
(Standard_Integer
, Base
),
7556 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
7559 -- Binary case, in this case, we call one of two routines, either the
7560 -- unsigned integer case, or the unsigned long long integer case,
7561 -- with a final "and" operation to do the required mod.
7564 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
7565 Ent
:= RTE
(RE_Exp_Unsigned
);
7567 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
7574 Make_Function_Call
(Loc
,
7575 Name
=> New_Reference_To
(Ent
, Loc
),
7576 Parameter_Associations
=> New_List
(
7577 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
7580 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
7584 -- Common exit point for modular type case
7586 Analyze_And_Resolve
(N
, Typ
);
7589 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7590 -- It is not worth having routines for Short_[Short_]Integer, since for
7591 -- most machines it would not help, and it would generate more code that
7592 -- might need certification when a certified run time is required.
7594 -- In the integer cases, we have two routines, one for when overflow
7595 -- checks are required, and one when they are not required, since there
7596 -- is a real gain in omitting checks on many machines.
7598 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
7599 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
7601 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
7602 or else (Rtyp
= Universal_Integer
)
7604 Etyp
:= Standard_Long_Long_Integer
;
7607 Rent
:= RE_Exp_Long_Long_Integer
;
7609 Rent
:= RE_Exn_Long_Long_Integer
;
7612 elsif Is_Signed_Integer_Type
(Rtyp
) then
7613 Etyp
:= Standard_Integer
;
7616 Rent
:= RE_Exp_Integer
;
7618 Rent
:= RE_Exn_Integer
;
7621 -- Floating-point cases, always done using Long_Long_Float. We do not
7622 -- need separate routines for the overflow case here, since in the case
7623 -- of floating-point, we generate infinities anyway as a rule (either
7624 -- that or we automatically trap overflow), and if there is an infinity
7625 -- generated and a range check is required, the check will fail anyway.
7628 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
7629 Etyp
:= Standard_Long_Long_Float
;
7630 Rent
:= RE_Exn_Long_Long_Float
;
7633 -- Common processing for integer cases and floating-point cases.
7634 -- If we are in the right type, we can call runtime routine directly
7637 and then Rtyp
/= Universal_Integer
7638 and then Rtyp
/= Universal_Real
7641 Make_Function_Call
(Loc
,
7642 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
7643 Parameter_Associations
=> New_List
(Base
, Exp
)));
7645 -- Otherwise we have to introduce conversions (conversions are also
7646 -- required in the universal cases, since the runtime routine is
7647 -- typed using one of the standard types).
7652 Make_Function_Call
(Loc
,
7653 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
7654 Parameter_Associations
=> New_List
(
7655 Convert_To
(Etyp
, Base
),
7659 Analyze_And_Resolve
(N
, Typ
);
7663 when RE_Not_Available
=>
7665 end Expand_N_Op_Expon
;
7667 --------------------
7668 -- Expand_N_Op_Ge --
7669 --------------------
7671 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
7672 Typ
: constant Entity_Id
:= Etype
(N
);
7673 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7674 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7675 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7678 Binary_Op_Validity_Checks
(N
);
7680 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7681 -- means we no longer have a comparison operation, we are all done.
7683 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7685 if Nkind
(N
) /= N_Op_Ge
then
7691 if Is_Array_Type
(Typ1
) then
7692 Expand_Array_Comparison
(N
);
7696 -- Deal with boolean operands
7698 if Is_Boolean_Type
(Typ1
) then
7699 Adjust_Condition
(Op1
);
7700 Adjust_Condition
(Op2
);
7701 Set_Etype
(N
, Standard_Boolean
);
7702 Adjust_Result_Type
(N
, Typ
);
7705 Rewrite_Comparison
(N
);
7707 -- If we still have comparison, and Vax_Float type, process it
7709 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7710 Expand_Vax_Comparison
(N
);
7714 Optimize_Length_Comparison
(N
);
7717 --------------------
7718 -- Expand_N_Op_Gt --
7719 --------------------
7721 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
7722 Typ
: constant Entity_Id
:= Etype
(N
);
7723 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7724 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7725 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7728 Binary_Op_Validity_Checks
(N
);
7730 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7731 -- means we no longer have a comparison operation, we are all done.
7733 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7735 if Nkind
(N
) /= N_Op_Gt
then
7739 -- Deal with array type operands
7741 if Is_Array_Type
(Typ1
) then
7742 Expand_Array_Comparison
(N
);
7746 -- Deal with boolean type operands
7748 if Is_Boolean_Type
(Typ1
) then
7749 Adjust_Condition
(Op1
);
7750 Adjust_Condition
(Op2
);
7751 Set_Etype
(N
, Standard_Boolean
);
7752 Adjust_Result_Type
(N
, Typ
);
7755 Rewrite_Comparison
(N
);
7757 -- If we still have comparison, and Vax_Float type, process it
7759 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7760 Expand_Vax_Comparison
(N
);
7764 Optimize_Length_Comparison
(N
);
7767 --------------------
7768 -- Expand_N_Op_Le --
7769 --------------------
7771 procedure Expand_N_Op_Le
(N
: Node_Id
) is
7772 Typ
: constant Entity_Id
:= Etype
(N
);
7773 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7774 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7775 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7778 Binary_Op_Validity_Checks
(N
);
7780 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7781 -- means we no longer have a comparison operation, we are all done.
7783 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7785 if Nkind
(N
) /= N_Op_Le
then
7789 -- Deal with array type operands
7791 if Is_Array_Type
(Typ1
) then
7792 Expand_Array_Comparison
(N
);
7796 -- Deal with Boolean type operands
7798 if Is_Boolean_Type
(Typ1
) then
7799 Adjust_Condition
(Op1
);
7800 Adjust_Condition
(Op2
);
7801 Set_Etype
(N
, Standard_Boolean
);
7802 Adjust_Result_Type
(N
, Typ
);
7805 Rewrite_Comparison
(N
);
7807 -- If we still have comparison, and Vax_Float type, process it
7809 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7810 Expand_Vax_Comparison
(N
);
7814 Optimize_Length_Comparison
(N
);
7817 --------------------
7818 -- Expand_N_Op_Lt --
7819 --------------------
7821 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
7822 Typ
: constant Entity_Id
:= Etype
(N
);
7823 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7824 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7825 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
7828 Binary_Op_Validity_Checks
(N
);
7830 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7831 -- means we no longer have a comparison operation, we are all done.
7833 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7835 if Nkind
(N
) /= N_Op_Lt
then
7839 -- Deal with array type operands
7841 if Is_Array_Type
(Typ1
) then
7842 Expand_Array_Comparison
(N
);
7846 -- Deal with Boolean type operands
7848 if Is_Boolean_Type
(Typ1
) then
7849 Adjust_Condition
(Op1
);
7850 Adjust_Condition
(Op2
);
7851 Set_Etype
(N
, Standard_Boolean
);
7852 Adjust_Result_Type
(N
, Typ
);
7855 Rewrite_Comparison
(N
);
7857 -- If we still have comparison, and Vax_Float type, process it
7859 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
7860 Expand_Vax_Comparison
(N
);
7864 Optimize_Length_Comparison
(N
);
7867 -----------------------
7868 -- Expand_N_Op_Minus --
7869 -----------------------
7871 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
7872 Loc
: constant Source_Ptr
:= Sloc
(N
);
7873 Typ
: constant Entity_Id
:= Etype
(N
);
7876 Unary_Op_Validity_Checks
(N
);
7878 -- Check for MINIMIZED/ELIMINATED overflow mode
7880 if Minimized_Eliminated_Overflow_Check
(N
) then
7881 Apply_Arithmetic_Overflow_Check
(N
);
7885 if not Backend_Overflow_Checks_On_Target
7886 and then Is_Signed_Integer_Type
(Etype
(N
))
7887 and then Do_Overflow_Check
(N
)
7889 -- Software overflow checking expands -expr into (0 - expr)
7892 Make_Op_Subtract
(Loc
,
7893 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
7894 Right_Opnd
=> Right_Opnd
(N
)));
7896 Analyze_And_Resolve
(N
, Typ
);
7898 -- Vax floating-point types case
7900 elsif Vax_Float
(Etype
(N
)) then
7901 Expand_Vax_Arith
(N
);
7903 end Expand_N_Op_Minus
;
7905 ---------------------
7906 -- Expand_N_Op_Mod --
7907 ---------------------
7909 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
7910 Loc
: constant Source_Ptr
:= Sloc
(N
);
7911 Typ
: constant Entity_Id
:= Etype
(N
);
7912 DOC
: constant Boolean := Do_Overflow_Check
(N
);
7913 DDC
: constant Boolean := Do_Division_Check
(N
);
7926 pragma Warnings
(Off
, Lhi
);
7929 Binary_Op_Validity_Checks
(N
);
7931 -- Check for MINIMIZED/ELIMINATED overflow mode
7933 if Minimized_Eliminated_Overflow_Check
(N
) then
7934 Apply_Arithmetic_Overflow_Check
(N
);
7938 if Is_Integer_Type
(Etype
(N
)) then
7939 Apply_Divide_Checks
(N
);
7941 -- All done if we don't have a MOD any more, which can happen as a
7942 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
7944 if Nkind
(N
) /= N_Op_Mod
then
7949 -- Proceed with expansion of mod operator
7951 Left
:= Left_Opnd
(N
);
7952 Right
:= Right_Opnd
(N
);
7954 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
7955 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
7957 -- Convert mod to rem if operands are known non-negative. We do this
7958 -- since it is quite likely that this will improve the quality of code,
7959 -- (the operation now corresponds to the hardware remainder), and it
7960 -- does not seem likely that it could be harmful.
7962 if LOK
and then Llo
>= 0
7964 ROK
and then Rlo
>= 0
7967 Make_Op_Rem
(Sloc
(N
),
7968 Left_Opnd
=> Left_Opnd
(N
),
7969 Right_Opnd
=> Right_Opnd
(N
)));
7971 -- Instead of reanalyzing the node we do the analysis manually. This
7972 -- avoids anomalies when the replacement is done in an instance and
7973 -- is epsilon more efficient.
7975 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
7977 Set_Do_Overflow_Check
(N
, DOC
);
7978 Set_Do_Division_Check
(N
, DDC
);
7979 Expand_N_Op_Rem
(N
);
7982 -- Otherwise, normal mod processing
7985 -- Apply optimization x mod 1 = 0. We don't really need that with
7986 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
7987 -- certainly harmless.
7989 if Is_Integer_Type
(Etype
(N
))
7990 and then Compile_Time_Known_Value
(Right
)
7991 and then Expr_Value
(Right
) = Uint_1
7993 -- Call Remove_Side_Effects to ensure that any side effects in
7994 -- the ignored left operand (in particular function calls to
7995 -- user defined functions) are properly executed.
7997 Remove_Side_Effects
(Left
);
7999 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8000 Analyze_And_Resolve
(N
, Typ
);
8004 -- Deal with annoying case of largest negative number remainder
8005 -- minus one. Gigi does not handle this case correctly, because
8006 -- it generates a divide instruction which may trap in this case.
8008 -- In fact the check is quite easy, if the right operand is -1, then
8009 -- the mod value is always 0, and we can just ignore the left operand
8010 -- completely in this case.
8012 -- This only applies if we still have a mod operator. Skip if we
8013 -- have already rewritten this (e.g. in the case of eliminated
8014 -- overflow checks which have driven us into bignum mode).
8016 if Nkind
(N
) = N_Op_Mod
then
8018 -- The operand type may be private (e.g. in the expansion of an
8019 -- intrinsic operation) so we must use the underlying type to get
8020 -- the bounds, and convert the literals explicitly.
8024 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
8026 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
8028 ((not LOK
) or else (Llo
= LLB
))
8031 Make_If_Expression
(Loc
,
8032 Expressions
=> New_List
(
8034 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8036 Unchecked_Convert_To
(Typ
,
8037 Make_Integer_Literal
(Loc
, -1))),
8038 Unchecked_Convert_To
(Typ
,
8039 Make_Integer_Literal
(Loc
, Uint_0
)),
8040 Relocate_Node
(N
))));
8042 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8043 Analyze_And_Resolve
(N
, Typ
);
8047 end Expand_N_Op_Mod
;
8049 --------------------------
8050 -- Expand_N_Op_Multiply --
8051 --------------------------
8053 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
8054 Loc
: constant Source_Ptr
:= Sloc
(N
);
8055 Lop
: constant Node_Id
:= Left_Opnd
(N
);
8056 Rop
: constant Node_Id
:= Right_Opnd
(N
);
8058 Lp2
: constant Boolean :=
8059 Nkind
(Lop
) = N_Op_Expon
8060 and then Is_Power_Of_2_For_Shift
(Lop
);
8062 Rp2
: constant Boolean :=
8063 Nkind
(Rop
) = N_Op_Expon
8064 and then Is_Power_Of_2_For_Shift
(Rop
);
8066 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
8067 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
8068 Typ
: Entity_Id
:= Etype
(N
);
8071 Binary_Op_Validity_Checks
(N
);
8073 -- Check for MINIMIZED/ELIMINATED overflow mode
8075 if Minimized_Eliminated_Overflow_Check
(N
) then
8076 Apply_Arithmetic_Overflow_Check
(N
);
8080 -- Special optimizations for integer types
8082 if Is_Integer_Type
(Typ
) then
8084 -- N * 0 = 0 for integer types
8086 if Compile_Time_Known_Value
(Rop
)
8087 and then Expr_Value
(Rop
) = Uint_0
8089 -- Call Remove_Side_Effects to ensure that any side effects in
8090 -- the ignored left operand (in particular function calls to
8091 -- user defined functions) are properly executed.
8093 Remove_Side_Effects
(Lop
);
8095 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8096 Analyze_And_Resolve
(N
, Typ
);
8100 -- Similar handling for 0 * N = 0
8102 if Compile_Time_Known_Value
(Lop
)
8103 and then Expr_Value
(Lop
) = Uint_0
8105 Remove_Side_Effects
(Rop
);
8106 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8107 Analyze_And_Resolve
(N
, Typ
);
8111 -- N * 1 = 1 * N = N for integer types
8113 -- This optimisation is not done if we are going to
8114 -- rewrite the product 1 * 2 ** N to a shift.
8116 if Compile_Time_Known_Value
(Rop
)
8117 and then Expr_Value
(Rop
) = Uint_1
8123 elsif Compile_Time_Known_Value
(Lop
)
8124 and then Expr_Value
(Lop
) = Uint_1
8132 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8133 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8134 -- operand is an integer, as required for this to work.
8139 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8143 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
8146 Left_Opnd
=> Right_Opnd
(Lop
),
8147 Right_Opnd
=> Right_Opnd
(Rop
))));
8148 Analyze_And_Resolve
(N
, Typ
);
8153 Make_Op_Shift_Left
(Loc
,
8156 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
8157 Analyze_And_Resolve
(N
, Typ
);
8161 -- Same processing for the operands the other way round
8165 Make_Op_Shift_Left
(Loc
,
8168 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
8169 Analyze_And_Resolve
(N
, Typ
);
8173 -- Do required fixup of universal fixed operation
8175 if Typ
= Universal_Fixed
then
8176 Fixup_Universal_Fixed_Operation
(N
);
8180 -- Multiplications with fixed-point results
8182 if Is_Fixed_Point_Type
(Typ
) then
8184 -- No special processing if Treat_Fixed_As_Integer is set, since from
8185 -- a semantic point of view such operations are simply integer
8186 -- operations and will be treated that way.
8188 if not Treat_Fixed_As_Integer
(N
) then
8190 -- Case of fixed * integer => fixed
8192 if Is_Integer_Type
(Rtyp
) then
8193 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
8195 -- Case of integer * fixed => fixed
8197 elsif Is_Integer_Type
(Ltyp
) then
8198 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
8200 -- Case of fixed * fixed => fixed
8203 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
8207 -- Other cases of multiplication of fixed-point operands. Again we
8208 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8210 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
8211 and then not Treat_Fixed_As_Integer
(N
)
8213 if Is_Integer_Type
(Typ
) then
8214 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
8216 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8217 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
8220 -- Mixed-mode operations can appear in a non-static universal context,
8221 -- in which case the integer argument must be converted explicitly.
8223 elsif Typ
= Universal_Real
8224 and then Is_Integer_Type
(Rtyp
)
8226 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
8228 Analyze_And_Resolve
(Rop
, Universal_Real
);
8230 elsif Typ
= Universal_Real
8231 and then Is_Integer_Type
(Ltyp
)
8233 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
8235 Analyze_And_Resolve
(Lop
, Universal_Real
);
8237 -- Non-fixed point cases, check software overflow checking required
8239 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
8240 Apply_Arithmetic_Overflow_Check
(N
);
8242 -- Deal with VAX float case
8244 elsif Vax_Float
(Typ
) then
8245 Expand_Vax_Arith
(N
);
8248 end Expand_N_Op_Multiply
;
8250 --------------------
8251 -- Expand_N_Op_Ne --
8252 --------------------
8254 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
8255 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
8258 -- Case of elementary type with standard operator
8260 if Is_Elementary_Type
(Typ
)
8261 and then Sloc
(Entity
(N
)) = Standard_Location
8263 Binary_Op_Validity_Checks
(N
);
8265 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8266 -- means we no longer have a /= operation, we are all done.
8268 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8270 if Nkind
(N
) /= N_Op_Ne
then
8274 -- Boolean types (requiring handling of non-standard case)
8276 if Is_Boolean_Type
(Typ
) then
8277 Adjust_Condition
(Left_Opnd
(N
));
8278 Adjust_Condition
(Right_Opnd
(N
));
8279 Set_Etype
(N
, Standard_Boolean
);
8280 Adjust_Result_Type
(N
, Typ
);
8283 Rewrite_Comparison
(N
);
8285 -- If we still have comparison for Vax_Float, process it
8287 if Vax_Float
(Typ
) and then Nkind
(N
) in N_Op_Compare
then
8288 Expand_Vax_Comparison
(N
);
8292 -- For all cases other than elementary types, we rewrite node as the
8293 -- negation of an equality operation, and reanalyze. The equality to be
8294 -- used is defined in the same scope and has the same signature. This
8295 -- signature must be set explicitly since in an instance it may not have
8296 -- the same visibility as in the generic unit. This avoids duplicating
8297 -- or factoring the complex code for record/array equality tests etc.
8301 Loc
: constant Source_Ptr
:= Sloc
(N
);
8303 Ne
: constant Entity_Id
:= Entity
(N
);
8306 Binary_Op_Validity_Checks
(N
);
8312 Left_Opnd
=> Left_Opnd
(N
),
8313 Right_Opnd
=> Right_Opnd
(N
)));
8314 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
8316 if Scope
(Ne
) /= Standard_Standard
then
8317 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
8320 -- For navigation purposes, we want to treat the inequality as an
8321 -- implicit reference to the corresponding equality. Preserve the
8322 -- Comes_From_ source flag to generate proper Xref entries.
8324 Preserve_Comes_From_Source
(Neg
, N
);
8325 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
8327 Analyze_And_Resolve
(N
, Standard_Boolean
);
8331 Optimize_Length_Comparison
(N
);
8334 ---------------------
8335 -- Expand_N_Op_Not --
8336 ---------------------
8338 -- If the argument is other than a Boolean array type, there is no special
8339 -- expansion required, except for VMS operations on signed integers.
8341 -- For the packed case, we call the special routine in Exp_Pakd, except
8342 -- that if the component size is greater than one, we use the standard
8343 -- routine generating a gruesome loop (it is so peculiar to have packed
8344 -- arrays with non-standard Boolean representations anyway, so it does not
8345 -- matter that we do not handle this case efficiently).
8347 -- For the unpacked case (and for the special packed case where we have non
8348 -- standard Booleans, as discussed above), we generate and insert into the
8349 -- tree the following function definition:
8351 -- function Nnnn (A : arr) is
8354 -- for J in a'range loop
8355 -- B (J) := not A (J);
8360 -- Here arr is the actual subtype of the parameter (and hence always
8361 -- constrained). Then we replace the not with a call to this function.
8363 procedure Expand_N_Op_Not
(N
: Node_Id
) is
8364 Loc
: constant Source_Ptr
:= Sloc
(N
);
8365 Typ
: constant Entity_Id
:= Etype
(N
);
8374 Func_Name
: Entity_Id
;
8375 Loop_Statement
: Node_Id
;
8378 Unary_Op_Validity_Checks
(N
);
8380 -- For boolean operand, deal with non-standard booleans
8382 if Is_Boolean_Type
(Typ
) then
8383 Adjust_Condition
(Right_Opnd
(N
));
8384 Set_Etype
(N
, Standard_Boolean
);
8385 Adjust_Result_Type
(N
, Typ
);
8389 -- For the VMS "not" on signed integer types, use conversion to and from
8390 -- a predefined modular type.
8392 if Is_VMS_Operator
(Entity
(N
)) then
8398 -- If this is a derived type, retrieve original VMS type so that
8399 -- the proper sized type is used for intermediate values.
8401 if Is_Derived_Type
(Typ
) then
8402 Rtyp
:= First_Subtype
(Etype
(Typ
));
8407 -- The proper unsigned type must have a size compatible with the
8408 -- operand, to prevent misalignment.
8410 if RM_Size
(Rtyp
) <= 8 then
8411 Utyp
:= RTE
(RE_Unsigned_8
);
8413 elsif RM_Size
(Rtyp
) <= 16 then
8414 Utyp
:= RTE
(RE_Unsigned_16
);
8416 elsif RM_Size
(Rtyp
) = RM_Size
(Standard_Unsigned
) then
8417 Utyp
:= RTE
(RE_Unsigned_32
);
8420 Utyp
:= RTE
(RE_Long_Long_Unsigned
);
8424 Unchecked_Convert_To
(Typ
,
8426 Unchecked_Convert_To
(Utyp
, Right_Opnd
(N
)))));
8427 Analyze_And_Resolve
(N
, Typ
);
8432 -- Only array types need any other processing
8434 if not Is_Array_Type
(Typ
) then
8438 -- Case of array operand. If bit packed with a component size of 1,
8439 -- handle it in Exp_Pakd if the operand is known to be aligned.
8441 if Is_Bit_Packed_Array
(Typ
)
8442 and then Component_Size
(Typ
) = 1
8443 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
8445 Expand_Packed_Not
(N
);
8449 -- Case of array operand which is not bit-packed. If the context is
8450 -- a safe assignment, call in-place operation, If context is a larger
8451 -- boolean expression in the context of a safe assignment, expansion is
8452 -- done by enclosing operation.
8454 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
8455 Convert_To_Actual_Subtype
(Opnd
);
8456 Arr
:= Etype
(Opnd
);
8457 Ensure_Defined
(Arr
, N
);
8458 Silly_Boolean_Array_Not_Test
(N
, Arr
);
8460 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
8461 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
8462 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8465 -- Special case the negation of a binary operation
8467 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
8468 and then Safe_In_Place_Array_Op
8469 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
8471 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8475 elsif Nkind
(Parent
(N
)) in N_Binary_Op
8476 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
8479 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
8480 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
8481 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
8484 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
8486 -- (not A) op (not B) can be reduced to a single call
8488 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
8491 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
8494 -- A xor (not B) can also be special-cased
8496 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
8503 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
8504 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8505 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
8508 Make_Indexed_Component
(Loc
,
8509 Prefix
=> New_Reference_To
(A
, Loc
),
8510 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
8513 Make_Indexed_Component
(Loc
,
8514 Prefix
=> New_Reference_To
(B
, Loc
),
8515 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
8518 Make_Implicit_Loop_Statement
(N
,
8519 Identifier
=> Empty
,
8522 Make_Iteration_Scheme
(Loc
,
8523 Loop_Parameter_Specification
=>
8524 Make_Loop_Parameter_Specification
(Loc
,
8525 Defining_Identifier
=> J
,
8526 Discrete_Subtype_Definition
=>
8527 Make_Attribute_Reference
(Loc
,
8528 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
8529 Attribute_Name
=> Name_Range
))),
8531 Statements
=> New_List
(
8532 Make_Assignment_Statement
(Loc
,
8534 Expression
=> Make_Op_Not
(Loc
, A_J
))));
8536 Func_Name
:= Make_Temporary
(Loc
, 'N');
8537 Set_Is_Inlined
(Func_Name
);
8540 Make_Subprogram_Body
(Loc
,
8542 Make_Function_Specification
(Loc
,
8543 Defining_Unit_Name
=> Func_Name
,
8544 Parameter_Specifications
=> New_List
(
8545 Make_Parameter_Specification
(Loc
,
8546 Defining_Identifier
=> A
,
8547 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))),
8548 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
8550 Declarations
=> New_List
(
8551 Make_Object_Declaration
(Loc
,
8552 Defining_Identifier
=> B
,
8553 Object_Definition
=> New_Reference_To
(Arr
, Loc
))),
8555 Handled_Statement_Sequence
=>
8556 Make_Handled_Sequence_Of_Statements
(Loc
,
8557 Statements
=> New_List
(
8559 Make_Simple_Return_Statement
(Loc
,
8560 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
8563 Make_Function_Call
(Loc
,
8564 Name
=> New_Reference_To
(Func_Name
, Loc
),
8565 Parameter_Associations
=> New_List
(Opnd
)));
8567 Analyze_And_Resolve
(N
, Typ
);
8568 end Expand_N_Op_Not
;
8570 --------------------
8571 -- Expand_N_Op_Or --
8572 --------------------
8574 procedure Expand_N_Op_Or
(N
: Node_Id
) is
8575 Typ
: constant Entity_Id
:= Etype
(N
);
8578 Binary_Op_Validity_Checks
(N
);
8580 if Is_Array_Type
(Etype
(N
)) then
8581 Expand_Boolean_Operator
(N
);
8583 elsif Is_Boolean_Type
(Etype
(N
)) then
8584 Adjust_Condition
(Left_Opnd
(N
));
8585 Adjust_Condition
(Right_Opnd
(N
));
8586 Set_Etype
(N
, Standard_Boolean
);
8587 Adjust_Result_Type
(N
, Typ
);
8589 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8590 Expand_Intrinsic_Call
(N
, Entity
(N
));
8595 ----------------------
8596 -- Expand_N_Op_Plus --
8597 ----------------------
8599 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
8601 Unary_Op_Validity_Checks
(N
);
8603 -- Check for MINIMIZED/ELIMINATED overflow mode
8605 if Minimized_Eliminated_Overflow_Check
(N
) then
8606 Apply_Arithmetic_Overflow_Check
(N
);
8609 end Expand_N_Op_Plus
;
8611 ---------------------
8612 -- Expand_N_Op_Rem --
8613 ---------------------
8615 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
8616 Loc
: constant Source_Ptr
:= Sloc
(N
);
8617 Typ
: constant Entity_Id
:= Etype
(N
);
8628 -- Set if corresponding operand can be negative
8630 pragma Unreferenced
(Hi
);
8633 Binary_Op_Validity_Checks
(N
);
8635 -- Check for MINIMIZED/ELIMINATED overflow mode
8637 if Minimized_Eliminated_Overflow_Check
(N
) then
8638 Apply_Arithmetic_Overflow_Check
(N
);
8642 if Is_Integer_Type
(Etype
(N
)) then
8643 Apply_Divide_Checks
(N
);
8645 -- All done if we don't have a REM any more, which can happen as a
8646 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8648 if Nkind
(N
) /= N_Op_Rem
then
8653 -- Proceed with expansion of REM
8655 Left
:= Left_Opnd
(N
);
8656 Right
:= Right_Opnd
(N
);
8658 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
8659 -- but it is useful with other back ends (e.g. AAMP), and is certainly
8662 if Is_Integer_Type
(Etype
(N
))
8663 and then Compile_Time_Known_Value
(Right
)
8664 and then Expr_Value
(Right
) = Uint_1
8666 -- Call Remove_Side_Effects to ensure that any side effects in the
8667 -- ignored left operand (in particular function calls to user defined
8668 -- functions) are properly executed.
8670 Remove_Side_Effects
(Left
);
8672 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8673 Analyze_And_Resolve
(N
, Typ
);
8677 -- Deal with annoying case of largest negative number remainder minus
8678 -- one. Gigi does not handle this case correctly, because it generates
8679 -- a divide instruction which may trap in this case.
8681 -- In fact the check is quite easy, if the right operand is -1, then
8682 -- the remainder is always 0, and we can just ignore the left operand
8683 -- completely in this case.
8685 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8686 Lneg
:= (not OK
) or else Lo
< 0;
8688 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8689 Rneg
:= (not OK
) or else Lo
< 0;
8691 -- We won't mess with trying to find out if the left operand can really
8692 -- be the largest negative number (that's a pain in the case of private
8693 -- types and this is really marginal). We will just assume that we need
8694 -- the test if the left operand can be negative at all.
8696 if Lneg
and Rneg
then
8698 Make_If_Expression
(Loc
,
8699 Expressions
=> New_List
(
8701 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8703 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
8705 Unchecked_Convert_To
(Typ
,
8706 Make_Integer_Literal
(Loc
, Uint_0
)),
8708 Relocate_Node
(N
))));
8710 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8711 Analyze_And_Resolve
(N
, Typ
);
8713 end Expand_N_Op_Rem
;
8715 -----------------------------
8716 -- Expand_N_Op_Rotate_Left --
8717 -----------------------------
8719 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
8721 Binary_Op_Validity_Checks
(N
);
8722 end Expand_N_Op_Rotate_Left
;
8724 ------------------------------
8725 -- Expand_N_Op_Rotate_Right --
8726 ------------------------------
8728 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
8730 Binary_Op_Validity_Checks
(N
);
8731 end Expand_N_Op_Rotate_Right
;
8733 ----------------------------
8734 -- Expand_N_Op_Shift_Left --
8735 ----------------------------
8737 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
8739 Binary_Op_Validity_Checks
(N
);
8740 end Expand_N_Op_Shift_Left
;
8742 -----------------------------
8743 -- Expand_N_Op_Shift_Right --
8744 -----------------------------
8746 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
8748 Binary_Op_Validity_Checks
(N
);
8749 end Expand_N_Op_Shift_Right
;
8751 ----------------------------------------
8752 -- Expand_N_Op_Shift_Right_Arithmetic --
8753 ----------------------------------------
8755 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
8757 Binary_Op_Validity_Checks
(N
);
8758 end Expand_N_Op_Shift_Right_Arithmetic
;
8760 --------------------------
8761 -- Expand_N_Op_Subtract --
8762 --------------------------
8764 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
8765 Typ
: constant Entity_Id
:= Etype
(N
);
8768 Binary_Op_Validity_Checks
(N
);
8770 -- Check for MINIMIZED/ELIMINATED overflow mode
8772 if Minimized_Eliminated_Overflow_Check
(N
) then
8773 Apply_Arithmetic_Overflow_Check
(N
);
8777 -- N - 0 = N for integer types
8779 if Is_Integer_Type
(Typ
)
8780 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
8781 and then Expr_Value
(Right_Opnd
(N
)) = 0
8783 Rewrite
(N
, Left_Opnd
(N
));
8787 -- Arithmetic overflow checks for signed integer/fixed point types
8789 if Is_Signed_Integer_Type
(Typ
)
8791 Is_Fixed_Point_Type
(Typ
)
8793 Apply_Arithmetic_Overflow_Check
(N
);
8795 -- VAX floating-point types case
8797 elsif Vax_Float
(Typ
) then
8798 Expand_Vax_Arith
(N
);
8800 end Expand_N_Op_Subtract
;
8802 ---------------------
8803 -- Expand_N_Op_Xor --
8804 ---------------------
8806 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
8807 Typ
: constant Entity_Id
:= Etype
(N
);
8810 Binary_Op_Validity_Checks
(N
);
8812 if Is_Array_Type
(Etype
(N
)) then
8813 Expand_Boolean_Operator
(N
);
8815 elsif Is_Boolean_Type
(Etype
(N
)) then
8816 Adjust_Condition
(Left_Opnd
(N
));
8817 Adjust_Condition
(Right_Opnd
(N
));
8818 Set_Etype
(N
, Standard_Boolean
);
8819 Adjust_Result_Type
(N
, Typ
);
8821 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8822 Expand_Intrinsic_Call
(N
, Entity
(N
));
8825 end Expand_N_Op_Xor
;
8827 ----------------------
8828 -- Expand_N_Or_Else --
8829 ----------------------
8831 procedure Expand_N_Or_Else
(N
: Node_Id
)
8832 renames Expand_Short_Circuit_Operator
;
8834 -----------------------------------
8835 -- Expand_N_Qualified_Expression --
8836 -----------------------------------
8838 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
8839 Operand
: constant Node_Id
:= Expression
(N
);
8840 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
8843 -- Do validity check if validity checking operands
8845 if Validity_Checks_On
and then Validity_Check_Operands
then
8846 Ensure_Valid
(Operand
);
8849 -- Apply possible constraint check
8851 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
8853 if Do_Range_Check
(Operand
) then
8854 Set_Do_Range_Check
(Operand
, False);
8855 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
8857 end Expand_N_Qualified_Expression
;
8859 ------------------------------------
8860 -- Expand_N_Quantified_Expression --
8861 ------------------------------------
8865 -- for all X in range => Cond
8870 -- for X in range loop
8877 -- Similarly, an existentially quantified expression:
8879 -- for some X in range => Cond
8884 -- for X in range loop
8891 -- In both cases, the iteration may be over a container in which case it is
8892 -- given by an iterator specification, not a loop parameter specification.
8894 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
8895 Actions
: constant List_Id
:= New_List
;
8896 For_All
: constant Boolean := All_Present
(N
);
8897 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
8898 Loc
: constant Source_Ptr
:= Sloc
(N
);
8899 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
8906 -- Create the declaration of the flag which tracks the status of the
8907 -- quantified expression. Generate:
8909 -- Flag : Boolean := (True | False);
8911 Flag
:= Make_Temporary
(Loc
, 'T', N
);
8914 Make_Object_Declaration
(Loc
,
8915 Defining_Identifier
=> Flag
,
8916 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8918 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
8920 -- Construct the circuitry which tracks the status of the quantified
8921 -- expression. Generate:
8923 -- if [not] Cond then
8924 -- Flag := (False | True);
8928 Cond
:= Relocate_Node
(Condition
(N
));
8931 Cond
:= Make_Op_Not
(Loc
, Cond
);
8935 Make_Implicit_If_Statement
(N
,
8937 Then_Statements
=> New_List
(
8938 Make_Assignment_Statement
(Loc
,
8939 Name
=> New_Occurrence_Of
(Flag
, Loc
),
8941 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
8942 Make_Exit_Statement
(Loc
))));
8944 -- Build the loop equivalent of the quantified expression
8946 if Present
(Iter_Spec
) then
8948 Make_Iteration_Scheme
(Loc
,
8949 Iterator_Specification
=> Iter_Spec
);
8952 Make_Iteration_Scheme
(Loc
,
8953 Loop_Parameter_Specification
=> Loop_Spec
);
8957 Make_Loop_Statement
(Loc
,
8958 Iteration_Scheme
=> Scheme
,
8959 Statements
=> Stmts
,
8960 End_Label
=> Empty
));
8962 -- Transform the quantified expression
8965 Make_Expression_With_Actions
(Loc
,
8966 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
8967 Actions
=> Actions
));
8968 Analyze_And_Resolve
(N
, Standard_Boolean
);
8969 end Expand_N_Quantified_Expression
;
8971 ---------------------------------
8972 -- Expand_N_Selected_Component --
8973 ---------------------------------
8975 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
8976 Loc
: constant Source_Ptr
:= Sloc
(N
);
8977 Par
: constant Node_Id
:= Parent
(N
);
8978 P
: constant Node_Id
:= Prefix
(N
);
8979 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
8985 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
8986 -- Gigi needs a temporary for prefixes that depend on a discriminant,
8987 -- unless the context of an assignment can provide size information.
8988 -- Don't we have a general routine that does this???
8990 function Is_Subtype_Declaration
return Boolean;
8991 -- The replacement of a discriminant reference by its value is required
8992 -- if this is part of the initialization of an temporary generated by a
8993 -- change of representation. This shows up as the construction of a
8994 -- discriminant constraint for a subtype declared at the same point as
8995 -- the entity in the prefix of the selected component. We recognize this
8996 -- case when the context of the reference is:
8997 -- subtype ST is T(Obj.D);
8998 -- where the entity for Obj comes from source, and ST has the same sloc.
9000 -----------------------
9001 -- In_Left_Hand_Side --
9002 -----------------------
9004 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
9006 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
9007 and then Comp
= Name
(Parent
(Comp
)))
9008 or else (Present
(Parent
(Comp
))
9009 and then Nkind
(Parent
(Comp
)) in N_Subexpr
9010 and then In_Left_Hand_Side
(Parent
(Comp
)));
9011 end In_Left_Hand_Side
;
9013 -----------------------------
9014 -- Is_Subtype_Declaration --
9015 -----------------------------
9017 function Is_Subtype_Declaration
return Boolean is
9018 Par
: constant Node_Id
:= Parent
(N
);
9021 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
9022 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
9023 and then Comes_From_Source
(Entity
(Prefix
(N
)))
9024 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
9025 end Is_Subtype_Declaration
;
9027 -- Start of processing for Expand_N_Selected_Component
9030 -- Insert explicit dereference if required
9032 if Is_Access_Type
(Ptyp
) then
9034 -- First set prefix type to proper access type, in case it currently
9035 -- has a private (non-access) view of this type.
9037 Set_Etype
(P
, Ptyp
);
9039 Insert_Explicit_Dereference
(P
);
9040 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
9042 if Ekind
(Etype
(P
)) = E_Private_Subtype
9043 and then Is_For_Access_Subtype
(Etype
(P
))
9045 Set_Etype
(P
, Base_Type
(Etype
(P
)));
9051 -- Deal with discriminant check required
9053 if Do_Discriminant_Check
(N
) then
9055 -- Present the discriminant checking function to the backend, so that
9056 -- it can inline the call to the function.
9059 (Discriminant_Checking_Func
9060 (Original_Record_Component
(Entity
(Selector_Name
(N
)))));
9062 -- Now reset the flag and generate the call
9064 Set_Do_Discriminant_Check
(N
, False);
9065 Generate_Discriminant_Check
(N
);
9068 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9069 -- function, then additional actuals must be passed.
9071 if Ada_Version
>= Ada_2005
9072 and then Is_Build_In_Place_Function_Call
(P
)
9074 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
9077 -- Gigi cannot handle unchecked conversions that are the prefix of a
9078 -- selected component with discriminants. This must be checked during
9079 -- expansion, because during analysis the type of the selector is not
9080 -- known at the point the prefix is analyzed. If the conversion is the
9081 -- target of an assignment, then we cannot force the evaluation.
9083 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
9084 and then Has_Discriminants
(Etype
(N
))
9085 and then not In_Left_Hand_Side
(N
)
9087 Force_Evaluation
(Prefix
(N
));
9090 -- Remaining processing applies only if selector is a discriminant
9092 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
9094 -- If the selector is a discriminant of a constrained record type,
9095 -- we may be able to rewrite the expression with the actual value
9096 -- of the discriminant, a useful optimization in some cases.
9098 if Is_Record_Type
(Ptyp
)
9099 and then Has_Discriminants
(Ptyp
)
9100 and then Is_Constrained
(Ptyp
)
9102 -- Do this optimization for discrete types only, and not for
9103 -- access types (access discriminants get us into trouble!)
9105 if not Is_Discrete_Type
(Etype
(N
)) then
9108 -- Don't do this on the left hand of an assignment statement.
9109 -- Normally one would think that references like this would not
9110 -- occur, but they do in generated code, and mean that we really
9111 -- do want to assign the discriminant!
9113 elsif Nkind
(Par
) = N_Assignment_Statement
9114 and then Name
(Par
) = N
9118 -- Don't do this optimization for the prefix of an attribute or
9119 -- the name of an object renaming declaration since these are
9120 -- contexts where we do not want the value anyway.
9122 elsif (Nkind
(Par
) = N_Attribute_Reference
9123 and then Prefix
(Par
) = N
)
9124 or else Is_Renamed_Object
(N
)
9128 -- Don't do this optimization if we are within the code for a
9129 -- discriminant check, since the whole point of such a check may
9130 -- be to verify the condition on which the code below depends!
9132 elsif Is_In_Discriminant_Check
(N
) then
9135 -- Green light to see if we can do the optimization. There is
9136 -- still one condition that inhibits the optimization below but
9137 -- now is the time to check the particular discriminant.
9140 -- Loop through discriminants to find the matching discriminant
9141 -- constraint to see if we can copy it.
9143 Disc
:= First_Discriminant
(Ptyp
);
9144 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
9145 Discr_Loop
: while Present
(Dcon
) loop
9146 Dval
:= Node
(Dcon
);
9148 -- Check if this is the matching discriminant and if the
9149 -- discriminant value is simple enough to make sense to
9150 -- copy. We don't want to copy complex expressions, and
9151 -- indeed to do so can cause trouble (before we put in
9152 -- this guard, a discriminant expression containing an
9153 -- AND THEN was copied, causing problems for coverage
9156 -- However, if the reference is part of the initialization
9157 -- code generated for an object declaration, we must use
9158 -- the discriminant value from the subtype constraint,
9159 -- because the selected component may be a reference to the
9160 -- object being initialized, whose discriminant is not yet
9161 -- set. This only happens in complex cases involving changes
9162 -- or representation.
9164 if Disc
= Entity
(Selector_Name
(N
))
9165 and then (Is_Entity_Name
(Dval
)
9166 or else Compile_Time_Known_Value
(Dval
)
9167 or else Is_Subtype_Declaration
)
9169 -- Here we have the matching discriminant. Check for
9170 -- the case of a discriminant of a component that is
9171 -- constrained by an outer discriminant, which cannot
9172 -- be optimized away.
9174 if Denotes_Discriminant
9175 (Dval
, Check_Concurrent
=> True)
9179 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
9181 Denotes_Discriminant
9182 (Selector_Name
(Original_Node
(Dval
)), True)
9186 -- Do not retrieve value if constraint is not static. It
9187 -- is generally not useful, and the constraint may be a
9188 -- rewritten outer discriminant in which case it is in
9191 elsif Is_Entity_Name
(Dval
)
9192 and then Nkind
(Parent
(Entity
(Dval
))) =
9193 N_Object_Declaration
9194 and then Present
(Expression
(Parent
(Entity
(Dval
))))
9196 not Is_Static_Expression
9197 (Expression
(Parent
(Entity
(Dval
))))
9201 -- In the context of a case statement, the expression may
9202 -- have the base type of the discriminant, and we need to
9203 -- preserve the constraint to avoid spurious errors on
9206 elsif Nkind
(Parent
(N
)) = N_Case_Statement
9207 and then Etype
(Dval
) /= Etype
(Disc
)
9210 Make_Qualified_Expression
(Loc
,
9212 New_Occurrence_Of
(Etype
(Disc
), Loc
),
9214 New_Copy_Tree
(Dval
)));
9215 Analyze_And_Resolve
(N
, Etype
(Disc
));
9217 -- In case that comes out as a static expression,
9218 -- reset it (a selected component is never static).
9220 Set_Is_Static_Expression
(N
, False);
9223 -- Otherwise we can just copy the constraint, but the
9224 -- result is certainly not static! In some cases the
9225 -- discriminant constraint has been analyzed in the
9226 -- context of the original subtype indication, but for
9227 -- itypes the constraint might not have been analyzed
9228 -- yet, and this must be done now.
9231 Rewrite
(N
, New_Copy_Tree
(Dval
));
9232 Analyze_And_Resolve
(N
);
9233 Set_Is_Static_Expression
(N
, False);
9239 Next_Discriminant
(Disc
);
9240 end loop Discr_Loop
;
9242 -- Note: the above loop should always find a matching
9243 -- discriminant, but if it does not, we just missed an
9244 -- optimization due to some glitch (perhaps a previous
9245 -- error), so ignore.
9250 -- The only remaining processing is in the case of a discriminant of
9251 -- a concurrent object, where we rewrite the prefix to denote the
9252 -- corresponding record type. If the type is derived and has renamed
9253 -- discriminants, use corresponding discriminant, which is the one
9254 -- that appears in the corresponding record.
9256 if not Is_Concurrent_Type
(Ptyp
) then
9260 Disc
:= Entity
(Selector_Name
(N
));
9262 if Is_Derived_Type
(Ptyp
)
9263 and then Present
(Corresponding_Discriminant
(Disc
))
9265 Disc
:= Corresponding_Discriminant
(Disc
);
9269 Make_Selected_Component
(Loc
,
9271 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
9273 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
9279 -- Set Atomic_Sync_Required if necessary for atomic component
9281 if Nkind
(N
) = N_Selected_Component
then
9283 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
9287 -- If component is atomic, but type is not, setting depends on
9288 -- disable/enable state for the component.
9290 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
9291 Set
:= not Atomic_Synchronization_Disabled
(E
);
9293 -- If component is not atomic, but its type is atomic, setting
9294 -- depends on disable/enable state for the type.
9296 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9297 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
9299 -- If both component and type are atomic, we disable if either
9300 -- component or its type have sync disabled.
9302 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9303 Set
:= (not Atomic_Synchronization_Disabled
(E
))
9305 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
9311 -- Set flag if required
9314 Activate_Atomic_Synchronization
(N
);
9318 end Expand_N_Selected_Component
;
9320 --------------------
9321 -- Expand_N_Slice --
9322 --------------------
9324 procedure Expand_N_Slice
(N
: Node_Id
) is
9325 Loc
: constant Source_Ptr
:= Sloc
(N
);
9326 Typ
: constant Entity_Id
:= Etype
(N
);
9327 Pfx
: constant Node_Id
:= Prefix
(N
);
9328 Ptp
: Entity_Id
:= Etype
(Pfx
);
9330 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
9331 -- Check whether the argument is an actual for a procedure call, in
9332 -- which case the expansion of a bit-packed slice is deferred until the
9333 -- call itself is expanded. The reason this is required is that we might
9334 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9335 -- that copy out would be missed if we created a temporary here in
9336 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9337 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9338 -- is harmless to defer expansion in the IN case, since the call
9339 -- processing will still generate the appropriate copy in operation,
9340 -- which will take care of the slice.
9342 procedure Make_Temporary_For_Slice
;
9343 -- Create a named variable for the value of the slice, in cases where
9344 -- the back-end cannot handle it properly, e.g. when packed types or
9345 -- unaligned slices are involved.
9347 -------------------------
9348 -- Is_Procedure_Actual --
9349 -------------------------
9351 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
9352 Par
: Node_Id
:= Parent
(N
);
9356 -- If our parent is a procedure call we can return
9358 if Nkind
(Par
) = N_Procedure_Call_Statement
then
9361 -- If our parent is a type conversion, keep climbing the tree,
9362 -- since a type conversion can be a procedure actual. Also keep
9363 -- climbing if parameter association or a qualified expression,
9364 -- since these are additional cases that do can appear on
9365 -- procedure actuals.
9367 elsif Nkind_In
(Par
, N_Type_Conversion
,
9368 N_Parameter_Association
,
9369 N_Qualified_Expression
)
9371 Par
:= Parent
(Par
);
9373 -- Any other case is not what we are looking for
9379 end Is_Procedure_Actual
;
9381 ------------------------------
9382 -- Make_Temporary_For_Slice --
9383 ------------------------------
9385 procedure Make_Temporary_For_Slice
is
9387 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
9391 Make_Object_Declaration
(Loc
,
9392 Defining_Identifier
=> Ent
,
9393 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
9395 Set_No_Initialization
(Decl
);
9397 Insert_Actions
(N
, New_List
(
9399 Make_Assignment_Statement
(Loc
,
9400 Name
=> New_Occurrence_Of
(Ent
, Loc
),
9401 Expression
=> Relocate_Node
(N
))));
9403 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
9404 Analyze_And_Resolve
(N
, Typ
);
9405 end Make_Temporary_For_Slice
;
9407 -- Start of processing for Expand_N_Slice
9410 -- Special handling for access types
9412 if Is_Access_Type
(Ptp
) then
9414 Ptp
:= Designated_Type
(Ptp
);
9417 Make_Explicit_Dereference
(Sloc
(N
),
9418 Prefix
=> Relocate_Node
(Pfx
)));
9420 Analyze_And_Resolve
(Pfx
, Ptp
);
9423 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9424 -- function, then additional actuals must be passed.
9426 if Ada_Version
>= Ada_2005
9427 and then Is_Build_In_Place_Function_Call
(Pfx
)
9429 Make_Build_In_Place_Call_In_Anonymous_Context
(Pfx
);
9432 -- The remaining case to be handled is packed slices. We can leave
9433 -- packed slices as they are in the following situations:
9435 -- 1. Right or left side of an assignment (we can handle this
9436 -- situation correctly in the assignment statement expansion).
9438 -- 2. Prefix of indexed component (the slide is optimized away in this
9439 -- case, see the start of Expand_N_Slice.)
9441 -- 3. Object renaming declaration, since we want the name of the
9442 -- slice, not the value.
9444 -- 4. Argument to procedure call, since copy-in/copy-out handling may
9445 -- be required, and this is handled in the expansion of call
9448 -- 5. Prefix of an address attribute (this is an error which is caught
9449 -- elsewhere, and the expansion would interfere with generating the
9452 if not Is_Packed
(Typ
) then
9454 -- Apply transformation for actuals of a function call, where
9455 -- Expand_Actuals is not used.
9457 if Nkind
(Parent
(N
)) = N_Function_Call
9458 and then Is_Possibly_Unaligned_Slice
(N
)
9460 Make_Temporary_For_Slice
;
9463 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
9464 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9465 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
9469 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
9470 or else Is_Renamed_Object
(N
)
9471 or else Is_Procedure_Actual
(N
)
9475 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
9476 and then Attribute_Name
(Parent
(N
)) = Name_Address
9481 Make_Temporary_For_Slice
;
9485 ------------------------------
9486 -- Expand_N_Type_Conversion --
9487 ------------------------------
9489 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
9490 Loc
: constant Source_Ptr
:= Sloc
(N
);
9491 Operand
: constant Node_Id
:= Expression
(N
);
9492 Target_Type
: constant Entity_Id
:= Etype
(N
);
9493 Operand_Type
: Entity_Id
:= Etype
(Operand
);
9495 procedure Handle_Changed_Representation
;
9496 -- This is called in the case of record and array type conversions to
9497 -- see if there is a change of representation to be handled. Change of
9498 -- representation is actually handled at the assignment statement level,
9499 -- and what this procedure does is rewrite node N conversion as an
9500 -- assignment to temporary. If there is no change of representation,
9501 -- then the conversion node is unchanged.
9503 procedure Raise_Accessibility_Error
;
9504 -- Called when we know that an accessibility check will fail. Rewrites
9505 -- node N to an appropriate raise statement and outputs warning msgs.
9506 -- The Etype of the raise node is set to Target_Type.
9508 procedure Real_Range_Check
;
9509 -- Handles generation of range check for real target value
9511 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
9512 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
9513 -- evaluates to True.
9515 -----------------------------------
9516 -- Handle_Changed_Representation --
9517 -----------------------------------
9519 procedure Handle_Changed_Representation
is
9528 -- Nothing else to do if no change of representation
9530 if Same_Representation
(Operand_Type
, Target_Type
) then
9533 -- The real change of representation work is done by the assignment
9534 -- statement processing. So if this type conversion is appearing as
9535 -- the expression of an assignment statement, nothing needs to be
9536 -- done to the conversion.
9538 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9541 -- Otherwise we need to generate a temporary variable, and do the
9542 -- change of representation assignment into that temporary variable.
9543 -- The conversion is then replaced by a reference to this variable.
9548 -- If type is unconstrained we have to add a constraint, copied
9549 -- from the actual value of the left hand side.
9551 if not Is_Constrained
(Target_Type
) then
9552 if Has_Discriminants
(Operand_Type
) then
9553 Disc
:= First_Discriminant
(Operand_Type
);
9555 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
9556 Disc
:= First_Stored_Discriminant
(Operand_Type
);
9560 while Present
(Disc
) loop
9562 Make_Selected_Component
(Loc
,
9564 Duplicate_Subexpr_Move_Checks
(Operand
),
9566 Make_Identifier
(Loc
, Chars
(Disc
))));
9567 Next_Discriminant
(Disc
);
9570 elsif Is_Array_Type
(Operand_Type
) then
9571 N_Ix
:= First_Index
(Target_Type
);
9574 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
9576 -- We convert the bounds explicitly. We use an unchecked
9577 -- conversion because bounds checks are done elsewhere.
9582 Unchecked_Convert_To
(Etype
(N_Ix
),
9583 Make_Attribute_Reference
(Loc
,
9585 Duplicate_Subexpr_No_Checks
9586 (Operand
, Name_Req
=> True),
9587 Attribute_Name
=> Name_First
,
9588 Expressions
=> New_List
(
9589 Make_Integer_Literal
(Loc
, J
)))),
9592 Unchecked_Convert_To
(Etype
(N_Ix
),
9593 Make_Attribute_Reference
(Loc
,
9595 Duplicate_Subexpr_No_Checks
9596 (Operand
, Name_Req
=> True),
9597 Attribute_Name
=> Name_Last
,
9598 Expressions
=> New_List
(
9599 Make_Integer_Literal
(Loc
, J
))))));
9606 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
9608 if Present
(Cons
) then
9610 Make_Subtype_Indication
(Loc
,
9611 Subtype_Mark
=> Odef
,
9613 Make_Index_Or_Discriminant_Constraint
(Loc
,
9614 Constraints
=> Cons
));
9617 Temp
:= Make_Temporary
(Loc
, 'C');
9619 Make_Object_Declaration
(Loc
,
9620 Defining_Identifier
=> Temp
,
9621 Object_Definition
=> Odef
);
9623 Set_No_Initialization
(Decl
, True);
9625 -- Insert required actions. It is essential to suppress checks
9626 -- since we have suppressed default initialization, which means
9627 -- that the variable we create may have no discriminants.
9632 Make_Assignment_Statement
(Loc
,
9633 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9634 Expression
=> Relocate_Node
(N
))),
9635 Suppress
=> All_Checks
);
9637 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9640 end Handle_Changed_Representation
;
9642 -------------------------------
9643 -- Raise_Accessibility_Error --
9644 -------------------------------
9646 procedure Raise_Accessibility_Error
is
9649 Make_Raise_Program_Error
(Sloc
(N
),
9650 Reason
=> PE_Accessibility_Check_Failed
));
9651 Set_Etype
(N
, Target_Type
);
9653 Error_Msg_N
("?accessibility check failure", N
);
9655 ("\?& will be raised at run time", N
, Standard_Program_Error
);
9656 end Raise_Accessibility_Error
;
9658 ----------------------
9659 -- Real_Range_Check --
9660 ----------------------
9662 -- Case of conversions to floating-point or fixed-point. If range checks
9663 -- are enabled and the target type has a range constraint, we convert:
9669 -- Tnn : typ'Base := typ'Base (x);
9670 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
9673 -- This is necessary when there is a conversion of integer to float or
9674 -- to fixed-point to ensure that the correct checks are made. It is not
9675 -- necessary for float to float where it is enough to simply set the
9676 -- Do_Range_Check flag.
9678 procedure Real_Range_Check
is
9679 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
9680 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
9681 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
9682 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
9687 -- Nothing to do if conversion was rewritten
9689 if Nkind
(N
) /= N_Type_Conversion
then
9693 -- Nothing to do if range checks suppressed, or target has the same
9694 -- range as the base type (or is the base type).
9696 if Range_Checks_Suppressed
(Target_Type
)
9697 or else (Lo
= Type_Low_Bound
(Btyp
)
9699 Hi
= Type_High_Bound
(Btyp
))
9704 -- Nothing to do if expression is an entity on which checks have been
9707 if Is_Entity_Name
(Operand
)
9708 and then Range_Checks_Suppressed
(Entity
(Operand
))
9713 -- Nothing to do if bounds are all static and we can tell that the
9714 -- expression is within the bounds of the target. Note that if the
9715 -- operand is of an unconstrained floating-point type, then we do
9716 -- not trust it to be in range (might be infinite)
9719 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
9720 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
9723 if (not Is_Floating_Point_Type
(Xtyp
)
9724 or else Is_Constrained
(Xtyp
))
9725 and then Compile_Time_Known_Value
(S_Lo
)
9726 and then Compile_Time_Known_Value
(S_Hi
)
9727 and then Compile_Time_Known_Value
(Hi
)
9728 and then Compile_Time_Known_Value
(Lo
)
9731 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
9732 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
9737 if Is_Real_Type
(Xtyp
) then
9738 S_Lov
:= Expr_Value_R
(S_Lo
);
9739 S_Hiv
:= Expr_Value_R
(S_Hi
);
9741 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
9742 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
9746 and then S_Lov
>= D_Lov
9747 and then S_Hiv
<= D_Hiv
9749 Set_Do_Range_Check
(Operand
, False);
9756 -- For float to float conversions, we are done
9758 if Is_Floating_Point_Type
(Xtyp
)
9760 Is_Floating_Point_Type
(Btyp
)
9765 -- Otherwise rewrite the conversion as described above
9767 Conv
:= Relocate_Node
(N
);
9768 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
9769 Set_Etype
(Conv
, Btyp
);
9771 -- Enable overflow except for case of integer to float conversions,
9772 -- where it is never required, since we can never have overflow in
9775 if not Is_Integer_Type
(Etype
(Operand
)) then
9776 Enable_Overflow_Check
(Conv
);
9779 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
9781 Insert_Actions
(N
, New_List
(
9782 Make_Object_Declaration
(Loc
,
9783 Defining_Identifier
=> Tnn
,
9784 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
9785 Constant_Present
=> True,
9786 Expression
=> Conv
),
9788 Make_Raise_Constraint_Error
(Loc
,
9793 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9795 Make_Attribute_Reference
(Loc
,
9796 Attribute_Name
=> Name_First
,
9798 New_Occurrence_Of
(Target_Type
, Loc
))),
9802 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9804 Make_Attribute_Reference
(Loc
,
9805 Attribute_Name
=> Name_Last
,
9807 New_Occurrence_Of
(Target_Type
, Loc
)))),
9808 Reason
=> CE_Range_Check_Failed
)));
9810 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
9811 Analyze_And_Resolve
(N
, Btyp
);
9812 end Real_Range_Check
;
9814 -----------------------------
9815 -- Has_Extra_Accessibility --
9816 -----------------------------
9818 -- Returns true for a formal of an anonymous access type or for
9819 -- an Ada 2012-style stand-alone object of an anonymous access type.
9821 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
9823 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
9824 return Present
(Effective_Extra_Accessibility
(Id
));
9828 end Has_Extra_Accessibility
;
9830 -- Start of processing for Expand_N_Type_Conversion
9833 -- Nothing at all to do if conversion is to the identical type so remove
9834 -- the conversion completely, it is useless, except that it may carry
9835 -- an Assignment_OK attribute, which must be propagated to the operand.
9837 if Operand_Type
= Target_Type
then
9838 if Assignment_OK
(N
) then
9839 Set_Assignment_OK
(Operand
);
9842 Rewrite
(N
, Relocate_Node
(Operand
));
9846 -- Nothing to do if this is the second argument of read. This is a
9847 -- "backwards" conversion that will be handled by the specialized code
9848 -- in attribute processing.
9850 if Nkind
(Parent
(N
)) = N_Attribute_Reference
9851 and then Attribute_Name
(Parent
(N
)) = Name_Read
9852 and then Next
(First
(Expressions
(Parent
(N
)))) = N
9857 -- Check for case of converting to a type that has an invariant
9858 -- associated with it. This required an invariant check. We convert
9864 -- do invariant_check (typ (expr)) in typ (expr);
9866 -- using Duplicate_Subexpr to avoid multiple side effects
9868 -- Note: the Comes_From_Source check, and then the resetting of this
9869 -- flag prevents what would otherwise be an infinite recursion.
9871 if Has_Invariants
(Target_Type
)
9872 and then Present
(Invariant_Procedure
(Target_Type
))
9873 and then Comes_From_Source
(N
)
9875 Set_Comes_From_Source
(N
, False);
9877 Make_Expression_With_Actions
(Loc
,
9878 Actions
=> New_List
(
9879 Make_Invariant_Call
(Duplicate_Subexpr
(N
))),
9880 Expression
=> Duplicate_Subexpr_No_Checks
(N
)));
9881 Analyze_And_Resolve
(N
, Target_Type
);
9885 -- Here if we may need to expand conversion
9887 -- If the operand of the type conversion is an arithmetic operation on
9888 -- signed integers, and the based type of the signed integer type in
9889 -- question is smaller than Standard.Integer, we promote both of the
9890 -- operands to type Integer.
9892 -- For example, if we have
9894 -- target-type (opnd1 + opnd2)
9896 -- and opnd1 and opnd2 are of type short integer, then we rewrite
9899 -- target-type (integer(opnd1) + integer(opnd2))
9901 -- We do this because we are always allowed to compute in a larger type
9902 -- if we do the right thing with the result, and in this case we are
9903 -- going to do a conversion which will do an appropriate check to make
9904 -- sure that things are in range of the target type in any case. This
9905 -- avoids some unnecessary intermediate overflows.
9907 -- We might consider a similar transformation in the case where the
9908 -- target is a real type or a 64-bit integer type, and the operand
9909 -- is an arithmetic operation using a 32-bit integer type. However,
9910 -- we do not bother with this case, because it could cause significant
9911 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
9912 -- much cheaper, but we don't want different behavior on 32-bit and
9913 -- 64-bit machines. Note that the exclusion of the 64-bit case also
9914 -- handles the configurable run-time cases where 64-bit arithmetic
9915 -- may simply be unavailable.
9917 -- Note: this circuit is partially redundant with respect to the circuit
9918 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
9919 -- the processing here. Also we still need the Checks circuit, since we
9920 -- have to be sure not to generate junk overflow checks in the first
9921 -- place, since it would be trick to remove them here!
9923 if Integer_Promotion_Possible
(N
) then
9925 -- All conditions met, go ahead with transformation
9933 Make_Type_Conversion
(Loc
,
9934 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
9935 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
9937 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
9938 Set_Right_Opnd
(Opnd
, R
);
9940 if Nkind
(Operand
) in N_Binary_Op
then
9942 Make_Type_Conversion
(Loc
,
9943 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
9944 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
9946 Set_Left_Opnd
(Opnd
, L
);
9950 Make_Type_Conversion
(Loc
,
9951 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
9952 Expression
=> Opnd
));
9954 Analyze_And_Resolve
(N
, Target_Type
);
9959 -- Do validity check if validity checking operands
9961 if Validity_Checks_On
9962 and then Validity_Check_Operands
9964 Ensure_Valid
(Operand
);
9967 -- Special case of converting from non-standard boolean type
9969 if Is_Boolean_Type
(Operand_Type
)
9970 and then (Nonzero_Is_True
(Operand_Type
))
9972 Adjust_Condition
(Operand
);
9973 Set_Etype
(Operand
, Standard_Boolean
);
9974 Operand_Type
:= Standard_Boolean
;
9977 -- Case of converting to an access type
9979 if Is_Access_Type
(Target_Type
) then
9981 -- Apply an accessibility check when the conversion operand is an
9982 -- access parameter (or a renaming thereof), unless conversion was
9983 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
9984 -- Note that other checks may still need to be applied below (such
9985 -- as tagged type checks).
9987 if Is_Entity_Name
(Operand
)
9988 and then Has_Extra_Accessibility
(Entity
(Operand
))
9989 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
9990 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
9991 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
9993 Apply_Accessibility_Check
9994 (Operand
, Target_Type
, Insert_Node
=> Operand
);
9996 -- If the level of the operand type is statically deeper than the
9997 -- level of the target type, then force Program_Error. Note that this
9998 -- can only occur for cases where the attribute is within the body of
9999 -- an instantiation (otherwise the conversion will already have been
10000 -- rejected as illegal). Note: warnings are issued by the analyzer
10001 -- for the instance cases.
10003 elsif In_Instance_Body
10004 and then Type_Access_Level
(Operand_Type
) >
10005 Type_Access_Level
(Target_Type
)
10007 Raise_Accessibility_Error
;
10009 -- When the operand is a selected access discriminant the check needs
10010 -- to be made against the level of the object denoted by the prefix
10011 -- of the selected name. Force Program_Error for this case as well
10012 -- (this accessibility violation can only happen if within the body
10013 -- of an instantiation).
10015 elsif In_Instance_Body
10016 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
10017 and then Nkind
(Operand
) = N_Selected_Component
10018 and then Object_Access_Level
(Operand
) >
10019 Type_Access_Level
(Target_Type
)
10021 Raise_Accessibility_Error
;
10026 -- Case of conversions of tagged types and access to tagged types
10028 -- When needed, that is to say when the expression is class-wide, Add
10029 -- runtime a tag check for (strict) downward conversion by using the
10030 -- membership test, generating:
10032 -- [constraint_error when Operand not in Target_Type'Class]
10034 -- or in the access type case
10036 -- [constraint_error
10037 -- when Operand /= null
10038 -- and then Operand.all not in
10039 -- Designated_Type (Target_Type)'Class]
10041 if (Is_Access_Type
(Target_Type
)
10042 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
10043 or else Is_Tagged_Type
(Target_Type
)
10045 -- Do not do any expansion in the access type case if the parent is a
10046 -- renaming, since this is an error situation which will be caught by
10047 -- Sem_Ch8, and the expansion can interfere with this error check.
10049 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
10053 -- Otherwise, proceed with processing tagged conversion
10055 Tagged_Conversion
: declare
10056 Actual_Op_Typ
: Entity_Id
;
10057 Actual_Targ_Typ
: Entity_Id
;
10058 Make_Conversion
: Boolean := False;
10059 Root_Op_Typ
: Entity_Id
;
10061 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
10062 -- Create a membership check to test whether Operand is a member
10063 -- of Targ_Typ. If the original Target_Type is an access, include
10064 -- a test for null value. The check is inserted at N.
10066 --------------------
10067 -- Make_Tag_Check --
10068 --------------------
10070 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
10075 -- [Constraint_Error
10076 -- when Operand /= null
10077 -- and then Operand.all not in Targ_Typ]
10079 if Is_Access_Type
(Target_Type
) then
10081 Make_And_Then
(Loc
,
10084 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10085 Right_Opnd
=> Make_Null
(Loc
)),
10090 Make_Explicit_Dereference
(Loc
,
10091 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
10092 Right_Opnd
=> New_Reference_To
(Targ_Typ
, Loc
)));
10095 -- [Constraint_Error when Operand not in Targ_Typ]
10100 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10101 Right_Opnd
=> New_Reference_To
(Targ_Typ
, Loc
));
10105 Make_Raise_Constraint_Error
(Loc
,
10107 Reason
=> CE_Tag_Check_Failed
));
10108 end Make_Tag_Check
;
10110 -- Start of processing for Tagged_Conversion
10113 -- Handle entities from the limited view
10115 if Is_Access_Type
(Operand_Type
) then
10117 Available_View
(Designated_Type
(Operand_Type
));
10119 Actual_Op_Typ
:= Operand_Type
;
10122 if Is_Access_Type
(Target_Type
) then
10124 Available_View
(Designated_Type
(Target_Type
));
10126 Actual_Targ_Typ
:= Target_Type
;
10129 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
10131 -- Ada 2005 (AI-251): Handle interface type conversion
10133 if Is_Interface
(Actual_Op_Typ
) then
10134 Expand_Interface_Conversion
(N
, Is_Static
=> False);
10138 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
10140 -- Create a runtime tag check for a downward class-wide type
10143 if Is_Class_Wide_Type
(Actual_Op_Typ
)
10144 and then Actual_Op_Typ
/= Actual_Targ_Typ
10145 and then Root_Op_Typ
/= Actual_Targ_Typ
10146 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
10147 Use_Full_View
=> True)
10149 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
10150 Make_Conversion
:= True;
10153 -- AI05-0073: If the result subtype of the function is defined
10154 -- by an access_definition designating a specific tagged type
10155 -- T, a check is made that the result value is null or the tag
10156 -- of the object designated by the result value identifies T.
10157 -- Constraint_Error is raised if this check fails.
10159 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
10162 Func_Typ
: Entity_Id
;
10165 -- Climb scope stack looking for the enclosing function
10167 Func
:= Current_Scope
;
10168 while Present
(Func
)
10169 and then Ekind
(Func
) /= E_Function
10171 Func
:= Scope
(Func
);
10174 -- The function's return subtype must be defined using
10175 -- an access definition.
10177 if Nkind
(Result_Definition
(Parent
(Func
))) =
10178 N_Access_Definition
10180 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
10182 -- The return subtype denotes a specific tagged type,
10183 -- in other words, a non class-wide type.
10185 if Is_Tagged_Type
(Func_Typ
)
10186 and then not Is_Class_Wide_Type
(Func_Typ
)
10188 Make_Tag_Check
(Actual_Targ_Typ
);
10189 Make_Conversion
:= True;
10195 -- We have generated a tag check for either a class-wide type
10196 -- conversion or for AI05-0073.
10198 if Make_Conversion
then
10203 Make_Unchecked_Type_Conversion
(Loc
,
10204 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
10205 Expression
=> Relocate_Node
(Expression
(N
)));
10207 Analyze_And_Resolve
(N
, Target_Type
);
10211 end Tagged_Conversion
;
10213 -- Case of other access type conversions
10215 elsif Is_Access_Type
(Target_Type
) then
10216 Apply_Constraint_Check
(Operand
, Target_Type
);
10218 -- Case of conversions from a fixed-point type
10220 -- These conversions require special expansion and processing, found in
10221 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10222 -- since from a semantic point of view, these are simple integer
10223 -- conversions, which do not need further processing.
10225 elsif Is_Fixed_Point_Type
(Operand_Type
)
10226 and then not Conversion_OK
(N
)
10228 -- We should never see universal fixed at this case, since the
10229 -- expansion of the constituent divide or multiply should have
10230 -- eliminated the explicit mention of universal fixed.
10232 pragma Assert
(Operand_Type
/= Universal_Fixed
);
10234 -- Check for special case of the conversion to universal real that
10235 -- occurs as a result of the use of a round attribute. In this case,
10236 -- the real type for the conversion is taken from the target type of
10237 -- the Round attribute and the result must be marked as rounded.
10239 if Target_Type
= Universal_Real
10240 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
10241 and then Attribute_Name
(Parent
(N
)) = Name_Round
10243 Set_Rounded_Result
(N
);
10244 Set_Etype
(N
, Etype
(Parent
(N
)));
10247 -- Otherwise do correct fixed-conversion, but skip these if the
10248 -- Conversion_OK flag is set, because from a semantic point of view
10249 -- these are simple integer conversions needing no further processing
10250 -- (the backend will simply treat them as integers).
10252 if not Conversion_OK
(N
) then
10253 if Is_Fixed_Point_Type
(Etype
(N
)) then
10254 Expand_Convert_Fixed_To_Fixed
(N
);
10257 elsif Is_Integer_Type
(Etype
(N
)) then
10258 Expand_Convert_Fixed_To_Integer
(N
);
10261 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
10262 Expand_Convert_Fixed_To_Float
(N
);
10267 -- Case of conversions to a fixed-point type
10269 -- These conversions require special expansion and processing, found in
10270 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10271 -- since from a semantic point of view, these are simple integer
10272 -- conversions, which do not need further processing.
10274 elsif Is_Fixed_Point_Type
(Target_Type
)
10275 and then not Conversion_OK
(N
)
10277 if Is_Integer_Type
(Operand_Type
) then
10278 Expand_Convert_Integer_To_Fixed
(N
);
10281 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
10282 Expand_Convert_Float_To_Fixed
(N
);
10286 -- Case of float-to-integer conversions
10288 -- We also handle float-to-fixed conversions with Conversion_OK set
10289 -- since semantically the fixed-point target is treated as though it
10290 -- were an integer in such cases.
10292 elsif Is_Floating_Point_Type
(Operand_Type
)
10294 (Is_Integer_Type
(Target_Type
)
10296 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
10298 -- One more check here, gcc is still not able to do conversions of
10299 -- this type with proper overflow checking, and so gigi is doing an
10300 -- approximation of what is required by doing floating-point compares
10301 -- with the end-point. But that can lose precision in some cases, and
10302 -- give a wrong result. Converting the operand to Universal_Real is
10303 -- helpful, but still does not catch all cases with 64-bit integers
10304 -- on targets with only 64-bit floats.
10306 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10307 -- Can this code be removed ???
10309 if Do_Range_Check
(Operand
) then
10311 Make_Type_Conversion
(Loc
,
10313 New_Occurrence_Of
(Universal_Real
, Loc
),
10315 Relocate_Node
(Operand
)));
10317 Set_Etype
(Operand
, Universal_Real
);
10318 Enable_Range_Check
(Operand
);
10319 Set_Do_Range_Check
(Expression
(Operand
), False);
10322 -- Case of array conversions
10324 -- Expansion of array conversions, add required length/range checks but
10325 -- only do this if there is no change of representation. For handling of
10326 -- this case, see Handle_Changed_Representation.
10328 elsif Is_Array_Type
(Target_Type
) then
10329 if Is_Constrained
(Target_Type
) then
10330 Apply_Length_Check
(Operand
, Target_Type
);
10332 Apply_Range_Check
(Operand
, Target_Type
);
10335 Handle_Changed_Representation
;
10337 -- Case of conversions of discriminated types
10339 -- Add required discriminant checks if target is constrained. Again this
10340 -- change is skipped if we have a change of representation.
10342 elsif Has_Discriminants
(Target_Type
)
10343 and then Is_Constrained
(Target_Type
)
10345 Apply_Discriminant_Check
(Operand
, Target_Type
);
10346 Handle_Changed_Representation
;
10348 -- Case of all other record conversions. The only processing required
10349 -- is to check for a change of representation requiring the special
10350 -- assignment processing.
10352 elsif Is_Record_Type
(Target_Type
) then
10354 -- Ada 2005 (AI-216): Program_Error is raised when converting from
10355 -- a derived Unchecked_Union type to an unconstrained type that is
10356 -- not Unchecked_Union if the operand lacks inferable discriminants.
10358 if Is_Derived_Type
(Operand_Type
)
10359 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
10360 and then not Is_Constrained
(Target_Type
)
10361 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
10362 and then not Has_Inferable_Discriminants
(Operand
)
10364 -- To prevent Gigi from generating illegal code, we generate a
10365 -- Program_Error node, but we give it the target type of the
10366 -- conversion (is this requirement documented somewhere ???)
10369 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
10370 Reason
=> PE_Unchecked_Union_Restriction
);
10373 Set_Etype
(PE
, Target_Type
);
10378 Handle_Changed_Representation
;
10381 -- Case of conversions of enumeration types
10383 elsif Is_Enumeration_Type
(Target_Type
) then
10385 -- Special processing is required if there is a change of
10386 -- representation (from enumeration representation clauses).
10388 if not Same_Representation
(Target_Type
, Operand_Type
) then
10390 -- Convert: x(y) to x'val (ytyp'val (y))
10393 Make_Attribute_Reference
(Loc
,
10394 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
10395 Attribute_Name
=> Name_Val
,
10396 Expressions
=> New_List
(
10397 Make_Attribute_Reference
(Loc
,
10398 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
10399 Attribute_Name
=> Name_Pos
,
10400 Expressions
=> New_List
(Operand
)))));
10402 Analyze_And_Resolve
(N
, Target_Type
);
10405 -- Case of conversions to floating-point
10407 elsif Is_Floating_Point_Type
(Target_Type
) then
10411 -- At this stage, either the conversion node has been transformed into
10412 -- some other equivalent expression, or left as a conversion that can be
10413 -- handled by Gigi, in the following cases:
10415 -- Conversions with no change of representation or type
10417 -- Numeric conversions involving integer, floating- and fixed-point
10418 -- values. Fixed-point values are allowed only if Conversion_OK is
10419 -- set, i.e. if the fixed-point values are to be treated as integers.
10421 -- No other conversions should be passed to Gigi
10423 -- Check: are these rules stated in sinfo??? if so, why restate here???
10425 -- The only remaining step is to generate a range check if we still have
10426 -- a type conversion at this stage and Do_Range_Check is set. For now we
10427 -- do this only for conversions of discrete types.
10429 if Nkind
(N
) = N_Type_Conversion
10430 and then Is_Discrete_Type
(Etype
(N
))
10433 Expr
: constant Node_Id
:= Expression
(N
);
10438 if Do_Range_Check
(Expr
)
10439 and then Is_Discrete_Type
(Etype
(Expr
))
10441 Set_Do_Range_Check
(Expr
, False);
10443 -- Before we do a range check, we have to deal with treating a
10444 -- fixed-point operand as an integer. The way we do this is
10445 -- simply to do an unchecked conversion to an appropriate
10446 -- integer type large enough to hold the result.
10448 -- This code is not active yet, because we are only dealing
10449 -- with discrete types so far ???
10451 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
10452 and then Treat_Fixed_As_Integer
(Expr
)
10454 Ftyp
:= Base_Type
(Etype
(Expr
));
10456 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
10457 Ityp
:= Standard_Long_Long_Integer
;
10459 Ityp
:= Standard_Integer
;
10462 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
10465 -- Reset overflow flag, since the range check will include
10466 -- dealing with possible overflow, and generate the check. If
10467 -- Address is either a source type or target type, suppress
10468 -- range check to avoid typing anomalies when it is a visible
10471 Set_Do_Overflow_Check
(N
, False);
10472 if not Is_Descendent_Of_Address
(Etype
(Expr
))
10473 and then not Is_Descendent_Of_Address
(Target_Type
)
10475 Generate_Range_Check
10476 (Expr
, Target_Type
, CE_Range_Check_Failed
);
10482 -- Final step, if the result is a type conversion involving Vax_Float
10483 -- types, then it is subject for further special processing.
10485 if Nkind
(N
) = N_Type_Conversion
10486 and then (Vax_Float
(Operand_Type
) or else Vax_Float
(Target_Type
))
10488 Expand_Vax_Conversion
(N
);
10492 -- Here at end of processing
10495 -- Apply predicate check if required. Note that we can't just call
10496 -- Apply_Predicate_Check here, because the type looks right after
10497 -- the conversion and it would omit the check. The Comes_From_Source
10498 -- guard is necessary to prevent infinite recursions when we generate
10499 -- internal conversions for the purpose of checking predicates.
10501 if Present
(Predicate_Function
(Target_Type
))
10502 and then Target_Type
/= Operand_Type
10503 and then Comes_From_Source
(N
)
10506 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
10509 -- Avoid infinite recursion on the subsequent expansion of
10510 -- of the copy of the original type conversion.
10512 Set_Comes_From_Source
(New_Expr
, False);
10513 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
10516 end Expand_N_Type_Conversion
;
10518 -----------------------------------
10519 -- Expand_N_Unchecked_Expression --
10520 -----------------------------------
10522 -- Remove the unchecked expression node from the tree. Its job was simply
10523 -- to make sure that its constituent expression was handled with checks
10524 -- off, and now that that is done, we can remove it from the tree, and
10525 -- indeed must, since Gigi does not expect to see these nodes.
10527 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
10528 Exp
: constant Node_Id
:= Expression
(N
);
10530 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
10532 end Expand_N_Unchecked_Expression
;
10534 ----------------------------------------
10535 -- Expand_N_Unchecked_Type_Conversion --
10536 ----------------------------------------
10538 -- If this cannot be handled by Gigi and we haven't already made a
10539 -- temporary for it, do it now.
10541 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
10542 Target_Type
: constant Entity_Id
:= Etype
(N
);
10543 Operand
: constant Node_Id
:= Expression
(N
);
10544 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
10547 -- Nothing at all to do if conversion is to the identical type so remove
10548 -- the conversion completely, it is useless, except that it may carry
10549 -- an Assignment_OK indication which must be propagated to the operand.
10551 if Operand_Type
= Target_Type
then
10553 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
10555 if Assignment_OK
(N
) then
10556 Set_Assignment_OK
(Operand
);
10559 Rewrite
(N
, Relocate_Node
(Operand
));
10563 -- If we have a conversion of a compile time known value to a target
10564 -- type and the value is in range of the target type, then we can simply
10565 -- replace the construct by an integer literal of the correct type. We
10566 -- only apply this to integer types being converted. Possibly it may
10567 -- apply in other cases, but it is too much trouble to worry about.
10569 -- Note that we do not do this transformation if the Kill_Range_Check
10570 -- flag is set, since then the value may be outside the expected range.
10571 -- This happens in the Normalize_Scalars case.
10573 -- We also skip this if either the target or operand type is biased
10574 -- because in this case, the unchecked conversion is supposed to
10575 -- preserve the bit pattern, not the integer value.
10577 if Is_Integer_Type
(Target_Type
)
10578 and then not Has_Biased_Representation
(Target_Type
)
10579 and then Is_Integer_Type
(Operand_Type
)
10580 and then not Has_Biased_Representation
(Operand_Type
)
10581 and then Compile_Time_Known_Value
(Operand
)
10582 and then not Kill_Range_Check
(N
)
10585 Val
: constant Uint
:= Expr_Value
(Operand
);
10588 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
10590 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
10592 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
10594 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
10596 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
10598 -- If Address is the target type, just set the type to avoid a
10599 -- spurious type error on the literal when Address is a visible
10602 if Is_Descendent_Of_Address
(Target_Type
) then
10603 Set_Etype
(N
, Target_Type
);
10605 Analyze_And_Resolve
(N
, Target_Type
);
10613 -- Nothing to do if conversion is safe
10615 if Safe_Unchecked_Type_Conversion
(N
) then
10619 -- Otherwise force evaluation unless Assignment_OK flag is set (this
10620 -- flag indicates ??? -- more comments needed here)
10622 if Assignment_OK
(N
) then
10625 Force_Evaluation
(N
);
10627 end Expand_N_Unchecked_Type_Conversion
;
10629 ----------------------------
10630 -- Expand_Record_Equality --
10631 ----------------------------
10633 -- For non-variant records, Equality is expanded when needed into:
10635 -- and then Lhs.Discr1 = Rhs.Discr1
10637 -- and then Lhs.Discrn = Rhs.Discrn
10638 -- and then Lhs.Cmp1 = Rhs.Cmp1
10640 -- and then Lhs.Cmpn = Rhs.Cmpn
10642 -- The expression is folded by the back-end for adjacent fields. This
10643 -- function is called for tagged record in only one occasion: for imple-
10644 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
10645 -- otherwise the primitive "=" is used directly.
10647 function Expand_Record_Equality
10652 Bodies
: List_Id
) return Node_Id
10654 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
10659 First_Time
: Boolean := True;
10661 function Suitable_Element
(C
: Entity_Id
) return Entity_Id
;
10662 -- Return the first field to compare beginning with C, skipping the
10663 -- inherited components.
10665 ----------------------
10666 -- Suitable_Element --
10667 ----------------------
10669 function Suitable_Element
(C
: Entity_Id
) return Entity_Id
is
10674 elsif Ekind
(C
) /= E_Discriminant
10675 and then Ekind
(C
) /= E_Component
10677 return Suitable_Element
(Next_Entity
(C
));
10679 elsif Is_Tagged_Type
(Typ
)
10680 and then C
/= Original_Record_Component
(C
)
10682 return Suitable_Element
(Next_Entity
(C
));
10684 elsif Chars
(C
) = Name_uTag
then
10685 return Suitable_Element
(Next_Entity
(C
));
10687 -- The .NET/JVM version of type Root_Controlled contains two fields
10688 -- which should not be considered part of the object. To achieve
10689 -- proper equiality between two controlled objects on .NET/JVM, skip
10690 -- field _parent whenever it is of type Root_Controlled.
10692 elsif Chars
(C
) = Name_uParent
10693 and then VM_Target
/= No_VM
10694 and then Etype
(C
) = RTE
(RE_Root_Controlled
)
10696 return Suitable_Element
(Next_Entity
(C
));
10698 elsif Is_Interface
(Etype
(C
)) then
10699 return Suitable_Element
(Next_Entity
(C
));
10704 end Suitable_Element
;
10706 -- Start of processing for Expand_Record_Equality
10709 -- Generates the following code: (assuming that Typ has one Discr and
10710 -- component C2 is also a record)
10713 -- and then Lhs.Discr1 = Rhs.Discr1
10714 -- and then Lhs.C1 = Rhs.C1
10715 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
10717 -- and then Lhs.Cmpn = Rhs.Cmpn
10719 Result
:= New_Reference_To
(Standard_True
, Loc
);
10720 C
:= Suitable_Element
(First_Entity
(Typ
));
10721 while Present
(C
) loop
10729 First_Time
:= False;
10733 New_Lhs
:= New_Copy_Tree
(Lhs
);
10734 New_Rhs
:= New_Copy_Tree
(Rhs
);
10738 Expand_Composite_Equality
(Nod
, Etype
(C
),
10740 Make_Selected_Component
(Loc
,
10742 Selector_Name
=> New_Reference_To
(C
, Loc
)),
10744 Make_Selected_Component
(Loc
,
10746 Selector_Name
=> New_Reference_To
(C
, Loc
)),
10749 -- If some (sub)component is an unchecked_union, the whole
10750 -- operation will raise program error.
10752 if Nkind
(Check
) = N_Raise_Program_Error
then
10754 Set_Etype
(Result
, Standard_Boolean
);
10758 Make_And_Then
(Loc
,
10759 Left_Opnd
=> Result
,
10760 Right_Opnd
=> Check
);
10764 C
:= Suitable_Element
(Next_Entity
(C
));
10768 end Expand_Record_Equality
;
10770 ---------------------------
10771 -- Expand_Set_Membership --
10772 ---------------------------
10774 procedure Expand_Set_Membership
(N
: Node_Id
) is
10775 Lop
: constant Node_Id
:= Left_Opnd
(N
);
10779 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
10780 -- If the alternative is a subtype mark, create a simple membership
10781 -- test. Otherwise create an equality test for it.
10787 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
10789 L
: constant Node_Id
:= New_Copy
(Lop
);
10790 R
: constant Node_Id
:= Relocate_Node
(Alt
);
10793 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
10794 or else Nkind
(Alt
) = N_Range
10797 Make_In
(Sloc
(Alt
),
10802 Make_Op_Eq
(Sloc
(Alt
),
10810 -- Start of processing for Expand_Set_Membership
10813 Remove_Side_Effects
(Lop
);
10815 Alt
:= Last
(Alternatives
(N
));
10816 Res
:= Make_Cond
(Alt
);
10819 while Present
(Alt
) loop
10821 Make_Or_Else
(Sloc
(Alt
),
10822 Left_Opnd
=> Make_Cond
(Alt
),
10823 Right_Opnd
=> Res
);
10828 Analyze_And_Resolve
(N
, Standard_Boolean
);
10829 end Expand_Set_Membership
;
10831 -----------------------------------
10832 -- Expand_Short_Circuit_Operator --
10833 -----------------------------------
10835 -- Deal with special expansion if actions are present for the right operand
10836 -- and deal with optimizing case of arguments being True or False. We also
10837 -- deal with the special case of non-standard boolean values.
10839 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
10840 Loc
: constant Source_Ptr
:= Sloc
(N
);
10841 Typ
: constant Entity_Id
:= Etype
(N
);
10842 Left
: constant Node_Id
:= Left_Opnd
(N
);
10843 Right
: constant Node_Id
:= Right_Opnd
(N
);
10844 LocR
: constant Source_Ptr
:= Sloc
(Right
);
10847 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
10848 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
10849 -- If Left = Shortcut_Value then Right need not be evaluated
10851 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
10852 -- For Opnd a boolean expression, return a Boolean expression equivalent
10853 -- to Opnd /= Shortcut_Value.
10855 --------------------
10856 -- Make_Test_Expr --
10857 --------------------
10859 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
10861 if Shortcut_Value
then
10862 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
10866 end Make_Test_Expr
;
10868 Op_Var
: Entity_Id
;
10869 -- Entity for a temporary variable holding the value of the operator,
10870 -- used for expansion in the case where actions are present.
10872 -- Start of processing for Expand_Short_Circuit_Operator
10875 -- Deal with non-standard booleans
10877 if Is_Boolean_Type
(Typ
) then
10878 Adjust_Condition
(Left
);
10879 Adjust_Condition
(Right
);
10880 Set_Etype
(N
, Standard_Boolean
);
10883 -- Check for cases where left argument is known to be True or False
10885 if Compile_Time_Known_Value
(Left
) then
10887 -- Mark SCO for left condition as compile time known
10889 if Generate_SCO
and then Comes_From_Source
(Left
) then
10890 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
10893 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
10894 -- Any actions associated with Right will be executed unconditionally
10895 -- and can thus be inserted into the tree unconditionally.
10897 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
10898 if Present
(Actions
(N
)) then
10899 Insert_Actions
(N
, Actions
(N
));
10902 Rewrite
(N
, Right
);
10904 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
10905 -- In this case we can forget the actions associated with Right,
10906 -- since they will never be executed.
10909 Kill_Dead_Code
(Right
);
10910 Kill_Dead_Code
(Actions
(N
));
10911 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
10914 Adjust_Result_Type
(N
, Typ
);
10918 -- If Actions are present for the right operand, we have to do some
10919 -- special processing. We can't just let these actions filter back into
10920 -- code preceding the short circuit (which is what would have happened
10921 -- if we had not trapped them in the short-circuit form), since they
10922 -- must only be executed if the right operand of the short circuit is
10923 -- executed and not otherwise.
10925 -- the temporary variable C.
10927 if Present
(Actions
(N
)) then
10928 Actlist
:= Actions
(N
);
10930 -- The old approach is to expand:
10932 -- left AND THEN right
10936 -- C : Boolean := False;
10944 -- and finally rewrite the operator into a reference to C. Similarly
10945 -- for left OR ELSE right, with negated values. Note that this
10946 -- rewrite causes some difficulties for coverage analysis because
10947 -- of the introduction of the new variable C, which obscures the
10948 -- structure of the test.
10950 -- We use this "old approach" if use of N_Expression_With_Actions
10951 -- is False (see description in Opt of when this is or is not set).
10953 if not Use_Expression_With_Actions
then
10954 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
10957 Make_Object_Declaration
(Loc
,
10958 Defining_Identifier
=>
10960 Object_Definition
=>
10961 New_Occurrence_Of
(Standard_Boolean
, Loc
),
10963 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
10965 Append_To
(Actlist
,
10966 Make_Implicit_If_Statement
(Right
,
10967 Condition
=> Make_Test_Expr
(Right
),
10968 Then_Statements
=> New_List
(
10969 Make_Assignment_Statement
(LocR
,
10970 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
10973 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
10976 Make_Implicit_If_Statement
(Left
,
10977 Condition
=> Make_Test_Expr
(Left
),
10978 Then_Statements
=> Actlist
));
10980 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
10981 Analyze_And_Resolve
(N
, Standard_Boolean
);
10983 -- The new approach, activated for now by the use of debug flag
10984 -- -gnatd.X is to use the new Expression_With_Actions node for the
10985 -- right operand of the short-circuit form. This should solve the
10986 -- traceability problems for coverage analysis.
10990 Make_Expression_With_Actions
(LocR
,
10991 Expression
=> Relocate_Node
(Right
),
10992 Actions
=> Actlist
));
10993 Set_Actions
(N
, No_List
);
10994 Analyze_And_Resolve
(Right
, Standard_Boolean
);
10997 Adjust_Result_Type
(N
, Typ
);
11001 -- No actions present, check for cases of right argument True/False
11003 if Compile_Time_Known_Value
(Right
) then
11005 -- Mark SCO for left condition as compile time known
11007 if Generate_SCO
and then Comes_From_Source
(Right
) then
11008 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
11011 -- Change (Left and then True), (Left or else False) to Left.
11012 -- Note that we know there are no actions associated with the right
11013 -- operand, since we just checked for this case above.
11015 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
11018 -- Change (Left and then False), (Left or else True) to Right,
11019 -- making sure to preserve any side effects associated with the Left
11023 Remove_Side_Effects
(Left
);
11024 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11028 Adjust_Result_Type
(N
, Typ
);
11029 end Expand_Short_Circuit_Operator
;
11031 -------------------------------------
11032 -- Fixup_Universal_Fixed_Operation --
11033 -------------------------------------
11035 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
11036 Conv
: constant Node_Id
:= Parent
(N
);
11039 -- We must have a type conversion immediately above us
11041 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
11043 -- Normally the type conversion gives our target type. The exception
11044 -- occurs in the case of the Round attribute, where the conversion
11045 -- will be to universal real, and our real type comes from the Round
11046 -- attribute (as well as an indication that we must round the result)
11048 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
11049 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
11051 Set_Etype
(N
, Etype
(Parent
(Conv
)));
11052 Set_Rounded_Result
(N
);
11054 -- Normal case where type comes from conversion above us
11057 Set_Etype
(N
, Etype
(Conv
));
11059 end Fixup_Universal_Fixed_Operation
;
11061 ---------------------------------
11062 -- Has_Inferable_Discriminants --
11063 ---------------------------------
11065 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
11067 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
11068 -- Determines whether the left-most prefix of a selected component is a
11069 -- formal parameter in a subprogram. Assumes N is a selected component.
11071 --------------------------------
11072 -- Prefix_Is_Formal_Parameter --
11073 --------------------------------
11075 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
11076 Sel_Comp
: Node_Id
;
11079 -- Move to the left-most prefix by climbing up the tree
11082 while Present
(Parent
(Sel_Comp
))
11083 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
11085 Sel_Comp
:= Parent
(Sel_Comp
);
11088 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
11089 end Prefix_Is_Formal_Parameter
;
11091 -- Start of processing for Has_Inferable_Discriminants
11094 -- For selected components, the subtype of the selector must be a
11095 -- constrained Unchecked_Union. If the component is subject to a
11096 -- per-object constraint, then the enclosing object must have inferable
11099 if Nkind
(N
) = N_Selected_Component
then
11100 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
11102 -- A small hack. If we have a per-object constrained selected
11103 -- component of a formal parameter, return True since we do not
11104 -- know the actual parameter association yet.
11106 if Prefix_Is_Formal_Parameter
(N
) then
11109 -- Otherwise, check the enclosing object and the selector
11112 return Has_Inferable_Discriminants
(Prefix
(N
))
11113 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
11116 -- The call to Has_Inferable_Discriminants will determine whether
11117 -- the selector has a constrained Unchecked_Union nominal type.
11120 return Has_Inferable_Discriminants
(Selector_Name
(N
));
11123 -- A qualified expression has inferable discriminants if its subtype
11124 -- mark is a constrained Unchecked_Union subtype.
11126 elsif Nkind
(N
) = N_Qualified_Expression
then
11127 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
11128 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
11130 -- For all other names, it is sufficient to have a constrained
11131 -- Unchecked_Union nominal subtype.
11134 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
11135 and then Is_Constrained
(Etype
(N
));
11137 end Has_Inferable_Discriminants
;
11139 -------------------------------
11140 -- Insert_Dereference_Action --
11141 -------------------------------
11143 procedure Insert_Dereference_Action
(N
: Node_Id
) is
11145 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
11146 -- Return true if type of P is derived from Checked_Pool;
11148 -----------------------------
11149 -- Is_Checked_Storage_Pool --
11150 -----------------------------
11152 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
11161 while T
/= Etype
(T
) loop
11162 if Is_RTE
(T
, RE_Checked_Pool
) then
11170 end Is_Checked_Storage_Pool
;
11174 Typ
: constant Entity_Id
:= Etype
(N
);
11175 Desig
: constant Entity_Id
:= Available_View
(Designated_Type
(Typ
));
11176 Loc
: constant Source_Ptr
:= Sloc
(N
);
11177 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
11178 Pnod
: constant Node_Id
:= Parent
(N
);
11186 -- Start of processing for Insert_Dereference_Action
11189 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
11191 -- Do not re-expand a dereference which has already been processed by
11194 if Has_Dereference_Action
(Pnod
) then
11197 -- Do not perform this type of expansion for internally-generated
11200 elsif not Comes_From_Source
(Original_Node
(Pnod
)) then
11203 -- A dereference action is only applicable to objects which have been
11204 -- allocated on a checked pool.
11206 elsif not Is_Checked_Storage_Pool
(Pool
) then
11210 -- Extract the address of the dereferenced object. Generate:
11212 -- Addr : System.Address := <N>'Pool_Address;
11214 Addr
:= Make_Temporary
(Loc
, 'P');
11217 Make_Object_Declaration
(Loc
,
11218 Defining_Identifier
=> Addr
,
11219 Object_Definition
=>
11220 New_Reference_To
(RTE
(RE_Address
), Loc
),
11222 Make_Attribute_Reference
(Loc
,
11223 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
11224 Attribute_Name
=> Name_Pool_Address
)));
11226 -- Calculate the size of the dereferenced object. Generate:
11228 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11231 Make_Explicit_Dereference
(Loc
,
11232 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11233 Set_Has_Dereference_Action
(Deref
);
11235 Size
:= Make_Temporary
(Loc
, 'S');
11238 Make_Object_Declaration
(Loc
,
11239 Defining_Identifier
=> Size
,
11241 Object_Definition
=>
11242 New_Reference_To
(RTE
(RE_Storage_Count
), Loc
),
11245 Make_Op_Divide
(Loc
,
11247 Make_Attribute_Reference
(Loc
,
11249 Attribute_Name
=> Name_Size
),
11251 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
11253 -- Calculate the alignment of the dereferenced object. Generate:
11254 -- Alig : constant Storage_Count := <N>.all'Alignment;
11257 Make_Explicit_Dereference
(Loc
,
11258 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11259 Set_Has_Dereference_Action
(Deref
);
11261 Alig
:= Make_Temporary
(Loc
, 'A');
11264 Make_Object_Declaration
(Loc
,
11265 Defining_Identifier
=> Alig
,
11266 Object_Definition
=>
11267 New_Reference_To
(RTE
(RE_Storage_Count
), Loc
),
11269 Make_Attribute_Reference
(Loc
,
11271 Attribute_Name
=> Name_Alignment
)));
11273 -- A dereference of a controlled object requires special processing. The
11274 -- finalization machinery requests additional space from the underlying
11275 -- pool to allocate and hide two pointers. As a result, a checked pool
11276 -- may mark the wrong memory as valid. Since checked pools do not have
11277 -- knowledge of hidden pointers, we have to bring the two pointers back
11278 -- in view in order to restore the original state of the object.
11280 if Needs_Finalization
(Desig
) then
11282 -- Adjust the address and size of the dereferenced object. Generate:
11283 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11286 Make_Procedure_Call_Statement
(Loc
,
11288 New_Reference_To
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
11289 Parameter_Associations
=> New_List
(
11290 New_Reference_To
(Addr
, Loc
),
11291 New_Reference_To
(Size
, Loc
),
11292 New_Reference_To
(Alig
, Loc
)));
11294 -- Class-wide types complicate things because we cannot determine
11295 -- statically whether the actual object is truly controlled. We must
11296 -- generate a runtime check to detect this property. Generate:
11298 -- if Needs_Finalization (<N>.all'Tag) then
11302 if Is_Class_Wide_Type
(Desig
) then
11304 Make_Explicit_Dereference
(Loc
,
11305 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11306 Set_Has_Dereference_Action
(Deref
);
11309 Make_If_Statement
(Loc
,
11311 Make_Function_Call
(Loc
,
11313 New_Reference_To
(RTE
(RE_Needs_Finalization
), Loc
),
11314 Parameter_Associations
=> New_List
(
11315 Make_Attribute_Reference
(Loc
,
11317 Attribute_Name
=> Name_Tag
))),
11318 Then_Statements
=> New_List
(Stmt
));
11321 Insert_Action
(N
, Stmt
);
11325 -- Dereference (Pool, Addr, Size, Alig);
11328 Make_Procedure_Call_Statement
(Loc
,
11331 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
11332 Parameter_Associations
=> New_List
(
11333 New_Reference_To
(Pool
, Loc
),
11334 New_Reference_To
(Addr
, Loc
),
11335 New_Reference_To
(Size
, Loc
),
11336 New_Reference_To
(Alig
, Loc
))));
11338 -- Mark the explicit dereference as processed to avoid potential
11339 -- infinite expansion.
11341 Set_Has_Dereference_Action
(Pnod
);
11344 when RE_Not_Available
=>
11346 end Insert_Dereference_Action
;
11348 --------------------------------
11349 -- Integer_Promotion_Possible --
11350 --------------------------------
11352 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
11353 Operand
: constant Node_Id
:= Expression
(N
);
11354 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11355 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
11358 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
11362 -- We only do the transformation for source constructs. We assume
11363 -- that the expander knows what it is doing when it generates code.
11365 Comes_From_Source
(N
)
11367 -- If the operand type is Short_Integer or Short_Short_Integer,
11368 -- then we will promote to Integer, which is available on all
11369 -- targets, and is sufficient to ensure no intermediate overflow.
11370 -- Furthermore it is likely to be as efficient or more efficient
11371 -- than using the smaller type for the computation so we do this
11372 -- unconditionally.
11375 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
11377 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
11379 -- Test for interesting operation, which includes addition,
11380 -- division, exponentiation, multiplication, subtraction, absolute
11381 -- value and unary negation. Unary "+" is omitted since it is a
11382 -- no-op and thus can't overflow.
11384 and then Nkind_In
(Operand
, N_Op_Abs
,
11391 end Integer_Promotion_Possible
;
11393 ------------------------------
11394 -- Make_Array_Comparison_Op --
11395 ------------------------------
11397 -- This is a hand-coded expansion of the following generic function:
11400 -- type elem is (<>);
11401 -- type index is (<>);
11402 -- type a is array (index range <>) of elem;
11404 -- function Gnnn (X : a; Y: a) return boolean is
11405 -- J : index := Y'first;
11408 -- if X'length = 0 then
11411 -- elsif Y'length = 0 then
11415 -- for I in X'range loop
11416 -- if X (I) = Y (J) then
11417 -- if J = Y'last then
11420 -- J := index'succ (J);
11424 -- return X (I) > Y (J);
11428 -- return X'length > Y'length;
11432 -- Note that since we are essentially doing this expansion by hand, we
11433 -- do not need to generate an actual or formal generic part, just the
11434 -- instantiated function itself.
11436 function Make_Array_Comparison_Op
11438 Nod
: Node_Id
) return Node_Id
11440 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11442 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
11443 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
11444 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
11445 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
11447 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
11449 Loop_Statement
: Node_Id
;
11450 Loop_Body
: Node_Id
;
11452 Inner_If
: Node_Id
;
11453 Final_Expr
: Node_Id
;
11454 Func_Body
: Node_Id
;
11455 Func_Name
: Entity_Id
;
11461 -- if J = Y'last then
11464 -- J := index'succ (J);
11468 Make_Implicit_If_Statement
(Nod
,
11471 Left_Opnd
=> New_Reference_To
(J
, Loc
),
11473 Make_Attribute_Reference
(Loc
,
11474 Prefix
=> New_Reference_To
(Y
, Loc
),
11475 Attribute_Name
=> Name_Last
)),
11477 Then_Statements
=> New_List
(
11478 Make_Exit_Statement
(Loc
)),
11482 Make_Assignment_Statement
(Loc
,
11483 Name
=> New_Reference_To
(J
, Loc
),
11485 Make_Attribute_Reference
(Loc
,
11486 Prefix
=> New_Reference_To
(Index
, Loc
),
11487 Attribute_Name
=> Name_Succ
,
11488 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))))));
11490 -- if X (I) = Y (J) then
11493 -- return X (I) > Y (J);
11497 Make_Implicit_If_Statement
(Nod
,
11501 Make_Indexed_Component
(Loc
,
11502 Prefix
=> New_Reference_To
(X
, Loc
),
11503 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
11506 Make_Indexed_Component
(Loc
,
11507 Prefix
=> New_Reference_To
(Y
, Loc
),
11508 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)))),
11510 Then_Statements
=> New_List
(Inner_If
),
11512 Else_Statements
=> New_List
(
11513 Make_Simple_Return_Statement
(Loc
,
11517 Make_Indexed_Component
(Loc
,
11518 Prefix
=> New_Reference_To
(X
, Loc
),
11519 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
11522 Make_Indexed_Component
(Loc
,
11523 Prefix
=> New_Reference_To
(Y
, Loc
),
11524 Expressions
=> New_List
(
11525 New_Reference_To
(J
, Loc
)))))));
11527 -- for I in X'range loop
11532 Make_Implicit_Loop_Statement
(Nod
,
11533 Identifier
=> Empty
,
11535 Iteration_Scheme
=>
11536 Make_Iteration_Scheme
(Loc
,
11537 Loop_Parameter_Specification
=>
11538 Make_Loop_Parameter_Specification
(Loc
,
11539 Defining_Identifier
=> I
,
11540 Discrete_Subtype_Definition
=>
11541 Make_Attribute_Reference
(Loc
,
11542 Prefix
=> New_Reference_To
(X
, Loc
),
11543 Attribute_Name
=> Name_Range
))),
11545 Statements
=> New_List
(Loop_Body
));
11547 -- if X'length = 0 then
11549 -- elsif Y'length = 0 then
11552 -- for ... loop ... end loop;
11553 -- return X'length > Y'length;
11557 Make_Attribute_Reference
(Loc
,
11558 Prefix
=> New_Reference_To
(X
, Loc
),
11559 Attribute_Name
=> Name_Length
);
11562 Make_Attribute_Reference
(Loc
,
11563 Prefix
=> New_Reference_To
(Y
, Loc
),
11564 Attribute_Name
=> Name_Length
);
11568 Left_Opnd
=> Length1
,
11569 Right_Opnd
=> Length2
);
11572 Make_Implicit_If_Statement
(Nod
,
11576 Make_Attribute_Reference
(Loc
,
11577 Prefix
=> New_Reference_To
(X
, Loc
),
11578 Attribute_Name
=> Name_Length
),
11580 Make_Integer_Literal
(Loc
, 0)),
11584 Make_Simple_Return_Statement
(Loc
,
11585 Expression
=> New_Reference_To
(Standard_False
, Loc
))),
11587 Elsif_Parts
=> New_List
(
11588 Make_Elsif_Part
(Loc
,
11592 Make_Attribute_Reference
(Loc
,
11593 Prefix
=> New_Reference_To
(Y
, Loc
),
11594 Attribute_Name
=> Name_Length
),
11596 Make_Integer_Literal
(Loc
, 0)),
11600 Make_Simple_Return_Statement
(Loc
,
11601 Expression
=> New_Reference_To
(Standard_True
, Loc
))))),
11603 Else_Statements
=> New_List
(
11605 Make_Simple_Return_Statement
(Loc
,
11606 Expression
=> Final_Expr
)));
11610 Formals
:= New_List
(
11611 Make_Parameter_Specification
(Loc
,
11612 Defining_Identifier
=> X
,
11613 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
11615 Make_Parameter_Specification
(Loc
,
11616 Defining_Identifier
=> Y
,
11617 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
11619 -- function Gnnn (...) return boolean is
11620 -- J : index := Y'first;
11625 Func_Name
:= Make_Temporary
(Loc
, 'G');
11628 Make_Subprogram_Body
(Loc
,
11630 Make_Function_Specification
(Loc
,
11631 Defining_Unit_Name
=> Func_Name
,
11632 Parameter_Specifications
=> Formals
,
11633 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
11635 Declarations
=> New_List
(
11636 Make_Object_Declaration
(Loc
,
11637 Defining_Identifier
=> J
,
11638 Object_Definition
=> New_Reference_To
(Index
, Loc
),
11640 Make_Attribute_Reference
(Loc
,
11641 Prefix
=> New_Reference_To
(Y
, Loc
),
11642 Attribute_Name
=> Name_First
))),
11644 Handled_Statement_Sequence
=>
11645 Make_Handled_Sequence_Of_Statements
(Loc
,
11646 Statements
=> New_List
(If_Stat
)));
11649 end Make_Array_Comparison_Op
;
11651 ---------------------------
11652 -- Make_Boolean_Array_Op --
11653 ---------------------------
11655 -- For logical operations on boolean arrays, expand in line the following,
11656 -- replacing 'and' with 'or' or 'xor' where needed:
11658 -- function Annn (A : typ; B: typ) return typ is
11661 -- for J in A'range loop
11662 -- C (J) := A (J) op B (J);
11667 -- Here typ is the boolean array type
11669 function Make_Boolean_Array_Op
11671 N
: Node_Id
) return Node_Id
11673 Loc
: constant Source_Ptr
:= Sloc
(N
);
11675 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
11676 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
11677 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
11678 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
11686 Func_Name
: Entity_Id
;
11687 Func_Body
: Node_Id
;
11688 Loop_Statement
: Node_Id
;
11692 Make_Indexed_Component
(Loc
,
11693 Prefix
=> New_Reference_To
(A
, Loc
),
11694 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11697 Make_Indexed_Component
(Loc
,
11698 Prefix
=> New_Reference_To
(B
, Loc
),
11699 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11702 Make_Indexed_Component
(Loc
,
11703 Prefix
=> New_Reference_To
(C
, Loc
),
11704 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
11706 if Nkind
(N
) = N_Op_And
then
11710 Right_Opnd
=> B_J
);
11712 elsif Nkind
(N
) = N_Op_Or
then
11716 Right_Opnd
=> B_J
);
11722 Right_Opnd
=> B_J
);
11726 Make_Implicit_Loop_Statement
(N
,
11727 Identifier
=> Empty
,
11729 Iteration_Scheme
=>
11730 Make_Iteration_Scheme
(Loc
,
11731 Loop_Parameter_Specification
=>
11732 Make_Loop_Parameter_Specification
(Loc
,
11733 Defining_Identifier
=> J
,
11734 Discrete_Subtype_Definition
=>
11735 Make_Attribute_Reference
(Loc
,
11736 Prefix
=> New_Reference_To
(A
, Loc
),
11737 Attribute_Name
=> Name_Range
))),
11739 Statements
=> New_List
(
11740 Make_Assignment_Statement
(Loc
,
11742 Expression
=> Op
)));
11744 Formals
:= New_List
(
11745 Make_Parameter_Specification
(Loc
,
11746 Defining_Identifier
=> A
,
11747 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
11749 Make_Parameter_Specification
(Loc
,
11750 Defining_Identifier
=> B
,
11751 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
11753 Func_Name
:= Make_Temporary
(Loc
, 'A');
11754 Set_Is_Inlined
(Func_Name
);
11757 Make_Subprogram_Body
(Loc
,
11759 Make_Function_Specification
(Loc
,
11760 Defining_Unit_Name
=> Func_Name
,
11761 Parameter_Specifications
=> Formals
,
11762 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
11764 Declarations
=> New_List
(
11765 Make_Object_Declaration
(Loc
,
11766 Defining_Identifier
=> C
,
11767 Object_Definition
=> New_Reference_To
(Typ
, Loc
))),
11769 Handled_Statement_Sequence
=>
11770 Make_Handled_Sequence_Of_Statements
(Loc
,
11771 Statements
=> New_List
(
11773 Make_Simple_Return_Statement
(Loc
,
11774 Expression
=> New_Reference_To
(C
, Loc
)))));
11777 end Make_Boolean_Array_Op
;
11779 -----------------------------------------
11780 -- Minimized_Eliminated_Overflow_Check --
11781 -----------------------------------------
11783 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
11786 Is_Signed_Integer_Type
(Etype
(N
))
11787 and then Do_Overflow_Check
(N
)
11788 and then Overflow_Check_Mode
(Empty
) in Minimized_Or_Eliminated
;
11789 end Minimized_Eliminated_Overflow_Check
;
11791 --------------------------------
11792 -- Optimize_Length_Comparison --
11793 --------------------------------
11795 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
11796 Loc
: constant Source_Ptr
:= Sloc
(N
);
11797 Typ
: constant Entity_Id
:= Etype
(N
);
11802 -- First and Last attribute reference nodes, which end up as left and
11803 -- right operands of the optimized result.
11806 -- True for comparison operand of zero
11809 -- Comparison operand, set only if Is_Zero is false
11812 -- Entity whose length is being compared
11815 -- Integer_Literal node for length attribute expression, or Empty
11816 -- if there is no such expression present.
11819 -- Type of array index to which 'Length is applied
11821 Op
: Node_Kind
:= Nkind
(N
);
11822 -- Kind of comparison operator, gets flipped if operands backwards
11824 function Is_Optimizable
(N
: Node_Id
) return Boolean;
11825 -- Tests N to see if it is an optimizable comparison value (defined as
11826 -- constant zero or one, or something else where the value is known to
11827 -- be positive and in the range of 32-bits, and where the corresponding
11828 -- Length value is also known to be 32-bits. If result is true, sets
11829 -- Is_Zero, Ityp, and Comp accordingly.
11831 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
11832 -- Tests if N is a length attribute applied to a simple entity. If so,
11833 -- returns True, and sets Ent to the entity, and Index to the integer
11834 -- literal provided as an attribute expression, or to Empty if none.
11835 -- Also returns True if the expression is a generated type conversion
11836 -- whose expression is of the desired form. This latter case arises
11837 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
11838 -- to check for being in range, which is not needed in this context.
11839 -- Returns False if neither condition holds.
11841 function Prepare_64
(N
: Node_Id
) return Node_Id
;
11842 -- Given a discrete expression, returns a Long_Long_Integer typed
11843 -- expression representing the underlying value of the expression.
11844 -- This is done with an unchecked conversion to the result type. We
11845 -- use unchecked conversion to handle the enumeration type case.
11847 ----------------------
11848 -- Is_Entity_Length --
11849 ----------------------
11851 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
11853 if Nkind
(N
) = N_Attribute_Reference
11854 and then Attribute_Name
(N
) = Name_Length
11855 and then Is_Entity_Name
(Prefix
(N
))
11857 Ent
:= Entity
(Prefix
(N
));
11859 if Present
(Expressions
(N
)) then
11860 Index
:= First
(Expressions
(N
));
11867 elsif Nkind
(N
) = N_Type_Conversion
11868 and then not Comes_From_Source
(N
)
11870 return Is_Entity_Length
(Expression
(N
));
11875 end Is_Entity_Length
;
11877 --------------------
11878 -- Is_Optimizable --
11879 --------------------
11881 function Is_Optimizable
(N
: Node_Id
) return Boolean is
11889 if Compile_Time_Known_Value
(N
) then
11890 Val
:= Expr_Value
(N
);
11892 if Val
= Uint_0
then
11897 elsif Val
= Uint_1
then
11904 -- Here we have to make sure of being within 32-bits
11906 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
11909 or else Lo
< Uint_1
11910 or else Hi
> UI_From_Int
(Int
'Last)
11915 -- Comparison value was within range, so now we must check the index
11916 -- value to make sure it is also within 32-bits.
11918 Indx
:= First_Index
(Etype
(Ent
));
11920 if Present
(Index
) then
11921 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
11926 Ityp
:= Etype
(Indx
);
11928 if Esize
(Ityp
) > 32 then
11935 end Is_Optimizable
;
11941 function Prepare_64
(N
: Node_Id
) return Node_Id
is
11943 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
11946 -- Start of processing for Optimize_Length_Comparison
11949 -- Nothing to do if not a comparison
11951 if Op
not in N_Op_Compare
then
11955 -- Nothing to do if special -gnatd.P debug flag set
11957 if Debug_Flag_Dot_PP
then
11961 -- Ent'Length op 0/1
11963 if Is_Entity_Length
(Left_Opnd
(N
))
11964 and then Is_Optimizable
(Right_Opnd
(N
))
11968 -- 0/1 op Ent'Length
11970 elsif Is_Entity_Length
(Right_Opnd
(N
))
11971 and then Is_Optimizable
(Left_Opnd
(N
))
11973 -- Flip comparison to opposite sense
11976 when N_Op_Lt
=> Op
:= N_Op_Gt
;
11977 when N_Op_Le
=> Op
:= N_Op_Ge
;
11978 when N_Op_Gt
=> Op
:= N_Op_Lt
;
11979 when N_Op_Ge
=> Op
:= N_Op_Le
;
11980 when others => null;
11983 -- Else optimization not possible
11989 -- Fall through if we will do the optimization
11991 -- Cases to handle:
11993 -- X'Length = 0 => X'First > X'Last
11994 -- X'Length = 1 => X'First = X'Last
11995 -- X'Length = n => X'First + (n - 1) = X'Last
11997 -- X'Length /= 0 => X'First <= X'Last
11998 -- X'Length /= 1 => X'First /= X'Last
11999 -- X'Length /= n => X'First + (n - 1) /= X'Last
12001 -- X'Length >= 0 => always true, warn
12002 -- X'Length >= 1 => X'First <= X'Last
12003 -- X'Length >= n => X'First + (n - 1) <= X'Last
12005 -- X'Length > 0 => X'First <= X'Last
12006 -- X'Length > 1 => X'First < X'Last
12007 -- X'Length > n => X'First + (n - 1) < X'Last
12009 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12010 -- X'Length <= 1 => X'First >= X'Last
12011 -- X'Length <= n => X'First + (n - 1) >= X'Last
12013 -- X'Length < 0 => always false (warn)
12014 -- X'Length < 1 => X'First > X'Last
12015 -- X'Length < n => X'First + (n - 1) > X'Last
12017 -- Note: for the cases of n (not constant 0,1), we require that the
12018 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12019 -- and the same for the comparison value. Then we do the comparison
12020 -- using 64-bit arithmetic (actually long long integer), so that we
12021 -- cannot have overflow intefering with the result.
12023 -- First deal with warning cases
12032 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
12033 Analyze_And_Resolve
(N
, Typ
);
12034 Warn_On_Known_Condition
(N
);
12041 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
12042 Analyze_And_Resolve
(N
, Typ
);
12043 Warn_On_Known_Condition
(N
);
12047 if Constant_Condition_Warnings
12048 and then Comes_From_Source
(Original_Node
(N
))
12050 Error_Msg_N
("could replace by ""'=""?", N
);
12060 -- Build the First reference we will use
12063 Make_Attribute_Reference
(Loc
,
12064 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12065 Attribute_Name
=> Name_First
);
12067 if Present
(Index
) then
12068 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
12071 -- If general value case, then do the addition of (n - 1), and
12072 -- also add the needed conversions to type Long_Long_Integer.
12074 if Present
(Comp
) then
12077 Left_Opnd
=> Prepare_64
(Left
),
12079 Make_Op_Subtract
(Loc
,
12080 Left_Opnd
=> Prepare_64
(Comp
),
12081 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
12084 -- Build the Last reference we will use
12087 Make_Attribute_Reference
(Loc
,
12088 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12089 Attribute_Name
=> Name_Last
);
12091 if Present
(Index
) then
12092 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
12095 -- If general operand, convert Last reference to Long_Long_Integer
12097 if Present
(Comp
) then
12098 Right
:= Prepare_64
(Right
);
12101 -- Check for cases to optimize
12103 -- X'Length = 0 => X'First > X'Last
12104 -- X'Length < 1 => X'First > X'Last
12105 -- X'Length < n => X'First + (n - 1) > X'Last
12107 if (Is_Zero
and then Op
= N_Op_Eq
)
12108 or else (not Is_Zero
and then Op
= N_Op_Lt
)
12113 Right_Opnd
=> Right
);
12115 -- X'Length = 1 => X'First = X'Last
12116 -- X'Length = n => X'First + (n - 1) = X'Last
12118 elsif not Is_Zero
and then Op
= N_Op_Eq
then
12122 Right_Opnd
=> Right
);
12124 -- X'Length /= 0 => X'First <= X'Last
12125 -- X'Length > 0 => X'First <= X'Last
12127 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
12131 Right_Opnd
=> Right
);
12133 -- X'Length /= 1 => X'First /= X'Last
12134 -- X'Length /= n => X'First + (n - 1) /= X'Last
12136 elsif not Is_Zero
and then Op
= N_Op_Ne
then
12140 Right_Opnd
=> Right
);
12142 -- X'Length >= 1 => X'First <= X'Last
12143 -- X'Length >= n => X'First + (n - 1) <= X'Last
12145 elsif not Is_Zero
and then Op
= N_Op_Ge
then
12149 Right_Opnd
=> Right
);
12151 -- X'Length > 1 => X'First < X'Last
12152 -- X'Length > n => X'First + (n = 1) < X'Last
12154 elsif not Is_Zero
and then Op
= N_Op_Gt
then
12158 Right_Opnd
=> Right
);
12160 -- X'Length <= 1 => X'First >= X'Last
12161 -- X'Length <= n => X'First + (n - 1) >= X'Last
12163 elsif not Is_Zero
and then Op
= N_Op_Le
then
12167 Right_Opnd
=> Right
);
12169 -- Should not happen at this stage
12172 raise Program_Error
;
12175 -- Rewrite and finish up
12177 Rewrite
(N
, Result
);
12178 Analyze_And_Resolve
(N
, Typ
);
12180 end Optimize_Length_Comparison
;
12182 ------------------------
12183 -- Rewrite_Comparison --
12184 ------------------------
12186 procedure Rewrite_Comparison
(N
: Node_Id
) is
12187 Warning_Generated
: Boolean := False;
12188 -- Set to True if first pass with Assume_Valid generates a warning in
12189 -- which case we skip the second pass to avoid warning overloaded.
12192 -- Set to Standard_True or Standard_False
12195 if Nkind
(N
) = N_Type_Conversion
then
12196 Rewrite_Comparison
(Expression
(N
));
12199 elsif Nkind
(N
) not in N_Op_Compare
then
12203 -- Now start looking at the comparison in detail. We potentially go
12204 -- through this loop twice. The first time, Assume_Valid is set False
12205 -- in the call to Compile_Time_Compare. If this call results in a
12206 -- clear result of always True or Always False, that's decisive and
12207 -- we are done. Otherwise we repeat the processing with Assume_Valid
12208 -- set to True to generate additional warnings. We can skip that step
12209 -- if Constant_Condition_Warnings is False.
12211 for AV
in False .. True loop
12213 Typ
: constant Entity_Id
:= Etype
(N
);
12214 Op1
: constant Node_Id
:= Left_Opnd
(N
);
12215 Op2
: constant Node_Id
:= Right_Opnd
(N
);
12217 Res
: constant Compare_Result
:=
12218 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
12219 -- Res indicates if compare outcome can be compile time determined
12221 True_Result
: Boolean;
12222 False_Result
: Boolean;
12225 case N_Op_Compare
(Nkind
(N
)) is
12227 True_Result
:= Res
= EQ
;
12228 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
12231 True_Result
:= Res
in Compare_GE
;
12232 False_Result
:= Res
= LT
;
12235 and then Constant_Condition_Warnings
12236 and then Comes_From_Source
(Original_Node
(N
))
12237 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
12238 and then not In_Instance
12239 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12240 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12243 ("can never be greater than, could replace by ""'=""?", N
);
12244 Warning_Generated
:= True;
12248 True_Result
:= Res
= GT
;
12249 False_Result
:= Res
in Compare_LE
;
12252 True_Result
:= Res
= LT
;
12253 False_Result
:= Res
in Compare_GE
;
12256 True_Result
:= Res
in Compare_LE
;
12257 False_Result
:= Res
= GT
;
12260 and then Constant_Condition_Warnings
12261 and then Comes_From_Source
(Original_Node
(N
))
12262 and then Nkind
(Original_Node
(N
)) = N_Op_Le
12263 and then not In_Instance
12264 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
12265 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
12268 ("can never be less than, could replace by ""'=""?", N
);
12269 Warning_Generated
:= True;
12273 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
12274 False_Result
:= Res
= EQ
;
12277 -- If this is the first iteration, then we actually convert the
12278 -- comparison into True or False, if the result is certain.
12281 if True_Result
or False_Result
then
12282 Result
:= Boolean_Literals
(True_Result
);
12285 New_Occurrence_Of
(Result
, Sloc
(N
))));
12286 Analyze_And_Resolve
(N
, Typ
);
12287 Warn_On_Known_Condition
(N
);
12291 -- If this is the second iteration (AV = True), and the original
12292 -- node comes from source and we are not in an instance, then give
12293 -- a warning if we know result would be True or False. Note: we
12294 -- know Constant_Condition_Warnings is set if we get here.
12296 elsif Comes_From_Source
(Original_Node
(N
))
12297 and then not In_Instance
12299 if True_Result
then
12301 ("condition can only be False if invalid values present?",
12303 elsif False_Result
then
12305 ("condition can only be True if invalid values present?",
12311 -- Skip second iteration if not warning on constant conditions or
12312 -- if the first iteration already generated a warning of some kind or
12313 -- if we are in any case assuming all values are valid (so that the
12314 -- first iteration took care of the valid case).
12316 exit when not Constant_Condition_Warnings
;
12317 exit when Warning_Generated
;
12318 exit when Assume_No_Invalid_Values
;
12320 end Rewrite_Comparison
;
12322 ----------------------------
12323 -- Safe_In_Place_Array_Op --
12324 ----------------------------
12326 function Safe_In_Place_Array_Op
12329 Op2
: Node_Id
) return Boolean
12331 Target
: Entity_Id
;
12333 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
12334 -- Operand is safe if it cannot overlap part of the target of the
12335 -- operation. If the operand and the target are identical, the operand
12336 -- is safe. The operand can be empty in the case of negation.
12338 function Is_Unaliased
(N
: Node_Id
) return Boolean;
12339 -- Check that N is a stand-alone entity
12345 function Is_Unaliased
(N
: Node_Id
) return Boolean is
12349 and then No
(Address_Clause
(Entity
(N
)))
12350 and then No
(Renamed_Object
(Entity
(N
)));
12353 ---------------------
12354 -- Is_Safe_Operand --
12355 ---------------------
12357 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
12362 elsif Is_Entity_Name
(Op
) then
12363 return Is_Unaliased
(Op
);
12365 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
12366 return Is_Unaliased
(Prefix
(Op
));
12368 elsif Nkind
(Op
) = N_Slice
then
12370 Is_Unaliased
(Prefix
(Op
))
12371 and then Entity
(Prefix
(Op
)) /= Target
;
12373 elsif Nkind
(Op
) = N_Op_Not
then
12374 return Is_Safe_Operand
(Right_Opnd
(Op
));
12379 end Is_Safe_Operand
;
12381 -- Start of processing for Safe_In_Place_Array_Op
12384 -- Skip this processing if the component size is different from system
12385 -- storage unit (since at least for NOT this would cause problems).
12387 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
12390 -- Cannot do in place stuff on VM_Target since cannot pass addresses
12392 elsif VM_Target
/= No_VM
then
12395 -- Cannot do in place stuff if non-standard Boolean representation
12397 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
12400 elsif not Is_Unaliased
(Lhs
) then
12404 Target
:= Entity
(Lhs
);
12405 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
12407 end Safe_In_Place_Array_Op
;
12409 -----------------------
12410 -- Tagged_Membership --
12411 -----------------------
12413 -- There are two different cases to consider depending on whether the right
12414 -- operand is a class-wide type or not. If not we just compare the actual
12415 -- tag of the left expr to the target type tag:
12417 -- Left_Expr.Tag = Right_Type'Tag;
12419 -- If it is a class-wide type we use the RT function CW_Membership which is
12420 -- usually implemented by looking in the ancestor tables contained in the
12421 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
12423 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
12424 -- function IW_Membership which is usually implemented by looking in the
12425 -- table of abstract interface types plus the ancestor table contained in
12426 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
12428 procedure Tagged_Membership
12430 SCIL_Node
: out Node_Id
;
12431 Result
: out Node_Id
)
12433 Left
: constant Node_Id
:= Left_Opnd
(N
);
12434 Right
: constant Node_Id
:= Right_Opnd
(N
);
12435 Loc
: constant Source_Ptr
:= Sloc
(N
);
12437 Full_R_Typ
: Entity_Id
;
12438 Left_Type
: Entity_Id
;
12439 New_Node
: Node_Id
;
12440 Right_Type
: Entity_Id
;
12444 SCIL_Node
:= Empty
;
12446 -- Handle entities from the limited view
12448 Left_Type
:= Available_View
(Etype
(Left
));
12449 Right_Type
:= Available_View
(Etype
(Right
));
12451 -- In the case where the type is an access type, the test is applied
12452 -- using the designated types (needed in Ada 2012 for implicit anonymous
12453 -- access conversions, for AI05-0149).
12455 if Is_Access_Type
(Right_Type
) then
12456 Left_Type
:= Designated_Type
(Left_Type
);
12457 Right_Type
:= Designated_Type
(Right_Type
);
12460 if Is_Class_Wide_Type
(Left_Type
) then
12461 Left_Type
:= Root_Type
(Left_Type
);
12464 if Is_Class_Wide_Type
(Right_Type
) then
12465 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
12467 Full_R_Typ
:= Underlying_Type
(Right_Type
);
12471 Make_Selected_Component
(Loc
,
12472 Prefix
=> Relocate_Node
(Left
),
12474 New_Reference_To
(First_Tag_Component
(Left_Type
), Loc
));
12476 if Is_Class_Wide_Type
(Right_Type
) then
12478 -- No need to issue a run-time check if we statically know that the
12479 -- result of this membership test is always true. For example,
12480 -- considering the following declarations:
12482 -- type Iface is interface;
12483 -- type T is tagged null record;
12484 -- type DT is new T and Iface with null record;
12489 -- These membership tests are always true:
12492 -- Obj2 in T'Class;
12493 -- Obj2 in Iface'Class;
12495 -- We do not need to handle cases where the membership is illegal.
12498 -- Obj1 in DT'Class; -- Compile time error
12499 -- Obj1 in Iface'Class; -- Compile time error
12501 if not Is_Class_Wide_Type
(Left_Type
)
12502 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
12503 Use_Full_View
=> True)
12504 or else (Is_Interface
(Etype
(Right_Type
))
12505 and then Interface_Present_In_Ancestor
12507 Iface
=> Etype
(Right_Type
))))
12509 Result
:= New_Reference_To
(Standard_True
, Loc
);
12513 -- Ada 2005 (AI-251): Class-wide applied to interfaces
12515 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
12517 -- Support to: "Iface_CW_Typ in Typ'Class"
12519 or else Is_Interface
(Left_Type
)
12521 -- Issue error if IW_Membership operation not available in a
12522 -- configurable run time setting.
12524 if not RTE_Available
(RE_IW_Membership
) then
12526 ("dynamic membership test on interface types", N
);
12532 Make_Function_Call
(Loc
,
12533 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
12534 Parameter_Associations
=> New_List
(
12535 Make_Attribute_Reference
(Loc
,
12537 Attribute_Name
=> Name_Address
),
12539 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
12542 -- Ada 95: Normal case
12545 Build_CW_Membership
(Loc
,
12546 Obj_Tag_Node
=> Obj_Tag
,
12549 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
12551 New_Node
=> New_Node
);
12553 -- Generate the SCIL node for this class-wide membership test.
12554 -- Done here because the previous call to Build_CW_Membership
12555 -- relocates Obj_Tag.
12557 if Generate_SCIL
then
12558 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
12559 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
12560 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
12563 Result
:= New_Node
;
12566 -- Right_Type is not a class-wide type
12569 -- No need to check the tag of the object if Right_Typ is abstract
12571 if Is_Abstract_Type
(Right_Type
) then
12572 Result
:= New_Reference_To
(Standard_False
, Loc
);
12577 Left_Opnd
=> Obj_Tag
,
12580 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
12583 end Tagged_Membership
;
12585 ------------------------------
12586 -- Unary_Op_Validity_Checks --
12587 ------------------------------
12589 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
12591 if Validity_Checks_On
and Validity_Check_Operands
then
12592 Ensure_Valid
(Right_Opnd
(N
));
12594 end Unary_Op_Validity_Checks
;