1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Einfo
.Entities
; use Einfo
.Entities
;
33 with Einfo
.Utils
; use Einfo
.Utils
;
34 with Elists
; use Elists
;
35 with Errout
; use Errout
;
36 with Exp_Aggr
; use Exp_Aggr
;
37 with Exp_Ch3
; use Exp_Ch3
;
38 with Exp_Ch6
; use Exp_Ch6
;
39 with Exp_Ch7
; use Exp_Ch7
;
40 with Exp_Ch9
; use Exp_Ch9
;
41 with Exp_Disp
; use Exp_Disp
;
42 with Exp_Fixd
; use Exp_Fixd
;
43 with Exp_Intr
; use Exp_Intr
;
44 with Exp_Pakd
; use Exp_Pakd
;
45 with Exp_Tss
; use Exp_Tss
;
46 with Exp_Util
; use Exp_Util
;
47 with Freeze
; use Freeze
;
48 with Inline
; use Inline
;
50 with Namet
; use Namet
;
51 with Nlists
; use Nlists
;
52 with Nmake
; use Nmake
;
54 with Par_SCO
; use Par_SCO
;
55 with Restrict
; use Restrict
;
56 with Rident
; use Rident
;
57 with Rtsfind
; use Rtsfind
;
59 with Sem_Aux
; use Sem_Aux
;
60 with Sem_Cat
; use Sem_Cat
;
61 with Sem_Ch3
; use Sem_Ch3
;
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 Sinfo
.Nodes
; use Sinfo
.Nodes
;
70 with Sinfo
.Utils
; use Sinfo
.Utils
;
71 with Snames
; use Snames
;
72 with Stand
; use Stand
;
73 with SCIL_LL
; use SCIL_LL
;
74 with Targparm
; use Targparm
;
75 with Tbuild
; use Tbuild
;
76 with Ttypes
; use Ttypes
;
77 with Uintp
; use Uintp
;
78 with Urealp
; use Urealp
;
79 with Validsw
; use Validsw
;
80 with Warnsw
; use Warnsw
;
82 package body Exp_Ch4
is
84 Too_Large_Length_For_Array
: constant Unat
:= Uint_256
;
85 -- Threshold from which we do not try to create static array temporaries in
86 -- order to eliminate dynamic stack allocations.
88 -----------------------
89 -- Local Subprograms --
90 -----------------------
92 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
93 pragma Inline
(Binary_Op_Validity_Checks
);
94 -- Performs validity checks for a binary operator
96 procedure Build_Boolean_Array_Proc_Call
100 -- If a boolean array assignment can be done in place, build call to
101 -- corresponding library procedure.
103 procedure Displace_Allocator_Pointer
(N
: Node_Id
);
104 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
105 -- Expand_Allocator_Expression. Allocating class-wide interface objects
106 -- this routine displaces the pointer to the allocated object to reference
107 -- the component referencing the corresponding secondary dispatch table.
109 procedure Expand_Allocator_Expression
(N
: Node_Id
);
110 -- Subsidiary to Expand_N_Allocator, for the case when the expression
111 -- is a qualified expression.
113 procedure Expand_Array_Comparison
(N
: Node_Id
);
114 -- This routine handles expansion of the comparison operators (N_Op_Lt,
115 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
116 -- code for these operators is similar, differing only in the details of
117 -- the actual comparison call that is made. Special processing (call a
120 function Expand_Array_Equality
125 Typ
: Entity_Id
) return Node_Id
;
126 -- Expand an array equality into a call to a function implementing this
127 -- equality, and a call to it. Loc is the location for the generated nodes.
128 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
129 -- on which to attach bodies of local functions that are created in the
130 -- process. It is the responsibility of the caller to insert those bodies
131 -- at the right place. Nod provides the Sloc value for the generated code.
132 -- Normally the types used for the generated equality routine are taken
133 -- from Lhs and Rhs. However, in some situations of generated code, the
134 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
135 -- the type to be used for the formal parameters.
137 procedure Expand_Boolean_Operator
(N
: Node_Id
);
138 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
139 -- case of array type arguments.
141 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
);
142 -- When generating C code, convert nonbinary modular arithmetic operations
143 -- into code that relies on the front-end expansion of operator Mod. No
144 -- expansion is performed if N is not a nonbinary modular operand.
146 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
);
147 -- Common expansion processing for short-circuit boolean operators
149 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
);
150 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
151 -- where we allow comparison of "out of range" values.
153 function Expand_Composite_Equality
154 (Outer_Type
: Entity_Id
;
156 Comp_Type
: Entity_Id
;
158 Rhs
: Node_Id
) return Node_Id
;
159 -- Local recursive function used to expand equality for nested composite
160 -- types. Used by Expand_Record/Array_Equality. Nod provides the Sloc value
161 -- for generated code. Lhs and Rhs are the left and right sides for the
162 -- comparison, and Comp_Typ is the type of the objects to compare.
163 -- Outer_Type is the composite type containing a component of type
164 -- Comp_Type -- used for printing messages.
166 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
167 -- Routine to expand concatenation of a sequence of two or more operands
168 -- (in the list Operands) and replace node Cnode with the result of the
169 -- concatenation. The operands can be of any appropriate type, and can
170 -- include both arrays and singleton elements.
172 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
);
173 -- N is an N_In membership test mode, with the overflow check mode set to
174 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
175 -- integer type. This is a case where top level processing is required to
176 -- handle overflow checks in subtrees.
178 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
179 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
180 -- fixed. We do not have such a type at runtime, so the purpose of this
181 -- routine is to find the real type by looking up the tree. We also
182 -- determine if the operation must be rounded.
184 procedure Get_First_Index_Bounds
(T
: Entity_Id
; Lo
, Hi
: out Uint
);
185 -- T is an array whose index bounds are all known at compile time. Return
186 -- the value of the low and high bounds of the first index of T.
188 function Get_Size_For_Range
(Lo
, Hi
: Uint
) return Uint
;
189 -- Return the size of a small signed integer type covering Lo .. Hi, the
190 -- main goal being to return a size lower than that of standard types.
192 procedure Insert_Dereference_Action
(N
: Node_Id
);
193 -- N is an expression whose type is an access. When the type of the
194 -- associated storage pool is derived from Checked_Pool, generate a
195 -- call to the 'Dereference' primitive operation.
197 function Make_Array_Comparison_Op
199 Nod
: Node_Id
) return Node_Id
;
200 -- Comparisons between arrays are expanded in line. This function produces
201 -- the body of the implementation of (a > b), where a and b are one-
202 -- dimensional arrays of some discrete type. The original node is then
203 -- expanded into the appropriate call to this function. Nod provides the
204 -- Sloc value for the generated code.
206 function Make_Boolean_Array_Op
208 N
: Node_Id
) return Node_Id
;
209 -- Boolean operations on boolean arrays are expanded in line. This function
210 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
211 -- b). It is used only the normal case and not the packed case. The type
212 -- involved, Typ, is the Boolean array type, and the logical operations in
213 -- the body are simple boolean operations. Note that Typ is always a
214 -- constrained type (the caller has ensured this by using
215 -- Convert_To_Actual_Subtype if necessary).
217 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean;
218 -- For signed arithmetic operations when the current overflow mode is
219 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
220 -- as the first thing we do. We then return. We count on the recursive
221 -- apparatus for overflow checks to call us back with an equivalent
222 -- operation that is in CHECKED mode, avoiding a recursive entry into this
223 -- routine, and that is when we will proceed with the expansion of the
224 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
225 -- these optimizations without first making this check, since there may be
226 -- operands further down the tree that are relying on the recursive calls
227 -- triggered by the top level nodes to properly process overflow checking
228 -- and remaining expansion on these nodes. Note that this call back may be
229 -- skipped if the operation is done in Bignum mode but that's fine, since
230 -- the Bignum call takes care of everything.
232 procedure Narrow_Large_Operation
(N
: Node_Id
);
233 -- Try to compute the result of a large operation in a narrower type than
234 -- its nominal type. This is mainly aimed at getting rid of operations done
235 -- in Universal_Integer that can be generated for attributes.
237 procedure Optimize_Length_Comparison
(N
: Node_Id
);
238 -- Given an expression, if it is of the form X'Length op N (or the other
239 -- way round), where N is known at compile time to be 0 or 1, or something
240 -- else where the value is known to be nonnegative and in the 32-bit range,
241 -- and X is a simple entity, and op is a comparison operator, optimizes it
242 -- into a comparison of X'First and X'Last.
244 procedure Process_Transients_In_Expression
247 -- Subsidiary routine to the expansion of expression_with_actions, if and
248 -- case expressions. Inspect and process actions list Stmts of expression
249 -- Expr for transient objects. If such objects are found, the routine will
250 -- generate code to finalize them when the enclosing context is elaborated
253 -- This specific processing is required for these expressions because the
254 -- management of transient objects for expressions implemented in Exp_Ch7
255 -- cannot deal with nested lists of actions whose effects may outlive the
256 -- lists and affect the result of the parent expressions. In these cases,
257 -- the lifetime of temporaries created in these lists must be extended to
258 -- match that of the enclosing context of the parent expressions and, in
259 -- particular, their finalization must be deferred to this context.
261 procedure Rewrite_Comparison
(N
: Node_Id
);
262 -- If N is the node for a comparison whose outcome can be determined at
263 -- compile time, then the node N can be rewritten with True or False. If
264 -- the outcome cannot be determined at compile time, the call has no
265 -- effect. If N is a type conversion, then this processing is applied to
266 -- its expression. If N is neither comparison nor a type conversion, the
267 -- call has no effect.
269 procedure Tagged_Membership
271 SCIL_Node
: out Node_Id
;
272 Result
: out Node_Id
);
273 -- Construct the expression corresponding to the tagged membership test.
274 -- Deals with a second operand being (or not) a class-wide type.
276 function Safe_In_Place_Array_Op
279 Op2
: Node_Id
) return Boolean;
280 -- In the context of an assignment, where the right-hand side is a boolean
281 -- operation on arrays, check whether operation can be performed in place.
283 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
284 pragma Inline
(Unary_Op_Validity_Checks
);
285 -- Performs validity checks for a unary operator
287 -------------------------------
288 -- Binary_Op_Validity_Checks --
289 -------------------------------
291 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
293 if Validity_Checks_On
and Validity_Check_Operands
then
294 Ensure_Valid
(Left_Opnd
(N
));
295 Ensure_Valid
(Right_Opnd
(N
));
297 end Binary_Op_Validity_Checks
;
299 ------------------------------------
300 -- Build_Boolean_Array_Proc_Call --
301 ------------------------------------
303 procedure Build_Boolean_Array_Proc_Call
308 Loc
: constant Source_Ptr
:= Sloc
(N
);
309 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
310 Target
: constant Node_Id
:=
311 Make_Attribute_Reference
(Loc
,
313 Attribute_Name
=> Name_Address
);
315 Arg1
: Node_Id
:= Op1
;
316 Arg2
: Node_Id
:= Op2
;
318 Proc_Name
: Entity_Id
;
321 if Kind
= N_Op_Not
then
322 if Nkind
(Op1
) in N_Binary_Op
then
324 -- Use negated version of the binary operators
326 if Nkind
(Op1
) = N_Op_And
then
327 Proc_Name
:= RTE
(RE_Vector_Nand
);
329 elsif Nkind
(Op1
) = N_Op_Or
then
330 Proc_Name
:= RTE
(RE_Vector_Nor
);
332 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
333 Proc_Name
:= RTE
(RE_Vector_Xor
);
337 Make_Procedure_Call_Statement
(Loc
,
338 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
340 Parameter_Associations
=> New_List
(
342 Make_Attribute_Reference
(Loc
,
343 Prefix
=> Left_Opnd
(Op1
),
344 Attribute_Name
=> Name_Address
),
346 Make_Attribute_Reference
(Loc
,
347 Prefix
=> Right_Opnd
(Op1
),
348 Attribute_Name
=> Name_Address
),
350 Make_Attribute_Reference
(Loc
,
351 Prefix
=> Left_Opnd
(Op1
),
352 Attribute_Name
=> Name_Length
)));
355 Proc_Name
:= RTE
(RE_Vector_Not
);
358 Make_Procedure_Call_Statement
(Loc
,
359 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
360 Parameter_Associations
=> New_List
(
363 Make_Attribute_Reference
(Loc
,
365 Attribute_Name
=> Name_Address
),
367 Make_Attribute_Reference
(Loc
,
369 Attribute_Name
=> Name_Length
)));
373 -- We use the following equivalences:
375 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
376 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
377 -- (not X) xor (not Y) = X xor Y
378 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
380 if Nkind
(Op1
) = N_Op_Not
then
381 Arg1
:= Right_Opnd
(Op1
);
382 Arg2
:= Right_Opnd
(Op2
);
384 if Kind
= N_Op_And
then
385 Proc_Name
:= RTE
(RE_Vector_Nor
);
386 elsif Kind
= N_Op_Or
then
387 Proc_Name
:= RTE
(RE_Vector_Nand
);
389 Proc_Name
:= RTE
(RE_Vector_Xor
);
393 if Kind
= N_Op_And
then
394 Proc_Name
:= RTE
(RE_Vector_And
);
395 elsif Kind
= N_Op_Or
then
396 Proc_Name
:= RTE
(RE_Vector_Or
);
397 elsif Nkind
(Op2
) = N_Op_Not
then
398 Proc_Name
:= RTE
(RE_Vector_Nxor
);
399 Arg2
:= Right_Opnd
(Op2
);
401 Proc_Name
:= RTE
(RE_Vector_Xor
);
406 Make_Procedure_Call_Statement
(Loc
,
407 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
408 Parameter_Associations
=> New_List
(
410 Make_Attribute_Reference
(Loc
,
412 Attribute_Name
=> Name_Address
),
413 Make_Attribute_Reference
(Loc
,
415 Attribute_Name
=> Name_Address
),
416 Make_Attribute_Reference
(Loc
,
418 Attribute_Name
=> Name_Length
)));
421 Rewrite
(N
, Call_Node
);
425 when RE_Not_Available
=>
427 end Build_Boolean_Array_Proc_Call
;
429 -----------------------
431 -----------------------
433 function Build_Eq_Call
437 Rhs
: Node_Id
) return Node_Id
439 Eq
: constant Entity_Id
:= Get_User_Defined_Equality
(Typ
);
443 if Is_Abstract_Subprogram
(Eq
) then
444 return Make_Raise_Program_Error
(Loc
,
445 Reason
=> PE_Explicit_Raise
);
449 Make_Function_Call
(Loc
,
450 Name
=> New_Occurrence_Of
(Eq
, Loc
),
451 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
455 -- If not found, predefined operation will be used
460 --------------------------------
461 -- Displace_Allocator_Pointer --
462 --------------------------------
464 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
465 Loc
: constant Source_Ptr
:= Sloc
(N
);
466 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
472 -- Do nothing in case of VM targets: the virtual machine will handle
473 -- interfaces directly.
475 if not Tagged_Type_Expansion
then
479 pragma Assert
(Nkind
(N
) = N_Identifier
480 and then Nkind
(Orig_Node
) = N_Allocator
);
482 PtrT
:= Etype
(Orig_Node
);
483 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
484 Etyp
:= Etype
(Expression
(Orig_Node
));
486 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
488 -- If the type of the allocator expression is not an interface type
489 -- we can generate code to reference the record component containing
490 -- the pointer to the secondary dispatch table.
492 if not Is_Interface
(Etyp
) then
494 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
497 -- 1) Get access to the allocated object
500 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
504 -- 2) Add the conversion to displace the pointer to reference
505 -- the secondary dispatch table.
507 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
508 Analyze_And_Resolve
(N
, Dtyp
);
510 -- 3) The 'access to the secondary dispatch table will be used
511 -- as the value returned by the allocator.
514 Make_Attribute_Reference
(Loc
,
515 Prefix
=> Relocate_Node
(N
),
516 Attribute_Name
=> Name_Access
));
517 Set_Etype
(N
, Saved_Typ
);
521 -- If the type of the allocator expression is an interface type we
522 -- generate a run-time call to displace "this" to reference the
523 -- component containing the pointer to the secondary dispatch table
524 -- or else raise Constraint_Error if the actual object does not
525 -- implement the target interface. This case corresponds to the
526 -- following example:
528 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
530 -- return new Iface_2'Class'(Obj);
535 Unchecked_Convert_To
(PtrT
,
536 Make_Function_Call
(Loc
,
537 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
538 Parameter_Associations
=> New_List
(
539 Unchecked_Convert_To
(RTE
(RE_Address
),
545 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
547 Analyze_And_Resolve
(N
, PtrT
);
550 end Displace_Allocator_Pointer
;
552 ---------------------------------
553 -- Expand_Allocator_Expression --
554 ---------------------------------
556 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
557 Loc
: constant Source_Ptr
:= Sloc
(N
);
558 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
559 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
560 T
: constant Entity_Id
:= Entity
(Indic
);
561 PtrT
: constant Entity_Id
:= Etype
(N
);
562 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
563 Special_Return
: constant Boolean := For_Special_Return_Object
(N
);
565 procedure Build_Aggregate_In_Place
(Temp
: Entity_Id
; Typ
: Entity_Id
);
566 -- If Exp is an aggregate to build in place, build the declaration of
567 -- Temp with Typ and with expression an uninitialized allocator for
568 -- Etype (Exp), then perform an in-place aggregate assignment of Exp
569 -- into the allocated memory.
571 ------------------------------
572 -- Build_Aggregate_In_Place --
573 ------------------------------
575 procedure Build_Aggregate_In_Place
(Temp
: Entity_Id
; Typ
: Entity_Id
) is
576 Temp_Decl
: constant Node_Id
:=
577 Make_Object_Declaration
(Loc
,
578 Defining_Identifier
=> Temp
,
579 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
582 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
585 -- Prevent default initialization of the allocator
587 Set_No_Initialization
(Expression
(Temp_Decl
));
589 -- Copy the Comes_From_Source flag onto the allocator since logically
590 -- this allocator is a replacement of the original allocator. This is
591 -- for proper handling of restriction No_Implicit_Heap_Allocations.
593 Preserve_Comes_From_Source
(Expression
(Temp_Decl
), N
);
595 -- Insert the declaration and generate the in-place assignment
597 Insert_Action
(N
, Temp_Decl
);
598 Convert_Aggr_In_Allocator
(N
, Exp
, Temp
);
599 end Build_Aggregate_In_Place
;
604 Aggr_In_Place
: Boolean;
609 TagT
: Entity_Id
:= Empty
;
610 -- Type used as source for tag assignment
612 TagR
: Node_Id
:= Empty
;
613 -- Target reference for tag assignment
616 -- Handle call to C++ constructor
618 if Is_CPP_Constructor_Call
(Exp
) then
619 Make_CPP_Constructor_Call_In_Allocator
621 Function_Call
=> Exp
);
626 -- type A is access T1;
627 -- X : A := new T2'(...);
628 -- T1 and T2 can be different subtypes, and we might need to check
629 -- both constraints. First check against the type of the qualified
632 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
634 Aggr_In_Place
:= Is_Delayed_Aggregate
(Exp
);
636 -- If the expression is an aggregate to be built in place, then we need
637 -- to delay applying predicate checks, because this would result in the
638 -- creation of a temporary, which is illegal for limited types,
640 if not Aggr_In_Place
then
641 Apply_Predicate_Check
(Exp
, T
);
644 -- Check that any anonymous access discriminants are suitable
645 -- for use in an allocator.
647 -- Note: This check is performed here instead of during analysis so that
648 -- we can check against the fully resolved etype of Exp.
650 if Is_Entity_Name
(Exp
)
651 and then Has_Anonymous_Access_Discriminant
(Etype
(Exp
))
652 and then Static_Accessibility_Level
(Exp
, Object_Decl_Level
)
653 > Static_Accessibility_Level
(N
, Object_Decl_Level
)
655 -- A dynamic check and a warning are generated when we are within
660 Make_Raise_Program_Error
(Loc
,
661 Reason
=> PE_Accessibility_Check_Failed
));
663 Error_Msg_Warn
:= SPARK_Mode
/= On
;
664 Error_Msg_N
("anonymous access discriminant is too deep for use"
665 & " in allocator<<", N
);
666 Error_Msg_N
("\Program_Error [<<", N
);
668 -- Otherwise, make the error static
671 Error_Msg_N
("anonymous access discriminant is too deep for use"
672 & " in allocator", N
);
676 if Do_Range_Check
(Exp
) then
677 Generate_Range_Check
(Exp
, T
, CE_Range_Check_Failed
);
680 -- A check is also needed in cases where the designated subtype is
681 -- constrained and differs from the subtype given in the qualified
682 -- expression. Note that the check on the qualified expression does
683 -- not allow sliding, but this check does (a relaxation from Ada 83).
685 if Is_Constrained
(DesigT
)
686 and then not Subtypes_Statically_Match
(T
, DesigT
)
688 Apply_Constraint_Check
(Exp
, DesigT
, No_Sliding
=> False);
690 Apply_Predicate_Check
(Exp
, DesigT
);
692 if Do_Range_Check
(Exp
) then
693 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
697 if Nkind
(Exp
) = N_Raise_Constraint_Error
then
698 Rewrite
(N
, New_Copy
(Exp
));
703 -- Case of tagged type or type requiring finalization
705 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
707 -- Ada 2005 (AI-318-02): If the initialization expression is a call
708 -- to a build-in-place function, then access to the allocated object
709 -- must be passed to the function.
711 if Is_Build_In_Place_Function_Call
(Exp
) then
712 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
713 Apply_Accessibility_Check_For_Allocator
714 (N
, Exp
, N
, Built_In_Place
=> True);
717 -- Ada 2005 (AI-318-02): Specialization of the previous case for
718 -- expressions containing a build-in-place function call whose
719 -- returned object covers interface types, and Expr has calls to
720 -- Ada.Tags.Displace to displace the pointer to the returned build-
721 -- in-place object to reference the secondary dispatch table of a
722 -- covered interface type.
724 elsif Present
(Unqual_BIP_Iface_Function_Call
(Exp
)) then
725 Make_Build_In_Place_Iface_Call_In_Allocator
(N
, Exp
);
726 Apply_Accessibility_Check_For_Allocator
727 (N
, Exp
, N
, Built_In_Place
=> True);
731 -- Actions inserted before:
732 -- Temp : constant PtrT := new T'(Expression);
733 -- Temp._tag = T'tag; -- when not class-wide
734 -- [Deep_]Adjust (Temp.all);
736 -- We analyze by hand the new internal allocator to avoid any
737 -- recursion and inappropriate call to Initialize.
739 -- We don't want to remove side effects when the expression must be
740 -- built in place and we don't need it when there is no storage pool
741 -- or this is a return/secondary stack allocation.
744 and then Present
(Storage_Pool
(N
))
745 and then not Is_RTE
(Storage_Pool
(N
), RE_RS_Pool
)
746 and then not Is_RTE
(Storage_Pool
(N
), RE_SS_Pool
)
748 Remove_Side_Effects
(Exp
);
751 Temp
:= Make_Temporary
(Loc
, 'P', N
);
753 -- For a class wide allocation generate the following code:
755 -- type Equiv_Record is record ... end record;
756 -- implicit subtype CW is <Class_Wide_Subytpe>;
757 -- temp : PtrT := new CW'(CW!(expr));
759 if Is_Class_Wide_Type
(T
) then
760 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
762 -- Ada 2005 (AI-251): If the expression is a class-wide interface
763 -- object we generate code to move up "this" to reference the
764 -- base of the object before allocating the new object.
766 -- Note that Exp'Address is recursively expanded into a call
767 -- to Base_Address (Exp.Tag)
769 if Is_Class_Wide_Type
(Etype
(Exp
))
770 and then Is_Interface
(Etype
(Exp
))
771 and then Tagged_Type_Expansion
775 Unchecked_Convert_To
(Entity
(Indic
),
776 Make_Explicit_Dereference
(Loc
,
777 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
778 Make_Attribute_Reference
(Loc
,
780 Attribute_Name
=> Name_Address
)))));
784 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
787 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
790 -- Processing for allocators returning non-interface types
792 if not Is_Interface
(DesigT
) then
793 if Aggr_In_Place
then
794 Build_Aggregate_In_Place
(Temp
, PtrT
);
797 Node
:= Relocate_Node
(N
);
801 Make_Object_Declaration
(Loc
,
802 Defining_Identifier
=> Temp
,
803 Constant_Present
=> True,
804 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
807 Insert_Action
(N
, Temp_Decl
);
810 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
811 -- interface type. In this case we use the type of the qualified
812 -- expression to allocate the object.
816 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
821 Make_Full_Type_Declaration
(Loc
,
822 Defining_Identifier
=> Def_Id
,
824 Make_Access_To_Object_Definition
(Loc
,
826 Null_Exclusion_Present
=> False,
828 Is_Access_Constant
(Etype
(N
)),
829 Subtype_Indication
=>
830 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
832 Insert_Action
(N
, New_Decl
);
834 -- Inherit the allocation-related attributes from the original
837 Set_Finalization_Collection
838 (Def_Id
, Finalization_Collection
(PtrT
));
840 Set_Associated_Storage_Pool
841 (Def_Id
, Associated_Storage_Pool
(PtrT
));
843 -- Declare the object using the previous type declaration
845 if Aggr_In_Place
then
846 Build_Aggregate_In_Place
(Temp
, Def_Id
);
849 Node
:= Relocate_Node
(N
);
853 Make_Object_Declaration
(Loc
,
854 Defining_Identifier
=> Temp
,
855 Constant_Present
=> True,
856 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
859 Insert_Action
(N
, Temp_Decl
);
862 -- Generate an additional object containing the address of the
863 -- returned object. The type of this second object declaration
864 -- is the correct type required for the common processing that
865 -- is still performed by this subprogram. The displacement of
866 -- this pointer to reference the component associated with the
867 -- interface type will be done at the end of common processing.
870 Make_Object_Declaration
(Loc
,
871 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
872 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
874 Unchecked_Convert_To
(PtrT
,
875 New_Occurrence_Of
(Temp
, Loc
)));
877 Insert_Action
(N
, New_Decl
);
879 Temp_Decl
:= New_Decl
;
880 Temp
:= Defining_Identifier
(New_Decl
);
884 -- Generate the tag assignment
886 -- Suppress the tag assignment for VM targets because VM tags are
887 -- represented implicitly in objects.
889 if not Tagged_Type_Expansion
then
892 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
893 -- interface objects because in this case the tag does not change.
895 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
896 pragma Assert
(Is_Class_Wide_Type
897 (Directly_Designated_Type
(Etype
(N
))));
900 -- Likewise if the allocator is made for a special return object
902 elsif Special_Return
then
905 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
908 Make_Explicit_Dereference
(Loc
,
909 Prefix
=> New_Occurrence_Of
(Temp
, Loc
));
911 elsif Is_Private_Type
(T
)
912 and then Is_Tagged_Type
(Underlying_Type
(T
))
914 TagT
:= Underlying_Type
(T
);
916 Unchecked_Convert_To
(Underlying_Type
(T
),
917 Make_Explicit_Dereference
(Loc
,
918 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
921 if Present
(TagT
) then
923 Make_Tag_Assignment_From_Type
924 (Loc
, TagR
, Underlying_Type
(TagT
)));
927 -- Generate an Adjust call if the object will be moved. In Ada 2005,
928 -- the object may be inherently limited, in which case there is no
929 -- Adjust procedure, and the object is built in place. In Ada 95, the
930 -- object can be limited but not inherently limited if this allocator
931 -- came from a return statement (we're allocating the result on the
932 -- secondary stack); in that case, the object will be moved, so we do
933 -- want to Adjust. But the call is always skipped if the allocator is
934 -- made for a special return object because it's generated elsewhere.
936 -- Needs_Finalization (DesigT) may differ from Needs_Finalization (T)
937 -- if one of the two types is class-wide, and the other is not.
939 if Needs_Finalization
(DesigT
)
940 and then Needs_Finalization
(T
)
941 and then not Is_Inherently_Limited_Type
(T
)
942 and then not Aggr_In_Place
943 and then Nkind
(Exp
) /= N_Function_Call
944 and then not Special_Return
946 -- An unchecked conversion is needed in the classwide case because
947 -- the designated type can be an ancestor of the subtype mark of
953 Unchecked_Convert_To
(T
,
954 Make_Explicit_Dereference
(Loc
,
955 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
958 if Present
(Adj_Call
) then
959 Insert_Action
(N
, Adj_Call
);
963 -- This needs to done before generating the accessibility check below
964 -- because the check comes with cleanup code that invokes Free on the
965 -- temporary and, therefore, expects the object to be attached to its
966 -- finalization collection if it is controlled.
968 Build_Allocate_Deallocate_Proc
(Declaration_Node
(Temp
), Mark
=> N
);
970 -- Note: the accessibility check must be inserted after the call to
971 -- [Deep_]Adjust to ensure proper completion of the assignment.
973 Apply_Accessibility_Check_For_Allocator
(N
, Exp
, Temp
);
975 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
976 Analyze_And_Resolve
(N
, PtrT
);
978 if Aggr_In_Place
then
979 Apply_Predicate_Check
(N
, T
, Deref
=> True);
982 -- Ada 2005 (AI-251): Displace the pointer to reference the record
983 -- component containing the secondary dispatch table of the interface
986 if Is_Interface
(DesigT
) then
987 Displace_Allocator_Pointer
(N
);
990 -- Always force the generation of a temporary for aggregates when
991 -- generating C code, to simplify the work in the code generator.
994 or else (Modify_Tree_For_C
and then Nkind
(Exp
) = N_Aggregate
)
996 Temp
:= Make_Temporary
(Loc
, 'P', N
);
997 Build_Aggregate_In_Place
(Temp
, PtrT
);
998 Build_Allocate_Deallocate_Proc
(Declaration_Node
(Temp
), Mark
=> N
);
999 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1000 Analyze_And_Resolve
(N
, PtrT
);
1002 if Aggr_In_Place
then
1003 Apply_Predicate_Check
(N
, T
, Deref
=> True);
1006 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1007 Install_Null_Excluding_Check
(Exp
);
1009 elsif Is_Access_Type
(DesigT
)
1010 and then Nkind
(Exp
) = N_Allocator
1011 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1013 -- Apply constraint to designated subtype indication
1015 Apply_Constraint_Check
1016 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1018 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1020 -- Propagate constraint_error to enclosing allocator
1022 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1026 Build_Allocate_Deallocate_Proc
(N
);
1028 -- For an access-to-unconstrained-packed-array type, build an
1029 -- expression with a constrained subtype in order for the code
1030 -- generator to compute the proper size for the allocator.
1032 if Is_Packed_Array
(T
) and then not Is_Constrained
(T
) then
1034 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1035 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1038 Make_Subtype_Declaration
(Loc
,
1039 Defining_Identifier
=> ConstrT
,
1040 Subtype_Indication
=>
1041 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1042 Freeze_Itype
(ConstrT
, Exp
);
1043 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1047 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1048 -- to a build-in-place function, then access to the allocated object
1049 -- must be passed to the function.
1051 if Is_Build_In_Place_Function_Call
(Exp
) then
1052 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1057 when RE_Not_Available
=>
1059 end Expand_Allocator_Expression
;
1061 -----------------------------
1062 -- Expand_Array_Comparison --
1063 -----------------------------
1065 -- Expansion is only required in the case of array types. For the unpacked
1066 -- case, an appropriate runtime routine is called. For packed cases, and
1067 -- also in some other cases where a runtime routine cannot be called, the
1068 -- form of the expansion is:
1070 -- [body for greater_nn; boolean_expression]
1072 -- The body is built by Make_Array_Comparison_Op, and the form of the
1073 -- Boolean expression depends on the operator involved.
1075 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1076 Loc
: constant Source_Ptr
:= Sloc
(N
);
1077 Op1
: Node_Id
:= Left_Opnd
(N
);
1078 Op2
: Node_Id
:= Right_Opnd
(N
);
1079 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1080 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1083 Func_Body
: Node_Id
;
1084 Func_Name
: Entity_Id
;
1088 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1089 -- True for byte addressable target
1091 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1092 -- Returns True if the length of the given operand is known to be less
1093 -- than 4. Returns False if this length is known to be four or greater
1094 -- or is not known at compile time.
1096 ------------------------
1097 -- Length_Less_Than_4 --
1098 ------------------------
1100 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1101 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1104 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1105 return String_Literal_Length
(Otyp
) < 4;
1107 elsif Compile_Time_Known_Bounds
(Otyp
) then
1112 Get_First_Index_Bounds
(Otyp
, Lo
, Hi
);
1119 end Length_Less_Than_4
;
1121 -- Start of processing for Expand_Array_Comparison
1124 -- Deal first with unpacked case, where we can call a runtime routine
1125 -- except that we avoid this for targets for which are not addressable
1128 if not Is_Bit_Packed_Array
(Typ1
) and then Byte_Addressable
then
1129 -- The call we generate is:
1131 -- Compare_Array_xn[_Unaligned]
1132 -- (left'address, right'address, left'length, right'length) <op> 0
1134 -- x = U for unsigned, S for signed
1135 -- n = 8,16,32,64,128 for component size
1136 -- Add _Unaligned if length < 4 and component size is 8.
1137 -- <op> is the standard comparison operator
1139 if Component_Size
(Typ1
) = 8 then
1140 if Length_Less_Than_4
(Op1
)
1142 Length_Less_Than_4
(Op2
)
1144 if Is_Unsigned_Type
(Ctyp
) then
1145 Comp
:= RE_Compare_Array_U8_Unaligned
;
1147 Comp
:= RE_Compare_Array_S8_Unaligned
;
1151 if Is_Unsigned_Type
(Ctyp
) then
1152 Comp
:= RE_Compare_Array_U8
;
1154 Comp
:= RE_Compare_Array_S8
;
1158 elsif Component_Size
(Typ1
) = 16 then
1159 if Is_Unsigned_Type
(Ctyp
) then
1160 Comp
:= RE_Compare_Array_U16
;
1162 Comp
:= RE_Compare_Array_S16
;
1165 elsif Component_Size
(Typ1
) = 32 then
1166 if Is_Unsigned_Type
(Ctyp
) then
1167 Comp
:= RE_Compare_Array_U32
;
1169 Comp
:= RE_Compare_Array_S32
;
1172 elsif Component_Size
(Typ1
) = 64 then
1173 if Is_Unsigned_Type
(Ctyp
) then
1174 Comp
:= RE_Compare_Array_U64
;
1176 Comp
:= RE_Compare_Array_S64
;
1179 else pragma Assert
(Component_Size
(Typ1
) = 128);
1180 if Is_Unsigned_Type
(Ctyp
) then
1181 Comp
:= RE_Compare_Array_U128
;
1183 Comp
:= RE_Compare_Array_S128
;
1187 if RTE_Available
(Comp
) then
1189 -- Expand to a call only if the runtime function is available,
1190 -- otherwise fall back to inline code.
1192 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1193 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1196 Comp_Call
: constant Node_Id
:=
1197 Make_Function_Call
(Loc
,
1198 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1200 Parameter_Associations
=> New_List
(
1201 Make_Attribute_Reference
(Loc
,
1202 Prefix
=> Relocate_Node
(Op1
),
1203 Attribute_Name
=> Name_Address
),
1205 Make_Attribute_Reference
(Loc
,
1206 Prefix
=> Relocate_Node
(Op2
),
1207 Attribute_Name
=> Name_Address
),
1209 Make_Attribute_Reference
(Loc
,
1210 Prefix
=> Relocate_Node
(Op1
),
1211 Attribute_Name
=> Name_Length
),
1213 Make_Attribute_Reference
(Loc
,
1214 Prefix
=> Relocate_Node
(Op2
),
1215 Attribute_Name
=> Name_Length
)));
1217 Zero
: constant Node_Id
:=
1218 Make_Integer_Literal
(Loc
,
1226 Comp_Op
:= Make_Op_Lt
(Loc
, Comp_Call
, Zero
);
1228 Comp_Op
:= Make_Op_Le
(Loc
, Comp_Call
, Zero
);
1230 Comp_Op
:= Make_Op_Gt
(Loc
, Comp_Call
, Zero
);
1232 Comp_Op
:= Make_Op_Ge
(Loc
, Comp_Call
, Zero
);
1234 raise Program_Error
;
1237 Rewrite
(N
, Comp_Op
);
1240 Analyze_And_Resolve
(N
, Standard_Boolean
);
1245 -- Cases where we cannot make runtime call
1247 -- For (a <= b) we convert to not (a > b)
1249 if Chars
(N
) = Name_Op_Le
then
1255 Right_Opnd
=> Op2
)));
1256 Analyze_And_Resolve
(N
, Standard_Boolean
);
1259 -- For < the Boolean expression is
1260 -- greater__nn (op2, op1)
1262 elsif Chars
(N
) = Name_Op_Lt
then
1263 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1267 Op1
:= Right_Opnd
(N
);
1268 Op2
:= Left_Opnd
(N
);
1270 -- For (a >= b) we convert to not (a < b)
1272 elsif Chars
(N
) = Name_Op_Ge
then
1278 Right_Opnd
=> Op2
)));
1279 Analyze_And_Resolve
(N
, Standard_Boolean
);
1282 -- For > the Boolean expression is
1283 -- greater__nn (op1, op2)
1286 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1287 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1290 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1292 Make_Function_Call
(Loc
,
1293 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1294 Parameter_Associations
=> New_List
(Op1
, Op2
));
1296 Insert_Action
(N
, Func_Body
);
1298 Analyze_And_Resolve
(N
, Standard_Boolean
);
1299 end Expand_Array_Comparison
;
1301 ---------------------------
1302 -- Expand_Array_Equality --
1303 ---------------------------
1305 -- Expand an equality function for multi-dimensional arrays. Here is an
1306 -- example of such a function for Nb_Dimension = 2
1308 -- function Enn (A : atyp; B : btyp) return boolean is
1310 -- if (A'length (1) = 0 or else A'length (2) = 0)
1312 -- (B'length (1) = 0 or else B'length (2) = 0)
1314 -- return true; -- RM 4.5.2(22)
1317 -- if A'length (1) /= B'length (1)
1319 -- A'length (2) /= B'length (2)
1321 -- return false; -- RM 4.5.2(23)
1325 -- A1 : Index_T1 := A'first (1);
1326 -- B1 : Index_T1 := B'first (1);
1330 -- A2 : Index_T2 := A'first (2);
1331 -- B2 : Index_T2 := B'first (2);
1334 -- if A (A1, A2) /= B (B1, B2) then
1338 -- exit when A2 = A'last (2);
1339 -- A2 := Index_T2'succ (A2);
1340 -- B2 := Index_T2'succ (B2);
1344 -- exit when A1 = A'last (1);
1345 -- A1 := Index_T1'succ (A1);
1346 -- B1 := Index_T1'succ (B1);
1353 -- Note on the formal types used (atyp and btyp). If either of the arrays
1354 -- is of a private type, we use the underlying type, and do an unchecked
1355 -- conversion of the actual. If either of the arrays has a bound depending
1356 -- on a discriminant, then we use the base type since otherwise we have an
1357 -- escaped discriminant in the function.
1359 -- If both arrays are constrained and have the same bounds, we can generate
1360 -- a loop with an explicit iteration scheme using a 'Range attribute over
1363 function Expand_Array_Equality
1368 Typ
: Entity_Id
) return Node_Id
1370 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1371 Decls
: constant List_Id
:= New_List
;
1372 Index_List1
: constant List_Id
:= New_List
;
1373 Index_List2
: constant List_Id
:= New_List
;
1375 First_Idx
: Node_Id
;
1377 Func_Name
: Entity_Id
;
1378 Func_Body
: Node_Id
;
1380 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1381 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1385 -- The parameter types to be used for the formals
1389 -- The LHS and RHS converted to the parameter types
1394 Dim
: Pos
) return Node_Id
;
1395 -- This builds the attribute reference Arr'Nam (Dim)
1397 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1398 -- Create one statement to compare corresponding components, designated
1399 -- by a full set of indexes.
1401 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1402 -- Given one of the arguments, computes the appropriate type to be used
1403 -- for that argument in the corresponding function formal
1405 function Handle_One_Dimension
1407 Index
: Node_Id
) return Node_Id
;
1408 -- This procedure returns the following code
1411 -- An : Index_T := A'First (N);
1412 -- Bn : Index_T := B'First (N);
1416 -- exit when An = A'Last (N);
1417 -- An := Index_T'Succ (An)
1418 -- Bn := Index_T'Succ (Bn)
1422 -- If both indexes are constrained and identical, the procedure
1423 -- returns a simpler loop:
1425 -- for An in A'Range (N) loop
1429 -- N is the dimension for which we are generating a loop. Index is the
1430 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1431 -- xxx statement is either the loop or declare for the next dimension
1432 -- or if this is the last dimension the comparison of corresponding
1433 -- components of the arrays.
1435 -- The actual way the code works is to return the comparison of
1436 -- corresponding components for the N+1 call. That's neater.
1438 function Test_Empty_Arrays
return Node_Id
;
1439 -- This function constructs the test for both arrays being empty
1440 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1442 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1444 function Test_Lengths_Correspond
return Node_Id
;
1445 -- This function constructs the test for arrays having different lengths
1446 -- in at least one index position, in which case the resulting code is:
1448 -- A'length (1) /= B'length (1)
1450 -- A'length (2) /= B'length (2)
1461 Dim
: Pos
) return Node_Id
1465 Make_Attribute_Reference
(Loc
,
1466 Attribute_Name
=> Nam
,
1467 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1468 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
1471 ------------------------
1472 -- Component_Equality --
1473 ------------------------
1475 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1480 -- if a(i1...) /= b(j1...) then return false; end if;
1483 Make_Indexed_Component
(Loc
,
1484 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1485 Expressions
=> Index_List1
);
1488 Make_Indexed_Component
(Loc
,
1489 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1490 Expressions
=> Index_List2
);
1492 Test
:= Expand_Composite_Equality
1493 (Outer_Type
=> Typ
, Nod
=> Nod
, Comp_Type
=> Component_Type
(Typ
),
1494 Lhs
=> L
, Rhs
=> R
);
1496 -- If some (sub)component is an unchecked_union, the whole operation
1497 -- will raise program error.
1499 if Nkind
(Test
) = N_Raise_Program_Error
then
1501 -- This node is going to be inserted at a location where a
1502 -- statement is expected: clear its Etype so analysis will set
1503 -- it to the expected Standard_Void_Type.
1505 Set_Etype
(Test
, Empty
);
1510 Make_Implicit_If_Statement
(Nod
,
1511 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1512 Then_Statements
=> New_List
(
1513 Make_Simple_Return_Statement
(Loc
,
1514 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1516 end Component_Equality
;
1522 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1533 T
:= Underlying_Type
(T
);
1535 X
:= First_Index
(T
);
1536 while Present
(X
) loop
1537 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1539 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1552 --------------------------
1553 -- Handle_One_Dimension --
1554 ---------------------------
1556 function Handle_One_Dimension
1558 Index
: Node_Id
) return Node_Id
1560 Need_Separate_Indexes
: constant Boolean :=
1561 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1562 -- If the index types are identical, and we are working with
1563 -- constrained types, then we can use the same index for both
1566 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1569 Index_T
: Entity_Id
;
1574 if N
> Number_Dimensions
(Ltyp
) then
1575 return Component_Equality
(Ltyp
);
1578 -- Case where we generate a loop
1580 Index_T
:= Base_Type
(Etype
(Index
));
1582 if Need_Separate_Indexes
then
1583 Bn
:= Make_Temporary
(Loc
, 'B');
1588 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1589 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1591 Stm_List
:= New_List
(
1592 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1594 if Need_Separate_Indexes
then
1596 -- Generate guard for loop, followed by increments of indexes
1598 Append_To
(Stm_List
,
1599 Make_Exit_Statement
(Loc
,
1602 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1603 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1605 Append_To
(Stm_List
,
1606 Make_Assignment_Statement
(Loc
,
1607 Name
=> New_Occurrence_Of
(An
, Loc
),
1609 Make_Attribute_Reference
(Loc
,
1610 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1611 Attribute_Name
=> Name_Succ
,
1612 Expressions
=> New_List
(
1613 New_Occurrence_Of
(An
, Loc
)))));
1615 Append_To
(Stm_List
,
1616 Make_Assignment_Statement
(Loc
,
1617 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1619 Make_Attribute_Reference
(Loc
,
1620 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1621 Attribute_Name
=> Name_Succ
,
1622 Expressions
=> New_List
(
1623 New_Occurrence_Of
(Bn
, Loc
)))));
1626 -- If separate indexes, we need a declare block for An and Bn, and a
1627 -- loop without an iteration scheme.
1629 if Need_Separate_Indexes
then
1631 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1634 Make_Block_Statement
(Loc
,
1635 Declarations
=> New_List
(
1636 Make_Object_Declaration
(Loc
,
1637 Defining_Identifier
=> An
,
1638 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1639 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1641 Make_Object_Declaration
(Loc
,
1642 Defining_Identifier
=> Bn
,
1643 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1644 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1646 Handled_Statement_Sequence
=>
1647 Make_Handled_Sequence_Of_Statements
(Loc
,
1648 Statements
=> New_List
(Loop_Stm
)));
1650 -- If no separate indexes, return loop statement with explicit
1651 -- iteration scheme on its own.
1655 Make_Implicit_Loop_Statement
(Nod
,
1656 Statements
=> Stm_List
,
1658 Make_Iteration_Scheme
(Loc
,
1659 Loop_Parameter_Specification
=>
1660 Make_Loop_Parameter_Specification
(Loc
,
1661 Defining_Identifier
=> An
,
1662 Discrete_Subtype_Definition
=>
1663 Arr_Attr
(A
, Name_Range
, N
))));
1666 end Handle_One_Dimension
;
1668 -----------------------
1669 -- Test_Empty_Arrays --
1670 -----------------------
1672 function Test_Empty_Arrays
return Node_Id
is
1673 Alist
: Node_Id
:= Empty
;
1674 Blist
: Node_Id
:= Empty
;
1677 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1678 Evolve_Or_Else
(Alist
,
1680 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1681 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
1683 Evolve_Or_Else
(Blist
,
1685 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1686 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
1692 Right_Opnd
=> Blist
);
1693 end Test_Empty_Arrays
;
1695 -----------------------------
1696 -- Test_Lengths_Correspond --
1697 -----------------------------
1699 function Test_Lengths_Correspond
return Node_Id
is
1700 Result
: Node_Id
:= Empty
;
1703 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1704 Evolve_Or_Else
(Result
,
1706 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1707 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
)));
1711 end Test_Lengths_Correspond
;
1713 -- Start of processing for Expand_Array_Equality
1716 Ltyp
:= Get_Arg_Type
(Lhs
);
1717 Rtyp
:= Get_Arg_Type
(Rhs
);
1719 -- For now, if the argument types are not the same, go to the base type,
1720 -- since the code assumes that the formals have the same type. This is
1721 -- fixable in future ???
1723 if Ltyp
/= Rtyp
then
1724 Ltyp
:= Base_Type
(Ltyp
);
1725 Rtyp
:= Base_Type
(Rtyp
);
1728 -- If the array type is distinct from the type of the arguments, it
1729 -- is the full view of a private type. Apply an unchecked conversion
1730 -- to ensure that analysis of the code below succeeds.
1733 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1735 New_Lhs
:= OK_Convert_To
(Ltyp
, Lhs
);
1741 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1743 New_Rhs
:= OK_Convert_To
(Rtyp
, Rhs
);
1748 pragma Assert
(Ltyp
= Rtyp
);
1749 First_Idx
:= First_Index
(Ltyp
);
1751 -- If optimization is enabled and the array boils down to a couple of
1752 -- consecutive elements, generate a simple conjunction of comparisons
1753 -- which should be easier to optimize by the code generator.
1755 if Optimization_Level
> 0
1756 and then Is_Constrained
(Ltyp
)
1757 and then Number_Dimensions
(Ltyp
) = 1
1758 and then Compile_Time_Known_Bounds
(Ltyp
)
1759 and then Expr_Value
(Type_High_Bound
(Etype
(First_Idx
))) =
1760 Expr_Value
(Type_Low_Bound
(Etype
(First_Idx
))) + 1
1763 Ctyp
: constant Entity_Id
:= Component_Type
(Ltyp
);
1764 Low_B
: constant Node_Id
:=
1765 Type_Low_Bound
(Etype
(First_Idx
));
1766 High_B
: constant Node_Id
:=
1767 Type_High_Bound
(Etype
(First_Idx
));
1769 TestL
, TestH
: Node_Id
;
1773 Make_Indexed_Component
(Loc
,
1774 Prefix
=> New_Copy_Tree
(New_Lhs
),
1775 Expressions
=> New_List
(New_Copy_Tree
(Low_B
)));
1778 Make_Indexed_Component
(Loc
,
1779 Prefix
=> New_Copy_Tree
(New_Rhs
),
1780 Expressions
=> New_List
(New_Copy_Tree
(Low_B
)));
1782 TestL
:= Expand_Composite_Equality
1783 (Outer_Type
=> Ltyp
, Nod
=> Nod
, Comp_Type
=> Ctyp
,
1784 Lhs
=> L
, Rhs
=> R
);
1787 Make_Indexed_Component
(Loc
,
1789 Expressions
=> New_List
(New_Copy_Tree
(High_B
)));
1792 Make_Indexed_Component
(Loc
,
1794 Expressions
=> New_List
(New_Copy_Tree
(High_B
)));
1796 TestH
:= Expand_Composite_Equality
1797 (Outer_Type
=> Ltyp
, Nod
=> Nod
, Comp_Type
=> Ctyp
,
1798 Lhs
=> L
, Rhs
=> R
);
1801 Make_And_Then
(Loc
, Left_Opnd
=> TestL
, Right_Opnd
=> TestH
);
1805 -- Build list of formals for function
1807 Formals
:= New_List
(
1808 Make_Parameter_Specification
(Loc
,
1809 Defining_Identifier
=> A
,
1810 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
1812 Make_Parameter_Specification
(Loc
,
1813 Defining_Identifier
=> B
,
1814 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
1816 Func_Name
:= Make_Temporary
(Loc
, 'E');
1818 -- Build statement sequence for function
1821 Make_Subprogram_Body
(Loc
,
1823 Make_Function_Specification
(Loc
,
1824 Defining_Unit_Name
=> Func_Name
,
1825 Parameter_Specifications
=> Formals
,
1826 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1828 Declarations
=> Decls
,
1830 Handled_Statement_Sequence
=>
1831 Make_Handled_Sequence_Of_Statements
(Loc
,
1832 Statements
=> New_List
(
1834 Make_Implicit_If_Statement
(Nod
,
1835 Condition
=> Test_Empty_Arrays
,
1836 Then_Statements
=> New_List
(
1837 Make_Simple_Return_Statement
(Loc
,
1839 New_Occurrence_Of
(Standard_True
, Loc
)))),
1841 Make_Implicit_If_Statement
(Nod
,
1842 Condition
=> Test_Lengths_Correspond
,
1843 Then_Statements
=> New_List
(
1844 Make_Simple_Return_Statement
(Loc
,
1845 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
1847 Handle_One_Dimension
(1, First_Idx
),
1849 Make_Simple_Return_Statement
(Loc
,
1850 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1852 Set_Has_Completion
(Func_Name
, True);
1853 Set_Is_Inlined
(Func_Name
);
1855 Append_To
(Bodies
, Func_Body
);
1858 Make_Function_Call
(Loc
,
1859 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1860 Parameter_Associations
=> New_List
(New_Lhs
, New_Rhs
));
1861 end Expand_Array_Equality
;
1863 -----------------------------
1864 -- Expand_Boolean_Operator --
1865 -----------------------------
1867 -- Note that we first get the actual subtypes of the operands, since we
1868 -- always want to deal with types that have bounds.
1870 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
1871 Typ
: constant Entity_Id
:= Etype
(N
);
1874 -- Special case of bit packed array where both operands are known to be
1875 -- properly aligned. In this case we use an efficient run time routine
1876 -- to carry out the operation (see System.Bit_Ops).
1878 if Is_Bit_Packed_Array
(Typ
)
1879 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
1880 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
1882 Expand_Packed_Boolean_Operator
(N
);
1886 -- For the normal non-packed case, the general expansion is to build
1887 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1888 -- and then inserting it into the tree. The original operator node is
1889 -- then rewritten as a call to this function. We also use this in the
1890 -- packed case if either operand is a possibly unaligned object.
1893 Loc
: constant Source_Ptr
:= Sloc
(N
);
1894 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
1895 R
: Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
1896 Func_Body
: Node_Id
;
1897 Func_Name
: Entity_Id
;
1900 Convert_To_Actual_Subtype
(L
);
1901 Convert_To_Actual_Subtype
(R
);
1902 Ensure_Defined
(Etype
(L
), N
);
1903 Ensure_Defined
(Etype
(R
), N
);
1904 Apply_Length_Check
(R
, Etype
(L
));
1906 if Nkind
(N
) = N_Op_Xor
then
1907 R
:= Duplicate_Subexpr
(R
);
1908 Silly_Boolean_Array_Xor_Test
(N
, R
, Etype
(L
));
1911 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1912 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
1914 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
1916 elsif Nkind
(Parent
(N
)) = N_Op_Not
1917 and then Nkind
(N
) = N_Op_And
1918 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1919 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
1923 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
1924 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1925 Insert_Action
(N
, Func_Body
);
1927 -- Now rewrite the expression with a call
1929 if Transform_Function_Array
then
1931 Temp_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1940 Make_Object_Declaration
(Loc
,
1941 Defining_Identifier
=> Temp_Id
,
1942 Object_Definition
=>
1943 New_Occurrence_Of
(Etype
(L
), Loc
));
1946 -- Proc_Call (L, R, Temp);
1949 Make_Procedure_Call_Statement
(Loc
,
1950 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1951 Parameter_Associations
=>
1954 Make_Type_Conversion
1955 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
),
1956 New_Occurrence_Of
(Temp_Id
, Loc
)));
1958 Insert_Actions
(Parent
(N
), New_List
(Decl
, Call
));
1959 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1963 Make_Function_Call
(Loc
,
1964 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1965 Parameter_Associations
=>
1968 Make_Type_Conversion
1969 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
1972 Analyze_And_Resolve
(N
, Typ
);
1975 end Expand_Boolean_Operator
;
1977 ------------------------------------------------
1978 -- Expand_Compare_Minimize_Eliminate_Overflow --
1979 ------------------------------------------------
1981 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
1982 Loc
: constant Source_Ptr
:= Sloc
(N
);
1984 Result_Type
: constant Entity_Id
:= Etype
(N
);
1985 -- Capture result type (could be a derived boolean type)
1990 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1991 -- Entity for Long_Long_Integer'Base
1994 procedure Set_False
;
1995 -- These procedures rewrite N with an occurrence of Standard_True or
1996 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2002 procedure Set_False
is
2004 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2005 Warn_On_Known_Condition
(N
);
2012 procedure Set_True
is
2014 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2015 Warn_On_Known_Condition
(N
);
2018 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2021 -- OK, this is the case we are interested in. First step is to process
2022 -- our operands using the Minimize_Eliminate circuitry which applies
2023 -- this processing to the two operand subtrees.
2025 Minimize_Eliminate_Overflows
2026 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2027 Minimize_Eliminate_Overflows
2028 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2030 -- See if the range information decides the result of the comparison.
2031 -- We can only do this if we in fact have full range information (which
2032 -- won't be the case if either operand is bignum at this stage).
2034 if Present
(Llo
) and then Present
(Rlo
) then
2035 case N_Op_Compare
(Nkind
(N
)) is
2037 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2039 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2046 elsif Lhi
< Rlo
then
2053 elsif Lhi
<= Rlo
then
2060 elsif Lhi
<= Rlo
then
2067 elsif Lhi
< Rlo
then
2072 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2074 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2079 -- All done if we did the rewrite
2081 if Nkind
(N
) not in N_Op_Compare
then
2086 -- Otherwise, time to do the comparison
2089 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2090 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2093 -- If the two operands have the same signed integer type we are
2094 -- all set, nothing more to do. This is the case where either
2095 -- both operands were unchanged, or we rewrote both of them to
2096 -- be Long_Long_Integer.
2098 -- Note: Entity for the comparison may be wrong, but it's not worth
2099 -- the effort to change it, since the back end does not use it.
2101 if Is_Signed_Integer_Type
(Ltype
)
2102 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2106 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2108 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2110 Left
: Node_Id
:= Left_Opnd
(N
);
2111 Right
: Node_Id
:= Right_Opnd
(N
);
2112 -- Bignum references for left and right operands
2115 if not Is_RTE
(Ltype
, RE_Bignum
) then
2116 Left
:= Convert_To_Bignum
(Left
);
2117 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2118 Right
:= Convert_To_Bignum
(Right
);
2121 -- We rewrite our node with:
2124 -- Bnn : Result_Type;
2126 -- M : Mark_Id := SS_Mark;
2128 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2136 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2137 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2141 case N_Op_Compare
(Nkind
(N
)) is
2142 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2143 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2144 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2145 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2146 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2147 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2150 -- Insert assignment to Bnn into the bignum block
2153 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2154 Make_Assignment_Statement
(Loc
,
2155 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2157 Make_Function_Call
(Loc
,
2159 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2160 Parameter_Associations
=> New_List
(Left
, Right
))));
2162 -- Now do the rewrite with expression actions
2165 Make_Expression_With_Actions
(Loc
,
2166 Actions
=> New_List
(
2167 Make_Object_Declaration
(Loc
,
2168 Defining_Identifier
=> Bnn
,
2169 Object_Definition
=>
2170 New_Occurrence_Of
(Result_Type
, Loc
)),
2172 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2173 Analyze_And_Resolve
(N
, Result_Type
);
2177 -- No bignums involved, but types are different, so we must have
2178 -- rewritten one of the operands as a Long_Long_Integer but not
2181 -- If left operand is Long_Long_Integer, convert right operand
2182 -- and we are done (with a comparison of two Long_Long_Integers).
2184 elsif Ltype
= LLIB
then
2185 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2186 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2189 -- If right operand is Long_Long_Integer, convert left operand
2190 -- and we are done (with a comparison of two Long_Long_Integers).
2192 -- This is the only remaining possibility
2194 else pragma Assert
(Rtype
= LLIB
);
2195 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2196 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2200 end Expand_Compare_Minimize_Eliminate_Overflow
;
2202 -------------------------------
2203 -- Expand_Composite_Equality --
2204 -------------------------------
2206 -- This function is only called for comparing internal fields of composite
2207 -- types when these fields are themselves composites. This is a special
2208 -- case because it is not possible to respect normal Ada visibility rules.
2210 function Expand_Composite_Equality
2211 (Outer_Type
: Entity_Id
;
2213 Comp_Type
: Entity_Id
;
2215 Rhs
: Node_Id
) return Node_Id
2217 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2218 Full_Type
: Entity_Id
;
2222 if Is_Private_Type
(Comp_Type
) then
2223 Full_Type
:= Underlying_Type
(Comp_Type
);
2225 Full_Type
:= Comp_Type
;
2228 -- If the private type has no completion the context may be the
2229 -- expansion of a composite equality for a composite type with some
2230 -- still incomplete components. The expression will not be analyzed
2231 -- until the enclosing type is completed, at which point this will be
2232 -- properly expanded, unless there is a bona fide completion error.
2234 if No
(Full_Type
) then
2235 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2238 Full_Type
:= Base_Type
(Full_Type
);
2240 -- When the base type itself is private, use the full view to expand
2241 -- the composite equality.
2243 if Is_Private_Type
(Full_Type
) then
2244 Full_Type
:= Underlying_Type
(Full_Type
);
2247 -- Case of tagged record types
2249 if Is_Tagged_Type
(Full_Type
) then
2250 Eq_Op
:= Find_Primitive_Eq
(Comp_Type
);
2251 pragma Assert
(Present
(Eq_Op
));
2254 Make_Function_Call
(Loc
,
2255 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2256 Parameter_Associations
=>
2258 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2259 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2261 -- Case of untagged record types
2263 elsif Is_Record_Type
(Full_Type
) then
2264 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2266 if Present
(Eq_Op
) then
2268 Op_Typ
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2270 L_Exp
, R_Exp
: Node_Id
;
2273 -- Adjust operands if necessary to comparison type
2275 if Base_Type
(Full_Type
) /= Base_Type
(Op_Typ
) then
2276 L_Exp
:= OK_Convert_To
(Op_Typ
, Lhs
);
2277 R_Exp
:= OK_Convert_To
(Op_Typ
, Rhs
);
2280 L_Exp
:= Relocate_Node
(Lhs
);
2281 R_Exp
:= Relocate_Node
(Rhs
);
2285 Make_Function_Call
(Loc
,
2286 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2287 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
));
2290 -- Equality composes in Ada 2012 for untagged record types. It also
2291 -- composes for bounded strings, because they are part of the
2292 -- predefined environment (see 4.5.2(32.1/1)). We could make it
2293 -- compose for bounded strings by making them tagged, or by making
2294 -- sure all subcomponents are set to the same value, even when not
2295 -- used. Instead, we have this special case in the compiler, because
2296 -- it's more efficient.
2298 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Comp_Type
)
2300 -- If no TSS has been created for the type, check whether there is
2301 -- a primitive equality declared for it.
2304 Op
: constant Node_Id
:=
2305 Build_Eq_Call
(Comp_Type
, Loc
, Lhs
, Rhs
);
2308 -- Use user-defined primitive if it exists, otherwise use
2309 -- predefined equality.
2311 if Present
(Op
) then
2314 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2319 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
);
2322 -- Case of non-record types (always use predefined equality)
2325 -- Print a warning if there is a user-defined "=", because it can be
2326 -- surprising that the predefined "=" takes precedence over it.
2328 -- Suppress the warning if the "user-defined" one is in the
2329 -- predefined library, because those are defined to compose
2330 -- properly by RM-4.5.2(32.1/1). Intrinsics also compose.
2333 Op
: constant Entity_Id
:= Find_Primitive_Eq
(Comp_Type
);
2335 if Warn_On_Ignored_Equality
2336 and then Present
(Op
)
2337 and then not In_Predefined_Unit
(Base_Type
(Comp_Type
))
2338 and then not Is_Intrinsic_Subprogram
(Op
)
2341 (Is_First_Subtype
(Outer_Type
)
2342 or else Is_Generic_Actual_Type
(Outer_Type
));
2343 Error_Msg_Node_1
:= Outer_Type
;
2344 Error_Msg_Node_2
:= Comp_Type
;
2346 ("?_q?""="" for type & uses predefined ""="" for }", Loc
);
2347 Error_Msg_Sloc
:= Sloc
(Op
);
2348 Error_Msg
("\?_q?""="" # is ignored here", Loc
);
2352 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2354 end Expand_Composite_Equality
;
2356 ------------------------
2357 -- Expand_Concatenate --
2358 ------------------------
2360 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2361 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2363 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2364 -- Result type of concatenation
2366 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2367 -- Component type. Elements of this component type can appear as one
2368 -- of the operands of concatenation as well as arrays.
2370 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2373 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2374 -- Index type. This is the base type of the index subtype, and is used
2375 -- for all computed bounds (which may be out of range of Istyp in the
2376 -- case of null ranges).
2379 -- This is the type we use to do arithmetic to compute the bounds and
2380 -- lengths of operands. The choice of this type is a little subtle and
2381 -- is discussed in a separate section at the start of the body code.
2383 Result_May_Be_Null
: Boolean := True;
2384 -- Reset to False if at least one operand is encountered which is known
2385 -- at compile time to be non-null. Used for handling the special case
2386 -- of setting the high bound to the last operand high bound for a null
2387 -- result, thus ensuring a proper high bound in the superflat case.
2389 N
: constant Nat
:= List_Length
(Opnds
);
2390 -- Number of concatenation operands including possibly null operands
2393 -- Number of operands excluding any known to be null, except that the
2394 -- last operand is always retained, in case it provides the bounds for
2397 Opnd
: Node_Id
:= Empty
;
2398 -- Current operand being processed in the loop through operands. After
2399 -- this loop is complete, always contains the last operand (which is not
2400 -- the same as Operands (NN), since null operands are skipped).
2402 -- Arrays describing the operands, only the first NN entries of each
2403 -- array are set (NN < N when we exclude known null operands).
2405 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2406 -- True if length of corresponding operand known at compile time
2408 Operands
: array (1 .. N
) of Node_Id
;
2409 -- Set to the corresponding entry in the Opnds list (but note that null
2410 -- operands are excluded, so not all entries in the list are stored).
2412 Fixed_Length
: array (1 .. N
) of Unat
;
2413 -- Set to length of operand. Entries in this array are set only if the
2414 -- corresponding entry in Is_Fixed_Length is True.
2416 Max_Length
: array (1 .. N
) of Unat
;
2417 -- Set to the maximum length of operand, or Too_Large_Length_For_Array
2418 -- if it is not known. Entries in this array are set only if the
2419 -- corresponding entry in Is_Fixed_Length is False;
2421 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2422 -- Set to lower bound of operand. Either an integer literal in the case
2423 -- where the bound is known at compile time, else actual lower bound.
2424 -- The operand low bound is of type Ityp.
2426 Var_Length
: array (1 .. N
) of Entity_Id
;
2427 -- Set to an entity of type Natural that contains the length of an
2428 -- operand whose length is not known at compile time. Entries in this
2429 -- array are set only if the corresponding entry in Is_Fixed_Length
2430 -- is False. The entity is of type Artyp.
2432 Aggr_Length
: array (0 .. N
) of Node_Id
;
2433 -- The J'th entry is an expression node that represents the total length
2434 -- of operands 1 through J. It is either an integer literal node, or a
2435 -- reference to a constant entity with the right value, so it is fine
2436 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth
2437 -- entry always is set to zero. The length is of type Artyp.
2439 Max_Aggr_Length
: Unat
:= Too_Large_Length_For_Array
;
2440 -- Set to the maximum total length, or Too_Large_Length_For_Array at
2441 -- least if it is not known.
2443 Low_Bound
: Node_Id
:= Empty
;
2444 -- A tree node representing the low bound of the result (of type Ityp).
2445 -- This is either an integer literal node, or an identifier reference to
2446 -- a constant entity initialized to the appropriate value.
2448 High_Bound
: Node_Id
:= Empty
;
2449 -- A tree node representing the high bound of the result (of type Ityp)
2451 Last_Opnd_Low_Bound
: Node_Id
:= Empty
;
2452 -- A tree node representing the low bound of the last operand. This
2453 -- need only be set if the result could be null. It is used for the
2454 -- special case of setting the right low bound for a null result.
2455 -- This is of type Ityp.
2457 Last_Opnd_High_Bound
: Node_Id
:= Empty
;
2458 -- A tree node representing the high bound of the last operand. This
2459 -- need only be set if the result could be null. It is used for the
2460 -- special case of setting the right high bound for a null result.
2461 -- This is of type Ityp.
2463 Result
: Node_Id
:= Empty
;
2464 -- Result of the concatenation (of type Ityp)
2466 Actions
: constant List_Id
:= New_List
;
2467 -- Collect actions to be inserted
2469 Known_Non_Null_Operand_Seen
: Boolean;
2470 -- Set True during generation of the assignments of operands into
2471 -- result once an operand known to be non-null has been seen.
2473 function Library_Level_Target
return Boolean;
2474 -- Return True if the concatenation is within the expression of the
2475 -- declaration of a library-level object.
2477 function Make_Artyp_Literal
(Val
: Uint
) return Node_Id
;
2478 -- This function makes an N_Integer_Literal node that is returned in
2479 -- analyzed form with the type set to Artyp. Importantly this literal
2480 -- is not flagged as static, so that if we do computations with it that
2481 -- result in statically detected out of range conditions, we will not
2482 -- generate error messages but instead warning messages.
2484 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2485 -- Given a node of type Ityp, returns the corresponding value of type
2486 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2487 -- For enum types, the Pos of the value is returned.
2489 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2490 -- The inverse function (uses Val in the case of enumeration types)
2492 --------------------------
2493 -- Library_Level_Target --
2494 --------------------------
2496 function Library_Level_Target
return Boolean is
2497 P
: Node_Id
:= Parent
(Cnode
);
2500 while Present
(P
) loop
2501 if Nkind
(P
) = N_Object_Declaration
then
2502 return Is_Library_Level_Entity
(Defining_Identifier
(P
));
2504 -- Prevent the search from going too far
2506 elsif Is_Body_Or_Package_Declaration
(P
) then
2514 end Library_Level_Target
;
2516 ------------------------
2517 -- Make_Artyp_Literal --
2518 ------------------------
2520 function Make_Artyp_Literal
(Val
: Uint
) return Node_Id
is
2521 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2523 Set_Etype
(Result
, Artyp
);
2524 Set_Analyzed
(Result
, True);
2525 Set_Is_Static_Expression
(Result
, False);
2527 end Make_Artyp_Literal
;
2533 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2535 if Ityp
= Base_Type
(Artyp
) then
2538 elsif Is_Enumeration_Type
(Ityp
) then
2540 Make_Attribute_Reference
(Loc
,
2541 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2542 Attribute_Name
=> Name_Pos
,
2543 Expressions
=> New_List
(X
));
2546 return Convert_To
(Artyp
, X
);
2554 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2556 if Is_Enumeration_Type
(Ityp
) then
2558 Make_Attribute_Reference
(Loc
,
2559 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2560 Attribute_Name
=> Name_Val
,
2561 Expressions
=> New_List
(X
));
2563 -- Case where we will do a type conversion
2566 if Ityp
= Base_Type
(Artyp
) then
2569 return Convert_To
(Ityp
, X
);
2576 Opnd_Typ
: Entity_Id
;
2577 Slice_Rng
: Node_Id
;
2578 Subtyp_Ind
: Node_Id
;
2579 Subtyp_Rng
: Node_Id
;
2586 -- Start of processing for Expand_Concatenate
2589 -- Choose an appropriate computational type
2591 -- We will be doing calculations of lengths and bounds in this routine
2592 -- and computing one from the other in some cases, e.g. getting the high
2593 -- bound by adding the length-1 to the low bound.
2595 -- We can't just use the index type, or even its base type for this
2596 -- purpose for two reasons. First it might be an enumeration type which
2597 -- is not suitable for computations of any kind, and second it may
2598 -- simply not have enough range. For example if the index type is
2599 -- -128..+127 then lengths can be up to 256, which is out of range of
2602 -- For enumeration types, we can simply use Standard_Integer, this is
2603 -- sufficient since the actual number of enumeration literals cannot
2604 -- possibly exceed the range of integer (remember we will be doing the
2605 -- arithmetic with POS values, not representation values).
2607 if Is_Enumeration_Type
(Ityp
) then
2608 Artyp
:= Standard_Integer
;
2610 -- For modular types, we use a 32-bit modular type for types whose size
2611 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2612 -- identity type, and for larger unsigned types we use a 64-bit type.
2614 elsif Is_Modular_Integer_Type
(Ityp
) then
2615 if RM_Size
(Ityp
) < Standard_Integer_Size
then
2616 Artyp
:= Standard_Unsigned
;
2617 elsif RM_Size
(Ityp
) = Standard_Integer_Size
then
2620 Artyp
:= Standard_Long_Long_Unsigned
;
2623 -- Similar treatment for signed types
2626 if RM_Size
(Ityp
) < Standard_Integer_Size
then
2627 Artyp
:= Standard_Integer
;
2628 elsif RM_Size
(Ityp
) = Standard_Integer_Size
then
2631 Artyp
:= Standard_Long_Long_Integer
;
2635 -- Supply dummy entry at start of length array
2637 Aggr_Length
(0) := Make_Artyp_Literal
(Uint_0
);
2639 -- Go through operands setting up the above arrays
2643 Opnd
:= Remove_Head
(Opnds
);
2644 Opnd_Typ
:= Etype
(Opnd
);
2646 -- The parent got messed up when we put the operands in a list,
2647 -- so now put back the proper parent for the saved operand, that
2648 -- is to say the concatenation node, to make sure that each operand
2649 -- is seen as a subexpression, e.g. if actions must be inserted.
2651 Set_Parent
(Opnd
, Cnode
);
2653 -- Set will be True when we have setup one entry in the array
2657 -- Singleton element (or character literal) case
2659 if Base_Type
(Opnd_Typ
) = Ctyp
then
2661 Operands
(NN
) := Opnd
;
2662 Is_Fixed_Length
(NN
) := True;
2663 Fixed_Length
(NN
) := Uint_1
;
2664 Result_May_Be_Null
:= False;
2666 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2667 -- since we know that the result cannot be null).
2669 Opnd_Low_Bound
(NN
) :=
2670 Make_Attribute_Reference
(Loc
,
2671 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
2672 Attribute_Name
=> Name_First
);
2676 -- String literal case (can only occur for strings of course)
2678 elsif Nkind
(Opnd
) = N_String_Literal
then
2679 Len
:= String_Literal_Length
(Opnd_Typ
);
2682 Result_May_Be_Null
:= False;
2685 -- Capture last operand low and high bound if result could be null
2687 if J
= N
and then Result_May_Be_Null
then
2688 Last_Opnd_Low_Bound
:=
2689 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2691 Last_Opnd_High_Bound
:=
2692 Make_Op_Subtract
(Loc
,
2694 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
2695 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
2698 -- Skip null string literal
2700 if J
< N
and then Len
= 0 then
2705 Operands
(NN
) := Opnd
;
2706 Is_Fixed_Length
(NN
) := True;
2708 -- Set length and bounds
2710 Fixed_Length
(NN
) := Len
;
2712 Opnd_Low_Bound
(NN
) :=
2713 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2720 -- Check constrained case with known bounds
2722 if Is_Constrained
(Opnd_Typ
)
2723 and then Compile_Time_Known_Bounds
(Opnd_Typ
)
2729 -- Fixed length constrained array type with known at compile
2730 -- time bounds is last case of fixed length operand.
2732 Get_First_Index_Bounds
(Opnd_Typ
, Lo
, Hi
);
2733 Len
:= UI_Max
(Hi
- Lo
+ 1, Uint_0
);
2736 Result_May_Be_Null
:= False;
2739 -- Capture last operand bounds if result could be null
2741 if J
= N
and then Result_May_Be_Null
then
2742 Last_Opnd_Low_Bound
:=
2743 To_Ityp
(Make_Integer_Literal
(Loc
, Lo
));
2745 Last_Opnd_High_Bound
:=
2746 To_Ityp
(Make_Integer_Literal
(Loc
, Hi
));
2749 -- Exclude null length case unless last operand
2751 if J
< N
and then Len
= 0 then
2756 Operands
(NN
) := Opnd
;
2757 Is_Fixed_Length
(NN
) := True;
2758 Fixed_Length
(NN
) := Len
;
2760 Opnd_Low_Bound
(NN
) :=
2761 To_Ityp
(Make_Integer_Literal
(Loc
, Lo
));
2766 -- All cases where the length is not known at compile time, or the
2767 -- special case of an operand which is known to be null but has a
2768 -- lower bound other than 1 or is other than a string type.
2773 -- Capture operand bounds
2775 Opnd_Low_Bound
(NN
) :=
2776 Make_Attribute_Reference
(Loc
,
2778 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2779 Attribute_Name
=> Name_First
);
2781 -- Capture last operand bounds if result could be null
2783 if J
= N
and Result_May_Be_Null
then
2784 Last_Opnd_Low_Bound
:=
2786 Make_Attribute_Reference
(Loc
,
2788 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2789 Attribute_Name
=> Name_First
));
2791 Last_Opnd_High_Bound
:=
2793 Make_Attribute_Reference
(Loc
,
2795 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2796 Attribute_Name
=> Name_Last
));
2799 -- Capture length of operand in entity
2801 Operands
(NN
) := Opnd
;
2802 Is_Fixed_Length
(NN
) := False;
2804 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
2806 -- If the operand is a slice, try to compute an upper bound for
2809 if Nkind
(Opnd
) = N_Slice
2810 and then Is_Constrained
(Etype
(Prefix
(Opnd
)))
2811 and then Compile_Time_Known_Bounds
(Etype
(Prefix
(Opnd
)))
2817 Get_First_Index_Bounds
(Etype
(Prefix
(Opnd
)), Lo
, Hi
);
2818 Max_Length
(NN
) := UI_Max
(Hi
- Lo
+ 1, Uint_0
);
2822 Max_Length
(NN
) := Too_Large_Length_For_Array
;
2826 Make_Object_Declaration
(Loc
,
2827 Defining_Identifier
=> Var_Length
(NN
),
2828 Constant_Present
=> True,
2829 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
2831 Make_Attribute_Reference
(Loc
,
2833 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2834 Attribute_Name
=> Name_Length
)));
2838 -- Set next entry in aggregate length array
2840 -- For first entry, make either integer literal for fixed length
2841 -- or a reference to the saved length for variable length.
2844 if Is_Fixed_Length
(1) then
2845 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
2846 Max_Aggr_Length
:= Fixed_Length
(1);
2848 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
2849 Max_Aggr_Length
:= Max_Length
(1);
2852 -- If entry is fixed length and only fixed lengths so far, make
2853 -- appropriate new integer literal adding new length.
2855 elsif Is_Fixed_Length
(NN
)
2856 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
2859 Make_Integer_Literal
(Loc
,
2860 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
2861 Max_Aggr_Length
:= Intval
(Aggr_Length
(NN
));
2863 -- All other cases, construct an addition node for the length and
2864 -- create an entity initialized to this length.
2867 Ent
:= Make_Temporary
(Loc
, 'L');
2869 if Is_Fixed_Length
(NN
) then
2870 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
2871 Max_Aggr_Length
:= Max_Aggr_Length
+ Fixed_Length
(NN
);
2874 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
2875 Max_Aggr_Length
:= Max_Aggr_Length
+ Max_Length
(NN
);
2879 Make_Object_Declaration
(Loc
,
2880 Defining_Identifier
=> Ent
,
2881 Constant_Present
=> True,
2882 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
2885 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
- 1)),
2886 Right_Opnd
=> Clen
)));
2888 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
2895 -- If we have only skipped null operands, return the last operand
2902 -- If we have only one non-null operand, return it and we are done.
2903 -- There is one case in which this cannot be done, and that is when
2904 -- the sole operand is of the element type, in which case it must be
2905 -- converted to an array, and the easiest way of doing that is to go
2906 -- through the normal general circuit.
2908 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
2909 Result
:= Operands
(1);
2913 -- Cases where we have a real concatenation
2915 -- Next step is to find the low bound for the result array that we
2916 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
2918 -- If the ultimate ancestor of the index subtype is a constrained array
2919 -- definition, then the lower bound is that of the index subtype as
2920 -- specified by (RM 4.5.3(6)).
2922 -- The right test here is to go to the root type, and then the ultimate
2923 -- ancestor is the first subtype of this root type.
2925 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
2927 Make_Attribute_Reference
(Loc
,
2929 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
2930 Attribute_Name
=> Name_First
);
2932 -- If the first operand in the list has known length we know that
2933 -- the lower bound of the result is the lower bound of this operand.
2935 elsif Is_Fixed_Length
(1) then
2936 Low_Bound
:= Opnd_Low_Bound
(1);
2938 -- OK, we don't know the lower bound, we have to build a horrible
2939 -- if expression node of the form
2941 -- if Cond1'Length /= 0 then
2944 -- if Opnd2'Length /= 0 then
2949 -- The nesting ends either when we hit an operand whose length is known
2950 -- at compile time, or on reaching the last operand, whose low bound we
2951 -- take unconditionally whether or not it is null. It's easiest to do
2952 -- this with a recursive procedure:
2956 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
2957 -- Returns the lower bound determined by operands J .. NN
2959 ---------------------
2960 -- Get_Known_Bound --
2961 ---------------------
2963 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
2965 if Is_Fixed_Length
(J
) or else J
= NN
then
2966 return New_Copy_Tree
(Opnd_Low_Bound
(J
));
2970 Make_If_Expression
(Loc
,
2971 Expressions
=> New_List
(
2975 New_Occurrence_Of
(Var_Length
(J
), Loc
),
2977 Make_Integer_Literal
(Loc
, 0)),
2979 New_Copy_Tree
(Opnd_Low_Bound
(J
)),
2980 Get_Known_Bound
(J
+ 1)));
2982 end Get_Known_Bound
;
2985 Ent
:= Make_Temporary
(Loc
, 'L');
2988 Make_Object_Declaration
(Loc
,
2989 Defining_Identifier
=> Ent
,
2990 Constant_Present
=> True,
2991 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
2992 Expression
=> Get_Known_Bound
(1)));
2994 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
2998 pragma Assert
(Present
(Low_Bound
));
3000 -- Now we can compute the high bound as Low_Bound + Length - 1
3002 if Compile_Time_Known_Value
(Low_Bound
)
3003 and then Nkind
(Aggr_Length
(NN
)) = N_Integer_Literal
3008 (Expr_Value
(Low_Bound
) + Intval
(Aggr_Length
(NN
)) - 1));
3014 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3016 Make_Op_Subtract
(Loc
,
3017 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3018 Right_Opnd
=> Make_Artyp_Literal
(Uint_1
))));
3020 -- Note that calculation of the high bound may cause overflow in some
3021 -- very weird cases, so in the general case we need an overflow check
3022 -- on the high bound. We can avoid this for the common case of string
3023 -- types and other types whose index is Positive, since we chose a
3024 -- wider range for the arithmetic type. If checks are suppressed, we
3025 -- do not set the flag so superfluous warnings may be omitted.
3027 if Istyp
/= Standard_Positive
3028 and then not Overflow_Checks_Suppressed
(Istyp
)
3030 Activate_Overflow_Check
(High_Bound
);
3034 -- Handle the exceptional case where the result is null, in which case
3035 -- case the bounds come from the last operand (so that we get the proper
3036 -- bounds if the last operand is superflat).
3038 if Result_May_Be_Null
then
3040 Make_If_Expression
(Loc
,
3041 Expressions
=> New_List
(
3043 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3044 Right_Opnd
=> Make_Artyp_Literal
(Uint_0
)),
3045 Last_Opnd_Low_Bound
,
3049 Make_If_Expression
(Loc
,
3050 Expressions
=> New_List
(
3052 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3053 Right_Opnd
=> Make_Artyp_Literal
(Uint_0
)),
3054 Last_Opnd_High_Bound
,
3058 -- Here is where we insert the saved up actions
3060 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3062 -- If the low bound is known at compile time and not the high bound, but
3063 -- we have computed a sensible upper bound for the length, then adjust
3064 -- the high bound for the subtype of the array. This will change it into
3065 -- a static subtype and thus help the code generator.
3067 if Compile_Time_Known_Value
(Low_Bound
)
3068 and then not Compile_Time_Known_Value
(High_Bound
)
3069 and then Max_Aggr_Length
< Too_Large_Length_For_Array
3072 Known_High_Bound
: constant Node_Id
:=
3075 (Expr_Value
(Low_Bound
) + Max_Aggr_Length
- 1));
3078 if not Is_Out_Of_Range
(Known_High_Bound
, Ityp
) then
3079 Slice_Rng
:= Make_Range
(Loc
, Low_Bound
, High_Bound
);
3080 High_Bound
:= Known_High_Bound
;
3091 Subtyp_Rng
:= Make_Range
(Loc
, Low_Bound
, High_Bound
);
3093 -- If the result cannot be null then the range cannot be superflat
3095 Set_Cannot_Be_Superflat
(Subtyp_Rng
, not Result_May_Be_Null
);
3097 -- Now we construct an array object with appropriate bounds. We mark
3098 -- the target as internal to prevent useless initialization when
3099 -- Initialize_Scalars is enabled. Also since this is the actual result
3100 -- entity, we make sure we have debug information for the result.
3103 Make_Subtype_Indication
(Loc
,
3104 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3106 Make_Index_Or_Discriminant_Constraint
(Loc
,
3107 Constraints
=> New_List
(Subtyp_Rng
)));
3109 Ent
:= Make_Temporary
(Loc
, 'S');
3110 Set_Is_Internal
(Ent
);
3111 Set_Debug_Info_Needed
(Ent
);
3113 -- If we are concatenating strings and the current scope already uses
3114 -- the secondary stack, allocate the result also on the secondary stack
3115 -- to avoid putting too much pressure on the primary stack.
3117 -- Don't do this if -gnatd.h is set, as this will break the wrapping of
3118 -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat.
3120 if Atyp
= Standard_String
3121 and then Uses_Sec_Stack
(Current_Scope
)
3122 and then RTE_Available
(RE_SS_Pool
)
3123 and then not Debug_Flag_Dot_H
3126 -- subtype Axx is String (<low-bound> .. <high-bound>)
3127 -- type Ayy is access Axx;
3128 -- Rxx : Ayy := new <Axx> [storage_pool = ss_pool];
3129 -- Sxx : Axx renames Rxx.all;
3132 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3133 Acc_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3139 Insert_Action
(Cnode
,
3140 Make_Subtype_Declaration
(Loc
,
3141 Defining_Identifier
=> ConstrT
,
3142 Subtype_Indication
=> Subtyp_Ind
),
3143 Suppress
=> All_Checks
);
3145 Freeze_Itype
(ConstrT
, Cnode
);
3147 Insert_Action
(Cnode
,
3148 Make_Full_Type_Declaration
(Loc
,
3149 Defining_Identifier
=> Acc_Typ
,
3151 Make_Access_To_Object_Definition
(Loc
,
3152 Subtype_Indication
=> New_Occurrence_Of
(ConstrT
, Loc
))),
3153 Suppress
=> All_Checks
);
3155 Mutate_Ekind
(Acc_Typ
, E_Access_Type
);
3156 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_SS_Pool
));
3159 Make_Allocator
(Loc
,
3160 Expression
=> New_Occurrence_Of
(ConstrT
, Loc
));
3162 -- This is currently done only for type String, which normally
3163 -- doesn't have default initialization, but we need to set the
3164 -- No_Initialization flag in case of either Initialize_Scalars
3165 -- or Normalize_Scalars.
3167 Set_No_Initialization
(Alloc
);
3169 Temp
:= Make_Temporary
(Loc
, 'R', Alloc
);
3170 Insert_Action
(Cnode
,
3171 Make_Object_Declaration
(Loc
,
3172 Defining_Identifier
=> Temp
,
3173 Object_Definition
=> New_Occurrence_Of
(Acc_Typ
, Loc
),
3174 Expression
=> Alloc
),
3175 Suppress
=> All_Checks
);
3177 Insert_Action
(Cnode
,
3178 Make_Object_Renaming_Declaration
(Loc
,
3179 Defining_Identifier
=> Ent
,
3180 Subtype_Mark
=> New_Occurrence_Of
(ConstrT
, Loc
),
3182 Make_Explicit_Dereference
(Loc
,
3183 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
3184 Suppress
=> All_Checks
);
3188 -- If the bound is statically known to be out of range, we do not
3189 -- want to abort, we want a warning and a runtime constraint error.
3190 -- Note that we have arranged that the result will not be treated
3191 -- as a static constant, so we won't get an illegality during this
3192 -- insertion. We also enable checks (in particular range checks) in
3193 -- case the bounds of Subtyp_Ind are out of range.
3195 Insert_Action
(Cnode
,
3196 Make_Object_Declaration
(Loc
,
3197 Defining_Identifier
=> Ent
,
3198 Object_Definition
=> Subtyp_Ind
));
3201 -- If the result of the concatenation appears as the initializing
3202 -- expression of an object declaration, we can just rename the
3203 -- result, rather than copying it.
3205 Set_OK_To_Rename
(Ent
);
3207 -- Catch the static out of range case now
3209 if Raises_Constraint_Error
(High_Bound
)
3210 or else Is_Out_Of_Range
(High_Bound
, Ityp
)
3212 -- Kill warning generated for the declaration of the static out of
3213 -- range high bound, and instead generate a Constraint_Error with
3214 -- an appropriate specific message.
3216 if Nkind
(High_Bound
) = N_Integer_Literal
then
3217 Kill_Dead_Code
(High_Bound
);
3218 Rewrite
(High_Bound
, New_Copy_Tree
(Low_Bound
));
3221 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3224 Apply_Compile_Time_Constraint_Error
3226 Msg
=> "concatenation result upper bound out of range??",
3227 Reason
=> CE_Range_Check_Failed
);
3232 -- Now we will generate the assignments to do the actual concatenation
3234 -- There is one case in which we will not do this, namely when all the
3235 -- following conditions are met:
3237 -- The result type is Standard.String
3239 -- There are nine or fewer retained (non-null) operands
3241 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3242 -- and the debug flag gnatd.c is not set.
3244 -- The corresponding System.Concat_n.Str_Concat_n routine is
3245 -- available in the run time.
3247 -- If all these conditions are met then we generate a call to the
3248 -- relevant concatenation routine. The purpose of this is to avoid
3249 -- undesirable code bloat at -O0.
3251 -- If the concatenation is within the declaration of a library-level
3252 -- object, we call the built-in concatenation routines to prevent code
3253 -- bloat, regardless of the optimization level. This is space efficient
3254 -- and prevents linking problems when units are compiled with different
3255 -- optimization levels.
3257 if Atyp
= Standard_String
3258 and then NN
in 2 .. 9
3259 and then (((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3260 and then not Debug_Flag_Dot_C
)
3261 or else Library_Level_Target
)
3264 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3275 if RTE_Available
(RR
(NN
)) then
3277 Opnds
: constant List_Id
:=
3278 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3281 for J
in 1 .. NN
loop
3282 if Is_List_Member
(Operands
(J
)) then
3283 Remove
(Operands
(J
));
3286 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3288 Make_Aggregate
(Loc
,
3289 Component_Associations
=> New_List
(
3290 Make_Component_Association
(Loc
,
3291 Choices
=> New_List
(
3292 Make_Integer_Literal
(Loc
, 1)),
3293 Expression
=> Operands
(J
)))));
3296 Append_To
(Opnds
, Operands
(J
));
3300 Insert_Action
(Cnode
,
3301 Make_Procedure_Call_Statement
(Loc
,
3302 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3303 Parameter_Associations
=> Opnds
));
3305 -- No assignments left to do below
3313 -- Not special case so generate the assignments
3315 Known_Non_Null_Operand_Seen
:= False;
3317 for J
in 1 .. NN
loop
3319 Lo
: constant Node_Id
:=
3321 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3322 Right_Opnd
=> Aggr_Length
(J
- 1));
3324 Hi
: constant Node_Id
:=
3326 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3328 Make_Op_Subtract
(Loc
,
3329 Left_Opnd
=> Aggr_Length
(J
),
3330 Right_Opnd
=> Make_Artyp_Literal
(Uint_1
)));
3333 -- Singleton case, simple assignment
3335 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3336 Known_Non_Null_Operand_Seen
:= True;
3337 Insert_Action
(Cnode
,
3338 Make_Assignment_Statement
(Loc
,
3340 Make_Indexed_Component
(Loc
,
3341 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3342 Expressions
=> New_List
(To_Ityp
(Lo
))),
3343 Expression
=> Operands
(J
)),
3344 Suppress
=> All_Checks
);
3346 -- Array case, slice assignment, skipped when argument is fixed
3347 -- length and known to be null.
3349 elsif not Is_Fixed_Length
(J
) or else Fixed_Length
(J
) > 0 then
3352 Make_Assignment_Statement
(Loc
,
3356 New_Occurrence_Of
(Ent
, Loc
),
3359 Low_Bound
=> To_Ityp
(Lo
),
3360 High_Bound
=> To_Ityp
(Hi
))),
3361 Expression
=> Operands
(J
));
3363 if Is_Fixed_Length
(J
) then
3364 Known_Non_Null_Operand_Seen
:= True;
3366 elsif not Known_Non_Null_Operand_Seen
then
3368 -- Here if operand length is not statically known and no
3369 -- operand known to be non-null has been processed yet.
3370 -- If operand length is 0, we do not need to perform the
3371 -- assignment, and we must avoid the evaluation of the
3372 -- high bound of the slice, since it may underflow if the
3373 -- low bound is Ityp'First.
3376 Make_Implicit_If_Statement
(Cnode
,
3380 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3381 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3382 Then_Statements
=> New_List
(Assign
));
3385 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3391 -- Finally we build the result, which is either a direct reference to
3392 -- the array object or a slice of it.
3394 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3396 if Present
(Slice_Rng
) then
3397 Result
:= Make_Slice
(Loc
, Result
, Slice_Rng
);
3401 pragma Assert
(Present
(Result
));
3402 Rewrite
(Cnode
, Result
);
3403 Analyze_And_Resolve
(Cnode
, Atyp
);
3404 end Expand_Concatenate
;
3406 ---------------------------------------------------
3407 -- Expand_Membership_Minimize_Eliminate_Overflow --
3408 ---------------------------------------------------
3410 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3411 pragma Assert
(Nkind
(N
) = N_In
);
3412 -- Despite the name, this routine applies only to N_In, not to
3413 -- N_Not_In. The latter is always rewritten as not (X in Y).
3415 Result_Type
: constant Entity_Id
:= Etype
(N
);
3416 -- Capture result type, may be a derived boolean type
3418 Loc
: constant Source_Ptr
:= Sloc
(N
);
3419 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3420 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3422 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3423 -- is thus tempting to capture these values, but due to the rewrites
3424 -- that occur as a result of overflow checking, these values change
3425 -- as we go along, and it is safe just to always use Etype explicitly.
3427 Restype
: constant Entity_Id
:= Etype
(N
);
3431 -- Bounds in Minimize calls, not used currently
3433 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3434 -- Entity for Long_Long_Integer'Base
3437 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3439 -- If right operand is a subtype name, and the subtype name has no
3440 -- predicate, then we can just replace the right operand with an
3441 -- explicit range T'First .. T'Last, and use the explicit range code.
3443 if Nkind
(Rop
) /= N_Range
3444 and then No
(Predicate_Function
(Etype
(Rop
)))
3447 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3452 Make_Attribute_Reference
(Loc
,
3453 Attribute_Name
=> Name_First
,
3454 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3456 Make_Attribute_Reference
(Loc
,
3457 Attribute_Name
=> Name_Last
,
3458 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3459 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3463 -- Here for the explicit range case. Note that the bounds of the range
3464 -- have not been processed for minimized or eliminated checks.
3466 if Nkind
(Rop
) = N_Range
then
3467 Minimize_Eliminate_Overflows
3468 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3469 Minimize_Eliminate_Overflows
3470 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3472 -- We have A in B .. C, treated as A >= B and then A <= C
3476 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3477 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3478 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3481 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3482 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3483 L
: constant Entity_Id
:=
3484 Make_Defining_Identifier
(Loc
, Name_uL
);
3485 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3486 Lbound
: constant Node_Id
:=
3487 Convert_To_Bignum
(Low_Bound
(Rop
));
3488 Hbound
: constant Node_Id
:=
3489 Convert_To_Bignum
(High_Bound
(Rop
));
3491 -- Now we rewrite the membership test node to look like
3494 -- Bnn : Result_Type;
3496 -- M : Mark_Id := SS_Mark;
3497 -- L : Bignum := Lopnd;
3499 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3507 -- Insert declaration of L into declarations of bignum block
3510 (Last
(Declarations
(Blk
)),
3511 Make_Object_Declaration
(Loc
,
3512 Defining_Identifier
=> L
,
3513 Object_Definition
=>
3514 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3515 Expression
=> Lopnd
));
3517 -- Insert assignment to Bnn into expressions of bignum block
3520 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3521 Make_Assignment_Statement
(Loc
,
3522 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3526 Make_Function_Call
(Loc
,
3528 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3529 Parameter_Associations
=> New_List
(
3530 New_Occurrence_Of
(L
, Loc
),
3534 Make_Function_Call
(Loc
,
3536 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3537 Parameter_Associations
=> New_List
(
3538 New_Occurrence_Of
(L
, Loc
),
3541 -- Now rewrite the node
3544 Make_Expression_With_Actions
(Loc
,
3545 Actions
=> New_List
(
3546 Make_Object_Declaration
(Loc
,
3547 Defining_Identifier
=> Bnn
,
3548 Object_Definition
=>
3549 New_Occurrence_Of
(Result_Type
, Loc
)),
3551 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3552 Analyze_And_Resolve
(N
, Result_Type
);
3556 -- Here if no bignums around
3559 -- Case where types are all the same
3561 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3563 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3567 -- If types are not all the same, it means that we have rewritten
3568 -- at least one of them to be of type Long_Long_Integer, and we
3569 -- will convert the other operands to Long_Long_Integer.
3572 Convert_To_And_Rewrite
(LLIB
, Lop
);
3573 Set_Analyzed
(Lop
, False);
3574 Analyze_And_Resolve
(Lop
, LLIB
);
3576 -- For the right operand, avoid unnecessary recursion into
3577 -- this routine, we know that overflow is not possible.
3579 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3580 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3581 Set_Analyzed
(Rop
, False);
3582 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3585 -- Now the three operands are of the same signed integer type,
3586 -- so we can use the normal expansion routine for membership,
3587 -- setting the flag to prevent recursion into this procedure.
3589 Set_No_Minimize_Eliminate
(N
);
3593 -- Right operand is a subtype name and the subtype has a predicate. We
3594 -- have to make sure the predicate is checked, and for that we need to
3595 -- use the standard N_In circuitry with appropriate types.
3598 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3600 -- If types are "right", just call Expand_N_In preventing recursion
3602 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3603 Set_No_Minimize_Eliminate
(N
);
3608 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3610 -- For X in T, we want to rewrite our node as
3613 -- Bnn : Result_Type;
3616 -- M : Mark_Id := SS_Mark;
3617 -- Lnn : Long_Long_Integer'Base
3623 -- if not Bignum_In_LLI_Range (Nnn) then
3626 -- Lnn := From_Bignum (Nnn);
3628 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3629 -- and then T'Base (Lnn) in T;
3638 -- A bit gruesome, but there doesn't seem to be a simpler way
3641 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3642 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3643 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3644 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3645 T
: constant Entity_Id
:= Etype
(Rop
);
3646 TB
: constant Entity_Id
:= Base_Type
(T
);
3650 -- Mark the last membership operation to prevent recursion
3654 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3655 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3656 Set_No_Minimize_Eliminate
(Nin
);
3658 -- Now decorate the block
3661 (Last
(Declarations
(Blk
)),
3662 Make_Object_Declaration
(Loc
,
3663 Defining_Identifier
=> Lnn
,
3664 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3667 (Last
(Declarations
(Blk
)),
3668 Make_Object_Declaration
(Loc
,
3669 Defining_Identifier
=> Nnn
,
3670 Object_Definition
=>
3671 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3674 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3676 Make_Assignment_Statement
(Loc
,
3677 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3678 Expression
=> Relocate_Node
(Lop
)),
3680 Make_Implicit_If_Statement
(N
,
3684 Make_Function_Call
(Loc
,
3687 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3688 Parameter_Associations
=> New_List
(
3689 New_Occurrence_Of
(Nnn
, Loc
)))),
3691 Then_Statements
=> New_List
(
3692 Make_Assignment_Statement
(Loc
,
3693 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3695 New_Occurrence_Of
(Standard_False
, Loc
))),
3697 Else_Statements
=> New_List
(
3698 Make_Assignment_Statement
(Loc
,
3699 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3701 Make_Function_Call
(Loc
,
3703 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3704 Parameter_Associations
=> New_List
(
3705 New_Occurrence_Of
(Nnn
, Loc
)))),
3707 Make_Assignment_Statement
(Loc
,
3708 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3713 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3718 Make_Attribute_Reference
(Loc
,
3719 Attribute_Name
=> Name_First
,
3721 New_Occurrence_Of
(TB
, Loc
))),
3725 Make_Attribute_Reference
(Loc
,
3726 Attribute_Name
=> Name_Last
,
3728 New_Occurrence_Of
(TB
, Loc
))))),
3730 Right_Opnd
=> Nin
))))));
3732 -- Now we can do the rewrite
3735 Make_Expression_With_Actions
(Loc
,
3736 Actions
=> New_List
(
3737 Make_Object_Declaration
(Loc
,
3738 Defining_Identifier
=> Bnn
,
3739 Object_Definition
=>
3740 New_Occurrence_Of
(Result_Type
, Loc
)),
3742 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3743 Analyze_And_Resolve
(N
, Result_Type
);
3747 -- Not bignum case, but types don't match (this means we rewrote the
3748 -- left operand to be Long_Long_Integer).
3751 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
3753 -- We rewrite the membership test as (where T is the type with
3754 -- the predicate, i.e. the type of the right operand)
3756 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3757 -- and then T'Base (Lop) in T
3760 T
: constant Entity_Id
:= Etype
(Rop
);
3761 TB
: constant Entity_Id
:= Base_Type
(T
);
3765 -- The last membership test is marked to prevent recursion
3769 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
3770 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3771 Set_No_Minimize_Eliminate
(Nin
);
3773 -- Now do the rewrite
3784 Make_Attribute_Reference
(Loc
,
3785 Attribute_Name
=> Name_First
,
3787 New_Occurrence_Of
(TB
, Loc
))),
3790 Make_Attribute_Reference
(Loc
,
3791 Attribute_Name
=> Name_Last
,
3793 New_Occurrence_Of
(TB
, Loc
))))),
3794 Right_Opnd
=> Nin
));
3795 Set_Analyzed
(N
, False);
3796 Analyze_And_Resolve
(N
, Restype
);
3800 end Expand_Membership_Minimize_Eliminate_Overflow
;
3802 ---------------------------------
3803 -- Expand_Nonbinary_Modular_Op --
3804 ---------------------------------
3806 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
) is
3807 Loc
: constant Source_Ptr
:= Sloc
(N
);
3808 Typ
: constant Entity_Id
:= Etype
(N
);
3810 procedure Expand_Modular_Addition
;
3811 -- Expand the modular addition, handling the special case of adding a
3814 procedure Expand_Modular_Op
;
3815 -- Compute the general rule: (lhs OP rhs) mod Modulus
3817 procedure Expand_Modular_Subtraction
;
3818 -- Expand the modular addition, handling the special case of subtracting
3821 -----------------------------
3822 -- Expand_Modular_Addition --
3823 -----------------------------
3825 procedure Expand_Modular_Addition
is
3827 -- If this is not the addition of a constant then compute it using
3828 -- the general rule: (lhs + rhs) mod Modulus
3830 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
3833 -- If this is an addition of a constant, convert it to a subtraction
3834 -- plus a conditional expression since we can compute it faster than
3835 -- computing the modulus.
3837 -- modMinusRhs = Modulus - rhs
3838 -- if lhs < modMinusRhs then lhs + rhs
3839 -- else lhs - modMinusRhs
3843 Mod_Minus_Right
: constant Uint
:=
3844 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
3846 Cond_Expr
: Node_Id
;
3847 Then_Expr
: Node_Id
;
3848 Else_Expr
: Node_Id
;
3850 -- To prevent spurious visibility issues, convert all
3851 -- operands to Standard.Unsigned.
3856 Unchecked_Convert_To
(Standard_Unsigned
,
3857 New_Copy_Tree
(Left_Opnd
(N
))),
3859 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
3864 Unchecked_Convert_To
(Standard_Unsigned
,
3865 New_Copy_Tree
(Left_Opnd
(N
))),
3867 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
3870 Make_Op_Subtract
(Loc
,
3872 Unchecked_Convert_To
(Standard_Unsigned
,
3873 New_Copy_Tree
(Left_Opnd
(N
))),
3875 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
3878 Unchecked_Convert_To
(Typ
,
3879 Make_If_Expression
(Loc
,
3881 New_List
(Cond_Expr
, Then_Expr
, Else_Expr
))));
3884 end Expand_Modular_Addition
;
3886 -----------------------
3887 -- Expand_Modular_Op --
3888 -----------------------
3890 procedure Expand_Modular_Op
is
3891 -- We will convert to another type (not a nonbinary-modulus modular
3892 -- type), evaluate the op in that representation, reduce the result,
3893 -- and convert back to the original type. This means that the
3894 -- backend does not have to deal with nonbinary-modulus ops.
3896 Op_Expr
: constant Node_Id
:= New_Op_Node
(Nkind
(N
), Loc
);
3899 Target_Type
: Entity_Id
;
3901 -- Select a target type that is large enough to avoid spurious
3902 -- intermediate overflow on pre-reduction computation (for
3903 -- correctness) but is no larger than is needed (for performance).
3906 Required_Size
: Uint
:= RM_Size
(Etype
(N
));
3907 Use_Unsigned
: Boolean := True;
3911 -- For example, if modulus is 255 then RM_Size will be 8
3912 -- and the range of possible values (before reduction) will
3913 -- be 0 .. 508; that range requires 9 bits.
3914 Required_Size
:= Required_Size
+ 1;
3916 when N_Op_Subtract
=>
3917 -- For example, if modulus is 255 then RM_Size will be 8
3918 -- and the range of possible values (before reduction) will
3919 -- be -254 .. 254; that range requires 9 bits, signed.
3920 Use_Unsigned
:= False;
3921 Required_Size
:= Required_Size
+ 1;
3923 when N_Op_Multiply
=>
3924 -- For example, if modulus is 255 then RM_Size will be 8
3925 -- and the range of possible values (before reduction) will
3926 -- be 0 .. 64,516; that range requires 16 bits.
3927 Required_Size
:= Required_Size
* 2;
3933 if Use_Unsigned
then
3934 if Required_Size
<= Standard_Short_Short_Integer_Size
then
3935 Target_Type
:= Standard_Short_Short_Unsigned
;
3936 elsif Required_Size
<= Standard_Short_Integer_Size
then
3937 Target_Type
:= Standard_Short_Unsigned
;
3938 elsif Required_Size
<= Standard_Integer_Size
then
3939 Target_Type
:= Standard_Unsigned
;
3941 pragma Assert
(Required_Size
<= 64);
3942 Target_Type
:= Standard_Unsigned_64
;
3944 elsif Required_Size
<= 8 then
3945 Target_Type
:= Standard_Integer_8
;
3946 elsif Required_Size
<= 16 then
3947 Target_Type
:= Standard_Integer_16
;
3948 elsif Required_Size
<= 32 then
3949 Target_Type
:= Standard_Integer_32
;
3951 pragma Assert
(Required_Size
<= 64);
3952 Target_Type
:= Standard_Integer_64
;
3955 pragma Assert
(Present
(Target_Type
));
3958 Set_Left_Opnd
(Op_Expr
,
3959 Unchecked_Convert_To
(Target_Type
,
3960 New_Copy_Tree
(Left_Opnd
(N
))));
3961 Set_Right_Opnd
(Op_Expr
,
3962 Unchecked_Convert_To
(Target_Type
,
3963 New_Copy_Tree
(Right_Opnd
(N
))));
3965 -- ??? Why do this stuff for some ops and not others?
3966 if Nkind
(N
) not in N_Op_And | N_Op_Or | N_Op_Xor
then
3968 -- Link this node to the tree to analyze it
3970 -- If the parent node is an expression with actions we link it to
3971 -- N since otherwise Force_Evaluation cannot identify if this node
3972 -- comes from the Expression and rejects generating the temporary.
3974 if Nkind
(Parent
(N
)) = N_Expression_With_Actions
then
3975 Set_Parent
(Op_Expr
, N
);
3980 Set_Parent
(Op_Expr
, Parent
(N
));
3985 -- Force generating a temporary because in the expansion of this
3986 -- expression we may generate code that performs this computation
3989 Force_Evaluation
(Op_Expr
, Mode
=> Strict
);
3994 Left_Opnd
=> Op_Expr
,
3995 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modulus
(Typ
)));
3998 Unchecked_Convert_To
(Typ
, Mod_Expr
));
3999 end Expand_Modular_Op
;
4001 --------------------------------
4002 -- Expand_Modular_Subtraction --
4003 --------------------------------
4005 procedure Expand_Modular_Subtraction
is
4007 -- If this is not the addition of a constant then compute it using
4008 -- the general rule: (lhs + rhs) mod Modulus
4010 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4013 -- If this is an addition of a constant, convert it to a subtraction
4014 -- plus a conditional expression since we can compute it faster than
4015 -- computing the modulus.
4017 -- modMinusRhs = Modulus - rhs
4018 -- if lhs < rhs then lhs + modMinusRhs
4023 Mod_Minus_Right
: constant Uint
:=
4024 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4026 Cond_Expr
: Node_Id
;
4027 Then_Expr
: Node_Id
;
4028 Else_Expr
: Node_Id
;
4033 Unchecked_Convert_To
(Standard_Unsigned
,
4034 New_Copy_Tree
(Left_Opnd
(N
))),
4036 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4041 Unchecked_Convert_To
(Standard_Unsigned
,
4042 New_Copy_Tree
(Left_Opnd
(N
))),
4044 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4047 Make_Op_Subtract
(Loc
,
4049 Unchecked_Convert_To
(Standard_Unsigned
,
4050 New_Copy_Tree
(Left_Opnd
(N
))),
4052 Unchecked_Convert_To
(Standard_Unsigned
,
4053 New_Copy_Tree
(Right_Opnd
(N
))));
4056 Unchecked_Convert_To
(Typ
,
4057 Make_If_Expression
(Loc
,
4059 New_List
(Cond_Expr
, Then_Expr
, Else_Expr
))));
4062 end Expand_Modular_Subtraction
;
4064 -- Start of processing for Expand_Nonbinary_Modular_Op
4067 -- No action needed if front-end expansion is not required or if we
4068 -- have a binary modular operand.
4070 if not Expand_Nonbinary_Modular_Ops
4071 or else not Non_Binary_Modulus
(Typ
)
4078 Expand_Modular_Addition
;
4080 when N_Op_Subtract
=>
4081 Expand_Modular_Subtraction
;
4085 -- Expand -expr into (0 - expr)
4088 Make_Op_Subtract
(Loc
,
4089 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
4090 Right_Opnd
=> Right_Opnd
(N
)));
4091 Analyze_And_Resolve
(N
, Typ
);
4097 Analyze_And_Resolve
(N
, Typ
);
4098 end Expand_Nonbinary_Modular_Op
;
4100 ------------------------
4101 -- Expand_N_Allocator --
4102 ------------------------
4104 procedure Expand_N_Allocator
(N
: Node_Id
) is
4105 Loc
: constant Source_Ptr
:= Sloc
(N
);
4106 PtrT
: constant Entity_Id
:= Etype
(N
);
4107 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4108 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4110 procedure Rewrite_Coextension
(N
: Node_Id
);
4111 -- Static coextensions have the same lifetime as the entity they
4112 -- constrain. Such occurrences can be rewritten as aliased objects
4113 -- and their unrestricted access used instead of the coextension.
4115 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4116 -- Given a constrained array type E, returns a node representing the
4117 -- code to compute a close approximation of the size in storage elements
4118 -- for the given type; for indexes that are modular types we compute
4119 -- 'Last - First (instead of 'Length) because for large arrays computing
4120 -- 'Last -'First + 1 causes overflow. This is done without using the
4121 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4124 -------------------------
4125 -- Rewrite_Coextension --
4126 -------------------------
4128 procedure Rewrite_Coextension
(N
: Node_Id
) is
4129 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4130 Temp_Decl
: Node_Id
;
4134 -- Cnn : aliased Etyp;
4137 Make_Object_Declaration
(Loc
,
4138 Defining_Identifier
=> Temp_Id
,
4139 Aliased_Present
=> True,
4140 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4142 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4143 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4146 Insert_Action
(N
, Temp_Decl
);
4148 Make_Attribute_Reference
(Loc
,
4149 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4150 Attribute_Name
=> Name_Unrestricted_Access
));
4152 Analyze_And_Resolve
(N
, PtrT
);
4153 end Rewrite_Coextension
;
4155 ------------------------------
4156 -- Size_In_Storage_Elements --
4157 ------------------------------
4159 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4160 Idx
: Node_Id
:= First_Index
(E
);
4162 Res
: Node_Id
:= Empty
;
4165 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4166 -- However, the reason for the existence of this function is to
4167 -- construct a test for sizes too large, which means near the 32-bit
4168 -- limit on a 32-bit machine, and precisely the trouble is that we
4169 -- get overflows when sizes are greater than 2**31.
4171 -- So what we end up doing for array types is to use the expression:
4173 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4175 -- which avoids this problem. All this is a bit bogus, but it does
4176 -- mean we catch common cases of trying to allocate arrays that are
4177 -- too large, and which in the absence of a check results in
4178 -- undetected chaos ???
4180 for J
in 1 .. Number_Dimensions
(E
) loop
4182 if not Is_Modular_Integer_Type
(Etype
(Idx
)) then
4184 Make_Attribute_Reference
(Loc
,
4185 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4186 Attribute_Name
=> Name_Length
,
4187 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4189 -- For indexes that are modular types we cannot generate code to
4190 -- compute 'Length since for large arrays 'Last -'First + 1 causes
4191 -- overflow; therefore we compute 'Last - 'First (which is not the
4192 -- exact number of components but it is valid for the purpose of
4193 -- this runtime check on 32-bit targets).
4197 Len_Minus_1_Expr
: Node_Id
;
4203 Make_Attribute_Reference
(Loc
,
4204 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4205 Attribute_Name
=> Name_Last
,
4207 New_List
(Make_Integer_Literal
(Loc
, J
))),
4208 Make_Attribute_Reference
(Loc
,
4209 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4210 Attribute_Name
=> Name_First
,
4212 New_List
(Make_Integer_Literal
(Loc
, J
))));
4215 Convert_To
(Standard_Unsigned
,
4216 Make_Op_Subtract
(Loc
,
4217 Make_Attribute_Reference
(Loc
,
4218 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4219 Attribute_Name
=> Name_Last
,
4221 New_List
(Make_Integer_Literal
(Loc
, J
))),
4222 Make_Attribute_Reference
(Loc
,
4223 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4224 Attribute_Name
=> Name_First
,
4226 New_List
(Make_Integer_Literal
(Loc
, J
)))));
4228 -- Handle superflat arrays, i.e. arrays with such bounds as
4229 -- 4 .. 2, to ensure that the result is correct.
4232 -- (if X'Last > X'First then X'Last - X'First else 0)
4235 Make_If_Expression
(Loc
,
4236 Expressions
=> New_List
(
4239 Make_Integer_Literal
(Loc
, Uint_0
)));
4247 pragma Assert
(Present
(Res
));
4249 Make_Op_Multiply
(Loc
,
4258 Make_Op_Multiply
(Loc
,
4261 Make_Attribute_Reference
(Loc
,
4262 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4263 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4264 end Size_In_Storage_Elements
;
4269 Init_Expr
: Node_Id
;
4270 Init_Stmts
: List_Id
;
4272 Rel_Typ
: Entity_Id
;
4273 Target_Ref
: Node_Id
;
4275 Temp_Decl
: Node_Id
;
4277 -- Start of processing for Expand_N_Allocator
4280 -- Warn on the presence of an allocator of an anonymous access type when
4281 -- enabled, except when it's an object declaration at library level.
4283 if Warn_On_Anonymous_Allocators
4284 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
4285 and then not (Is_Library_Level_Entity
(PtrT
)
4286 and then Nkind
(Associated_Node_For_Itype
(PtrT
)) =
4287 N_Object_Declaration
)
4289 Error_Msg_N
("?_a?use of an anonymous access type allocator", N
);
4292 -- RM E.2.2(17). We enforce that the expected type of an allocator
4293 -- shall not be a remote access-to-class-wide-limited-private type.
4294 -- We probably shouldn't be doing this legality check during expansion,
4295 -- but this is only an issue for Annex E users, and is unlikely to be a
4296 -- problem in practice.
4298 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4300 -- Processing for anonymous access-to-controlled types. These access
4301 -- types receive a special finalization collection which appears in the
4302 -- declarations of the enclosing semantic unit. This expansion is done
4303 -- now to ensure that any additional types generated by this routine or
4304 -- Expand_Allocator_Expression inherit the proper type attributes.
4306 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4307 or else (Is_Itype
(PtrT
)
4308 and then No
(Finalization_Collection
(PtrT
))))
4309 and then Needs_Finalization
(Dtyp
)
4311 -- Detect the allocation of an anonymous controlled object where the
4312 -- type of the context is named. For example:
4314 -- procedure Proc (Ptr : Named_Access_Typ);
4315 -- Proc (new Designated_Typ);
4317 -- Regardless of the anonymous-to-named access type conversion, the
4318 -- lifetime of the object must be associated with the named access
4319 -- type. Use the finalization-related attributes of this type.
4321 if Nkind
(Parent
(N
)) in N_Type_Conversion
4322 | N_Unchecked_Type_Conversion
4323 and then Ekind
(Etype
(Parent
(N
))) in E_Access_Subtype
4325 | E_General_Access_Type
4327 Rel_Typ
:= Etype
(Parent
(N
));
4332 -- Anonymous access-to-controlled types allocate on the global pool.
4333 -- Note that this is a "root type only" attribute.
4335 if No
(Associated_Storage_Pool
(PtrT
)) then
4336 if Present
(Rel_Typ
) then
4337 Set_Associated_Storage_Pool
4338 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4340 Set_Associated_Storage_Pool
4341 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4345 -- The finalization collection must be inserted and analyzed as part
4346 -- of the current semantic unit. Note that the collection is updated
4347 -- when analysis changes current units. Note that this is a root type
4350 if Present
(Rel_Typ
) then
4351 Set_Finalization_Collection
4352 (Root_Type
(PtrT
), Finalization_Collection
(Rel_Typ
));
4354 Build_Anonymous_Collection
(Root_Type
(PtrT
));
4358 -- Set the storage pool and find the appropriate version of Allocate to
4359 -- call. Do not overwrite the storage pool if it is already set, which
4360 -- can happen for build-in-place function returns (see
4361 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4363 if No
(Storage_Pool
(N
)) then
4364 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4366 if Present
(Pool
) then
4367 Set_Storage_Pool
(N
, Pool
);
4369 if Is_RTE
(Pool
, RE_RS_Pool
) then
4370 Set_Procedure_To_Call
(N
, RTE
(RE_RS_Allocate
));
4372 elsif Is_RTE
(Pool
, RE_SS_Pool
) then
4373 Check_Restriction
(No_Secondary_Stack
, N
);
4374 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4376 -- In the case of an allocator for a simple storage pool, locate
4377 -- and save a reference to the pool type's Allocate routine.
4379 elsif Present
(Get_Rep_Pragma
4380 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4383 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4384 Alloc_Op
: Entity_Id
;
4386 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4387 while Present
(Alloc_Op
) loop
4388 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4389 and then Present
(First_Formal
(Alloc_Op
))
4390 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4392 Set_Procedure_To_Call
(N
, Alloc_Op
);
4395 Alloc_Op
:= Homonym
(Alloc_Op
);
4400 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4401 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4404 Set_Procedure_To_Call
(N
,
4405 Find_Storage_Op
(Etype
(Pool
), Name_Allocate
));
4410 -- Under certain circumstances we can replace an allocator by an access
4411 -- to statically allocated storage. The conditions, as noted in AARM
4412 -- 3.10 (10c) are as follows:
4414 -- Size and initial value is known at compile time
4415 -- Access type is access-to-constant
4417 -- The allocator is not part of a constraint on a record component,
4418 -- because in that case the inserted actions are delayed until the
4419 -- record declaration is fully analyzed, which is too late for the
4420 -- analysis of the rewritten allocator.
4422 if Is_Access_Constant
(PtrT
)
4423 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4424 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4425 and then Size_Known_At_Compile_Time
4426 (Etype
(Expression
(Expression
(N
))))
4427 and then not Is_Record_Type
(Current_Scope
)
4429 -- Here we can do the optimization. For the allocator
4433 -- We insert an object declaration
4435 -- Tnn : aliased x := y;
4437 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4438 -- marked as requiring static allocation.
4440 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4441 Desig
:= Subtype_Mark
(Expression
(N
));
4443 -- If context is constrained, use constrained subtype directly,
4444 -- so that the constant is not labelled as having a nominally
4445 -- unconstrained subtype.
4447 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4448 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4452 Make_Object_Declaration
(Loc
,
4453 Defining_Identifier
=> Temp
,
4454 Aliased_Present
=> True,
4455 Constant_Present
=> Is_Access_Constant
(PtrT
),
4456 Object_Definition
=> Desig
,
4457 Expression
=> Expression
(Expression
(N
))));
4460 Make_Attribute_Reference
(Loc
,
4461 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4462 Attribute_Name
=> Name_Unrestricted_Access
));
4464 Analyze_And_Resolve
(N
, PtrT
);
4466 -- We set the variable as statically allocated, since we don't want
4467 -- it going on the stack of the current procedure.
4469 Set_Is_Statically_Allocated
(Temp
);
4473 -- Same if the allocator is an access discriminant for a local object:
4474 -- instead of an allocator we create a local value and constrain the
4475 -- enclosing object with the corresponding access attribute.
4477 if Is_Static_Coextension
(N
) then
4478 Rewrite_Coextension
(N
);
4482 -- Check for size too large, we do this because the back end misses
4483 -- proper checks here and can generate rubbish allocation calls when
4484 -- we are near the limit. We only do this for the 32-bit address case
4485 -- since that is from a practical point of view where we see a problem.
4487 if System_Address_Size
= 32
4488 and then not Storage_Checks_Suppressed
(PtrT
)
4489 and then not Storage_Checks_Suppressed
(Dtyp
)
4490 and then not Storage_Checks_Suppressed
(Etyp
)
4492 -- The check we want to generate should look like
4494 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4495 -- raise Storage_Error;
4498 -- where 3.5 gigabytes is a constant large enough to accommodate any
4499 -- reasonable request for. But we can't do it this way because at
4500 -- least at the moment we don't compute this attribute right, and
4501 -- can silently give wrong results when the result gets large. Since
4502 -- this is all about large results, that's bad, so instead we only
4503 -- apply the check for constrained arrays, and manually compute the
4504 -- value of the attribute ???
4506 -- The check on No_Initialization is used here to prevent generating
4507 -- this runtime check twice when the allocator is locally replaced by
4508 -- the expander with another one.
4510 if Is_Array_Type
(Etyp
) and then not No_Initialization
(N
) then
4513 Ins_Nod
: Node_Id
:= N
;
4514 Siz_Typ
: Entity_Id
:= Etyp
;
4518 -- For unconstrained array types initialized with a qualified
4519 -- expression we use its type to perform this check
4521 if not Is_Constrained
(Etyp
)
4522 and then not No_Initialization
(N
)
4523 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4525 Expr
:= Expression
(Expression
(N
));
4526 Siz_Typ
:= Etype
(Expression
(Expression
(N
)));
4528 -- If the qualified expression has been moved to an internal
4529 -- temporary (to remove side effects) then we must insert
4530 -- the runtime check before its declaration to ensure that
4531 -- the check is performed before the execution of the code
4532 -- computing the qualified expression.
4534 if Nkind
(Expr
) = N_Identifier
4535 and then Is_Internal_Name
(Chars
(Expr
))
4537 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
4539 Ins_Nod
:= Parent
(Entity
(Expr
));
4545 if Is_Constrained
(Siz_Typ
)
4546 and then Ekind
(Siz_Typ
) /= E_String_Literal_Subtype
4548 -- For CCG targets, the largest array may have up to 2**31-1
4549 -- components (i.e. 2 gigabytes if each array component is
4550 -- one byte). This ensures that fat pointer fields do not
4551 -- overflow, since they are 32-bit integer types, and also
4552 -- ensures that 'Length can be computed at run time.
4554 if Modify_Tree_For_C
then
4557 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4558 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4559 Uint_2
** 31 - Uint_1
));
4561 -- For native targets the largest object is 3.5 gigabytes
4566 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4567 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4568 Uint_7
* (Uint_2
** 29)));
4571 Insert_Action
(Ins_Nod
,
4572 Make_Raise_Storage_Error
(Loc
,
4574 Reason
=> SE_Object_Too_Large
));
4576 if Entity
(Cond
) = Standard_True
then
4578 ("object too large: Storage_Error will be raised at "
4586 -- If no storage pool has been specified, or the storage pool
4587 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4588 -- No_Standard_Allocators_After_Elaboration is present, then generate
4589 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4591 if Nkind
(N
) = N_Allocator
4592 and then (No
(Storage_Pool
(N
))
4593 or else Is_RTE
(Storage_Pool
(N
), RE_Global_Pool_Object
))
4594 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4597 Make_Procedure_Call_Statement
(Loc
,
4599 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4602 -- Handle case of qualified expression (other than optimization above)
4604 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4605 Expand_Allocator_Expression
(N
);
4607 -- If no initialization is necessary, just create a custom Allocate if
4608 -- the context requires it; that is the case only for allocators built
4609 -- for the special return objects because, in other cases, the custom
4610 -- Allocate will be created later during the expansion of the original
4611 -- allocator without the No_Initialization flag.
4613 elsif No_Initialization
(N
) then
4614 if For_Special_Return_Object
(N
) then
4615 Build_Allocate_Deallocate_Proc
(Parent
(N
));
4618 -- If the allocator is for a type which requires initialization, and
4619 -- there is no initial value (i.e. operand is a subtype indication
4620 -- rather than a qualified expression), then we must generate a call to
4621 -- the initialization routine:
4623 -- Temp : constant PtrT := new T;
4624 -- Init (Temp.all,...);
4627 -- A special case arises if T is a task type or contains tasks. In this
4628 -- case the call to Init (Temp.all ...) is replaced by code that ensures
4629 -- that tasks get activated (see Build_Task_Allocate_Block for details).
4632 -- Apply constraint checks against designated subtype (RM 4.8(10/2)).
4633 -- Discriminant checks will be generated by the expansion below.
4635 if Is_Array_Type
(Dtyp
) then
4636 Apply_Constraint_Check
(Expression
(N
), Dtyp
, No_Sliding
=> True);
4638 if Nkind
(Expression
(N
)) = N_Raise_Constraint_Error
then
4639 Rewrite
(N
, New_Copy
(Expression
(N
)));
4640 Set_Etype
(N
, PtrT
);
4645 -- First try a simple initialization; if it succeeds, then we just
4646 -- assign the value to the allocated memory.
4648 Init_Expr
:= Build_Default_Simple_Initialization
(N
, Etyp
, Empty
);
4650 if Present
(Init_Expr
) then
4656 -- We set the allocator as analyzed so that when we analyze
4657 -- the expression node, we do not get an unwanted recursive
4658 -- expansion of the allocator expression.
4662 Temp
:= Make_Temporary
(Loc
, 'P');
4665 -- Temp : constant PtrT := new ...;
4668 Make_Object_Declaration
(Loc
,
4669 Defining_Identifier
=> Temp
,
4670 Constant_Present
=> True,
4671 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
4672 Expression
=> Relocate_Node
(N
));
4674 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4680 Make_Explicit_Dereference
(Loc
,
4681 New_Occurrence_Of
(Temp
, Loc
));
4683 if Is_Incomplete_Or_Private_Type
(Designated_Type
(PtrT
)) then
4684 Deref
:= Unchecked_Convert_To
(Etype
(Init_Expr
), Deref
);
4688 Make_Assignment_Statement
(Loc
,
4690 Expression
=> Init_Expr
);
4691 Set_Assignment_OK
(Name
(Stmt
));
4693 Insert_Action
(N
, Stmt
, Suppress
=> All_Checks
);
4694 Build_Allocate_Deallocate_Proc
(Temp_Decl
);
4695 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4696 Analyze_And_Resolve
(N
, PtrT
);
4699 -- Or else build the fully-fledged initialization if need be
4702 -- For the task case, pass the Master_Id of the access type as
4703 -- the value of the _Master parameter, and _Chain as the value
4704 -- of the _Chain parameter (_Chain will be defined as part of
4705 -- the generated code for the allocator).
4707 -- In Ada 2005, the context may be a function that returns an
4708 -- anonymous access type. In that case the Master_Id has been
4709 -- created when expanding the function declaration.
4711 if Has_Task
(Etyp
) then
4712 if No
(Master_Id
(Base_Type
(PtrT
))) then
4713 -- The designated type was an incomplete type, and the
4714 -- access type did not get expanded. Salvage it now.
4716 if Present
(Declaration_Node
(Base_Type
(PtrT
))) then
4717 Expand_N_Full_Type_Declaration
4718 (Declaration_Node
(Base_Type
(PtrT
)));
4720 -- When the allocator has a subtype indication then a
4721 -- constraint is present and an itype has been added by
4722 -- Analyze_Allocator as the subtype of this allocator.
4724 -- If an allocator with constraints is called in the
4725 -- return statement of a function returning a general
4726 -- access type, then propagate to the itype the master
4727 -- of the general access type (since it is the master
4728 -- associated with the returned object).
4730 elsif Is_Itype
(PtrT
)
4731 and then Ekind
(Current_Scope
) = E_Function
4733 Ekind
(Etype
(Current_Scope
)) = E_General_Access_Type
4734 and then In_Return_Value
(N
)
4736 Set_Master_Id
(PtrT
, Master_Id
(Etype
(Current_Scope
)));
4738 -- The only other possibility is an itype. For this
4739 -- case, the master must exist in the context. This is
4740 -- the case when the allocator initializes an access
4741 -- component in an init-proc.
4744 pragma Assert
(Is_Itype
(PtrT
));
4745 Build_Master_Renaming
(PtrT
, N
);
4749 -- If the context of the allocator is a declaration or an
4750 -- assignment, we can generate a meaningful image for the
4751 -- task even though subsequent assignments might remove the
4752 -- connection between task and entity. We build this image
4753 -- when the left-hand side is a simple variable, a simple
4754 -- indexed assignment or a simple selected component.
4756 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
4757 Target_Ref
:= Defining_Identifier
(Parent
(N
));
4759 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4761 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4764 if Is_Entity_Name
(Nam
) then
4767 elsif Nkind
(Nam
) in N_Indexed_Component
4768 | N_Selected_Component
4769 and then Is_Entity_Name
(Prefix
(Nam
))
4778 -- Otherwise we just pass the access type
4784 -- Nothing to pass in the non-task case
4787 Target_Ref
:= Empty
;
4790 Temp
:= Make_Temporary
(Loc
, 'P');
4793 Build_Default_Initialization
(N
, Etyp
, Temp
,
4794 For_CW
=> Is_Class_Wide_Type
(Dtyp
),
4795 Target_Ref
=> Target_Ref
);
4797 if Present
(Init_Stmts
) then
4798 -- We set the allocator as analyzed so that when we analyze
4799 -- the expression node, we do not get an unwanted recursive
4800 -- expansion of the allocator expression.
4805 Make_Object_Declaration
(Loc
,
4806 Defining_Identifier
=> Temp
,
4807 Constant_Present
=> True,
4808 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
4809 Expression
=> Relocate_Node
(N
));
4811 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4813 -- If the designated type is a task type or contains tasks,
4814 -- create a specific block to activate the created tasks.
4816 if Has_Task
(Etyp
) then
4818 Actions
: constant List_Id
:= New_List
;
4821 Build_Task_Allocate_Block
4822 (Actions
, Relocate_Node
(N
), Init_Stmts
);
4823 Insert_Actions
(N
, Actions
, Suppress
=> All_Checks
);
4827 Insert_Actions
(N
, Init_Stmts
, Suppress
=> All_Checks
);
4830 Build_Allocate_Deallocate_Proc
(Temp_Decl
);
4831 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4832 Analyze_And_Resolve
(N
, PtrT
);
4834 Apply_Predicate_Check
(N
, Dtyp
, Deref
=> True);
4836 -- When designated type has Default_Initial_Condition aspects,
4837 -- make a call to the type's DIC procedure to perform the
4838 -- checks. Theoretically this might also be needed for cases
4839 -- where the type doesn't have an init proc, but those should
4840 -- be very uncommon, and for now we only support the init proc
4844 and then Present
(DIC_Procedure
(Dtyp
))
4845 and then not Has_Null_Body
(DIC_Procedure
(Dtyp
))
4848 Build_DIC_Call
(Loc
,
4849 Make_Explicit_Dereference
(Loc
,
4850 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
4854 -- Ada 2005 (AI-251): Displace the pointer to reference the
4855 -- record component containing the secondary dispatch table
4856 -- of the interface type.
4858 if Is_Interface
(Dtyp
) then
4859 Displace_Allocator_Pointer
(N
);
4862 -- No initialization required
4865 Build_Allocate_Deallocate_Proc
(N
);
4871 when RE_Not_Available
=>
4873 end Expand_N_Allocator
;
4875 -----------------------
4876 -- Expand_N_And_Then --
4877 -----------------------
4879 procedure Expand_N_And_Then
(N
: Node_Id
)
4880 renames Expand_Short_Circuit_Operator
;
4882 ------------------------------
4883 -- Expand_N_Case_Expression --
4884 ------------------------------
4886 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4887 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean;
4888 -- Return True if we can copy objects of this type when expanding a case
4895 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean is
4897 -- If Minimize_Expression_With_Actions is True, we can afford to copy
4898 -- large objects, as long as they are constrained and not limited.
4901 Is_Elementary_Type
(Underlying_Type
(Typ
))
4903 (Minimize_Expression_With_Actions
4904 and then Is_Constrained
(Underlying_Type
(Typ
))
4905 and then not Is_Limited_Type
(Underlying_Type
(Typ
)));
4910 Loc
: constant Source_Ptr
:= Sloc
(N
);
4911 Par
: constant Node_Id
:= Parent
(N
);
4912 Typ
: constant Entity_Id
:= Etype
(N
);
4916 Case_Stmt
: Node_Id
;
4918 Target
: Entity_Id
:= Empty
;
4919 Target_Typ
: Entity_Id
;
4921 In_Predicate
: Boolean := False;
4922 -- Flag set when the case expression appears within a predicate
4924 Optimize_Return_Stmt
: Boolean := False;
4925 -- Flag set when the case expression can be optimized in the context of
4926 -- a simple return statement.
4928 -- Start of processing for Expand_N_Case_Expression
4931 -- Check for MINIMIZED/ELIMINATED overflow mode
4933 if Minimized_Eliminated_Overflow_Check
(N
) then
4934 Apply_Arithmetic_Overflow_Check
(N
);
4938 -- If the case expression is a predicate specification, and the type
4939 -- to which it applies has a static predicate aspect, do not expand,
4940 -- because it will be converted to the proper predicate form later.
4942 if Ekind
(Current_Scope
) in E_Function | E_Procedure
4943 and then Is_Predicate_Function
(Current_Scope
)
4945 In_Predicate
:= True;
4947 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
4953 -- When the type of the case expression is elementary, expand
4955 -- (case X is when A => AX, when B => BX ...)
4970 -- In all other cases expand into
4972 -- type Ptr_Typ is access all Typ;
4973 -- Target : Ptr_Typ;
4976 -- Target := AX'Unrestricted_Access;
4978 -- Target := BX'Unrestricted_Access;
4982 -- and replace the case expression by a reference to Target.all.
4984 -- This approach avoids extra copies of potentially large objects. It
4985 -- also allows handling of values of limited or unconstrained types.
4986 -- Note that we do the copy also for constrained, nonlimited types
4987 -- when minimizing expressions with actions (e.g. when generating C
4988 -- code) since it allows us to do the optimization below in more cases.
4991 Make_Case_Statement
(Loc
,
4992 Expression
=> Expression
(N
),
4993 Alternatives
=> New_List
);
4995 -- Preserve the original context for which the case statement is being
4996 -- generated. This is needed by the finalization machinery to prevent
4997 -- the premature finalization of controlled objects found within the
5000 Set_From_Conditional_Expression
(Case_Stmt
);
5003 -- Small optimization: when the case expression appears in the context
5004 -- of a simple return statement, expand into
5014 -- This makes the expansion much easier when expressions are calls to
5015 -- a BIP function. But do not perform it when the return statement is
5016 -- within a predicate function, as this causes spurious errors.
5018 Optimize_Return_Stmt
:=
5019 Nkind
(Par
) = N_Simple_Return_Statement
and then not In_Predicate
;
5023 if Is_Copy_Type
(Typ
) then
5026 -- Otherwise create an access type to handle the general case using
5027 -- 'Unrestricted_Access.
5030 -- type Ptr_Typ is access all Typ;
5033 if Generate_C_Code
then
5035 -- We cannot ensure that correct C code will be generated if any
5036 -- temporary is created down the line (to e.g. handle checks or
5037 -- capture values) since we might end up with dangling references
5038 -- to local variables, so better be safe and reject the construct.
5041 ("case expression too complex, use case statement instead", N
);
5044 Target_Typ
:= Make_Temporary
(Loc
, 'P');
5047 Make_Full_Type_Declaration
(Loc
,
5048 Defining_Identifier
=> Target_Typ
,
5050 Make_Access_To_Object_Definition
(Loc
,
5051 All_Present
=> True,
5052 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5055 -- Create the declaration of the target which captures the value of the
5059 -- Target : [Ptr_]Typ;
5061 if not Optimize_Return_Stmt
then
5062 Target
:= Make_Temporary
(Loc
, 'T');
5065 Make_Object_Declaration
(Loc
,
5066 Defining_Identifier
=> Target
,
5067 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
5068 Set_No_Initialization
(Decl
);
5070 Append_To
(Acts
, Decl
);
5073 -- Process the alternatives
5075 Alt
:= First
(Alternatives
(N
));
5076 while Present
(Alt
) loop
5078 Alt_Expr
: Node_Id
:= Expression
(Alt
);
5079 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
5084 -- Take the unrestricted access of the expression value for non-
5085 -- scalar types. This approach avoids big copies and covers the
5086 -- limited and unconstrained cases.
5089 -- return AX['Unrestricted_Access];
5091 if Optimize_Return_Stmt
then
5093 Make_Simple_Return_Statement
(Alt_Loc
,
5094 Expression
=> Alt_Expr
));
5097 -- Target := AX['Unrestricted_Access];
5100 if not Is_Copy_Type
(Typ
) then
5102 Make_Attribute_Reference
(Alt_Loc
,
5103 Prefix
=> Relocate_Node
(Alt_Expr
),
5104 Attribute_Name
=> Name_Unrestricted_Access
);
5107 LHS
:= New_Occurrence_Of
(Target
, Loc
);
5108 Set_Assignment_OK
(LHS
);
5111 Make_Assignment_Statement
(Alt_Loc
,
5113 Expression
=> Alt_Expr
));
5116 -- Propagate declarations inserted in the node by Insert_Actions
5117 -- (for example, temporaries generated to remove side effects).
5118 -- These actions must remain attached to the alternative, given
5119 -- that they are generated by the corresponding expression.
5121 if Present
(Actions
(Alt
)) then
5122 Prepend_List
(Actions
(Alt
), Stmts
);
5126 (Alternatives
(Case_Stmt
),
5127 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5128 Discrete_Choices
=> Discrete_Choices
(Alt
),
5129 Statements
=> Stmts
));
5131 -- Finalize any transient objects on exit from the alternative.
5132 -- Note that this needs to be done only after Stmts is attached
5133 -- to the Alternatives list above (for Safe_To_Capture_Value).
5135 Process_Transients_In_Expression
(N
, Stmts
);
5141 -- Rewrite the parent return statement as a case statement
5143 if Optimize_Return_Stmt
then
5144 Rewrite
(Par
, Case_Stmt
);
5147 -- Otherwise rewrite the case expression itself
5150 Append_To
(Acts
, Case_Stmt
);
5152 if Is_Copy_Type
(Typ
) then
5154 Make_Expression_With_Actions
(Loc
,
5155 Expression
=> New_Occurrence_Of
(Target
, Loc
),
5159 Insert_Actions
(N
, Acts
);
5161 Make_Explicit_Dereference
(Loc
,
5162 Prefix
=> New_Occurrence_Of
(Target
, Loc
)));
5165 Analyze_And_Resolve
(N
, Typ
);
5167 end Expand_N_Case_Expression
;
5169 -----------------------------------
5170 -- Expand_N_Explicit_Dereference --
5171 -----------------------------------
5173 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5175 -- Insert explicit dereference call for the checked storage pool case
5177 Insert_Dereference_Action
(Prefix
(N
));
5179 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5180 -- we set the atomic sync flag.
5182 if Is_Atomic
(Etype
(N
))
5183 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5185 Activate_Atomic_Synchronization
(N
);
5187 end Expand_N_Explicit_Dereference
;
5189 --------------------------------------
5190 -- Expand_N_Expression_With_Actions --
5191 --------------------------------------
5193 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5194 Acts
: constant List_Id
:= Actions
(N
);
5196 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
5197 -- Force the evaluation of Boolean expression Expr
5199 ------------------------------
5200 -- Force_Boolean_Evaluation --
5201 ------------------------------
5203 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
5204 Loc
: constant Source_Ptr
:= Sloc
(N
);
5205 Flag_Decl
: Node_Id
;
5206 Flag_Id
: Entity_Id
;
5209 -- Relocate the expression to the actions list by capturing its value
5210 -- in a Boolean flag. Generate:
5211 -- Flag : constant Boolean := Expr;
5213 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5216 Make_Object_Declaration
(Loc
,
5217 Defining_Identifier
=> Flag_Id
,
5218 Constant_Present
=> True,
5219 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5220 Expression
=> Relocate_Node
(Expr
));
5222 Append
(Flag_Decl
, Acts
);
5223 Analyze
(Flag_Decl
);
5225 -- Replace the expression with a reference to the flag
5227 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
5228 Analyze
(Expression
(N
));
5229 end Force_Boolean_Evaluation
;
5231 -- Start of processing for Expand_N_Expression_With_Actions
5234 -- Do not evaluate the expression when it denotes an entity because the
5235 -- expression_with_actions node will be replaced by the reference.
5237 if Is_Entity_Name
(Expression
(N
)) then
5240 -- Do not evaluate the expression when there are no actions because the
5241 -- expression_with_actions node will be replaced by the expression.
5243 elsif Is_Empty_List
(Acts
) then
5246 -- Force the evaluation of the expression by capturing its value in a
5247 -- temporary. This ensures that aliases of transient objects do not leak
5248 -- to the expression of the expression_with_actions node:
5251 -- Trans_Id : Ctrl_Typ := ...;
5252 -- Alias : ... := Trans_Id;
5253 -- in ... Alias ... end;
5255 -- In the example above, Trans_Id cannot be finalized at the end of the
5256 -- actions list because this may affect the alias and the final value of
5257 -- the expression_with_actions. Forcing the evaluation encapsulates the
5258 -- reference to the Alias within the actions list:
5261 -- Trans_Id : Ctrl_Typ := ...;
5262 -- Alias : ... := Trans_Id;
5263 -- Val : constant Boolean := ... Alias ...;
5264 -- <finalize Trans_Id>
5267 -- Once this transformation is performed, it is safe to finalize the
5268 -- transient object at the end of the actions list.
5270 -- Note that Force_Evaluation does not remove side effects in operators
5271 -- because it assumes that all operands are evaluated and side effect
5272 -- free. This is not the case when an operand depends implicitly on the
5273 -- transient object through the use of access types.
5275 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5276 Force_Boolean_Evaluation
(Expression
(N
));
5278 -- The expression of an expression_with_actions node may not necessarily
5279 -- be Boolean when the node appears in an if expression. In this case do
5280 -- the usual forced evaluation to encapsulate potential aliasing.
5283 -- A check is also needed since the subtype of the EWA node and the
5284 -- subtype of the expression may differ (for example, the EWA node
5285 -- may have a null-excluding access subtype).
5287 Apply_Constraint_Check
(Expression
(N
), Etype
(N
));
5288 Force_Evaluation
(Expression
(N
));
5291 -- Process transient objects found within the actions of the EWA node
5293 Process_Transients_In_Expression
(N
, Acts
);
5295 -- Deal with case where there are no actions. In this case we simply
5296 -- rewrite the node with its expression since we don't need the actions
5297 -- and the specification of this node does not allow a null action list.
5299 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5300 -- the expanded tree and relying on being able to retrieve the original
5301 -- tree in cases like this. This raises a whole lot of issues of whether
5302 -- we have problems elsewhere, which will be addressed in the future???
5304 if Is_Empty_List
(Acts
) then
5305 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5307 end Expand_N_Expression_With_Actions
;
5309 ----------------------------
5310 -- Expand_N_If_Expression --
5311 ----------------------------
5313 -- Deal with limited types and condition actions
5315 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5316 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5317 Loc
: constant Source_Ptr
:= Sloc
(N
);
5318 Thenx
: constant Node_Id
:= Next
(Cond
);
5319 Elsex
: constant Node_Id
:= Next
(Thenx
);
5320 Par
: constant Node_Id
:= Parent
(N
);
5321 Typ
: constant Entity_Id
:= Etype
(N
);
5323 Force_Expand
: constant Boolean := Is_Anonymous_Access_Actual
(N
);
5324 -- Determine if we are dealing with a special case of a conditional
5325 -- expression used as an actual for an anonymous access type which
5326 -- forces us to transform the if expression into an expression with
5327 -- actions in order to create a temporary to capture the level of the
5328 -- expression in each branch.
5330 function OK_For_Single_Subtype
(T1
, T2
: Entity_Id
) return Boolean;
5331 -- Return true if it is acceptable to use a single subtype for two
5332 -- dependent expressions of subtype T1 and T2 respectively, which are
5333 -- unidimensional arrays whose index bounds are known at compile time.
5335 ---------------------------
5336 -- OK_For_Single_Subtype --
5337 ---------------------------
5339 function OK_For_Single_Subtype
(T1
, T2
: Entity_Id
) return Boolean is
5344 Get_First_Index_Bounds
(T1
, Lo1
, Hi1
);
5345 Get_First_Index_Bounds
(T2
, Lo2
, Hi2
);
5347 -- Return true if the length of the covering subtype is not too large
5350 UI_Max
(Hi1
, Hi2
) - UI_Min
(Lo1
, Lo2
) < Too_Large_Length_For_Array
;
5351 end OK_For_Single_Subtype
;
5361 Optimize_Return_Stmt
: Boolean := False;
5362 -- Flag set when the if expression can be optimized in the context of
5363 -- a simple return statement.
5365 -- Start of processing for Expand_N_If_Expression
5368 -- Deal with non-standard booleans
5370 Adjust_Condition
(Cond
);
5372 -- Check for MINIMIZED/ELIMINATED overflow mode.
5373 -- Apply_Arithmetic_Overflow_Check will not deal with Then/Else_Actions
5374 -- so skip this step if any actions are present.
5376 if Minimized_Eliminated_Overflow_Check
(N
)
5377 and then No
(Then_Actions
(N
))
5378 and then No
(Else_Actions
(N
))
5380 Apply_Arithmetic_Overflow_Check
(N
);
5384 -- Fold at compile time if condition known. We have already folded
5385 -- static if expressions, but it is possible to fold any case in which
5386 -- the condition is known at compile time, even though the result is
5389 -- Note that we don't do the fold of such cases in Sem_Elab because
5390 -- it can cause infinite loops with the expander adding a conditional
5391 -- expression, and Sem_Elab circuitry removing it repeatedly.
5393 if Compile_Time_Known_Value
(Cond
) then
5395 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5396 -- Fold at compile time. Assumes condition known. Return True if
5397 -- folding occurred, meaning we're done.
5399 ----------------------
5400 -- Fold_Known_Value --
5401 ----------------------
5403 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5405 if Is_True
(Expr_Value
(Cond
)) then
5407 Actions
:= Then_Actions
(N
);
5410 Actions
:= Else_Actions
(N
);
5415 if Present
(Actions
) then
5417 -- To minimize the use of Expression_With_Actions, just skip
5418 -- the optimization as it is not critical for correctness.
5420 if Minimize_Expression_With_Actions
then
5425 Make_Expression_With_Actions
(Loc
,
5426 Expression
=> Relocate_Node
(Expr
),
5427 Actions
=> Actions
));
5428 Analyze_And_Resolve
(N
, Typ
);
5431 Rewrite
(N
, Relocate_Node
(Expr
));
5434 -- Note that the result is never static (legitimate cases of
5435 -- static if expressions were folded in Sem_Eval).
5437 Set_Is_Static_Expression
(N
, False);
5439 end Fold_Known_Value
;
5442 if Fold_Known_Value
(Cond
) then
5448 -- Small optimization: when the if expression appears in the context of
5449 -- a simple return statement, expand into
5454 -- return else-expr;
5457 -- This makes the expansion much easier when expressions are calls to
5458 -- a BIP function. But do not perform it when the return statement is
5459 -- within a predicate function, as this causes spurious errors.
5461 Optimize_Return_Stmt
:=
5462 Nkind
(Par
) = N_Simple_Return_Statement
5463 and then not (Ekind
(Current_Scope
) in E_Function | E_Procedure
5464 and then Is_Predicate_Function
(Current_Scope
));
5466 if Optimize_Return_Stmt
then
5467 -- When the "then" or "else" expressions involve controlled function
5468 -- calls, generated temporaries are chained on the corresponding list
5469 -- of actions. These temporaries need to be finalized after the if
5470 -- expression is evaluated.
5472 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5473 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5476 Make_Implicit_If_Statement
(N
,
5477 Condition
=> Relocate_Node
(Cond
),
5478 Then_Statements
=> New_List
(
5479 Make_Simple_Return_Statement
(Sloc
(Thenx
),
5480 Expression
=> Relocate_Node
(Thenx
))),
5481 Else_Statements
=> New_List
(
5482 Make_Simple_Return_Statement
(Sloc
(Elsex
),
5483 Expression
=> Relocate_Node
(Elsex
))));
5485 -- Preserve the original context for which the if statement is
5486 -- being generated. This is needed by the finalization machinery
5487 -- to prevent the premature finalization of controlled objects
5488 -- found within the if statement.
5490 Set_From_Conditional_Expression
(New_If
);
5492 -- If the type is by reference, then we expand as follows to avoid the
5493 -- possibility of improper copying.
5495 -- type Ptr is access all Typ;
5499 -- Cnn := then-expr'Unrestricted_Access;
5502 -- Cnn := else-expr'Unrestricted_Access;
5505 -- and replace the if expression by a reference to Cnn.all.
5507 elsif Is_By_Reference_Type
(Typ
) then
5508 -- When the "then" or "else" expressions involve controlled function
5509 -- calls, generated temporaries are chained on the corresponding list
5510 -- of actions. These temporaries need to be finalized after the if
5511 -- expression is evaluated.
5513 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5514 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5517 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C', N
);
5518 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5522 -- type Ann is access all Typ;
5525 Make_Full_Type_Declaration
(Loc
,
5526 Defining_Identifier
=> Ptr_Typ
,
5528 Make_Access_To_Object_Definition
(Loc
,
5529 All_Present
=> True,
5530 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5536 Make_Object_Declaration
(Loc
,
5537 Defining_Identifier
=> Cnn
,
5538 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5539 Set_No_Initialization
(Decl
);
5543 -- Cnn := <Thenx>'Unrestricted_Access;
5545 -- Cnn := <Elsex>'Unrestricted_Access;
5549 Make_Implicit_If_Statement
(N
,
5550 Condition
=> Relocate_Node
(Cond
),
5551 Then_Statements
=> New_List
(
5552 Make_Assignment_Statement
(Sloc
(Thenx
),
5553 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5555 Make_Attribute_Reference
(Loc
,
5556 Prefix
=> Relocate_Node
(Thenx
),
5557 Attribute_Name
=> Name_Unrestricted_Access
))),
5559 Else_Statements
=> New_List
(
5560 Make_Assignment_Statement
(Sloc
(Elsex
),
5561 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5563 Make_Attribute_Reference
(Loc
,
5564 Prefix
=> Relocate_Node
(Elsex
),
5565 Attribute_Name
=> Name_Unrestricted_Access
))));
5567 -- Preserve the original context for which the if statement is
5568 -- being generated. This is needed by the finalization machinery
5569 -- to prevent the premature finalization of controlled objects
5570 -- found within the if statement.
5572 Set_From_Conditional_Expression
(New_If
);
5575 Make_Explicit_Dereference
(Loc
,
5576 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5579 -- If the result is a unidimensional unconstrained array but the two
5580 -- dependent expressions have constrained subtypes with known bounds,
5581 -- then we expand as follows:
5583 -- subtype Txx is Typ (<static low-bound> .. <static high-bound>);
5587 -- Cnn (<then low-bound .. then high-bound>) := then-expr;
5590 -- Cnn (<else low bound .. else high-bound>) := else-expr;
5593 -- and replace the if expression by a slice of Cnn, provided that Txx
5594 -- is not too large. This will create a static temporary instead of the
5595 -- dynamic one of the next case and thus help the code generator.
5597 -- Note that we need to deal with the case where the else expression is
5598 -- itself such a slice, in order to catch if expressions with more than
5599 -- two dependent expressions in the source code.
5601 -- Also note that this creates variables on branches without an explicit
5602 -- scope, causing troubles with e.g. the LLVM IR, so disable this
5603 -- optimization when Unnest_Subprogram_Mode (enabled for LLVM).
5605 elsif Is_Array_Type
(Typ
)
5606 and then Number_Dimensions
(Typ
) = 1
5607 and then not Is_Constrained
(Typ
)
5608 and then Is_Constrained
(Etype
(Thenx
))
5609 and then Compile_Time_Known_Bounds
(Etype
(Thenx
))
5611 ((Is_Constrained
(Etype
(Elsex
))
5612 and then Compile_Time_Known_Bounds
(Etype
(Elsex
))
5613 and then OK_For_Single_Subtype
(Etype
(Thenx
), Etype
(Elsex
)))
5615 (Nkind
(Elsex
) = N_Slice
5616 and then Is_Constrained
(Etype
(Prefix
(Elsex
)))
5617 and then Compile_Time_Known_Bounds
(Etype
(Prefix
(Elsex
)))
5619 OK_For_Single_Subtype
(Etype
(Thenx
), Etype
(Prefix
(Elsex
)))))
5620 and then not Generate_C_Code
5621 and then not Unnest_Subprogram_Mode
5623 -- When the "then" or "else" expressions involve controlled function
5624 -- calls, generated temporaries are chained on the corresponding list
5625 -- of actions. These temporaries need to be finalized after the if
5626 -- expression is evaluated.
5628 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5629 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5632 Ityp
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
5634 function Build_New_Bound
5637 Slice_Bnd
: Node_Id
) return Node_Id
;
5638 -- Build a new bound from the bounds of the if expression
5640 function To_Ityp
(V
: Uint
) return Node_Id
;
5641 -- Convert V to an index value in Ityp
5643 ---------------------
5644 -- Build_New_Bound --
5645 ---------------------
5647 function Build_New_Bound
5650 Slice_Bnd
: Node_Id
) return Node_Id
is
5653 -- We need to use the special processing for slices only if
5654 -- they do not have compile-time known bounds; if they do, they
5655 -- can be treated like any other expressions.
5657 if Nkind
(Elsex
) = N_Slice
5658 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
5660 if Compile_Time_Known_Value
(Slice_Bnd
)
5661 and then Expr_Value
(Slice_Bnd
) = Then_Bnd
5663 return To_Ityp
(Then_Bnd
);
5666 return Make_If_Expression
(Loc
,
5667 Expressions
=> New_List
(
5668 Duplicate_Subexpr
(Cond
),
5670 New_Copy_Tree
(Slice_Bnd
)));
5673 elsif Then_Bnd
= Else_Bnd
then
5674 return To_Ityp
(Then_Bnd
);
5677 return Make_If_Expression
(Loc
,
5678 Expressions
=> New_List
(
5679 Duplicate_Subexpr
(Cond
),
5681 To_Ityp
(Else_Bnd
)));
5683 end Build_New_Bound
;
5689 function To_Ityp
(V
: Uint
) return Node_Id
is
5690 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, V
);
5693 if Is_Enumeration_Type
(Ityp
) then
5695 Make_Attribute_Reference
(Loc
,
5696 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
5697 Attribute_Name
=> Name_Val
,
5698 Expressions
=> New_List
(Result
));
5705 Slice_Lo
, Slice_Hi
: Node_Id
;
5706 Subtyp_Ind
: Node_Id
;
5707 Else_Lo
, Else_Hi
: Uint
;
5708 Min_Lo
, Max_Hi
: Uint
;
5709 Then_Lo
, Then_Hi
: Uint
;
5710 Then_List
, Else_List
: List_Id
;
5713 Get_First_Index_Bounds
(Etype
(Thenx
), Then_Lo
, Then_Hi
);
5715 -- See the rationale in Build_New_Bound
5717 if Nkind
(Elsex
) = N_Slice
5718 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
5720 Slice_Lo
:= Low_Bound
(Discrete_Range
(Elsex
));
5721 Slice_Hi
:= High_Bound
(Discrete_Range
(Elsex
));
5722 Get_First_Index_Bounds
5723 (Etype
(Prefix
(Elsex
)), Else_Lo
, Else_Hi
);
5728 Get_First_Index_Bounds
(Etype
(Elsex
), Else_Lo
, Else_Hi
);
5731 Min_Lo
:= UI_Min
(Then_Lo
, Else_Lo
);
5732 Max_Hi
:= UI_Max
(Then_Hi
, Else_Hi
);
5734 -- Now we construct an array object with appropriate bounds and
5735 -- mark it as internal to prevent useless initialization when
5736 -- Initialize_Scalars is enabled. Also since this is the actual
5737 -- result entity, we make sure we have debug information for it.
5740 Make_Subtype_Indication
(Loc
,
5741 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
5743 Make_Index_Or_Discriminant_Constraint
(Loc
,
5744 Constraints
=> New_List
(
5746 Low_Bound
=> To_Ityp
(Min_Lo
),
5747 High_Bound
=> To_Ityp
(Max_Hi
)))));
5749 Ent
:= Make_Temporary
(Loc
, 'C');
5750 Set_Is_Internal
(Ent
);
5751 Set_Debug_Info_Needed
(Ent
);
5754 Make_Object_Declaration
(Loc
,
5755 Defining_Identifier
=> Ent
,
5756 Object_Definition
=> Subtyp_Ind
);
5758 -- If the result of the expression appears as the initializing
5759 -- expression of an object declaration, we can just rename the
5760 -- result, rather than copying it.
5762 Mutate_Ekind
(Ent
, E_Variable
);
5763 Set_OK_To_Rename
(Ent
);
5765 Then_List
:= New_List
(
5766 Make_Assignment_Statement
(Loc
,
5769 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
5772 Low_Bound
=> To_Ityp
(Then_Lo
),
5773 High_Bound
=> To_Ityp
(Then_Hi
))),
5774 Expression
=> Relocate_Node
(Thenx
)));
5776 Set_Suppress_Assignment_Checks
(Last
(Then_List
));
5778 -- See the rationale in Build_New_Bound
5780 if Nkind
(Elsex
) = N_Slice
5781 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
5783 Else_List
:= New_List
(
5784 Make_Assignment_Statement
(Loc
,
5787 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
5790 Low_Bound
=> New_Copy_Tree
(Slice_Lo
),
5791 High_Bound
=> New_Copy_Tree
(Slice_Hi
))),
5792 Expression
=> Relocate_Node
(Elsex
)));
5795 Else_List
:= New_List
(
5796 Make_Assignment_Statement
(Loc
,
5799 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
5802 Low_Bound
=> To_Ityp
(Else_Lo
),
5803 High_Bound
=> To_Ityp
(Else_Hi
))),
5804 Expression
=> Relocate_Node
(Elsex
)));
5807 Set_Suppress_Assignment_Checks
(Last
(Else_List
));
5810 Make_Implicit_If_Statement
(N
,
5811 Condition
=> Duplicate_Subexpr
(Cond
),
5812 Then_Statements
=> Then_List
,
5813 Else_Statements
=> Else_List
);
5817 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
5818 Discrete_Range
=> Make_Range
(Loc
,
5819 Low_Bound
=> Build_New_Bound
(Then_Lo
, Else_Lo
, Slice_Lo
),
5820 High_Bound
=> Build_New_Bound
(Then_Hi
, Else_Hi
, Slice_Hi
)));
5823 -- If the result is an unconstrained array and the if expression is in a
5824 -- context other than the initializing expression of the declaration of
5825 -- an object, then we pull out the if expression as follows:
5827 -- Cnn : constant typ := if-expression
5829 -- and then replace the if expression with an occurrence of Cnn. This
5830 -- avoids the need in the back end to create on-the-fly variable length
5831 -- temporaries (which it cannot do!)
5833 -- Note that the test for being in an object declaration avoids doing an
5834 -- unnecessary expansion, and also avoids infinite recursion.
5836 elsif Is_Array_Type
(Typ
)
5837 and then not Is_Constrained
(Typ
)
5838 and then not (Nkind
(Par
) = N_Object_Declaration
5839 and then Expression
(Par
) = N
)
5842 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5846 Make_Object_Declaration
(Loc
,
5847 Defining_Identifier
=> Cnn
,
5848 Constant_Present
=> True,
5849 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5850 Expression
=> Relocate_Node
(N
),
5851 Has_Init_Expression
=> True));
5853 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
5857 -- For other types, we only need to expand if there are other actions
5858 -- associated with either branch or we need to force expansion to deal
5859 -- with if expressions used as an actual of an anonymous access type.
5861 elsif Present
(Then_Actions
(N
))
5862 or else Present
(Else_Actions
(N
))
5863 or else Force_Expand
5865 -- We now wrap the actions into the appropriate expression
5867 if Minimize_Expression_With_Actions
5868 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
5869 or else Is_Constrained
(Underlying_Type
(Typ
)))
5871 -- When the "then" or "else" expressions involve controlled
5872 -- function calls, generated temporaries are chained on the
5873 -- corresponding list of actions. These temporaries need to
5874 -- be finalized after the if expression is evaluated.
5876 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5877 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5879 -- If we can't use N_Expression_With_Actions nodes, then we insert
5880 -- the following sequence of actions (using Insert_Actions):
5885 -- Cnn := then-expr;
5891 -- and replace the if expression by a reference to Cnn
5894 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5898 Make_Object_Declaration
(Loc
,
5899 Defining_Identifier
=> Cnn
,
5900 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
5903 Make_Implicit_If_Statement
(N
,
5904 Condition
=> Relocate_Node
(Cond
),
5906 Then_Statements
=> New_List
(
5907 Make_Assignment_Statement
(Sloc
(Thenx
),
5908 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5909 Expression
=> Relocate_Node
(Thenx
))),
5911 Else_Statements
=> New_List
(
5912 Make_Assignment_Statement
(Sloc
(Elsex
),
5913 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5914 Expression
=> Relocate_Node
(Elsex
))));
5916 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
5917 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
5919 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
5922 -- Regular path using Expression_With_Actions
5925 -- We do not need to call Process_Transients_In_Expression on
5926 -- the list of actions in this case, because the expansion of
5927 -- Expression_With_Actions will do it.
5929 if Present
(Then_Actions
(N
)) then
5931 Make_Expression_With_Actions
(Sloc
(Thenx
),
5932 Actions
=> Then_Actions
(N
),
5933 Expression
=> Relocate_Node
(Thenx
)));
5935 Set_Then_Actions
(N
, No_List
);
5936 Analyze_And_Resolve
(Thenx
, Typ
);
5939 if Present
(Else_Actions
(N
)) then
5941 Make_Expression_With_Actions
(Sloc
(Elsex
),
5942 Actions
=> Else_Actions
(N
),
5943 Expression
=> Relocate_Node
(Elsex
)));
5945 Set_Else_Actions
(N
, No_List
);
5946 Analyze_And_Resolve
(Elsex
, Typ
);
5949 -- We must force expansion into an expression with actions when
5950 -- an if expression gets used directly as an actual for an
5951 -- anonymous access type.
5953 if Force_Expand
then
5955 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
5964 Make_Object_Declaration
(Loc
,
5965 Defining_Identifier
=> Cnn
,
5966 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
5967 Append_To
(Acts
, Decl
);
5969 Set_No_Initialization
(Decl
);
5979 Make_Implicit_If_Statement
(N
,
5980 Condition
=> Relocate_Node
(Cond
),
5981 Then_Statements
=> New_List
(
5982 Make_Assignment_Statement
(Sloc
(Thenx
),
5983 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5984 Expression
=> Relocate_Node
(Thenx
))),
5986 Else_Statements
=> New_List
(
5987 Make_Assignment_Statement
(Sloc
(Elsex
),
5988 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5989 Expression
=> Relocate_Node
(Elsex
))));
5990 Append_To
(Acts
, New_If
);
5998 Make_Expression_With_Actions
(Loc
,
5999 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6001 Analyze_And_Resolve
(N
, Typ
);
6008 -- For the sake of GNATcoverage, generate an intermediate temporary in
6009 -- the case where the if expression is a condition in an outer decision,
6010 -- in order to make sure that no branch is shared between the decisions.
6012 elsif Opt
.Suppress_Control_Flow_Optimizations
6013 and then Nkind
(Original_Node
(Par
)) in N_Case_Expression
6017 | N_Goto_When_Statement
6019 | N_Return_When_Statement
6023 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
6029 -- Cnn : constant Typ := N;
6033 Make_Object_Declaration
(Loc
,
6034 Defining_Identifier
=> Cnn
,
6035 Constant_Present
=> True,
6036 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6037 Expression
=> Relocate_Node
(N
)));
6040 Make_Expression_With_Actions
(Loc
,
6041 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6044 Analyze_And_Resolve
(N
, Typ
);
6048 -- If no actions then no expansion needed, gigi will handle it using the
6049 -- same approach as a C conditional expression.
6055 -- Fall through here for either the limited expansion, or the case of
6056 -- inserting actions for nonlimited types. In both these cases, we must
6057 -- move the SLOC of the parent If statement to the newly created one and
6058 -- change it to the SLOC of the expression which, after expansion, will
6059 -- correspond to what is being evaluated.
6061 if Present
(Par
) and then Nkind
(Par
) = N_If_Statement
then
6062 Set_Sloc
(New_If
, Sloc
(Par
));
6063 Set_Sloc
(Par
, Loc
);
6066 -- Move Then_Actions and Else_Actions, if any, to the new if statement
6068 if Present
(Then_Actions
(N
)) then
6069 Prepend_List
(Then_Actions
(N
), Then_Statements
(New_If
));
6072 if Present
(Else_Actions
(N
)) then
6073 Prepend_List
(Else_Actions
(N
), Else_Statements
(New_If
));
6076 -- Rewrite the parent return statement as an if statement
6078 if Optimize_Return_Stmt
then
6079 Rewrite
(Par
, New_If
);
6082 -- Otherwise rewrite the if expression itself
6085 Insert_Action
(N
, Decl
);
6086 Insert_Action
(N
, New_If
);
6088 Analyze_And_Resolve
(N
, Typ
);
6090 end Expand_N_If_Expression
;
6096 procedure Expand_N_In
(N
: Node_Id
) is
6097 Loc
: constant Source_Ptr
:= Sloc
(N
);
6098 Restyp
: constant Entity_Id
:= Etype
(N
);
6099 Lop
: constant Node_Id
:= Left_Opnd
(N
);
6100 Rop
: constant Node_Id
:= Right_Opnd
(N
);
6101 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
6103 procedure Substitute_Valid_Test
;
6104 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6105 -- test for the left operand being in range of its subtype.
6107 ---------------------------
6108 -- Substitute_Valid_Test --
6109 ---------------------------
6111 procedure Substitute_Valid_Test
is
6112 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
6113 -- Determine whether arbitrary node Nod denotes a source object that
6114 -- may safely act as prefix of attribute 'Valid.
6116 ----------------------------
6117 -- Is_OK_Object_Reference --
6118 ----------------------------
6120 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
6121 Obj_Ref
: constant Node_Id
:= Original_Node
(Nod
);
6122 -- The original operand
6125 -- The object reference must be a source construct, otherwise the
6126 -- codefix suggestion may refer to nonexistent code from a user
6129 return Comes_From_Source
(Obj_Ref
)
6130 and then Is_Object_Reference
(Unqual_Conv
(Obj_Ref
));
6131 end Is_OK_Object_Reference
;
6133 -- Start of processing for Substitute_Valid_Test
6137 Make_Attribute_Reference
(Loc
,
6138 Prefix
=> Relocate_Node
(Lop
),
6139 Attribute_Name
=> Name_Valid
));
6141 Analyze_And_Resolve
(N
, Restyp
);
6143 -- Emit a warning when the left-hand operand of the membership test
6144 -- is a source object, otherwise the use of attribute 'Valid would be
6145 -- illegal. The warning is not given when overflow checking is either
6146 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6147 -- eliminated above.
6149 if Is_OK_Object_Reference
(Lop
)
6150 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
6153 ("??explicit membership test may be optimized away", N
);
6154 Error_Msg_N
-- CODEFIX
6155 ("\??use ''Valid attribute instead", N
);
6157 end Substitute_Valid_Test
;
6164 -- Start of processing for Expand_N_In
6167 -- If set membership case, expand with separate procedure
6169 if Present
(Alternatives
(N
)) then
6170 Expand_Set_Membership
(N
);
6174 -- Not set membership, proceed with expansion
6176 Ltyp
:= Etype
(Left_Opnd
(N
));
6177 Rtyp
:= Etype
(Right_Opnd
(N
));
6179 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6180 -- type, then expand with a separate procedure. Note the use of the
6181 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6183 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
))
6184 and then not No_Minimize_Eliminate
(N
)
6186 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
6190 -- Check case of explicit test for an expression in range of its
6191 -- subtype. This is suspicious usage and we replace it with a 'Valid
6192 -- test and give a warning for scalar types.
6194 if Is_Scalar_Type
(Ltyp
)
6196 -- Only relevant for source comparisons
6198 and then Comes_From_Source
(N
)
6200 -- In floating-point this is a standard way to check for finite values
6201 -- and using 'Valid would typically be a pessimization.
6203 and then not Is_Floating_Point_Type
(Ltyp
)
6205 -- Don't give the message unless right operand is a type entity and
6206 -- the type of the left operand matches this type. Note that this
6207 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6208 -- checks have changed the type of the left operand.
6210 and then Is_Entity_Name
(Rop
)
6211 and then Ltyp
= Entity
(Rop
)
6213 -- Skip this for predicated types, where such expressions are a
6214 -- reasonable way of testing if something meets the predicate.
6216 and then No
(Predicate_Function
(Ltyp
))
6218 Substitute_Valid_Test
;
6222 -- Do validity check on operands
6224 if Validity_Checks_On
and Validity_Check_Operands
then
6225 Ensure_Valid
(Left_Opnd
(N
));
6226 Validity_Check_Range
(Right_Opnd
(N
));
6229 -- Case of explicit range
6231 if Nkind
(Rop
) = N_Range
then
6233 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
6234 Hi
: constant Node_Id
:= High_Bound
(Rop
);
6236 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
6237 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
6238 Rop_Orig
: constant Node_Id
:= Original_Node
(Rop
);
6240 Comes_From_Simple_Range_In_Source
: constant Boolean :=
6241 Comes_From_Source
(N
)
6243 (Is_Entity_Name
(Rop_Orig
)
6244 and then Is_Type
(Entity
(Rop_Orig
))
6245 and then Present
(Predicate_Function
(Entity
(Rop_Orig
))));
6246 -- This is true for a membership test present in the source with a
6247 -- range or mark for a subtype that is not predicated. As already
6248 -- explained a few lines above, we do not want to give warnings on
6249 -- a test with a mark for a subtype that is predicated.
6251 Warn
: constant Boolean :=
6252 Constant_Condition_Warnings
6253 and then Comes_From_Simple_Range_In_Source
6254 and then not In_Instance
;
6255 -- This must be true for any of the optimization warnings, we
6256 -- clearly want to give them only for source with the flag on. We
6257 -- also skip these warnings in an instance since it may be the
6258 -- case that different instantiations have different ranges.
6260 Lcheck
: Compare_Result
;
6261 Ucheck
: Compare_Result
;
6264 -- If test is explicit x'First .. x'Last, replace by 'Valid test
6266 if Is_Scalar_Type
(Ltyp
)
6268 -- Only relevant for source comparisons
6270 and then Comes_From_Simple_Range_In_Source
6272 -- And left operand is X'First where X matches left operand
6273 -- type (this eliminates cases of type mismatch, including
6274 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6275 -- type of the left operand.
6277 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
6278 and then Attribute_Name
(Lo_Orig
) = Name_First
6279 and then Is_Entity_Name
(Prefix
(Lo_Orig
))
6280 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
6282 -- Same tests for right operand
6284 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
6285 and then Attribute_Name
(Hi_Orig
) = Name_Last
6286 and then Is_Entity_Name
(Prefix
(Hi_Orig
))
6287 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
6289 Substitute_Valid_Test
;
6293 -- If bounds of type are known at compile time, and the end points
6294 -- are known at compile time and identical, this is another case
6295 -- for substituting a valid test. We only do this for discrete
6296 -- types, since it won't arise in practice for float types.
6298 if Comes_From_Simple_Range_In_Source
6299 and then Is_Discrete_Type
(Ltyp
)
6300 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
6301 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
6302 and then Compile_Time_Known_Value
(Lo
)
6303 and then Compile_Time_Known_Value
(Hi
)
6304 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
6305 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
6307 -- Kill warnings in instances, since they may be cases where we
6308 -- have a test in the generic that makes sense with some types
6309 -- and not with other types.
6311 -- Similarly, do not rewrite membership as a 'Valid test if
6312 -- within the predicate function for the type.
6314 -- Finally, if the original bounds are type conversions, even
6315 -- if they have been folded into constants, there are different
6316 -- types involved and 'Valid is not appropriate.
6320 or else (Ekind
(Current_Scope
) = E_Function
6321 and then Is_Predicate_Function
(Current_Scope
))
6325 elsif Nkind
(Lo_Orig
) = N_Type_Conversion
6326 or else Nkind
(Hi_Orig
) = N_Type_Conversion
6331 Substitute_Valid_Test
;
6336 -- If we have an explicit range, do a bit of optimization based on
6337 -- range analysis (we may be able to kill one or both checks).
6339 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
6340 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
6342 -- If either check is known to fail, replace result by False since
6343 -- the other check does not matter. Preserve the static flag for
6344 -- legality checks, because we are constant-folding beyond RM 4.9.
6346 if Lcheck
= LT
or else Ucheck
= GT
then
6348 Error_Msg_N
("?c?range test optimized away", N
);
6349 Error_Msg_N
("\?c?value is known to be out of range", N
);
6352 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6353 Analyze_And_Resolve
(N
, Restyp
);
6354 Set_Is_Static_Expression
(N
, Static
);
6357 -- If both checks are known to succeed, replace result by True,
6358 -- since we know we are in range.
6360 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6362 Error_Msg_N
("?c?range test optimized away", N
);
6363 Error_Msg_N
("\?c?value is known to be in range", N
);
6366 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6367 Analyze_And_Resolve
(N
, Restyp
);
6368 Set_Is_Static_Expression
(N
, Static
);
6371 -- If lower bound check succeeds and upper bound check is not
6372 -- known to succeed or fail, then replace the range check with
6373 -- a comparison against the upper bound.
6375 elsif Lcheck
in Compare_GE
then
6379 Right_Opnd
=> High_Bound
(Rop
)));
6380 Analyze_And_Resolve
(N
, Restyp
);
6383 -- Inverse of previous case.
6385 elsif Ucheck
in Compare_LE
then
6389 Right_Opnd
=> Low_Bound
(Rop
)));
6390 Analyze_And_Resolve
(N
, Restyp
);
6394 -- We couldn't optimize away the range check, but there is one
6395 -- more issue. If we are checking constant conditionals, then we
6396 -- see if we can determine the outcome assuming everything is
6397 -- valid, and if so give an appropriate warning.
6399 if Warn
and then not Assume_No_Invalid_Values
then
6400 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
6401 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
6403 -- Result is out of range for valid value
6405 if Lcheck
= LT
or else Ucheck
= GT
then
6407 ("?c?value can only be in range if it is invalid", N
);
6409 -- Result is in range for valid value
6411 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6413 ("?c?value can only be out of range if it is invalid", N
);
6418 -- Try to narrow the operation
6420 if Ltyp
= Universal_Integer
and then Nkind
(N
) = N_In
then
6421 Narrow_Large_Operation
(N
);
6424 -- For all other cases of an explicit range, nothing to be done
6428 -- Here right operand is a subtype mark
6432 Typ
: Entity_Id
:= Etype
(Rop
);
6433 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
6434 Check_Null_Exclusion
: Boolean;
6435 Cond
: Node_Id
:= Empty
;
6437 Obj
: Node_Id
:= Lop
;
6438 SCIL_Node
: Node_Id
;
6441 Remove_Side_Effects
(Obj
);
6443 -- For tagged type, do tagged membership operation
6445 if Is_Tagged_Type
(Typ
) then
6447 -- No expansion will be performed for VM targets, as the VM
6448 -- back ends will handle the membership tests directly.
6450 if Tagged_Type_Expansion
then
6451 Tagged_Membership
(N
, SCIL_Node
, New_N
);
6453 Analyze_And_Resolve
(N
, Restyp
, Suppress
=> All_Checks
);
6455 -- Update decoration of relocated node referenced by the
6458 if Generate_SCIL
and then Present
(SCIL_Node
) then
6459 Set_SCIL_Node
(N
, SCIL_Node
);
6465 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6466 -- The reason we do this is that the bounds may have the wrong
6467 -- type if they come from the original type definition. Also this
6468 -- way we get all the processing above for an explicit range.
6470 -- Don't do this for predicated types, since in this case we want
6471 -- to generate the predicate check at the end of the function.
6473 elsif Is_Scalar_Type
(Typ
) then
6474 if No
(Predicate_Function
(Typ
)) then
6478 Make_Attribute_Reference
(Loc
,
6479 Attribute_Name
=> Name_First
,
6480 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
6483 Make_Attribute_Reference
(Loc
,
6484 Attribute_Name
=> Name_Last
,
6485 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
6487 Analyze_And_Resolve
(N
, Restyp
);
6492 -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is
6493 -- raised when evaluating an individual membership test if the
6494 -- subtype mark denotes a constrained Unchecked_Union subtype
6495 -- and the expression lacks inferable discriminants.
6497 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
6498 and then Is_Constrained
(Typ
)
6499 and then not Has_Inferable_Discriminants
(Lop
)
6502 Make_Expression_With_Actions
(Loc
,
6504 New_List
(Make_Raise_Program_Error
(Loc
,
6505 Reason
=> PE_Unchecked_Union_Restriction
)),
6507 New_Occurrence_Of
(Standard_False
, Loc
)));
6508 Analyze_And_Resolve
(N
, Restyp
);
6513 -- Here we have a non-scalar type
6517 -- If the null exclusion checks are not compatible, need to
6518 -- perform further checks. In other words, we cannot have
6519 -- Ltyp including null or Lop being null, and Typ excluding
6520 -- null. All other cases are OK.
6522 Check_Null_Exclusion
:=
6523 Can_Never_Be_Null
(Typ
)
6524 and then (not Can_Never_Be_Null
(Ltyp
)
6525 or else Nkind
(Lop
) = N_Null
);
6526 Typ
:= Designated_Type
(Typ
);
6529 if not Is_Constrained
(Typ
) then
6530 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6532 -- For the constrained array case, we have to check the subscripts
6533 -- for an exact match if the lengths are non-zero (the lengths
6534 -- must match in any case).
6536 elsif Is_Array_Type
(Typ
) then
6537 Check_Subscripts
: declare
6538 function Build_Attribute_Reference
6541 Dim
: Nat
) return Node_Id
;
6542 -- Build attribute reference E'Nam (Dim)
6544 -------------------------------
6545 -- Build_Attribute_Reference --
6546 -------------------------------
6548 function Build_Attribute_Reference
6551 Dim
: Nat
) return Node_Id
6555 Make_Attribute_Reference
(Loc
,
6557 Attribute_Name
=> Nam
,
6558 Expressions
=> New_List
(
6559 Make_Integer_Literal
(Loc
, Dim
)));
6560 end Build_Attribute_Reference
;
6562 -- Start of processing for Check_Subscripts
6565 for J
in 1 .. Number_Dimensions
(Typ
) loop
6566 Evolve_And_Then
(Cond
,
6569 Build_Attribute_Reference
6570 (Duplicate_Subexpr_No_Checks
(Obj
),
6573 Build_Attribute_Reference
6574 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
6576 Evolve_And_Then
(Cond
,
6579 Build_Attribute_Reference
6580 (Duplicate_Subexpr_No_Checks
(Obj
),
6583 Build_Attribute_Reference
6584 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
6586 end Check_Subscripts
;
6588 -- These are the cases where constraint checks may be required,
6589 -- e.g. records with possible discriminants
6592 -- Expand the test into a series of discriminant comparisons.
6593 -- The expression that is built is the negation of the one that
6594 -- is used for checking discriminant constraints.
6596 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6598 if Has_Discriminants
(Typ
) then
6599 Cond
:= Make_Op_Not
(Loc
,
6600 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6602 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6607 if Check_Null_Exclusion
then
6608 Cond
:= Make_And_Then
(Loc
,
6612 Right_Opnd
=> Make_Null
(Loc
)),
6613 Right_Opnd
=> Cond
);
6615 Cond
:= Make_Or_Else
(Loc
,
6619 Right_Opnd
=> Make_Null
(Loc
)),
6620 Right_Opnd
=> Cond
);
6625 Analyze_And_Resolve
(N
, Restyp
);
6627 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6628 -- expression of an anonymous access type. This can involve an
6629 -- accessibility test and a tagged type membership test in the
6630 -- case of tagged designated types.
6632 if Ada_Version
>= Ada_2012
6634 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6637 Expr_Entity
: Entity_Id
:= Empty
;
6639 Param_Level
: Node_Id
;
6640 Type_Level
: Node_Id
;
6643 if Is_Entity_Name
(Lop
) then
6644 Expr_Entity
:= Param_Entity
(Lop
);
6646 if No
(Expr_Entity
) then
6647 Expr_Entity
:= Entity
(Lop
);
6651 -- When restriction No_Dynamic_Accessibility_Checks is in
6652 -- effect, expand the membership test to a static value
6653 -- since we cannot rely on dynamic levels.
6655 if No_Dynamic_Accessibility_Checks_Enabled
(Lop
) then
6656 if Static_Accessibility_Level
6657 (Lop
, Object_Decl_Level
)
6658 > Type_Access_Level
(Rtyp
)
6660 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6662 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6664 Analyze_And_Resolve
(N
, Restyp
);
6666 -- If a conversion of the anonymous access value to the
6667 -- tested type would be illegal, then the result is False.
6669 elsif not Valid_Conversion
6670 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6672 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6673 Analyze_And_Resolve
(N
, Restyp
);
6675 -- Apply an accessibility check if the access object has an
6676 -- associated access level and when the level of the type is
6677 -- less deep than the level of the access parameter. This
6678 -- can only occur for access parameters and stand-alone
6679 -- objects of an anonymous access type.
6682 Param_Level
:= Accessibility_Level
6683 (Expr_Entity
, Dynamic_Level
);
6686 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6688 -- Return True only if the accessibility level of the
6689 -- expression entity is not deeper than the level of
6690 -- the tested access type.
6694 Left_Opnd
=> Relocate_Node
(N
),
6695 Right_Opnd
=> Make_Op_Le
(Loc
,
6696 Left_Opnd
=> Param_Level
,
6697 Right_Opnd
=> Type_Level
)));
6699 Analyze_And_Resolve
(N
);
6701 -- If the designated type is tagged, do tagged membership
6704 if Is_Tagged_Type
(Typ
) then
6706 -- No expansion will be performed for VM targets, as
6707 -- the VM back ends will handle the membership tests
6710 if Tagged_Type_Expansion
then
6712 -- Note that we have to pass Original_Node, because
6713 -- the membership test might already have been
6714 -- rewritten by earlier parts of membership test.
6717 (Original_Node
(N
), SCIL_Node
, New_N
);
6719 -- Update decoration of relocated node referenced
6720 -- by the SCIL node.
6722 if Generate_SCIL
and then Present
(SCIL_Node
) then
6723 Set_SCIL_Node
(New_N
, SCIL_Node
);
6728 Left_Opnd
=> Relocate_Node
(N
),
6729 Right_Opnd
=> New_N
));
6731 Analyze_And_Resolve
(N
, Restyp
);
6740 -- At this point, we have done the processing required for the basic
6741 -- membership test, but not yet dealt with the predicate.
6745 -- If a predicate is present, then we do the predicate test, but we
6746 -- most certainly want to omit this if we are within the predicate
6747 -- function itself, since otherwise we have an infinite recursion.
6748 -- The check should also not be emitted when testing against a range
6749 -- (the check is only done when the right operand is a subtype; see
6750 -- RM12-4.5.2 (28.1/3-30/3)).
6752 Predicate_Check
: declare
6753 function In_Range_Check
return Boolean;
6754 -- Within an expanded range check that may raise Constraint_Error do
6755 -- not generate a predicate check as well. It is redundant because
6756 -- the context will add an explicit predicate check, and it will
6757 -- raise the wrong exception if it fails.
6759 --------------------
6760 -- In_Range_Check --
6761 --------------------
6763 function In_Range_Check
return Boolean is
6767 while Present
(P
) loop
6768 if Nkind
(P
) = N_Raise_Constraint_Error
then
6771 elsif Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6772 or else Nkind
(P
) = N_Procedure_Call_Statement
6773 or else Nkind
(P
) in N_Declaration
6786 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6789 -- Start of processing for Predicate_Check
6793 and then Current_Scope
/= PFunc
6794 and then Nkind
(Rop
) /= N_Range
6796 -- First apply the transformation that was skipped above
6798 if Is_Scalar_Type
(Rtyp
) then
6802 Make_Attribute_Reference
(Loc
,
6803 Attribute_Name
=> Name_First
,
6804 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
6807 Make_Attribute_Reference
(Loc
,
6808 Attribute_Name
=> Name_Last
,
6809 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
6811 Analyze_And_Resolve
(N
, Restyp
);
6814 if not In_Range_Check
then
6815 -- Indicate via Static_Mem parameter that this predicate
6816 -- evaluation is for a membership test.
6817 R_Op
:= Make_Predicate_Call
(Rtyp
, Lop
, Static_Mem
=> True);
6819 R_Op
:= New_Occurrence_Of
(Standard_True
, Loc
);
6824 Left_Opnd
=> Relocate_Node
(N
),
6825 Right_Opnd
=> R_Op
));
6827 -- Analyze new expression, mark left operand as analyzed to
6828 -- avoid infinite recursion adding predicate calls. Similarly,
6829 -- suppress further range checks on the call.
6831 Set_Analyzed
(Left_Opnd
(N
));
6832 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6834 end Predicate_Check
;
6837 --------------------------------
6838 -- Expand_N_Indexed_Component --
6839 --------------------------------
6841 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6843 Wild_Reads_May_Have_Bad_Side_Effects
: Boolean
6844 renames Validity_Check_Subscripts
;
6845 -- This Boolean needs to be True if reading from a bad address can
6846 -- have a bad side effect (e.g., a segmentation fault that is not
6847 -- transformed into a Storage_Error exception, or interactions with
6848 -- memory-mapped I/O) that needs to be prevented. This refers to the
6849 -- act of reading itself, not to any damage that might be caused later
6850 -- by making use of whatever value was read. We assume here that
6851 -- Validity_Check_Subscripts meets this requirement, but introduce
6852 -- this declaration in order to document this assumption.
6854 function Is_Renamed_Variable_Name
(N
: Node_Id
) return Boolean;
6855 -- Returns True if the given name occurs as part of the renaming
6856 -- of a variable. In this case, the indexing operation should be
6857 -- treated as a write, rather than a read, with respect to validity
6858 -- checking. This is because the renamed variable can later be
6861 function Type_Requires_Subscript_Validity_Checks_For_Reads
6862 (Typ
: Entity_Id
) return Boolean;
6863 -- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing
6864 -- into an array of characters in order to read an element, it is ok
6865 -- if an invalid index value goes undetected. But if it is an array of
6866 -- pointers or an array of tasks, the consequences of such a read are
6867 -- potentially more severe and so we want to detect an invalid index
6868 -- value. This function captures that distinction; this is intended to
6869 -- be consistent with the "but does not by itself lead to erroneous
6870 -- ... execution" rule of RM 13.9.1(11).
6872 ------------------------------
6873 -- Is_Renamed_Variable_Name --
6874 ------------------------------
6876 function Is_Renamed_Variable_Name
(N
: Node_Id
) return Boolean is
6877 Rover
: Node_Id
:= N
;
6879 if Is_Variable
(N
) then
6882 Rover_Parent
: constant Node_Id
:= Parent
(Rover
);
6884 case Nkind
(Rover_Parent
) is
6885 when N_Object_Renaming_Declaration
=>
6886 return Rover
= Name
(Rover_Parent
);
6888 when N_Indexed_Component
6890 | N_Selected_Component
6892 exit when Rover
/= Prefix
(Rover_Parent
);
6893 Rover
:= Rover_Parent
;
6895 -- No need to check for qualified expressions or type
6896 -- conversions here, mostly because of the Is_Variable
6897 -- test. It is possible to have a view conversion for
6898 -- which Is_Variable yields True and which occurs as
6899 -- part of an object renaming, but only if the type is
6900 -- tagged; in that case this function will not be called.
6909 end Is_Renamed_Variable_Name
;
6911 -------------------------------------------------------
6912 -- Type_Requires_Subscript_Validity_Checks_For_Reads --
6913 -------------------------------------------------------
6915 function Type_Requires_Subscript_Validity_Checks_For_Reads
6916 (Typ
: Entity_Id
) return Boolean
6918 -- a shorter name for recursive calls
6919 function Needs_Check
(Typ
: Entity_Id
) return Boolean renames
6920 Type_Requires_Subscript_Validity_Checks_For_Reads
;
6922 if Is_Access_Type
(Typ
)
6923 or else Is_Tagged_Type
(Typ
)
6924 or else Is_Concurrent_Type
(Typ
)
6925 or else (Is_Array_Type
(Typ
)
6926 and then Needs_Check
(Component_Type
(Typ
)))
6927 or else (Is_Scalar_Type
(Typ
)
6928 and then Has_Aspect
(Typ
, Aspect_Default_Value
))
6933 if Is_Record_Type
(Typ
) then
6935 Comp
: Entity_Id
:= First_Component_Or_Discriminant
(Typ
);
6937 while Present
(Comp
) loop
6938 if Needs_Check
(Etype
(Comp
)) then
6942 Next_Component_Or_Discriminant
(Comp
);
6948 end Type_Requires_Subscript_Validity_Checks_For_Reads
;
6952 Loc
: constant Source_Ptr
:= Sloc
(N
);
6953 Typ
: constant Entity_Id
:= Etype
(N
);
6954 P
: constant Node_Id
:= Prefix
(N
);
6955 T
: constant Entity_Id
:= Etype
(P
);
6957 -- Start of processing for Expand_N_Indexed_Component
6960 -- A special optimization, if we have an indexed component that is
6961 -- selecting from a slice, then we can eliminate the slice, since, for
6962 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6963 -- the range check required by the slice. The range check for the slice
6964 -- itself has already been generated. The range check for the
6965 -- subscripting operation is ensured by converting the subject to
6966 -- the subtype of the slice.
6968 -- This optimization not only generates better code, avoiding slice
6969 -- messing especially in the packed case, but more importantly bypasses
6970 -- some problems in handling this peculiar case, for example, the issue
6971 -- of dealing specially with object renamings.
6973 if Nkind
(P
) = N_Slice
6975 -- This optimization is disabled for CodePeer because it can transform
6976 -- an index-check constraint_error into a range-check constraint_error
6977 -- and CodePeer cares about that distinction.
6979 and then not CodePeer_Mode
6982 Make_Indexed_Component
(Loc
,
6983 Prefix
=> Prefix
(P
),
6984 Expressions
=> New_List
(
6986 (Etype
(First_Index
(Etype
(P
))),
6987 First
(Expressions
(N
))))));
6988 Analyze_And_Resolve
(N
, Typ
);
6992 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6993 -- function, then additional actuals must be passed.
6995 if Is_Build_In_Place_Function_Call
(P
) then
6996 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6998 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
6999 -- containing build-in-place function calls whose returned object covers
7002 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
7003 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
7006 -- Generate index and validity checks
7009 Dims_Checked
: Dimension_Set
(Dimensions
=>
7010 (if Is_Array_Type
(T
)
7011 then Number_Dimensions
(T
)
7013 -- Dims_Checked is used to avoid generating two checks (one in
7014 -- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks)
7015 -- for the same index value in cases where the index check eliminates
7016 -- the need for the validity check. The Is_Array_Type test avoids
7017 -- cascading errors.
7020 Generate_Index_Checks
(N
, Checks_Generated
=> Dims_Checked
);
7022 if Validity_Checks_On
7023 and then (Validity_Check_Subscripts
7024 or else Wild_Reads_May_Have_Bad_Side_Effects
7025 or else Type_Requires_Subscript_Validity_Checks_For_Reads
7027 or else Is_Renamed_Variable_Name
(N
))
7029 if Validity_Check_Subscripts
then
7030 -- If we index into an array with an uninitialized variable
7031 -- and we generate an index check that passes at run time,
7032 -- passing that check does not ensure that the variable is
7033 -- valid (although it does in the common case where the
7034 -- object's subtype matches the index subtype).
7035 -- Consider an uninitialized variable with subtype 1 .. 10
7036 -- used to index into an array with bounds 1 .. 20 when the
7037 -- value of the uninitialized variable happens to be 15.
7038 -- The index check will succeed but the variable is invalid.
7039 -- If Validity_Check_Subscripts is True then we need to
7040 -- ensure validity, so we adjust Dims_Checked accordingly.
7041 Dims_Checked
.Elements
:= (others => False);
7043 elsif Is_Array_Type
(T
) then
7044 -- We are only adding extra validity checks here to
7045 -- deal with uninitialized variables (but this includes
7046 -- assigning one uninitialized variable to another). Other
7047 -- ways of producing invalid objects imply erroneousness, so
7048 -- the compiler can do whatever it wants for those cases.
7049 -- If an index type has the Default_Value aspect specified,
7050 -- then we don't have to worry about the possibility of an
7051 -- uninitialized variable, so no need for these extra
7055 Idx
: Node_Id
:= First_Index
(T
);
7057 for No_Check_Needed
of Dims_Checked
.Elements
loop
7058 No_Check_Needed
:= No_Check_Needed
7059 or else Has_Aspect
(Etype
(Idx
), Aspect_Default_Value
);
7065 Apply_Subscript_Validity_Checks
7066 (N
, No_Check_Needed
=> Dims_Checked
);
7070 -- If selecting from an array with atomic components, and atomic sync
7071 -- is not suppressed for this array type, set atomic sync flag.
7073 if (Has_Atomic_Components
(T
)
7074 and then not Atomic_Synchronization_Disabled
(T
))
7075 or else (Is_Atomic
(Typ
)
7076 and then not Atomic_Synchronization_Disabled
(Typ
))
7077 or else (Is_Entity_Name
(P
)
7078 and then Has_Atomic_Components
(Entity
(P
))
7079 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
7081 Activate_Atomic_Synchronization
(N
);
7084 -- All done if the prefix is not a packed array implemented specially
7086 if not (Is_Packed
(Etype
(Prefix
(N
)))
7087 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(N
)))))
7092 -- For packed arrays that are not bit-packed (i.e. the case of an array
7093 -- with one or more index types with a non-contiguous enumeration type),
7094 -- we can always use the normal packed element get circuit.
7096 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
7097 Expand_Packed_Element_Reference
(N
);
7101 -- For a reference to a component of a bit packed array, we convert it
7102 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
7103 -- want to do this for simple references, and not for:
7105 -- Left side of assignment, or prefix of left side of assignment, or
7106 -- prefix of the prefix, to handle packed arrays of packed arrays,
7107 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
7109 -- Renaming objects in renaming associations
7110 -- This case is handled when a use of the renamed variable occurs
7112 -- Actual parameters for a subprogram call
7113 -- This case is handled in Exp_Ch6.Expand_Actuals
7115 -- The second expression in a 'Read attribute reference
7117 -- The prefix of an address or bit or size attribute reference
7119 -- The following circuit detects these exceptions. Note that we need to
7120 -- deal with implicit dereferences when climbing up the parent chain,
7121 -- with the additional difficulty that the type of parents may have yet
7122 -- to be resolved since prefixes are usually resolved first.
7125 Child
: Node_Id
:= N
;
7126 Parnt
: Node_Id
:= Parent
(N
);
7130 if Nkind
(Parnt
) = N_Unchecked_Expression
then
7133 elsif Nkind
(Parnt
) = N_Object_Renaming_Declaration
then
7136 elsif Nkind
(Parnt
) in N_Subprogram_Call
7137 or else (Nkind
(Parnt
) = N_Parameter_Association
7138 and then Nkind
(Parent
(Parnt
)) in N_Subprogram_Call
)
7142 elsif Nkind
(Parnt
) = N_Attribute_Reference
7143 and then Attribute_Name
(Parnt
) in Name_Address
7146 and then Prefix
(Parnt
) = Child
7150 elsif Nkind
(Parnt
) = N_Assignment_Statement
7151 and then Name
(Parnt
) = Child
7155 -- If the expression is an index of an indexed component, it must
7156 -- be expanded regardless of context.
7158 elsif Nkind
(Parnt
) = N_Indexed_Component
7159 and then Child
/= Prefix
(Parnt
)
7161 Expand_Packed_Element_Reference
(N
);
7164 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
7165 and then Name
(Parent
(Parnt
)) = Parnt
7169 elsif Nkind
(Parnt
) = N_Attribute_Reference
7170 and then Attribute_Name
(Parnt
) = Name_Read
7171 and then Next
(First
(Expressions
(Parnt
))) = Child
7175 elsif Nkind
(Parnt
) = N_Indexed_Component
7176 and then Prefix
(Parnt
) = Child
7180 elsif Nkind
(Parnt
) = N_Selected_Component
7181 and then Prefix
(Parnt
) = Child
7182 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
7184 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
7188 -- If the parent is a dereference, either implicit or explicit,
7189 -- then the packed reference needs to be expanded.
7192 Expand_Packed_Element_Reference
(N
);
7196 -- Keep looking up tree for unchecked expression, or if we are the
7197 -- prefix of a possible assignment left side.
7200 Parnt
:= Parent
(Child
);
7203 end Expand_N_Indexed_Component
;
7205 ---------------------
7206 -- Expand_N_Not_In --
7207 ---------------------
7209 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7210 -- can be done. This avoids needing to duplicate this expansion code.
7212 procedure Expand_N_Not_In
(N
: Node_Id
) is
7213 Loc
: constant Source_Ptr
:= Sloc
(N
);
7214 Typ
: constant Entity_Id
:= Etype
(N
);
7215 Cfs
: constant Boolean := Comes_From_Source
(N
);
7222 Left_Opnd
=> Left_Opnd
(N
),
7223 Right_Opnd
=> Right_Opnd
(N
))));
7225 -- If this is a set membership, preserve list of alternatives
7227 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
7229 -- We want this to appear as coming from source if original does (see
7230 -- transformations in Expand_N_In).
7232 Set_Comes_From_Source
(N
, Cfs
);
7233 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
7235 -- Now analyze transformed node
7237 Analyze_And_Resolve
(N
, Typ
);
7238 end Expand_N_Not_In
;
7244 -- The only replacement required is for the case of a null of a type that
7245 -- is an access to protected subprogram, or a subtype thereof. We represent
7246 -- such access values as a record, and so we must replace the occurrence of
7247 -- null by the equivalent record (with a null address and a null pointer in
7248 -- it), so that the back end creates the proper value.
7250 procedure Expand_N_Null
(N
: Node_Id
) is
7251 Loc
: constant Source_Ptr
:= Sloc
(N
);
7252 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
7256 if Is_Access_Protected_Subprogram_Type
(Typ
) then
7258 Make_Aggregate
(Loc
,
7259 Expressions
=> New_List
(
7260 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
7264 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
7266 -- For subsequent semantic analysis, the node must retain its type.
7267 -- Gigi in any case replaces this type by the corresponding record
7268 -- type before processing the node.
7274 when RE_Not_Available
=>
7278 ---------------------
7279 -- Expand_N_Op_Abs --
7280 ---------------------
7282 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
7283 Loc
: constant Source_Ptr
:= Sloc
(N
);
7284 Expr
: constant Node_Id
:= Right_Opnd
(N
);
7285 Typ
: constant Entity_Id
:= Etype
(N
);
7288 Unary_Op_Validity_Checks
(N
);
7290 -- Check for MINIMIZED/ELIMINATED overflow mode
7292 if Minimized_Eliminated_Overflow_Check
(N
) then
7293 Apply_Arithmetic_Overflow_Check
(N
);
7297 -- Try to narrow the operation
7299 if Typ
= Universal_Integer
then
7300 Narrow_Large_Operation
(N
);
7302 if Nkind
(N
) /= N_Op_Abs
then
7307 -- Deal with software overflow checking
7309 if Is_Signed_Integer_Type
(Typ
)
7310 and then Do_Overflow_Check
(N
)
7312 -- The only case to worry about is when the argument is equal to the
7313 -- largest negative number, so what we do is to insert the check:
7315 -- [constraint_error when Expr = typ'Base'First]
7317 -- with the usual Duplicate_Subexpr use coding for expr
7320 Make_Raise_Constraint_Error
(Loc
,
7323 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
7325 Make_Attribute_Reference
(Loc
,
7327 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
7328 Attribute_Name
=> Name_First
)),
7329 Reason
=> CE_Overflow_Check_Failed
));
7331 Set_Do_Overflow_Check
(N
, False);
7333 end Expand_N_Op_Abs
;
7335 ---------------------
7336 -- Expand_N_Op_Add --
7337 ---------------------
7339 procedure Expand_N_Op_Add
(N
: Node_Id
) is
7340 Typ
: constant Entity_Id
:= Etype
(N
);
7343 Binary_Op_Validity_Checks
(N
);
7345 -- Check for MINIMIZED/ELIMINATED overflow mode
7347 if Minimized_Eliminated_Overflow_Check
(N
) then
7348 Apply_Arithmetic_Overflow_Check
(N
);
7352 -- N + 0 = 0 + N = N for integer types
7354 if Is_Integer_Type
(Typ
) then
7355 if Compile_Time_Known_Value
(Right_Opnd
(N
))
7356 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
7358 Rewrite
(N
, Left_Opnd
(N
));
7361 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
7362 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
7364 Rewrite
(N
, Right_Opnd
(N
));
7369 -- Try to narrow the operation
7371 if Typ
= Universal_Integer
then
7372 Narrow_Large_Operation
(N
);
7374 if Nkind
(N
) /= N_Op_Add
then
7379 -- Arithmetic overflow checks for signed integer/fixed point types
7381 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
7382 Apply_Arithmetic_Overflow_Check
(N
);
7386 -- Overflow checks for floating-point if -gnateF mode active
7388 Check_Float_Op_Overflow
(N
);
7390 Expand_Nonbinary_Modular_Op
(N
);
7391 end Expand_N_Op_Add
;
7393 ---------------------
7394 -- Expand_N_Op_And --
7395 ---------------------
7397 procedure Expand_N_Op_And
(N
: Node_Id
) is
7398 Typ
: constant Entity_Id
:= Etype
(N
);
7401 Binary_Op_Validity_Checks
(N
);
7403 if Is_Array_Type
(Etype
(N
)) then
7404 Expand_Boolean_Operator
(N
);
7406 elsif Is_Boolean_Type
(Etype
(N
)) then
7407 Adjust_Condition
(Left_Opnd
(N
));
7408 Adjust_Condition
(Right_Opnd
(N
));
7409 Set_Etype
(N
, Standard_Boolean
);
7410 Adjust_Result_Type
(N
, Typ
);
7412 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
7413 Expand_Intrinsic_Call
(N
, Entity
(N
));
7416 Expand_Nonbinary_Modular_Op
(N
);
7417 end Expand_N_Op_And
;
7419 ------------------------
7420 -- Expand_N_Op_Concat --
7421 ------------------------
7423 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
7425 -- List of operands to be concatenated
7428 -- Node which is to be replaced by the result of concatenating the nodes
7429 -- in the list Opnds.
7432 -- Ensure validity of both operands
7434 Binary_Op_Validity_Checks
(N
);
7436 -- If we are the left operand of a concatenation higher up the tree,
7437 -- then do nothing for now, since we want to deal with a series of
7438 -- concatenations as a unit.
7440 if Nkind
(Parent
(N
)) = N_Op_Concat
7441 and then N
= Left_Opnd
(Parent
(N
))
7446 -- We get here with a concatenation whose left operand may be a
7447 -- concatenation itself with a consistent type. We need to process
7448 -- these concatenation operands from left to right, which means
7449 -- from the deepest node in the tree to the highest node.
7452 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
7453 Cnode
:= Left_Opnd
(Cnode
);
7456 -- Now Cnode is the deepest concatenation, and its parents are the
7457 -- concatenation nodes above, so now we process bottom up, doing the
7460 -- The outer loop runs more than once if more than one concatenation
7461 -- type is involved.
7464 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
7465 Set_Parent
(Opnds
, N
);
7467 -- The inner loop gathers concatenation operands
7469 Inner
: while Cnode
/= N
7470 and then Base_Type
(Etype
(Cnode
)) =
7471 Base_Type
(Etype
(Parent
(Cnode
)))
7473 Cnode
:= Parent
(Cnode
);
7474 Append
(Right_Opnd
(Cnode
), Opnds
);
7477 -- Note: The following code is a temporary workaround for N731-034
7478 -- and N829-028 and will be kept until the general issue of internal
7479 -- symbol serialization is addressed. The workaround is kept under a
7480 -- debug switch to avoid permiating into the general case.
7482 -- Wrap the node to concatenate into an expression actions node to
7483 -- keep it nicely packaged. This is useful in the case of an assert
7484 -- pragma with a concatenation where we want to be able to delete
7485 -- the concatenation and all its expansion stuff.
7487 if Debug_Flag_Dot_H
then
7489 Cnod
: constant Node_Id
:= New_Copy_Tree
(Cnode
);
7490 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
7493 -- Note: use Rewrite rather than Replace here, so that for
7494 -- example Why_Not_Static can find the original concatenation
7498 Make_Expression_With_Actions
(Sloc
(Cnode
),
7499 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
7500 Expression
=> Cnod
));
7502 Expand_Concatenate
(Cnod
, Opnds
);
7503 Analyze_And_Resolve
(Cnode
, Typ
);
7509 Expand_Concatenate
(Cnode
, Opnds
);
7512 exit Outer
when Cnode
= N
;
7513 Cnode
:= Parent
(Cnode
);
7515 end Expand_N_Op_Concat
;
7517 ------------------------
7518 -- Expand_N_Op_Divide --
7519 ------------------------
7521 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
7522 Loc
: constant Source_Ptr
:= Sloc
(N
);
7523 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
7524 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
7525 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
7526 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
7527 Typ
: Entity_Id
:= Etype
(N
);
7528 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
7530 Compile_Time_Known_Value
(Ropnd
);
7534 Binary_Op_Validity_Checks
(N
);
7536 -- Check for MINIMIZED/ELIMINATED overflow mode
7538 if Minimized_Eliminated_Overflow_Check
(N
) then
7539 Apply_Arithmetic_Overflow_Check
(N
);
7543 -- Otherwise proceed with expansion of division
7546 Rval
:= Expr_Value
(Ropnd
);
7549 -- N / 1 = N for integer types
7551 if Rknow
and then Rval
= Uint_1
then
7556 -- Try to narrow the operation
7558 if Typ
= Universal_Integer
then
7559 Narrow_Large_Operation
(N
);
7561 if Nkind
(N
) /= N_Op_Divide
then
7566 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7567 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7568 -- operand is an unsigned integer, as required for this to work.
7570 if Nkind
(Ropnd
) = N_Op_Expon
7571 and then Is_Power_Of_2_For_Shift
(Ropnd
)
7573 -- We cannot do this transformation in configurable run time mode if we
7574 -- have 64-bit integers and long shifts are not available.
7576 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
7579 Make_Op_Shift_Right
(Loc
,
7582 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
7583 Analyze_And_Resolve
(N
, Typ
);
7587 -- Do required fixup of universal fixed operation
7589 if Typ
= Universal_Fixed
then
7590 Fixup_Universal_Fixed_Operation
(N
);
7594 -- Divisions with fixed-point results
7596 if Is_Fixed_Point_Type
(Typ
) then
7598 if Is_Integer_Type
(Rtyp
) then
7599 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
7601 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
7604 -- Deal with divide-by-zero check if back end cannot handle them
7605 -- and the flag is set indicating that we need such a check. Note
7606 -- that we don't need to bother here with the case of mixed-mode
7607 -- (Right operand an integer type), since these will be rewritten
7608 -- with conversions to a divide with a fixed-point right operand.
7610 if Nkind
(N
) = N_Op_Divide
7611 and then Do_Division_Check
(N
)
7612 and then not Backend_Divide_Checks_On_Target
7613 and then not Is_Integer_Type
(Rtyp
)
7615 Set_Do_Division_Check
(N
, False);
7617 Make_Raise_Constraint_Error
(Loc
,
7620 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
7621 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
7622 Reason
=> CE_Divide_By_Zero
));
7625 -- Other cases of division of fixed-point operands
7627 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
7628 if Is_Integer_Type
(Typ
) then
7629 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
7631 pragma Assert
(Is_Floating_Point_Type
(Typ
));
7632 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
7635 -- Mixed-mode operations can appear in a non-static universal context,
7636 -- in which case the integer argument must be converted explicitly.
7638 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
7640 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
7642 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
7644 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
7646 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
7648 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
7650 -- Non-fixed point cases, do integer zero divide and overflow checks
7652 elsif Is_Integer_Type
(Typ
) then
7653 Apply_Divide_Checks
(N
);
7656 -- Overflow checks for floating-point if -gnateF mode active
7658 Check_Float_Op_Overflow
(N
);
7660 Expand_Nonbinary_Modular_Op
(N
);
7661 end Expand_N_Op_Divide
;
7663 --------------------
7664 -- Expand_N_Op_Eq --
7665 --------------------
7667 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
7668 Loc
: constant Source_Ptr
:= Sloc
(N
);
7669 Typ
: constant Entity_Id
:= Etype
(N
);
7670 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
7671 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
7672 Bodies
: constant List_Id
:= New_List
;
7673 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
7675 procedure Build_Equality_Call
(Eq
: Entity_Id
);
7676 -- If a constructed equality exists for the type or for its parent,
7677 -- build and analyze call, adding conversions if the operation is
7680 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
;
7681 -- Find a primitive equality function within primitive operation list
7684 function Has_Unconstrained_UU_Component
(Typ
: Entity_Id
) return Boolean;
7685 -- Determines whether a type has a subcomponent of an unconstrained
7686 -- Unchecked_Union subtype. Typ is a record type.
7688 -------------------------
7689 -- Build_Equality_Call --
7690 -------------------------
7692 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
7693 Op_Typ
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
7695 L_Exp
, R_Exp
: Node_Id
;
7698 -- Adjust operands if necessary to comparison type
7700 if Base_Type
(A_Typ
) /= Base_Type
(Op_Typ
)
7701 and then not Is_Class_Wide_Type
(A_Typ
)
7703 L_Exp
:= OK_Convert_To
(Op_Typ
, Lhs
);
7704 R_Exp
:= OK_Convert_To
(Op_Typ
, Rhs
);
7707 L_Exp
:= Relocate_Node
(Lhs
);
7708 R_Exp
:= Relocate_Node
(Rhs
);
7712 Make_Function_Call
(Loc
,
7713 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7714 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7716 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7717 end Build_Equality_Call
;
7723 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
is
7724 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
;
7725 -- Find an equality in a possible alias chain starting from primitive
7728 ---------------------------
7729 -- Find_Aliased_Equality --
7730 ---------------------------
7732 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
is
7736 -- Inspect each candidate in the alias chain, checking whether it
7737 -- denotes an equality.
7740 while Present
(Candid
) loop
7741 if Is_User_Defined_Equality
(Candid
) then
7745 Candid
:= Alias
(Candid
);
7749 end Find_Aliased_Equality
;
7753 Eq_Prim
: Entity_Id
;
7754 Prim_Elmt
: Elmt_Id
;
7756 -- Start of processing for Find_Equality
7759 -- Assume that the tagged type lacks an equality
7763 -- Inspect the list of primitives looking for a suitable equality
7764 -- within a possible chain of aliases.
7766 Prim_Elmt
:= First_Elmt
(Prims
);
7767 while Present
(Prim_Elmt
) and then No
(Eq_Prim
) loop
7768 Eq_Prim
:= Find_Aliased_Equality
(Node
(Prim_Elmt
));
7770 Next_Elmt
(Prim_Elmt
);
7773 -- A tagged type should always have an equality
7775 pragma Assert
(Present
(Eq_Prim
));
7780 ------------------------------------
7781 -- Has_Unconstrained_UU_Component --
7782 ------------------------------------
7784 function Has_Unconstrained_UU_Component
7785 (Typ
: Entity_Id
) return Boolean
7787 function Unconstrained_UU_In_Component_Declaration
7788 (N
: Node_Id
) return Boolean;
7790 function Unconstrained_UU_In_Component_Items
7791 (L
: List_Id
) return Boolean;
7793 function Unconstrained_UU_In_Component_List
7794 (N
: Node_Id
) return Boolean;
7796 function Unconstrained_UU_In_Variant_Part
7797 (N
: Node_Id
) return Boolean;
7798 -- A family of routines that determine whether a particular construct
7799 -- of a record type definition contains a subcomponent of an
7800 -- unchecked union type whose nominal subtype is unconstrained.
7802 -- Individual routines correspond to the production rules of the Ada
7803 -- grammar, as described in the Ada RM (P).
7805 -----------------------------------------------
7806 -- Unconstrained_UU_In_Component_Declaration --
7807 -----------------------------------------------
7809 function Unconstrained_UU_In_Component_Declaration
7810 (N
: Node_Id
) return Boolean
7812 pragma Assert
(Nkind
(N
) = N_Component_Declaration
);
7814 Sindic
: constant Node_Id
:=
7815 Subtype_Indication
(Component_Definition
(N
));
7817 -- If the component declaration includes a subtype indication
7818 -- it is not an unchecked_union. Otherwise verify that it carries
7819 -- the Unchecked_Union flag and is either a record or a private
7820 -- type. A Record_Subtype declared elsewhere does not qualify,
7821 -- even if its parent type carries the flag.
7823 return Nkind
(Sindic
) in N_Expanded_Name | N_Identifier
7824 and then Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)))
7825 and then Ekind
(Entity
(Sindic
)) in
7826 E_Private_Type | E_Record_Type
;
7827 end Unconstrained_UU_In_Component_Declaration
;
7829 -----------------------------------------
7830 -- Unconstrained_UU_In_Component_Items --
7831 -----------------------------------------
7833 function Unconstrained_UU_In_Component_Items
7834 (L
: List_Id
) return Boolean
7836 N
: Node_Id
:= First
(L
);
7838 while Present
(N
) loop
7839 if Nkind
(N
) = N_Component_Declaration
7840 and then Unconstrained_UU_In_Component_Declaration
(N
)
7849 end Unconstrained_UU_In_Component_Items
;
7851 ----------------------------------------
7852 -- Unconstrained_UU_In_Component_List --
7853 ----------------------------------------
7855 function Unconstrained_UU_In_Component_List
7856 (N
: Node_Id
) return Boolean
7858 pragma Assert
(Nkind
(N
) = N_Component_List
);
7860 Optional_Variant_Part
: Node_Id
;
7862 if Unconstrained_UU_In_Component_Items
(Component_Items
(N
)) then
7866 Optional_Variant_Part
:= Variant_Part
(N
);
7869 Present
(Optional_Variant_Part
)
7871 Unconstrained_UU_In_Variant_Part
(Optional_Variant_Part
);
7872 end Unconstrained_UU_In_Component_List
;
7874 --------------------------------------
7875 -- Unconstrained_UU_In_Variant_Part --
7876 --------------------------------------
7878 function Unconstrained_UU_In_Variant_Part
7879 (N
: Node_Id
) return Boolean
7881 pragma Assert
(Nkind
(N
) = N_Variant_Part
);
7883 Variant
: Node_Id
:= First
(Variants
(N
));
7886 if Unconstrained_UU_In_Component_List
(Component_List
(Variant
))
7892 exit when No
(Variant
);
7896 end Unconstrained_UU_In_Variant_Part
;
7898 Typ_Def
: constant Node_Id
:=
7899 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
7901 Optional_Component_List
: constant Node_Id
:=
7902 Component_List
(Typ_Def
);
7904 -- Start of processing for Has_Unconstrained_UU_Component
7907 return Present
(Optional_Component_List
)
7909 Unconstrained_UU_In_Component_List
(Optional_Component_List
);
7910 end Has_Unconstrained_UU_Component
;
7916 -- Start of processing for Expand_N_Op_Eq
7919 Binary_Op_Validity_Checks
(N
);
7921 -- Deal with private types
7923 Typl
:= Underlying_Type
(A_Typ
);
7925 -- It may happen in error situations that the underlying type is not
7926 -- set. The error will be detected later, here we just defend the
7933 -- Now get the implementation base type (note that plain Base_Type here
7934 -- might lead us back to the private type, which is not what we want!)
7936 Typl
:= Implementation_Base_Type
(Typl
);
7938 -- Equality between variant records results in a call to a routine
7939 -- that has conditional tests of the discriminant value(s), and hence
7940 -- violates the No_Implicit_Conditionals restriction.
7942 if Has_Variant_Part
(Typl
) then
7947 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
7951 ("\comparison of variant records tests discriminants", N
);
7957 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7958 -- means we no longer have a comparison operation, we are all done.
7960 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
)) then
7961 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7964 if Nkind
(N
) /= N_Op_Eq
then
7968 -- Boolean types (requiring handling of non-standard case)
7970 if Is_Boolean_Type
(Typl
) then
7971 Adjust_Condition
(Left_Opnd
(N
));
7972 Adjust_Condition
(Right_Opnd
(N
));
7973 Set_Etype
(N
, Standard_Boolean
);
7974 Adjust_Result_Type
(N
, Typ
);
7978 elsif Is_Array_Type
(Typl
) then
7980 -- If we are doing full validity checking, and it is possible for the
7981 -- array elements to be invalid then expand out array comparisons to
7982 -- make sure that we check the array elements.
7984 if Validity_Check_Operands
7985 and then not Is_Known_Valid
(Component_Type
(Typl
))
7988 Save_Force_Validity_Checks
: constant Boolean :=
7989 Force_Validity_Checks
;
7991 Force_Validity_Checks
:= True;
7993 Expand_Array_Equality
7995 Relocate_Node
(Lhs
),
7996 Relocate_Node
(Rhs
),
7999 Insert_Actions
(N
, Bodies
);
8000 Analyze_And_Resolve
(N
, Standard_Boolean
);
8001 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
8004 -- Packed case where both operands are known aligned
8006 elsif Is_Bit_Packed_Array
(Typl
)
8007 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8008 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8010 Expand_Packed_Eq
(N
);
8012 -- Where the component type is elementary we can use a block bit
8013 -- comparison (if supported on the target) exception in the case
8014 -- of floating-point (negative zero issues require element by
8015 -- element comparison), and full access types (where we must be sure
8016 -- to load elements independently) and possibly unaligned arrays.
8018 elsif Is_Elementary_Type
(Component_Type
(Typl
))
8019 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
8020 and then not Is_Full_Access
(Component_Type
(Typl
))
8021 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8022 and then not Is_Possibly_Unaligned_Slice
(Lhs
)
8023 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8024 and then not Is_Possibly_Unaligned_Slice
(Rhs
)
8025 and then Support_Composite_Compare_On_Target
8029 -- For composite and floating-point cases, expand equality loop to
8030 -- make sure of using proper comparisons for tagged types, and
8031 -- correctly handling the floating-point case.
8035 Expand_Array_Equality
8037 Relocate_Node
(Lhs
),
8038 Relocate_Node
(Rhs
),
8041 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8042 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8047 elsif Is_Record_Type
(Typl
) then
8049 -- For tagged types, use the primitive "="
8051 if Is_Tagged_Type
(Typl
) then
8053 -- No need to do anything else compiling under restriction
8054 -- No_Dispatching_Calls. During the semantic analysis we
8055 -- already notified such violation.
8057 if Restriction_Active
(No_Dispatching_Calls
) then
8061 -- If this is an untagged private type completed with a derivation
8062 -- of an untagged private type whose full view is a tagged type,
8063 -- we use the primitive operations of the private type (since it
8064 -- does not have a full view, and also because its equality
8065 -- primitive may have been overridden in its untagged full view).
8067 if Inherits_From_Tagged_Full_View
(A_Typ
) then
8069 (Find_Equality
(Collect_Primitive_Operations
(A_Typ
)));
8071 -- Find the type's predefined equality or an overriding
8072 -- user-defined equality. The reason for not simply calling
8073 -- Find_Prim_Op here is that there may be a user-defined
8074 -- overloaded equality op that precedes the equality that we
8075 -- want, so we have to explicitly search (e.g., there could be
8076 -- an equality with two different parameter types).
8079 if Is_Class_Wide_Type
(Typl
) then
8080 Typl
:= Find_Specific_Type
(Typl
);
8084 (Find_Equality
(Primitive_Operations
(Typl
)));
8087 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8088 -- predefined equality operator for a type which has a subcomponent
8089 -- of an unchecked union type whose nominal subtype is unconstrained.
8091 elsif Has_Unconstrained_UU_Component
(Typl
) then
8093 Make_Raise_Program_Error
(Loc
,
8094 Reason
=> PE_Unchecked_Union_Restriction
));
8097 New_Occurrence_Of
(Standard_False
, Loc
));
8099 -- If a type support function is present, e.g. if there is a variant
8100 -- part, including an unchecked union type, use it.
8102 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
8104 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8106 -- When comparing two Bounded_Strings, use the primitive equality of
8107 -- the root Super_String type.
8109 elsif Is_Bounded_String
(Typl
) then
8112 (Collect_Primitive_Operations
(Root_Type
(Typl
))));
8114 -- Otherwise expand the component by component equality. Note that
8115 -- we never use block-bit comparisons for records, because of the
8116 -- problems with gaps. The back end will often be able to recombine
8117 -- the separate comparisons that we generate here.
8120 Remove_Side_Effects
(Lhs
);
8121 Remove_Side_Effects
(Rhs
);
8122 Rewrite
(N
, Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
));
8124 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8127 -- If unnesting, handle elementary types whose Equivalent_Types are
8128 -- records because there may be padding or undefined fields.
8130 elsif Unnest_Subprogram_Mode
8131 and then Ekind
(Typl
) in E_Class_Wide_Type
8132 | E_Class_Wide_Subtype
8133 | E_Access_Subprogram_Type
8134 | E_Access_Protected_Subprogram_Type
8135 | E_Anonymous_Access_Protected_Subprogram_Type
8137 and then Present
(Equivalent_Type
(Typl
))
8138 and then Is_Record_Type
(Equivalent_Type
(Typl
))
8140 Typl
:= Equivalent_Type
(Typl
);
8141 Remove_Side_Effects
(Lhs
);
8142 Remove_Side_Effects
(Rhs
);
8144 Expand_Record_Equality
(N
, Typl
,
8145 Unchecked_Convert_To
(Typl
, Lhs
),
8146 Unchecked_Convert_To
(Typl
, Rhs
)));
8148 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8151 -- Test if result is known at compile time
8153 Rewrite_Comparison
(N
);
8155 -- Try to narrow the operation
8157 if Typl
= Universal_Integer
and then Nkind
(N
) = N_Op_Eq
then
8158 Narrow_Large_Operation
(N
);
8161 -- Special optimization of length comparison
8163 Optimize_Length_Comparison
(N
);
8165 -- One more special case: if we have a comparison of X'Result = expr
8166 -- in floating-point, then if not already there, change expr to be
8167 -- f'Machine (expr) to eliminate surprise from extra precision.
8169 if Is_Floating_Point_Type
(Typl
)
8170 and then Is_Attribute_Result
(Original_Node
(Lhs
))
8172 -- Stick in the Typ'Machine call if not already there
8174 if Nkind
(Rhs
) /= N_Attribute_Reference
8175 or else Attribute_Name
(Rhs
) /= Name_Machine
8178 Make_Attribute_Reference
(Loc
,
8179 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
8180 Attribute_Name
=> Name_Machine
,
8181 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
8182 Analyze_And_Resolve
(Rhs
, Typl
);
8187 -----------------------
8188 -- Expand_N_Op_Expon --
8189 -----------------------
8191 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
8192 Loc
: constant Source_Ptr
:= Sloc
(N
);
8193 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
8194 Typ
: constant Entity_Id
:= Etype
(N
);
8195 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
8199 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
8200 -- Given an expression Exp, if the root type is Float or Long_Float,
8201 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8202 -- extra precision. This is done to ensure that X**A = X**B when A is
8203 -- a static constant and B is a variable with the same value. For any
8204 -- other type, the node Exp is returned unchanged.
8210 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
8211 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
8214 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
8216 Make_Attribute_Reference
(Loc
,
8217 Attribute_Name
=> Name_Machine
,
8218 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
8219 Expressions
=> New_List
(Relocate_Node
(Exp
)));
8237 -- Start of processing for Expand_N_Op_Expon
8240 Binary_Op_Validity_Checks
(N
);
8242 -- CodePeer wants to see the unexpanded N_Op_Expon node
8244 if CodePeer_Mode
then
8248 -- Relocation of left and right operands must be done after performing
8249 -- the validity checks since the generation of validation checks may
8250 -- remove side effects.
8252 Base
:= Relocate_Node
(Left_Opnd
(N
));
8253 Bastyp
:= Etype
(Base
);
8254 Exp
:= Relocate_Node
(Right_Opnd
(N
));
8255 Exptyp
:= Etype
(Exp
);
8257 -- If either operand is of a private type, then we have the use of an
8258 -- intrinsic operator, and we get rid of the privateness, by using root
8259 -- types of underlying types for the actual operation. Otherwise the
8260 -- private types will cause trouble if we expand multiplications or
8261 -- shifts etc. We also do this transformation if the result type is
8262 -- different from the base type.
8264 if Is_Private_Type
(Etype
(Base
))
8265 or else Is_Private_Type
(Typ
)
8266 or else Is_Private_Type
(Exptyp
)
8267 or else Rtyp
/= Root_Type
(Bastyp
)
8270 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
8271 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
8274 Unchecked_Convert_To
(Typ
,
8276 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
8277 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
8278 Analyze_And_Resolve
(N
, Typ
);
8283 -- Check for MINIMIZED/ELIMINATED overflow mode
8285 if Minimized_Eliminated_Overflow_Check
(N
) then
8286 Apply_Arithmetic_Overflow_Check
(N
);
8290 -- Test for case of known right argument where we can replace the
8291 -- exponentiation by an equivalent expression using multiplication.
8293 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8294 -- configurable run-time mode, we may not have the exponentiation
8295 -- routine available, and we don't want the legality of the program
8296 -- to depend on how clever the compiler is in knowing values.
8298 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
8299 Expv
:= Expr_Value
(Exp
);
8301 -- We only fold small non-negative exponents. You might think we
8302 -- could fold small negative exponents for the real case, but we
8303 -- can't because we are required to raise Constraint_Error for
8304 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8305 -- See ACVC test C4A012B, and it is not worth generating the test.
8307 -- For small negative exponents, we return the reciprocal of
8308 -- the folding of the exponentiation for the opposite (positive)
8309 -- exponent, as required by Ada RM 4.5.6(11/3).
8311 if abs Expv
<= 4 then
8313 -- X ** 0 = 1 (or 1.0)
8317 -- Call Remove_Side_Effects to ensure that any side effects
8318 -- in the ignored left operand (in particular function calls
8319 -- to user defined functions) are properly executed.
8321 Remove_Side_Effects
(Base
);
8323 if Ekind
(Typ
) in Integer_Kind
then
8324 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
8326 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
8339 Make_Op_Multiply
(Loc
,
8340 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8341 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8343 -- X ** 3 = X * X * X
8348 Make_Op_Multiply
(Loc
,
8350 Make_Op_Multiply
(Loc
,
8351 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8352 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
8353 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8358 -- En : constant base'type := base * base;
8363 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
8366 Make_Expression_With_Actions
(Loc
,
8367 Actions
=> New_List
(
8368 Make_Object_Declaration
(Loc
,
8369 Defining_Identifier
=> Temp
,
8370 Constant_Present
=> True,
8371 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8374 Make_Op_Multiply
(Loc
,
8376 Duplicate_Subexpr
(Base
),
8378 Duplicate_Subexpr_No_Checks
(Base
))))),
8382 Make_Op_Multiply
(Loc
,
8383 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
8384 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
8386 -- X ** N = 1.0 / X ** (-N)
8391 (Expv
= -1 or Expv
= -2 or Expv
= -3 or Expv
= -4);
8394 Make_Op_Divide
(Loc
,
8396 Make_Float_Literal
(Loc
,
8398 Significand
=> Uint_1
,
8399 Exponent
=> Uint_0
),
8402 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8404 Make_Integer_Literal
(Loc
,
8409 Analyze_And_Resolve
(N
, Typ
);
8414 -- Optimize 2 ** expression to shift where possible
8416 -- Note: we used to check that Exptyp was an unsigned type. But that is
8417 -- an unnecessary check, since if Exp is negative, we have a run-time
8418 -- error that is either caught (so we get the right result) or we have
8419 -- suppressed the check, in which case the code is erroneous anyway.
8421 if Is_Integer_Type
(Rtyp
)
8423 -- The base value must be "safe compile-time known", and exactly 2
8425 and then Nkind
(Base
) = N_Integer_Literal
8426 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
8427 and then Expr_Value
(Base
) = Uint_2
8429 -- This transformation is not applicable for a modular type with a
8430 -- nonbinary modulus because shifting makes no sense in that case.
8432 and then not Non_Binary_Modulus
(Typ
)
8434 -- Handle the cases where our parent is a division or multiplication
8435 -- specially. In these cases we can convert to using a shift at the
8436 -- parent level if we are not doing overflow checking, since it is
8437 -- too tricky to combine the overflow check at the parent level.
8440 and then Nkind
(Parent
(N
)) in N_Op_Divide | N_Op_Multiply
8443 P
: constant Node_Id
:= Parent
(N
);
8444 L
: constant Node_Id
:= Left_Opnd
(P
);
8445 R
: constant Node_Id
:= Right_Opnd
(P
);
8448 if (Nkind
(P
) = N_Op_Multiply
8450 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
8452 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
8453 and then not Do_Overflow_Check
(P
))
8456 (Nkind
(P
) = N_Op_Divide
8457 and then Is_Integer_Type
(Etype
(L
))
8458 and then Is_Unsigned_Type
(Etype
(L
))
8460 and then not Do_Overflow_Check
(P
))
8462 Set_Is_Power_Of_2_For_Shift
(N
);
8467 -- Here we have 2 ** N on its own, so we can convert this into a
8471 -- Op_Shift_Left (generated below) has modular-shift semantics;
8472 -- therefore we might need to generate an overflow check here
8473 -- if the type is signed.
8475 if Is_Signed_Integer_Type
(Typ
) and then Ovflo
then
8481 MaxS
: constant Uint
:= Esize
(Rtyp
) - 2;
8482 -- Maximum shift count with no overflow
8484 Determine_Range
(Exp
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8486 if not OK
or else Hi
> MaxS
then
8488 Make_Raise_Constraint_Error
(Loc
,
8491 Left_Opnd
=> Duplicate_Subexpr
(Exp
),
8492 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
8493 Reason
=> CE_Overflow_Check_Failed
));
8498 -- Generate Shift_Left (1, Exp)
8501 Make_Op_Shift_Left
(Loc
,
8502 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8503 Right_Opnd
=> Exp
));
8505 Analyze_And_Resolve
(N
, Typ
);
8510 -- Fall through if exponentiation must be done using a runtime routine
8512 -- First deal with modular case
8514 if Is_Modular_Integer_Type
(Rtyp
) then
8516 -- Nonbinary modular case, we call the special exponentiation
8517 -- routine for the nonbinary case, converting the argument to
8518 -- Long_Long_Integer and passing the modulus value. Then the
8519 -- result is converted back to the base type.
8521 if Non_Binary_Modulus
(Rtyp
) then
8524 Make_Function_Call
(Loc
,
8526 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
8527 Parameter_Associations
=> New_List
(
8528 Convert_To
(RTE
(RE_Unsigned
), Base
),
8529 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
8532 -- Binary modular case, in this case, we call one of three routines,
8533 -- either the unsigned integer case, or the unsigned long long
8534 -- integer case, or the unsigned long long long integer case, with a
8535 -- final "and" operation to do the required mod.
8538 if Esize
(Rtyp
) <= Standard_Integer_Size
then
8539 Ent
:= RTE
(RE_Exp_Unsigned
);
8540 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
8541 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
8543 Ent
:= RTE
(RE_Exp_Long_Long_Long_Unsigned
);
8550 Make_Function_Call
(Loc
,
8551 Name
=> New_Occurrence_Of
(Ent
, Loc
),
8552 Parameter_Associations
=> New_List
(
8553 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
8556 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
8560 -- Common exit point for modular type case
8562 Analyze_And_Resolve
(N
, Typ
);
8565 -- Signed integer cases, using either Integer, Long_Long_Integer or
8566 -- Long_Long_Long_Integer. It is not worth also having routines for
8567 -- Short_[Short_]Integer, since for most machines it would not help,
8568 -- and it would generate more code that might need certification when
8569 -- a certified run time is required.
8571 -- In the integer cases, we have two routines, one for when overflow
8572 -- checks are required, and one when they are not required, since there
8573 -- is a real gain in omitting checks on many machines.
8575 elsif Is_Signed_Integer_Type
(Rtyp
) then
8576 if Esize
(Rtyp
) <= Standard_Integer_Size
then
8577 Etyp
:= Standard_Integer
;
8580 Rent
:= RE_Exp_Integer
;
8582 Rent
:= RE_Exn_Integer
;
8585 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
8586 Etyp
:= Standard_Long_Long_Integer
;
8589 Rent
:= RE_Exp_Long_Long_Integer
;
8591 Rent
:= RE_Exn_Long_Long_Integer
;
8595 Etyp
:= Standard_Long_Long_Long_Integer
;
8598 Rent
:= RE_Exp_Long_Long_Long_Integer
;
8600 Rent
:= RE_Exn_Long_Long_Long_Integer
;
8604 -- Floating-point cases. We do not need separate routines for the
8605 -- overflow case here, since in the case of floating-point, we generate
8606 -- infinities anyway as a rule (either that or we automatically trap
8607 -- overflow), and if there is an infinity generated and a range check
8608 -- is required, the check will fail anyway.
8611 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
8613 -- Short_Float and Float are the same type for GNAT
8615 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
8616 Etyp
:= Standard_Float
;
8617 Rent
:= RE_Exn_Float
;
8619 elsif Rtyp
= Standard_Long_Float
then
8620 Etyp
:= Standard_Long_Float
;
8621 Rent
:= RE_Exn_Long_Float
;
8624 Etyp
:= Standard_Long_Long_Float
;
8625 Rent
:= RE_Exn_Long_Long_Float
;
8629 -- Common processing for integer cases and floating-point cases.
8630 -- If we are in the right type, we can call runtime routine directly
8633 and then not Is_Universal_Numeric_Type
(Rtyp
)
8637 Make_Function_Call
(Loc
,
8638 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8639 Parameter_Associations
=> New_List
(Base
, Exp
))));
8641 -- Otherwise we have to introduce conversions (conversions are also
8642 -- required in the universal cases, since the runtime routine is
8643 -- typed using one of the standard types).
8648 Make_Function_Call
(Loc
,
8649 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8650 Parameter_Associations
=> New_List
(
8651 Convert_To
(Etyp
, Base
),
8655 Analyze_And_Resolve
(N
, Typ
);
8659 when RE_Not_Available
=>
8661 end Expand_N_Op_Expon
;
8663 --------------------
8664 -- Expand_N_Op_Ge --
8665 --------------------
8667 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
8668 Typ
: constant Entity_Id
:= Etype
(N
);
8669 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8670 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8671 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8674 Binary_Op_Validity_Checks
(N
);
8676 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8677 -- means we no longer have a comparison operation, we are all done.
8679 if Minimized_Eliminated_Overflow_Check
(Op1
) then
8680 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8683 if Nkind
(N
) /= N_Op_Ge
then
8689 if Is_Array_Type
(Typ1
) then
8690 Expand_Array_Comparison
(N
);
8694 -- Deal with boolean operands
8696 if Is_Boolean_Type
(Typ1
) then
8697 Adjust_Condition
(Op1
);
8698 Adjust_Condition
(Op2
);
8699 Set_Etype
(N
, Standard_Boolean
);
8700 Adjust_Result_Type
(N
, Typ
);
8703 Rewrite_Comparison
(N
);
8705 -- Try to narrow the operation
8707 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Ge
then
8708 Narrow_Large_Operation
(N
);
8711 Optimize_Length_Comparison
(N
);
8714 --------------------
8715 -- Expand_N_Op_Gt --
8716 --------------------
8718 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
8719 Typ
: constant Entity_Id
:= Etype
(N
);
8720 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8721 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8722 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8725 Binary_Op_Validity_Checks
(N
);
8727 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8728 -- means we no longer have a comparison operation, we are all done.
8730 if Minimized_Eliminated_Overflow_Check
(Op1
) then
8731 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8734 if Nkind
(N
) /= N_Op_Gt
then
8738 -- Deal with array type operands
8740 if Is_Array_Type
(Typ1
) then
8741 Expand_Array_Comparison
(N
);
8745 -- Deal with boolean type operands
8747 if Is_Boolean_Type
(Typ1
) then
8748 Adjust_Condition
(Op1
);
8749 Adjust_Condition
(Op2
);
8750 Set_Etype
(N
, Standard_Boolean
);
8751 Adjust_Result_Type
(N
, Typ
);
8754 Rewrite_Comparison
(N
);
8756 -- Try to narrow the operation
8758 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Gt
then
8759 Narrow_Large_Operation
(N
);
8762 Optimize_Length_Comparison
(N
);
8765 --------------------
8766 -- Expand_N_Op_Le --
8767 --------------------
8769 procedure Expand_N_Op_Le
(N
: Node_Id
) is
8770 Typ
: constant Entity_Id
:= Etype
(N
);
8771 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8772 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8773 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8776 Binary_Op_Validity_Checks
(N
);
8778 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8779 -- means we no longer have a comparison operation, we are all done.
8781 if Minimized_Eliminated_Overflow_Check
(Op1
) then
8782 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8785 if Nkind
(N
) /= N_Op_Le
then
8789 -- Deal with array type operands
8791 if Is_Array_Type
(Typ1
) then
8792 Expand_Array_Comparison
(N
);
8796 -- Deal with Boolean type operands
8798 if Is_Boolean_Type
(Typ1
) then
8799 Adjust_Condition
(Op1
);
8800 Adjust_Condition
(Op2
);
8801 Set_Etype
(N
, Standard_Boolean
);
8802 Adjust_Result_Type
(N
, Typ
);
8805 Rewrite_Comparison
(N
);
8807 -- Try to narrow the operation
8809 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Le
then
8810 Narrow_Large_Operation
(N
);
8813 Optimize_Length_Comparison
(N
);
8816 --------------------
8817 -- Expand_N_Op_Lt --
8818 --------------------
8820 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
8821 Typ
: constant Entity_Id
:= Etype
(N
);
8822 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8823 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8824 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8827 Binary_Op_Validity_Checks
(N
);
8829 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8830 -- means we no longer have a comparison operation, we are all done.
8832 if Minimized_Eliminated_Overflow_Check
(Op1
) then
8833 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8836 if Nkind
(N
) /= N_Op_Lt
then
8840 -- Deal with array type operands
8842 if Is_Array_Type
(Typ1
) then
8843 Expand_Array_Comparison
(N
);
8847 -- Deal with Boolean type operands
8849 if Is_Boolean_Type
(Typ1
) then
8850 Adjust_Condition
(Op1
);
8851 Adjust_Condition
(Op2
);
8852 Set_Etype
(N
, Standard_Boolean
);
8853 Adjust_Result_Type
(N
, Typ
);
8856 Rewrite_Comparison
(N
);
8858 -- Try to narrow the operation
8860 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Lt
then
8861 Narrow_Large_Operation
(N
);
8864 Optimize_Length_Comparison
(N
);
8867 -----------------------
8868 -- Expand_N_Op_Minus --
8869 -----------------------
8871 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
8872 Loc
: constant Source_Ptr
:= Sloc
(N
);
8873 Typ
: constant Entity_Id
:= Etype
(N
);
8876 Unary_Op_Validity_Checks
(N
);
8878 -- Check for MINIMIZED/ELIMINATED overflow mode
8880 if Minimized_Eliminated_Overflow_Check
(N
) then
8881 Apply_Arithmetic_Overflow_Check
(N
);
8885 -- Try to narrow the operation
8887 if Typ
= Universal_Integer
then
8888 Narrow_Large_Operation
(N
);
8890 if Nkind
(N
) /= N_Op_Minus
then
8895 if not Backend_Overflow_Checks_On_Target
8896 and then Is_Signed_Integer_Type
(Typ
)
8897 and then Do_Overflow_Check
(N
)
8899 -- Software overflow checking expands -expr into (0 - expr)
8902 Make_Op_Subtract
(Loc
,
8903 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
8904 Right_Opnd
=> Right_Opnd
(N
)));
8906 Analyze_And_Resolve
(N
, Typ
);
8909 Expand_Nonbinary_Modular_Op
(N
);
8910 end Expand_N_Op_Minus
;
8912 ---------------------
8913 -- Expand_N_Op_Mod --
8914 ---------------------
8916 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
8917 Loc
: constant Source_Ptr
:= Sloc
(N
);
8918 Typ
: constant Entity_Id
:= Etype
(N
);
8919 DDC
: constant Boolean := Do_Division_Check
(N
);
8921 Is_Stoele_Mod
: constant Boolean :=
8922 Is_RTE
(Typ
, RE_Address
)
8923 and then Nkind
(Right_Opnd
(N
)) = N_Unchecked_Type_Conversion
8925 Is_RTE
(Etype
(Expression
(Right_Opnd
(N
))), RE_Storage_Offset
);
8926 -- True if this is the special mod operator of System.Storage_Elements
8939 pragma Warnings
(Off
, Lhi
);
8942 Binary_Op_Validity_Checks
(N
);
8944 -- Check for MINIMIZED/ELIMINATED overflow mode
8946 if Minimized_Eliminated_Overflow_Check
(N
) then
8947 Apply_Arithmetic_Overflow_Check
(N
);
8951 -- Try to narrow the operation
8953 if Typ
= Universal_Integer
then
8954 Narrow_Large_Operation
(N
);
8956 if Nkind
(N
) /= N_Op_Mod
then
8961 -- For the special mod operator of System.Storage_Elements, the checks
8962 -- are subsumed into the handling of the negative case below.
8964 if Is_Integer_Type
(Typ
) and then not Is_Stoele_Mod
then
8965 Apply_Divide_Checks
(N
);
8967 -- All done if we don't have a MOD any more, which can happen as a
8968 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8970 if Nkind
(N
) /= N_Op_Mod
then
8975 -- Proceed with expansion of mod operator
8977 Left
:= Left_Opnd
(N
);
8978 Right
:= Right_Opnd
(N
);
8980 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
8981 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
8983 -- Convert mod to rem if operands are both known to be non-negative, or
8984 -- both known to be non-positive (these are the cases in which rem and
8985 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8986 -- likely that this will improve the quality of code, (the operation now
8987 -- corresponds to the hardware remainder), and it does not seem likely
8988 -- that it could be harmful. It also avoids some cases of the elaborate
8989 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8992 and then ((Llo
>= 0 and then Rlo
>= 0)
8994 (Lhi
<= 0 and then Rhi
<= 0))
8995 and then not Is_Stoele_Mod
8998 Make_Op_Rem
(Sloc
(N
),
8999 Left_Opnd
=> Left_Opnd
(N
),
9000 Right_Opnd
=> Right_Opnd
(N
)));
9002 -- Instead of reanalyzing the node we do the analysis manually. This
9003 -- avoids anomalies when the replacement is done in an instance and
9004 -- is epsilon more efficient.
9006 pragma Assert
(Entity
(N
) = Standard_Op_Rem
);
9008 Set_Do_Division_Check
(N
, DDC
);
9009 Expand_N_Op_Rem
(N
);
9013 -- Otherwise, normal mod processing
9016 -- Apply optimization x mod 1 = 0. We don't really need that with
9017 -- gcc, but it is useful with other back ends and is certainly
9020 if Is_Integer_Type
(Etype
(N
))
9021 and then Compile_Time_Known_Value
(Right
)
9022 and then Expr_Value
(Right
) = Uint_1
9024 -- Call Remove_Side_Effects to ensure that any side effects in
9025 -- the ignored left operand (in particular function calls to
9026 -- user defined functions) are properly executed.
9028 Remove_Side_Effects
(Left
);
9030 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9031 Analyze_And_Resolve
(N
, Typ
);
9035 -- The negative case makes no sense since it is a case of a mod where
9036 -- the left argument is unsigned and the right argument is signed. In
9037 -- accordance with the (spirit of the) permission of RM 13.7.1(16),
9038 -- we raise CE, and also include the zero case here. Yes, the RM says
9039 -- PE, but this really is so obviously more like a constraint error.
9041 if Is_Stoele_Mod
and then (not ROK
or else Rlo
<= 0) then
9043 Make_Raise_Constraint_Error
(Loc
,
9047 Duplicate_Subexpr_No_Checks
(Expression
(Right
)),
9048 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9049 Reason
=> CE_Overflow_Check_Failed
));
9053 -- If we still have a mod operator and we are in Modify_Tree_For_C
9054 -- mode, and we have a signed integer type, then here is where we do
9055 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9056 -- for the special handling of the annoying case of largest negative
9057 -- number mod minus one.
9059 if Nkind
(N
) = N_Op_Mod
9060 and then Is_Signed_Integer_Type
(Typ
)
9061 and then Modify_Tree_For_C
9063 -- In the general case, we expand A mod B as
9065 -- Tnn : constant typ := A rem B;
9067 -- (if (A >= 0) = (B >= 0) then Tnn
9068 -- elsif Tnn = 0 then 0
9071 -- The comparison can be written simply as A >= 0 if we know that
9072 -- B >= 0 which is a very common case.
9074 -- An important optimization is when B is known at compile time
9075 -- to be 2**K for some constant. In this case we can simply AND
9076 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9077 -- and that works for both the positive and negative cases.
9080 P2
: constant Nat
:= Power_Of_Two
(Right
);
9085 Unchecked_Convert_To
(Typ
,
9088 Unchecked_Convert_To
9089 (Corresponding_Unsigned_Type
(Typ
), Left
),
9091 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
9092 Analyze_And_Resolve
(N
, Typ
);
9097 -- Here for the full rewrite
9100 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
9106 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9107 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
9109 if not LOK
or else Rlo
< 0 then
9115 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
9116 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
9120 Make_Object_Declaration
(Loc
,
9121 Defining_Identifier
=> Tnn
,
9122 Constant_Present
=> True,
9123 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9127 Right_Opnd
=> Right
)));
9130 Make_If_Expression
(Loc
,
9131 Expressions
=> New_List
(
9133 New_Occurrence_Of
(Tnn
, Loc
),
9134 Make_If_Expression
(Loc
,
9136 Expressions
=> New_List
(
9138 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9139 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9140 Make_Integer_Literal
(Loc
, 0),
9142 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9144 Duplicate_Subexpr_No_Checks
(Right
)))))));
9146 Analyze_And_Resolve
(N
, Typ
);
9151 -- Deal with annoying case of largest negative number mod minus one.
9152 -- Gigi may not handle this case correctly, because on some targets,
9153 -- the mod value is computed using a divide instruction which gives
9154 -- an overflow trap for this case.
9156 -- It would be a bit more efficient to figure out which targets
9157 -- this is really needed for, but in practice it is reasonable
9158 -- to do the following special check in all cases, since it means
9159 -- we get a clearer message, and also the overhead is minimal given
9160 -- that division is expensive in any case.
9162 -- In fact the check is quite easy, if the right operand is -1, then
9163 -- the mod value is always 0, and we can just ignore the left operand
9164 -- completely in this case.
9166 -- This only applies if we still have a mod operator. Skip if we
9167 -- have already rewritten this (e.g. in the case of eliminated
9168 -- overflow checks which have driven us into bignum mode).
9170 if Nkind
(N
) = N_Op_Mod
then
9172 -- The operand type may be private (e.g. in the expansion of an
9173 -- intrinsic operation) so we must use the underlying type to get
9174 -- the bounds, and convert the literals explicitly.
9178 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
9180 if (not ROK
or else (Rlo
<= (-1) and then (-1) <= Rhi
))
9181 and then (not LOK
or else Llo
= LLB
)
9182 and then not CodePeer_Mode
9185 Make_If_Expression
(Loc
,
9186 Expressions
=> New_List
(
9188 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9190 Unchecked_Convert_To
(Typ
,
9191 Make_Integer_Literal
(Loc
, -1))),
9192 Unchecked_Convert_To
(Typ
,
9193 Make_Integer_Literal
(Loc
, Uint_0
)),
9194 Relocate_Node
(N
))));
9196 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9197 Analyze_And_Resolve
(N
, Typ
);
9201 end Expand_N_Op_Mod
;
9203 --------------------------
9204 -- Expand_N_Op_Multiply --
9205 --------------------------
9207 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
9208 Loc
: constant Source_Ptr
:= Sloc
(N
);
9209 Lop
: constant Node_Id
:= Left_Opnd
(N
);
9210 Rop
: constant Node_Id
:= Right_Opnd
(N
);
9212 Lp2
: constant Boolean :=
9213 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
9214 Rp2
: constant Boolean :=
9215 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
9217 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
9218 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
9219 Typ
: Entity_Id
:= Etype
(N
);
9222 Binary_Op_Validity_Checks
(N
);
9224 -- Check for MINIMIZED/ELIMINATED overflow mode
9226 if Minimized_Eliminated_Overflow_Check
(N
) then
9227 Apply_Arithmetic_Overflow_Check
(N
);
9231 -- Special optimizations for integer types
9233 if Is_Integer_Type
(Typ
) then
9235 -- N * 0 = 0 for integer types
9237 if Compile_Time_Known_Value
(Rop
)
9238 and then Expr_Value
(Rop
) = Uint_0
9240 -- Call Remove_Side_Effects to ensure that any side effects in
9241 -- the ignored left operand (in particular function calls to
9242 -- user defined functions) are properly executed.
9244 Remove_Side_Effects
(Lop
);
9246 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9247 Analyze_And_Resolve
(N
, Typ
);
9251 -- Similar handling for 0 * N = 0
9253 if Compile_Time_Known_Value
(Lop
)
9254 and then Expr_Value
(Lop
) = Uint_0
9256 Remove_Side_Effects
(Rop
);
9257 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9258 Analyze_And_Resolve
(N
, Typ
);
9262 -- N * 1 = 1 * N = N for integer types
9264 -- This optimisation is not done if we are going to
9265 -- rewrite the product 1 * 2 ** N to a shift.
9267 if Compile_Time_Known_Value
(Rop
)
9268 and then Expr_Value
(Rop
) = Uint_1
9274 elsif Compile_Time_Known_Value
(Lop
)
9275 and then Expr_Value
(Lop
) = Uint_1
9283 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9284 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9285 -- operand is an integer, as required for this to work.
9290 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9294 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
9297 Left_Opnd
=> Right_Opnd
(Lop
),
9298 Right_Opnd
=> Right_Opnd
(Rop
))));
9299 Analyze_And_Resolve
(N
, Typ
);
9303 -- If the result is modular, perform the reduction of the result
9306 if Is_Modular_Integer_Type
(Typ
)
9307 and then not Non_Binary_Modulus
(Typ
)
9312 Make_Op_Shift_Left
(Loc
,
9315 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
9317 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9321 Make_Op_Shift_Left
(Loc
,
9324 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
9327 Analyze_And_Resolve
(N
, Typ
);
9331 -- Same processing for the operands the other way round
9334 if Is_Modular_Integer_Type
(Typ
)
9335 and then not Non_Binary_Modulus
(Typ
)
9340 Make_Op_Shift_Left
(Loc
,
9343 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
9345 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9349 Make_Op_Shift_Left
(Loc
,
9352 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
9355 Analyze_And_Resolve
(N
, Typ
);
9359 -- Try to narrow the operation
9361 if Typ
= Universal_Integer
then
9362 Narrow_Large_Operation
(N
);
9364 if Nkind
(N
) /= N_Op_Multiply
then
9369 -- Do required fixup of universal fixed operation
9371 if Typ
= Universal_Fixed
then
9372 Fixup_Universal_Fixed_Operation
(N
);
9376 -- Multiplications with fixed-point results
9378 if Is_Fixed_Point_Type
(Typ
) then
9380 -- Case of fixed * integer => fixed
9382 if Is_Integer_Type
(Rtyp
) then
9383 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
9385 -- Case of integer * fixed => fixed
9387 elsif Is_Integer_Type
(Ltyp
) then
9388 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
9390 -- Case of fixed * fixed => fixed
9393 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
9396 -- Other cases of multiplication of fixed-point operands
9398 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
9399 if Is_Integer_Type
(Typ
) then
9400 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
9402 pragma Assert
(Is_Floating_Point_Type
(Typ
));
9403 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
9406 -- Mixed-mode operations can appear in a non-static universal context,
9407 -- in which case the integer argument must be converted explicitly.
9409 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
9410 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
9411 Analyze_And_Resolve
(Rop
, Universal_Real
);
9413 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
9414 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
9415 Analyze_And_Resolve
(Lop
, Universal_Real
);
9417 -- Non-fixed point cases, check software overflow checking required
9419 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
9420 Apply_Arithmetic_Overflow_Check
(N
);
9423 -- Overflow checks for floating-point if -gnateF mode active
9425 Check_Float_Op_Overflow
(N
);
9427 Expand_Nonbinary_Modular_Op
(N
);
9428 end Expand_N_Op_Multiply
;
9430 --------------------
9431 -- Expand_N_Op_Ne --
9432 --------------------
9434 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
9435 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
9438 -- Case of elementary type with standard operator. But if unnesting,
9439 -- handle elementary types whose Equivalent_Types are records because
9440 -- there may be padding or undefined fields.
9442 if Is_Elementary_Type
(Typ
)
9443 and then Sloc
(Entity
(N
)) = Standard_Location
9444 and then not (Ekind
(Typ
) in E_Class_Wide_Type
9445 | E_Class_Wide_Subtype
9446 | E_Access_Subprogram_Type
9447 | E_Access_Protected_Subprogram_Type
9448 | E_Anonymous_Access_Protected_Subprogram_Type
9450 and then Present
(Equivalent_Type
(Typ
))
9451 and then Is_Record_Type
(Equivalent_Type
(Typ
)))
9453 Binary_Op_Validity_Checks
(N
);
9455 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9456 -- means we no longer have a /= operation, we are all done.
9458 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
)) then
9459 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9462 if Nkind
(N
) /= N_Op_Ne
then
9466 -- Boolean types (requiring handling of non-standard case)
9468 if Is_Boolean_Type
(Typ
) then
9469 Adjust_Condition
(Left_Opnd
(N
));
9470 Adjust_Condition
(Right_Opnd
(N
));
9471 Set_Etype
(N
, Standard_Boolean
);
9472 Adjust_Result_Type
(N
, Typ
);
9475 Rewrite_Comparison
(N
);
9477 -- Try to narrow the operation
9479 if Typ
= Universal_Integer
and then Nkind
(N
) = N_Op_Ne
then
9480 Narrow_Large_Operation
(N
);
9483 -- For all cases other than elementary types, we rewrite node as the
9484 -- negation of an equality operation, and reanalyze. The equality to be
9485 -- used is defined in the same scope and has the same signature. This
9486 -- signature must be set explicitly since in an instance it may not have
9487 -- the same visibility as in the generic unit. This avoids duplicating
9488 -- or factoring the complex code for record/array equality tests etc.
9490 -- This case is also used for the minimal expansion performed in
9495 Loc
: constant Source_Ptr
:= Sloc
(N
);
9497 Ne
: constant Entity_Id
:= Entity
(N
);
9500 Binary_Op_Validity_Checks
(N
);
9506 Left_Opnd
=> Left_Opnd
(N
),
9507 Right_Opnd
=> Right_Opnd
(N
)));
9509 if Scope
(Ne
) /= Standard_Standard
then
9510 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
9513 -- For navigation purposes, we want to treat the inequality as an
9514 -- implicit reference to the corresponding equality. Preserve the
9515 -- Comes_From_ source flag to generate proper Xref entries.
9517 Preserve_Comes_From_Source
(Neg
, N
);
9518 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
9520 Analyze_And_Resolve
(N
, Standard_Boolean
);
9524 -- No need for optimization in GNATprove mode, where we would rather see
9525 -- the original source expression.
9527 if not GNATprove_Mode
then
9528 Optimize_Length_Comparison
(N
);
9532 ---------------------
9533 -- Expand_N_Op_Not --
9534 ---------------------
9536 -- If the argument is other than a Boolean array type, there is no special
9537 -- expansion required, except for dealing with validity checks, and non-
9538 -- standard boolean representations.
9540 -- For the packed array case, we call the special routine in Exp_Pakd,
9541 -- except that if the component size is greater than one, we use the
9542 -- standard routine generating a gruesome loop (it is so peculiar to have
9543 -- packed arrays with non-standard Boolean representations anyway, so it
9544 -- does not matter that we do not handle this case efficiently).
9546 -- For the unpacked array case (and for the special packed case where we
9547 -- have non standard Booleans, as discussed above), we generate and insert
9548 -- into the tree the following function definition:
9550 -- function Nnnn (A : arr) is
9553 -- for J in a'range loop
9554 -- B (J) := not A (J);
9559 -- or in the case of Transform_Function_Array:
9561 -- procedure Nnnn (A : arr; RESULT : out arr) is
9563 -- for J in a'range loop
9564 -- RESULT (J) := not A (J);
9568 -- Here arr is the actual subtype of the parameter (and hence always
9569 -- constrained). Then we replace the not with a call to this subprogram.
9571 procedure Expand_N_Op_Not
(N
: Node_Id
) is
9572 Loc
: constant Source_Ptr
:= Sloc
(N
);
9573 Typ
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9582 Func_Name
: Entity_Id
;
9583 Loop_Statement
: Node_Id
;
9586 Unary_Op_Validity_Checks
(N
);
9588 -- For boolean operand, deal with non-standard booleans
9590 if Is_Boolean_Type
(Typ
) then
9591 Adjust_Condition
(Right_Opnd
(N
));
9592 Set_Etype
(N
, Standard_Boolean
);
9593 Adjust_Result_Type
(N
, Typ
);
9597 -- Only array types need any other processing
9599 if not Is_Array_Type
(Typ
) then
9603 -- Case of array operand. If bit packed with a component size of 1,
9604 -- handle it in Exp_Pakd if the operand is known to be aligned.
9606 if Is_Bit_Packed_Array
(Typ
)
9607 and then Component_Size
(Typ
) = 1
9608 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
9610 Expand_Packed_Not
(N
);
9614 -- Case of array operand which is not bit-packed. If the context is
9615 -- a safe assignment, call in-place operation, If context is a larger
9616 -- boolean expression in the context of a safe assignment, expansion is
9617 -- done by enclosing operation.
9619 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
9620 Convert_To_Actual_Subtype
(Opnd
);
9621 Arr
:= Etype
(Opnd
);
9622 Ensure_Defined
(Arr
, N
);
9623 Silly_Boolean_Array_Not_Test
(N
, Arr
);
9625 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9626 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
9627 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9630 -- Special case the negation of a binary operation
9632 elsif Nkind
(Opnd
) in N_Op_And | N_Op_Or | N_Op_Xor
9633 and then Safe_In_Place_Array_Op
9634 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
9636 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9640 elsif Nkind
(Parent
(N
)) in N_Binary_Op
9641 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9644 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
9645 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
9646 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
9649 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
9651 -- (not A) op (not B) can be reduced to a single call
9653 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
9656 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
9659 -- A xor (not B) can also be special-cased
9661 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
9668 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
9670 if Transform_Function_Array
then
9671 B
:= Make_Defining_Identifier
(Loc
, Name_UP_RESULT
);
9673 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
9676 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
9679 Make_Indexed_Component
(Loc
,
9680 Prefix
=> New_Occurrence_Of
(A
, Loc
),
9681 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9684 Make_Indexed_Component
(Loc
,
9685 Prefix
=> New_Occurrence_Of
(B
, Loc
),
9686 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9689 Make_Implicit_Loop_Statement
(N
,
9690 Identifier
=> Empty
,
9693 Make_Iteration_Scheme
(Loc
,
9694 Loop_Parameter_Specification
=>
9695 Make_Loop_Parameter_Specification
(Loc
,
9696 Defining_Identifier
=> J
,
9697 Discrete_Subtype_Definition
=>
9698 Make_Attribute_Reference
(Loc
,
9699 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
9700 Attribute_Name
=> Name_Range
))),
9702 Statements
=> New_List
(
9703 Make_Assignment_Statement
(Loc
,
9705 Expression
=> Make_Op_Not
(Loc
, A_J
))));
9707 Func_Name
:= Make_Temporary
(Loc
, 'N');
9708 Set_Is_Inlined
(Func_Name
);
9710 if Transform_Function_Array
then
9712 Make_Subprogram_Body
(Loc
,
9714 Make_Procedure_Specification
(Loc
,
9715 Defining_Unit_Name
=> Func_Name
,
9716 Parameter_Specifications
=> New_List
(
9717 Make_Parameter_Specification
(Loc
,
9718 Defining_Identifier
=> A
,
9719 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
9720 Make_Parameter_Specification
(Loc
,
9721 Defining_Identifier
=> B
,
9722 Out_Present
=> True,
9723 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
9725 Declarations
=> New_List
,
9727 Handled_Statement_Sequence
=>
9728 Make_Handled_Sequence_Of_Statements
(Loc
,
9729 Statements
=> New_List
(Loop_Statement
))));
9732 Temp_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
9741 Make_Object_Declaration
(Loc
,
9742 Defining_Identifier
=> Temp_Id
,
9743 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
9746 -- Proc_Call (Opnd, Temp);
9749 Make_Procedure_Call_Statement
(Loc
,
9750 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
9751 Parameter_Associations
=>
9752 New_List
(Opnd
, New_Occurrence_Of
(Temp_Id
, Loc
)));
9754 Insert_Actions
(Parent
(N
), New_List
(Decl
, Call
));
9755 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
9759 Make_Subprogram_Body
(Loc
,
9761 Make_Function_Specification
(Loc
,
9762 Defining_Unit_Name
=> Func_Name
,
9763 Parameter_Specifications
=> New_List
(
9764 Make_Parameter_Specification
(Loc
,
9765 Defining_Identifier
=> A
,
9766 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9767 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9769 Declarations
=> New_List
(
9770 Make_Object_Declaration
(Loc
,
9771 Defining_Identifier
=> B
,
9772 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
9774 Handled_Statement_Sequence
=>
9775 Make_Handled_Sequence_Of_Statements
(Loc
,
9776 Statements
=> New_List
(
9778 Make_Simple_Return_Statement
(Loc
,
9779 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
9782 Make_Function_Call
(Loc
,
9783 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
9784 Parameter_Associations
=> New_List
(Opnd
)));
9787 Analyze_And_Resolve
(N
, Typ
);
9788 end Expand_N_Op_Not
;
9790 --------------------
9791 -- Expand_N_Op_Or --
9792 --------------------
9794 procedure Expand_N_Op_Or
(N
: Node_Id
) is
9795 Typ
: constant Entity_Id
:= Etype
(N
);
9798 Binary_Op_Validity_Checks
(N
);
9800 if Is_Array_Type
(Etype
(N
)) then
9801 Expand_Boolean_Operator
(N
);
9803 elsif Is_Boolean_Type
(Etype
(N
)) then
9804 Adjust_Condition
(Left_Opnd
(N
));
9805 Adjust_Condition
(Right_Opnd
(N
));
9806 Set_Etype
(N
, Standard_Boolean
);
9807 Adjust_Result_Type
(N
, Typ
);
9809 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9810 Expand_Intrinsic_Call
(N
, Entity
(N
));
9813 Expand_Nonbinary_Modular_Op
(N
);
9816 ----------------------
9817 -- Expand_N_Op_Plus --
9818 ----------------------
9820 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
9821 Typ
: constant Entity_Id
:= Etype
(N
);
9824 Unary_Op_Validity_Checks
(N
);
9826 -- Check for MINIMIZED/ELIMINATED overflow mode
9828 if Minimized_Eliminated_Overflow_Check
(N
) then
9829 Apply_Arithmetic_Overflow_Check
(N
);
9833 -- Try to narrow the operation
9835 if Typ
= Universal_Integer
then
9836 Narrow_Large_Operation
(N
);
9838 end Expand_N_Op_Plus
;
9840 ---------------------
9841 -- Expand_N_Op_Rem --
9842 ---------------------
9844 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
9845 Loc
: constant Source_Ptr
:= Sloc
(N
);
9846 Typ
: constant Entity_Id
:= Etype
(N
);
9857 -- Set if corresponding operand can be negative
9860 Binary_Op_Validity_Checks
(N
);
9862 -- Check for MINIMIZED/ELIMINATED overflow mode
9864 if Minimized_Eliminated_Overflow_Check
(N
) then
9865 Apply_Arithmetic_Overflow_Check
(N
);
9869 -- Try to narrow the operation
9871 if Typ
= Universal_Integer
then
9872 Narrow_Large_Operation
(N
);
9874 if Nkind
(N
) /= N_Op_Rem
then
9879 if Is_Integer_Type
(Etype
(N
)) then
9880 Apply_Divide_Checks
(N
);
9882 -- All done if we don't have a REM any more, which can happen as a
9883 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9885 if Nkind
(N
) /= N_Op_Rem
then
9890 -- Proceed with expansion of REM
9892 Left
:= Left_Opnd
(N
);
9893 Right
:= Right_Opnd
(N
);
9895 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9896 -- but it is useful with other back ends, and is certainly harmless.
9898 if Is_Integer_Type
(Etype
(N
))
9899 and then Compile_Time_Known_Value
(Right
)
9900 and then Expr_Value
(Right
) = Uint_1
9902 -- Call Remove_Side_Effects to ensure that any side effects in the
9903 -- ignored left operand (in particular function calls to user defined
9904 -- functions) are properly executed.
9906 Remove_Side_Effects
(Left
);
9908 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9909 Analyze_And_Resolve
(N
, Typ
);
9913 -- Deal with annoying case of largest negative number remainder minus
9914 -- one. Gigi may not handle this case correctly, because on some
9915 -- targets, the mod value is computed using a divide instruction
9916 -- which gives an overflow trap for this case.
9918 -- It would be a bit more efficient to figure out which targets this
9919 -- is really needed for, but in practice it is reasonable to do the
9920 -- following special check in all cases, since it means we get a clearer
9921 -- message, and also the overhead is minimal given that division is
9922 -- expensive in any case.
9924 -- In fact the check is quite easy, if the right operand is -1, then
9925 -- the remainder is always 0, and we can just ignore the left operand
9926 -- completely in this case.
9928 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9929 Lneg
:= not OK
or else Lo
< 0;
9931 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9932 Rneg
:= not OK
or else Lo
< 0;
9934 -- We won't mess with trying to find out if the left operand can really
9935 -- be the largest negative number (that's a pain in the case of private
9936 -- types and this is really marginal). We will just assume that we need
9937 -- the test if the left operand can be negative at all.
9940 and then not CodePeer_Mode
9943 Make_If_Expression
(Loc
,
9944 Expressions
=> New_List
(
9946 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9948 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
9950 Unchecked_Convert_To
(Typ
,
9951 Make_Integer_Literal
(Loc
, Uint_0
)),
9953 Relocate_Node
(N
))));
9955 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9956 Analyze_And_Resolve
(N
, Typ
);
9958 end Expand_N_Op_Rem
;
9960 -----------------------------
9961 -- Expand_N_Op_Rotate_Left --
9962 -----------------------------
9964 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
9966 Binary_Op_Validity_Checks
(N
);
9968 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9969 -- so we rewrite in terms of logical shifts
9971 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9973 -- where Bits is the shift count mod Esize (the mod operation here
9974 -- deals with ludicrous large shift counts, which are apparently OK).
9976 if Modify_Tree_For_C
then
9978 Loc
: constant Source_Ptr
:= Sloc
(N
);
9979 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9980 Typ
: constant Entity_Id
:= Etype
(N
);
9983 -- Sem_Intr should prevent getting there with a non binary modulus
9985 pragma Assert
(not Non_Binary_Modulus
(Typ
));
9987 Rewrite
(Right_Opnd
(N
),
9989 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9990 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9992 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9997 Make_Op_Shift_Left
(Loc
,
9998 Left_Opnd
=> Left_Opnd
(N
),
9999 Right_Opnd
=> Right_Opnd
(N
)),
10002 Make_Op_Shift_Right
(Loc
,
10003 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10005 Make_Op_Subtract
(Loc
,
10006 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10008 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10010 Analyze_And_Resolve
(N
, Typ
);
10013 end Expand_N_Op_Rotate_Left
;
10015 ------------------------------
10016 -- Expand_N_Op_Rotate_Right --
10017 ------------------------------
10019 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
10021 Binary_Op_Validity_Checks
(N
);
10023 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10024 -- so we rewrite in terms of logical shifts
10026 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10028 -- where Bits is the shift count mod Esize (the mod operation here
10029 -- deals with ludicrous large shift counts, which are apparently OK).
10031 if Modify_Tree_For_C
then
10033 Loc
: constant Source_Ptr
:= Sloc
(N
);
10034 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10035 Typ
: constant Entity_Id
:= Etype
(N
);
10038 -- Sem_Intr should prevent getting there with a non binary modulus
10040 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10042 Rewrite
(Right_Opnd
(N
),
10044 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10045 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10047 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10052 Make_Op_Shift_Right
(Loc
,
10053 Left_Opnd
=> Left_Opnd
(N
),
10054 Right_Opnd
=> Right_Opnd
(N
)),
10057 Make_Op_Shift_Left
(Loc
,
10058 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10060 Make_Op_Subtract
(Loc
,
10061 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10063 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10065 Analyze_And_Resolve
(N
, Typ
);
10068 end Expand_N_Op_Rotate_Right
;
10070 ----------------------------
10071 -- Expand_N_Op_Shift_Left --
10072 ----------------------------
10074 -- Note: nothing in this routine depends on left as opposed to right shifts
10075 -- so we share the routine for expanding shift right operations.
10077 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
10079 Binary_Op_Validity_Checks
(N
);
10081 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10082 -- operand is not greater than the word size (since that would not
10083 -- be defined properly by the corresponding C shift operator).
10085 if Modify_Tree_For_C
then
10087 Right
: constant Node_Id
:= Right_Opnd
(N
);
10088 Loc
: constant Source_Ptr
:= Sloc
(Right
);
10089 Typ
: constant Entity_Id
:= Etype
(N
);
10090 Siz
: constant Uint
:= Esize
(Typ
);
10097 -- Sem_Intr should prevent getting there with a non binary modulus
10099 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10101 if Compile_Time_Known_Value
(Right
) then
10102 if Expr_Value
(Right
) >= Siz
then
10103 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10104 Analyze_And_Resolve
(N
, Typ
);
10107 -- Not compile time known, find range
10110 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10112 -- Nothing to do if known to be OK range, otherwise expand
10114 if not OK
or else Hi
>= Siz
then
10116 -- Prevent recursion on copy of shift node
10118 Orig
:= Relocate_Node
(N
);
10119 Set_Analyzed
(Orig
);
10121 -- Now do the rewrite
10124 Make_If_Expression
(Loc
,
10125 Expressions
=> New_List
(
10127 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
10128 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
10129 Make_Integer_Literal
(Loc
, 0),
10131 Analyze_And_Resolve
(N
, Typ
);
10136 end Expand_N_Op_Shift_Left
;
10138 -----------------------------
10139 -- Expand_N_Op_Shift_Right --
10140 -----------------------------
10142 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
10144 -- Share shift left circuit
10146 Expand_N_Op_Shift_Left
(N
);
10147 end Expand_N_Op_Shift_Right
;
10149 ----------------------------------------
10150 -- Expand_N_Op_Shift_Right_Arithmetic --
10151 ----------------------------------------
10153 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
10155 Binary_Op_Validity_Checks
(N
);
10157 -- If we are in Modify_Tree_For_C mode, there is no shift right
10158 -- arithmetic in C, so we rewrite in terms of logical shifts for
10159 -- modular integers, and keep the Shift_Right intrinsic for signed
10160 -- integers: even though doing a shift on a signed integer is not
10161 -- fully guaranteed by the C standard, this is what C compilers
10162 -- implement in practice.
10163 -- Consider also taking advantage of this for modular integers by first
10164 -- performing an unchecked conversion of the modular integer to a signed
10165 -- integer of the same sign, and then convert back.
10167 -- Shift_Right (Num, Bits) or
10169 -- then not (Shift_Right (Mask, bits))
10172 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10174 -- Note: the above works fine for shift counts greater than or equal
10175 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10176 -- generates all 1'bits.
10178 if Modify_Tree_For_C
and then Is_Modular_Integer_Type
(Etype
(N
)) then
10180 Loc
: constant Source_Ptr
:= Sloc
(N
);
10181 Typ
: constant Entity_Id
:= Etype
(N
);
10182 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
10183 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
10184 Left
: constant Node_Id
:= Left_Opnd
(N
);
10185 Right
: constant Node_Id
:= Right_Opnd
(N
);
10189 -- Sem_Intr should prevent getting there with a non binary modulus
10191 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10193 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10194 -- compile time as a single constant.
10196 if Compile_Time_Known_Value
(Right
) then
10198 Val
: constant Uint
:= Expr_Value
(Right
);
10201 if Val
>= Esize
(Typ
) then
10202 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
10206 Make_Integer_Literal
(Loc
,
10207 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
10215 Make_Op_Shift_Right
(Loc
,
10216 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
10217 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
10220 -- Now do the rewrite
10225 Make_Op_Shift_Right
(Loc
,
10227 Right_Opnd
=> Right
),
10229 Make_If_Expression
(Loc
,
10230 Expressions
=> New_List
(
10232 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
10233 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
10235 Make_Integer_Literal
(Loc
, 0)))));
10236 Analyze_And_Resolve
(N
, Typ
);
10239 end Expand_N_Op_Shift_Right_Arithmetic
;
10241 --------------------------
10242 -- Expand_N_Op_Subtract --
10243 --------------------------
10245 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
10246 Typ
: constant Entity_Id
:= Etype
(N
);
10249 Binary_Op_Validity_Checks
(N
);
10251 -- Check for MINIMIZED/ELIMINATED overflow mode
10253 if Minimized_Eliminated_Overflow_Check
(N
) then
10254 Apply_Arithmetic_Overflow_Check
(N
);
10258 -- Try to narrow the operation
10260 if Typ
= Universal_Integer
then
10261 Narrow_Large_Operation
(N
);
10263 if Nkind
(N
) /= N_Op_Subtract
then
10268 -- N - 0 = N for integer types
10270 if Is_Integer_Type
(Typ
)
10271 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
10272 and then Expr_Value
(Right_Opnd
(N
)) = 0
10274 Rewrite
(N
, Left_Opnd
(N
));
10278 -- Arithmetic overflow checks for signed integer/fixed point types
10280 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
10281 Apply_Arithmetic_Overflow_Check
(N
);
10284 -- Overflow checks for floating-point if -gnateF mode active
10286 Check_Float_Op_Overflow
(N
);
10288 Expand_Nonbinary_Modular_Op
(N
);
10289 end Expand_N_Op_Subtract
;
10291 ---------------------
10292 -- Expand_N_Op_Xor --
10293 ---------------------
10295 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
10296 Typ
: constant Entity_Id
:= Etype
(N
);
10299 Binary_Op_Validity_Checks
(N
);
10301 if Is_Array_Type
(Etype
(N
)) then
10302 Expand_Boolean_Operator
(N
);
10304 elsif Is_Boolean_Type
(Etype
(N
)) then
10305 Adjust_Condition
(Left_Opnd
(N
));
10306 Adjust_Condition
(Right_Opnd
(N
));
10307 Set_Etype
(N
, Standard_Boolean
);
10308 Adjust_Result_Type
(N
, Typ
);
10310 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10311 Expand_Intrinsic_Call
(N
, Entity
(N
));
10314 Expand_Nonbinary_Modular_Op
(N
);
10315 end Expand_N_Op_Xor
;
10317 ----------------------
10318 -- Expand_N_Or_Else --
10319 ----------------------
10321 procedure Expand_N_Or_Else
(N
: Node_Id
)
10322 renames Expand_Short_Circuit_Operator
;
10324 -----------------------------------
10325 -- Expand_N_Qualified_Expression --
10326 -----------------------------------
10328 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
10329 Operand
: constant Node_Id
:= Expression
(N
);
10330 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
10333 -- Do validity check if validity checking operands
10335 if Validity_Checks_On
and Validity_Check_Operands
then
10336 Ensure_Valid
(Operand
);
10339 Freeze_Before
(Operand
, Target_Type
);
10341 -- Apply possible constraint check
10343 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
10345 -- Apply possible predicate check
10347 Apply_Predicate_Check
(Operand
, Target_Type
);
10349 if Do_Range_Check
(Operand
) then
10350 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
10352 end Expand_N_Qualified_Expression
;
10354 ------------------------------------
10355 -- Expand_N_Quantified_Expression --
10356 ------------------------------------
10360 -- for all X in range => Cond
10365 -- for X in range loop
10366 -- if not Cond then
10372 -- Similarly, an existentially quantified expression:
10374 -- for some X in range => Cond
10379 -- for X in range loop
10386 -- In both cases, the iteration may be over a container in which case it is
10387 -- given by an iterator specification, not a loop parameter specification.
10389 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
10390 Actions
: constant List_Id
:= New_List
;
10391 For_All
: constant Boolean := All_Present
(N
);
10392 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
10393 Loc
: constant Source_Ptr
:= Sloc
(N
);
10394 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
10402 -- Ensure that the bound variable as well as the type of Name of the
10403 -- Iter_Spec if present are properly frozen. We must do this before
10404 -- expansion because the expression is about to be converted into a
10405 -- loop, and resulting freeze nodes may end up in the wrong place in the
10408 if Present
(Iter_Spec
) then
10409 Var
:= Defining_Identifier
(Iter_Spec
);
10411 Var
:= Defining_Identifier
(Loop_Spec
);
10415 P
: Node_Id
:= Parent
(N
);
10417 while Nkind
(P
) in N_Subexpr
loop
10421 if Present
(Iter_Spec
) then
10422 Freeze_Before
(P
, Etype
(Name
(Iter_Spec
)));
10425 Freeze_Before
(P
, Etype
(Var
));
10428 -- Create the declaration of the flag which tracks the status of the
10429 -- quantified expression. Generate:
10431 -- Flag : Boolean := (True | False);
10433 Flag
:= Make_Temporary
(Loc
, 'T', N
);
10435 Append_To
(Actions
,
10436 Make_Object_Declaration
(Loc
,
10437 Defining_Identifier
=> Flag
,
10438 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
10440 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
10442 -- Construct the circuitry which tracks the status of the quantified
10443 -- expression. Generate:
10445 -- if [not] Cond then
10446 -- Flag := (False | True);
10450 Cond
:= Relocate_Node
(Condition
(N
));
10453 Cond
:= Make_Op_Not
(Loc
, Cond
);
10456 Stmts
:= New_List
(
10457 Make_Implicit_If_Statement
(N
,
10459 Then_Statements
=> New_List
(
10460 Make_Assignment_Statement
(Loc
,
10461 Name
=> New_Occurrence_Of
(Flag
, Loc
),
10463 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
10464 Make_Exit_Statement
(Loc
))));
10466 -- Build the loop equivalent of the quantified expression
10468 if Present
(Iter_Spec
) then
10470 Make_Iteration_Scheme
(Loc
,
10471 Iterator_Specification
=> Iter_Spec
);
10474 Make_Iteration_Scheme
(Loc
,
10475 Loop_Parameter_Specification
=> Loop_Spec
);
10478 Append_To
(Actions
,
10479 Make_Loop_Statement
(Loc
,
10480 Iteration_Scheme
=> Scheme
,
10481 Statements
=> Stmts
,
10482 End_Label
=> Empty
));
10484 -- Transform the quantified expression
10487 Make_Expression_With_Actions
(Loc
,
10488 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
10489 Actions
=> Actions
));
10490 Analyze_And_Resolve
(N
, Standard_Boolean
);
10491 end Expand_N_Quantified_Expression
;
10493 ---------------------------------
10494 -- Expand_N_Selected_Component --
10495 ---------------------------------
10497 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
10498 Loc
: constant Source_Ptr
:= Sloc
(N
);
10499 Par
: constant Node_Id
:= Parent
(N
);
10500 P
: constant Node_Id
:= Prefix
(N
);
10501 S
: constant Node_Id
:= Selector_Name
(N
);
10502 Ptyp
: constant Entity_Id
:= Underlying_Type
(Etype
(P
));
10508 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
10509 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10510 -- unless the context of an assignment can provide size information.
10511 -- Don't we have a general routine that does this???
10513 function Is_Subtype_Declaration
return Boolean;
10514 -- The replacement of a discriminant reference by its value is required
10515 -- if this is part of the initialization of an temporary generated by a
10516 -- change of representation. This shows up as the construction of a
10517 -- discriminant constraint for a subtype declared at the same point as
10518 -- the entity in the prefix of the selected component. We recognize this
10519 -- case when the context of the reference is:
10520 -- subtype ST is T(Obj.D);
10521 -- where the entity for Obj comes from source, and ST has the same sloc.
10523 -----------------------
10524 -- In_Left_Hand_Side --
10525 -----------------------
10527 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
10529 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
10530 and then Comp
= Name
(Parent
(Comp
)))
10531 or else (Present
(Parent
(Comp
))
10532 and then Nkind
(Parent
(Comp
)) in N_Subexpr
10533 and then In_Left_Hand_Side
(Parent
(Comp
)));
10534 end In_Left_Hand_Side
;
10536 -----------------------------
10537 -- Is_Subtype_Declaration --
10538 -----------------------------
10540 function Is_Subtype_Declaration
return Boolean is
10541 Par
: constant Node_Id
:= Parent
(N
);
10544 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
10545 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
10546 and then Comes_From_Source
(Entity
(Prefix
(N
)))
10547 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
10548 end Is_Subtype_Declaration
;
10550 -- Start of processing for Expand_N_Selected_Component
10553 -- Deal with discriminant check required
10555 if Do_Discriminant_Check
(N
) then
10556 if Present
(Discriminant_Checking_Func
10557 (Original_Record_Component
(Entity
(S
))))
10559 -- Present the discriminant checking function to the backend, so
10560 -- that it can inline the call to the function.
10563 (Discriminant_Checking_Func
10564 (Original_Record_Component
(Entity
(S
))),
10567 -- Now reset the flag and generate the call
10569 Set_Do_Discriminant_Check
(N
, False);
10570 Generate_Discriminant_Check
(N
);
10572 -- In the case of Unchecked_Union, no discriminant checking is
10573 -- actually performed.
10576 if not Is_Unchecked_Union
10577 (Implementation_Base_Type
(Etype
(Prefix
(N
))))
10578 and then not Is_Predefined_Unit
(Get_Source_Unit
(N
))
10581 ("sorry - unable to generate discriminant check for" &
10582 " reference to variant component &",
10583 Selector_Name
(N
));
10586 Set_Do_Discriminant_Check
(N
, False);
10590 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10591 -- function, then additional actuals must be passed.
10593 if Is_Build_In_Place_Function_Call
(P
) then
10594 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
10596 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10597 -- containing build-in-place function calls whose returned object covers
10598 -- interface types.
10600 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
10601 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
10604 -- Gigi cannot handle unchecked conversions that are the prefix of a
10605 -- selected component with discriminants. This must be checked during
10606 -- expansion, because during analysis the type of the selector is not
10607 -- known at the point the prefix is analyzed. If the conversion is the
10608 -- target of an assignment, then we cannot force the evaluation.
10610 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
10611 and then Has_Discriminants
(Etype
(N
))
10612 and then not In_Left_Hand_Side
(N
)
10614 Force_Evaluation
(Prefix
(N
));
10617 -- Remaining processing applies only if selector is a discriminant
10619 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
10621 -- If the selector is a discriminant of a constrained record type,
10622 -- we may be able to rewrite the expression with the actual value
10623 -- of the discriminant, a useful optimization in some cases.
10625 if Is_Record_Type
(Ptyp
)
10626 and then Has_Discriminants
(Ptyp
)
10627 and then Is_Constrained
(Ptyp
)
10629 -- Do this optimization for discrete types only, and not for
10630 -- access types (access discriminants get us into trouble).
10632 if not Is_Discrete_Type
(Etype
(N
)) then
10635 -- Don't do this on the left-hand side of an assignment statement.
10636 -- Normally one would think that references like this would not
10637 -- occur, but they do in generated code, and mean that we really
10638 -- do want to assign the discriminant.
10640 elsif Nkind
(Par
) = N_Assignment_Statement
10641 and then Name
(Par
) = N
10645 -- Don't do this optimization for the prefix of an attribute or
10646 -- the name of an object renaming declaration since these are
10647 -- contexts where we do not want the value anyway.
10649 elsif (Nkind
(Par
) = N_Attribute_Reference
10650 and then Prefix
(Par
) = N
)
10651 or else Is_Renamed_Object
(N
)
10655 -- Don't do this optimization if we are within the code for a
10656 -- discriminant check, since the whole point of such a check may
10657 -- be to verify the condition on which the code below depends.
10659 elsif Is_In_Discriminant_Check
(N
) then
10662 -- Green light to see if we can do the optimization. There is
10663 -- still one condition that inhibits the optimization below but
10664 -- now is the time to check the particular discriminant.
10667 -- Loop through discriminants to find the matching discriminant
10668 -- constraint to see if we can copy it.
10670 Disc
:= First_Discriminant
(Ptyp
);
10671 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
10672 Discr_Loop
: while Present
(Dcon
) loop
10673 Dval
:= Node
(Dcon
);
10675 -- Check if this is the matching discriminant and if the
10676 -- discriminant value is simple enough to make sense to
10677 -- copy. We don't want to copy complex expressions, and
10678 -- indeed to do so can cause trouble (before we put in
10679 -- this guard, a discriminant expression containing an
10680 -- AND THEN was copied, causing problems for coverage
10681 -- analysis tools).
10683 -- However, if the reference is part of the initialization
10684 -- code generated for an object declaration, we must use
10685 -- the discriminant value from the subtype constraint,
10686 -- because the selected component may be a reference to the
10687 -- object being initialized, whose discriminant is not yet
10688 -- set. This only happens in complex cases involving changes
10689 -- of representation.
10691 if Disc
= Entity
(Selector_Name
(N
))
10692 and then (Is_Entity_Name
(Dval
)
10693 or else Compile_Time_Known_Value
(Dval
)
10694 or else Is_Subtype_Declaration
)
10696 -- Here we have the matching discriminant. Check for
10697 -- the case of a discriminant of a component that is
10698 -- constrained by an outer discriminant, which cannot
10699 -- be optimized away.
10701 if Denotes_Discriminant
(Dval
, Check_Concurrent
=> True)
10705 -- Do not retrieve value if constraint is not static. It
10706 -- is generally not useful, and the constraint may be a
10707 -- rewritten outer discriminant in which case it is in
10710 elsif Is_Entity_Name
(Dval
)
10712 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
10713 and then Present
(Expression
(Parent
(Entity
(Dval
))))
10715 Is_OK_Static_Expression
10716 (Expression
(Parent
(Entity
(Dval
))))
10720 -- In the context of a case statement, the expression may
10721 -- have the base type of the discriminant, and we need to
10722 -- preserve the constraint to avoid spurious errors on
10725 elsif Nkind
(Parent
(N
)) = N_Case_Statement
10726 and then Etype
(Dval
) /= Etype
(Disc
)
10729 Make_Qualified_Expression
(Loc
,
10731 New_Occurrence_Of
(Etype
(Disc
), Loc
),
10733 New_Copy_Tree
(Dval
)));
10734 Analyze_And_Resolve
(N
, Etype
(Disc
));
10736 -- In case that comes out as a static expression,
10737 -- reset it (a selected component is never static).
10739 Set_Is_Static_Expression
(N
, False);
10742 -- Otherwise we can just copy the constraint, but the
10743 -- result is certainly not static. In some cases the
10744 -- discriminant constraint has been analyzed in the
10745 -- context of the original subtype indication, but for
10746 -- itypes the constraint might not have been analyzed
10747 -- yet, and this must be done now.
10750 Rewrite
(N
, New_Copy_Tree
(Dval
));
10751 Analyze_And_Resolve
(N
);
10752 Set_Is_Static_Expression
(N
, False);
10758 Next_Discriminant
(Disc
);
10759 end loop Discr_Loop
;
10761 -- Note: the above loop should always find a matching
10762 -- discriminant, but if it does not, we just missed an
10763 -- optimization due to some glitch (perhaps a previous
10764 -- error), so ignore.
10769 -- The only remaining processing is in the case of a discriminant of
10770 -- a concurrent object, where we rewrite the prefix to denote the
10771 -- corresponding record type. If the type is derived and has renamed
10772 -- discriminants, use corresponding discriminant, which is the one
10773 -- that appears in the corresponding record.
10775 if not Is_Concurrent_Type
(Ptyp
) then
10779 Disc
:= Entity
(Selector_Name
(N
));
10781 if Is_Derived_Type
(Ptyp
)
10782 and then Present
(Corresponding_Discriminant
(Disc
))
10784 Disc
:= Corresponding_Discriminant
(Disc
);
10788 Make_Selected_Component
(Loc
,
10790 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
10791 New_Copy_Tree
(P
)),
10792 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
10794 Rewrite
(N
, New_N
);
10798 -- Set Atomic_Sync_Required if necessary for atomic component
10800 if Nkind
(N
) = N_Selected_Component
then
10802 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
10806 -- If component is atomic, but type is not, setting depends on
10807 -- disable/enable state for the component.
10809 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
10810 Set
:= not Atomic_Synchronization_Disabled
(E
);
10812 -- If component is not atomic, but its type is atomic, setting
10813 -- depends on disable/enable state for the type.
10815 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
10816 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
10818 -- If both component and type are atomic, we disable if either
10819 -- component or its type have sync disabled.
10821 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
10822 Set
:= not Atomic_Synchronization_Disabled
(E
)
10824 not Atomic_Synchronization_Disabled
(Etype
(E
));
10830 -- Set flag if required
10833 Activate_Atomic_Synchronization
(N
);
10837 end Expand_N_Selected_Component
;
10839 --------------------
10840 -- Expand_N_Slice --
10841 --------------------
10843 procedure Expand_N_Slice
(N
: Node_Id
) is
10844 Loc
: constant Source_Ptr
:= Sloc
(N
);
10845 Typ
: constant Entity_Id
:= Etype
(N
);
10847 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
10848 -- Check whether the argument is an actual for a procedure call, in
10849 -- which case the expansion of a bit-packed slice is deferred until the
10850 -- call itself is expanded. The reason this is required is that we might
10851 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10852 -- that copy out would be missed if we created a temporary here in
10853 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10854 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10855 -- is harmless to defer expansion in the IN case, since the call
10856 -- processing will still generate the appropriate copy in operation,
10857 -- which will take care of the slice.
10859 procedure Make_Temporary_For_Slice
;
10860 -- Create a named variable for the value of the slice, in cases where
10861 -- the back end cannot handle it properly, e.g. when packed types or
10862 -- unaligned slices are involved.
10864 -------------------------
10865 -- Is_Procedure_Actual --
10866 -------------------------
10868 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
10869 Par
: Node_Id
:= Parent
(N
);
10873 -- If our parent is a procedure call we can return
10875 if Nkind
(Par
) = N_Procedure_Call_Statement
then
10878 -- If our parent is a type conversion, keep climbing the tree,
10879 -- since a type conversion can be a procedure actual. Also keep
10880 -- climbing if parameter association or a qualified expression,
10881 -- since these are additional cases that do can appear on
10882 -- procedure actuals.
10884 elsif Nkind
(Par
) in N_Type_Conversion
10885 | N_Parameter_Association
10886 | N_Qualified_Expression
10888 Par
:= Parent
(Par
);
10890 -- Any other case is not what we are looking for
10896 end Is_Procedure_Actual
;
10898 ------------------------------
10899 -- Make_Temporary_For_Slice --
10900 ------------------------------
10902 procedure Make_Temporary_For_Slice
is
10903 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
10908 Make_Object_Declaration
(Loc
,
10909 Defining_Identifier
=> Ent
,
10910 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10912 Set_No_Initialization
(Decl
);
10914 Insert_Actions
(N
, New_List
(
10916 Make_Assignment_Statement
(Loc
,
10917 Name
=> New_Occurrence_Of
(Ent
, Loc
),
10918 Expression
=> Relocate_Node
(N
))));
10920 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
10921 Analyze_And_Resolve
(N
, Typ
);
10922 end Make_Temporary_For_Slice
;
10926 Pref
: constant Node_Id
:= Prefix
(N
);
10928 -- Start of processing for Expand_N_Slice
10931 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10932 -- function, then additional actuals must be passed.
10934 if Is_Build_In_Place_Function_Call
(Pref
) then
10935 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
10937 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10938 -- containing build-in-place function calls whose returned object covers
10939 -- interface types.
10941 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
10942 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
10945 -- The remaining case to be handled is packed slices. We can leave
10946 -- packed slices as they are in the following situations:
10948 -- 1. Right or left side of an assignment (we can handle this
10949 -- situation correctly in the assignment statement expansion).
10951 -- 2. Prefix of indexed component (the slide is optimized away in this
10952 -- case, see the start of Expand_N_Indexed_Component.)
10954 -- 3. Object renaming declaration, since we want the name of the
10955 -- slice, not the value.
10957 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10958 -- be required, and this is handled in the expansion of call
10961 -- 5. Prefix of an address attribute (this is an error which is caught
10962 -- elsewhere, and the expansion would interfere with generating the
10963 -- error message) or of a size attribute (because 'Size may change
10964 -- when applied to the temporary instead of the slice directly).
10966 if not Is_Packed
(Typ
) then
10968 -- Apply transformation for actuals of a function call, where
10969 -- Expand_Actuals is not used.
10971 if Nkind
(Parent
(N
)) = N_Function_Call
10972 and then Is_Possibly_Unaligned_Slice
(N
)
10974 Make_Temporary_For_Slice
;
10977 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
10978 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
10979 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
10983 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
10984 or else Is_Renamed_Object
(N
)
10985 or else Is_Procedure_Actual
(N
)
10989 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
10990 and then (Attribute_Name
(Parent
(N
)) = Name_Address
10991 or else Attribute_Name
(Parent
(N
)) = Name_Size
)
10996 Make_Temporary_For_Slice
;
10998 end Expand_N_Slice
;
11000 ------------------------------
11001 -- Expand_N_Type_Conversion --
11002 ------------------------------
11004 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
11005 Loc
: constant Source_Ptr
:= Sloc
(N
);
11006 Operand
: constant Node_Id
:= Expression
(N
);
11007 Operand_Acc
: Node_Id
:= Operand
;
11008 Target_Type
: Entity_Id
:= Etype
(N
);
11009 Operand_Type
: Entity_Id
:= Etype
(Operand
);
11011 procedure Discrete_Range_Check
;
11012 -- Handles generation of range check for discrete target value
11014 procedure Handle_Changed_Representation
;
11015 -- This is called in the case of record and array type conversions to
11016 -- see if there is a change of representation to be handled. Change of
11017 -- representation is actually handled at the assignment statement level,
11018 -- and what this procedure does is rewrite node N conversion as an
11019 -- assignment to temporary. If there is no change of representation,
11020 -- then the conversion node is unchanged.
11022 procedure Raise_Accessibility_Error
;
11023 -- Called when we know that an accessibility check will fail. Rewrites
11024 -- node N to an appropriate raise statement and outputs warning msgs.
11025 -- The Etype of the raise node is set to Target_Type. Note that in this
11026 -- case the rest of the processing should be skipped (i.e. the call to
11027 -- this procedure will be followed by "goto Done").
11029 procedure Real_Range_Check
;
11030 -- Handles generation of range check for real target value
11032 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
11033 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11034 -- evaluates to True.
11036 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
11038 -- Given a target type for a conversion, determine whether the
11039 -- statically deeper accessibility rules apply to it.
11041 --------------------------
11042 -- Discrete_Range_Check --
11043 --------------------------
11045 -- Case of conversions to a discrete type. We let Generate_Range_Check
11046 -- do the heavy lifting, after converting a fixed-point operand to an
11047 -- appropriate integer type.
11049 procedure Discrete_Range_Check
is
11053 procedure Generate_Temporary
;
11054 -- Generate a temporary to facilitate in the C backend the code
11055 -- generation of the unchecked conversion since the size of the
11056 -- source type may differ from the size of the target type.
11058 ------------------------
11059 -- Generate_Temporary --
11060 ------------------------
11062 procedure Generate_Temporary
is
11064 if Esize
(Etype
(Expr
)) < Esize
(Etype
(Ityp
)) then
11066 Exp_Type
: constant Entity_Id
:= Ityp
;
11067 Def_Id
: constant Entity_Id
:=
11068 Make_Temporary
(Loc
, 'R', Expr
);
11073 Set_Is_Internal
(Def_Id
);
11074 Set_Etype
(Def_Id
, Exp_Type
);
11075 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
11078 Make_Object_Declaration
(Loc
,
11079 Defining_Identifier
=> Def_Id
,
11080 Object_Definition
=> New_Occurrence_Of
11082 Constant_Present
=> True,
11083 Expression
=> Relocate_Node
(Expr
));
11085 Set_Assignment_OK
(E
);
11086 Insert_Action
(Expr
, E
);
11088 Set_Assignment_OK
(Res
, Assignment_OK
(Expr
));
11090 Rewrite
(Expr
, Res
);
11091 Analyze_And_Resolve
(Expr
, Exp_Type
);
11094 end Generate_Temporary
;
11096 -- Start of processing for Discrete_Range_Check
11099 -- Nothing more to do if conversion was rewritten
11101 if Nkind
(N
) /= N_Type_Conversion
then
11105 Expr
:= Expression
(N
);
11107 -- Clear the Do_Range_Check flag on Expr
11109 Set_Do_Range_Check
(Expr
, False);
11111 -- Nothing to do if range checks suppressed
11113 if Range_Checks_Suppressed
(Target_Type
) then
11117 -- Nothing to do if expression is an entity on which checks have been
11120 if Is_Entity_Name
(Expr
)
11121 and then Range_Checks_Suppressed
(Entity
(Expr
))
11126 -- Before we do a range check, we have to deal with treating
11127 -- a fixed-point operand as an integer. The way we do this
11128 -- is simply to do an unchecked conversion to an appropriate
11129 -- integer type with the smallest size, so that we can suppress
11132 if Is_Fixed_Point_Type
(Etype
(Expr
)) then
11133 Ityp
:= Small_Integer_Type_For
11134 (Esize
(Base_Type
(Etype
(Expr
))), Uns
=> False);
11136 -- Generate a temporary with the integer type to facilitate in the
11137 -- C backend the code generation for the unchecked conversion.
11139 if Modify_Tree_For_C
then
11140 Generate_Temporary
;
11143 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11146 -- Reset overflow flag, since the range check will include
11147 -- dealing with possible overflow, and generate the check.
11149 Set_Do_Overflow_Check
(N
, False);
11151 Generate_Range_Check
(Expr
, Target_Type
, CE_Range_Check_Failed
);
11152 end Discrete_Range_Check
;
11154 -----------------------------------
11155 -- Handle_Changed_Representation --
11156 -----------------------------------
11158 procedure Handle_Changed_Representation
is
11166 -- Nothing else to do if no change of representation
11168 if Has_Compatible_Representation
(Target_Type
, Operand_Type
) then
11171 -- The real change of representation work is done by the assignment
11172 -- statement processing. So if this type conversion is appearing as
11173 -- the expression of an assignment statement, nothing needs to be
11174 -- done to the conversion.
11176 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
11179 -- Otherwise we need to generate a temporary variable, and do the
11180 -- change of representation assignment into that temporary variable.
11181 -- The conversion is then replaced by a reference to this variable.
11186 -- If type is unconstrained we have to add a constraint, copied
11187 -- from the actual value of the left-hand side.
11189 if not Is_Constrained
(Target_Type
) then
11190 if Has_Discriminants
(Operand_Type
) then
11192 -- A change of representation can only apply to untagged
11193 -- types. We need to build the constraint that applies to
11194 -- the target type, using the constraints of the operand.
11195 -- The analysis is complicated if there are both inherited
11196 -- discriminants and constrained discriminants.
11197 -- We iterate over the discriminants of the target, and
11198 -- find the discriminant of the same name:
11200 -- a) If there is a corresponding discriminant in the object
11201 -- then the value is a selected component of the operand.
11203 -- b) Otherwise the value of a constrained discriminant is
11204 -- found in the stored constraint of the operand.
11207 Stored
: constant Elist_Id
:=
11208 Stored_Constraint
(Operand_Type
);
11209 -- Stored constraints of the operand. If present, they
11210 -- correspond to the discriminants of the parent type.
11212 Disc_O
: Entity_Id
;
11213 -- Discriminant of the operand type. Its value in the
11214 -- object is captured in a selected component.
11216 Disc_T
: Entity_Id
;
11217 -- Discriminant of the target type
11222 Disc_O
:= First_Discriminant
(Operand_Type
);
11223 Disc_T
:= First_Discriminant
(Target_Type
);
11224 Elmt
:= (if Present
(Stored
)
11225 then First_Elmt
(Stored
)
11229 while Present
(Disc_T
) loop
11230 if Present
(Disc_O
)
11231 and then Chars
(Disc_T
) = Chars
(Disc_O
)
11234 Make_Selected_Component
(Loc
,
11236 Duplicate_Subexpr_Move_Checks
(Operand
),
11238 Make_Identifier
(Loc
, Chars
(Disc_O
))));
11239 Next_Discriminant
(Disc_O
);
11241 elsif Present
(Elmt
) then
11242 Append_To
(Cons
, New_Copy_Tree
(Node
(Elmt
)));
11245 if Present
(Elmt
) then
11249 Next_Discriminant
(Disc_T
);
11253 elsif Is_Array_Type
(Operand_Type
) then
11254 N_Ix
:= First_Index
(Target_Type
);
11257 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
11259 -- We convert the bounds explicitly. We use an unchecked
11260 -- conversion because bounds checks are done elsewhere.
11265 Unchecked_Convert_To
(Etype
(N_Ix
),
11266 Make_Attribute_Reference
(Loc
,
11268 Duplicate_Subexpr_No_Checks
11269 (Operand
, Name_Req
=> True),
11270 Attribute_Name
=> Name_First
,
11271 Expressions
=> New_List
(
11272 Make_Integer_Literal
(Loc
, J
)))),
11275 Unchecked_Convert_To
(Etype
(N_Ix
),
11276 Make_Attribute_Reference
(Loc
,
11278 Duplicate_Subexpr_No_Checks
11279 (Operand
, Name_Req
=> True),
11280 Attribute_Name
=> Name_Last
,
11281 Expressions
=> New_List
(
11282 Make_Integer_Literal
(Loc
, J
))))));
11289 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
11291 if Present
(Cons
) then
11293 Make_Subtype_Indication
(Loc
,
11294 Subtype_Mark
=> Odef
,
11296 Make_Index_Or_Discriminant_Constraint
(Loc
,
11297 Constraints
=> Cons
));
11300 Temp
:= Make_Temporary
(Loc
, 'C');
11302 Make_Object_Declaration
(Loc
,
11303 Defining_Identifier
=> Temp
,
11304 Object_Definition
=> Odef
);
11306 Set_No_Initialization
(Decl
, True);
11308 -- Insert required actions. It is essential to suppress checks
11309 -- since we have suppressed default initialization, which means
11310 -- that the variable we create may have no discriminants.
11315 Make_Assignment_Statement
(Loc
,
11316 Name
=> New_Occurrence_Of
(Temp
, Loc
),
11317 Expression
=> Relocate_Node
(N
))),
11318 Suppress
=> All_Checks
);
11320 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
11323 end Handle_Changed_Representation
;
11325 -------------------------------
11326 -- Raise_Accessibility_Error --
11327 -------------------------------
11329 procedure Raise_Accessibility_Error
is
11331 Error_Msg_Warn
:= SPARK_Mode
/= On
;
11333 Make_Raise_Program_Error
(Sloc
(N
),
11334 Reason
=> PE_Accessibility_Check_Failed
));
11335 Set_Etype
(N
, Target_Type
);
11337 Error_Msg_N
("accessibility check failure<<", N
);
11338 Error_Msg_N
("\Program_Error [<<", N
);
11339 end Raise_Accessibility_Error
;
11341 ----------------------
11342 -- Real_Range_Check --
11343 ----------------------
11345 -- Case of conversions to floating-point or fixed-point. If range checks
11346 -- are enabled and the target type has a range constraint, we convert:
11352 -- Tnn : typ'Base := typ'Base (x);
11353 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11356 -- This is necessary when there is a conversion of integer to float or
11357 -- to fixed-point to ensure that the correct checks are made. It is not
11358 -- necessary for the float-to-float case where it is enough to just set
11359 -- the Do_Range_Check flag on the expression.
11361 procedure Real_Range_Check
is
11362 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
11363 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
11364 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
11375 -- Nothing more to do if conversion was rewritten
11377 if Nkind
(N
) /= N_Type_Conversion
then
11381 Expr
:= Expression
(N
);
11383 -- Clear the Do_Range_Check flag on Expr
11385 Set_Do_Range_Check
(Expr
, False);
11387 -- Nothing to do if range checks suppressed, or target has the same
11388 -- range as the base type (or is the base type).
11390 if Range_Checks_Suppressed
(Target_Type
)
11391 or else (Lo
= Type_Low_Bound
(Btyp
)
11393 Hi
= Type_High_Bound
(Btyp
))
11398 -- Nothing to do if expression is an entity on which checks have been
11401 if Is_Entity_Name
(Expr
)
11402 and then Range_Checks_Suppressed
(Entity
(Expr
))
11407 -- Nothing to do if expression was rewritten into a float-to-float
11408 -- conversion, since this kind of conversion is handled elsewhere.
11410 if Is_Floating_Point_Type
(Etype
(Expr
))
11411 and then Is_Floating_Point_Type
(Target_Type
)
11416 -- Nothing to do if bounds are all static and we can tell that the
11417 -- expression is within the bounds of the target. Note that if the
11418 -- operand is of an unconstrained floating-point type, then we do
11419 -- not trust it to be in range (might be infinite)
11422 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Expr
));
11423 S_Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Expr
));
11426 if (not Is_Floating_Point_Type
(Etype
(Expr
))
11427 or else Is_Constrained
(Etype
(Expr
)))
11428 and then Compile_Time_Known_Value
(S_Lo
)
11429 and then Compile_Time_Known_Value
(S_Hi
)
11430 and then Compile_Time_Known_Value
(Hi
)
11431 and then Compile_Time_Known_Value
(Lo
)
11434 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
11435 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
11440 if Is_Real_Type
(Etype
(Expr
)) then
11441 S_Lov
:= Expr_Value_R
(S_Lo
);
11442 S_Hiv
:= Expr_Value_R
(S_Hi
);
11444 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
11445 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
11449 and then S_Lov
>= D_Lov
11450 and then S_Hiv
<= D_Hiv
11458 -- Otherwise rewrite the conversion as described above
11460 Conv
:= Convert_To
(Btyp
, Expr
);
11462 -- If a conversion is necessary, then copy the specific flags from
11463 -- the original one and also move the Do_Overflow_Check flag since
11464 -- this new conversion is to the base type.
11466 if Nkind
(Conv
) = N_Type_Conversion
then
11467 Set_Conversion_OK
(Conv
, Conversion_OK
(N
));
11468 Set_Float_Truncate
(Conv
, Float_Truncate
(N
));
11469 Set_Rounded_Result
(Conv
, Rounded_Result
(N
));
11471 if Do_Overflow_Check
(N
) then
11472 Set_Do_Overflow_Check
(Conv
);
11473 Set_Do_Overflow_Check
(N
, False);
11477 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
11479 -- For a conversion from Float to Fixed where the bounds of the
11480 -- fixed-point type are static, we can obtain a more accurate
11481 -- fixed-point value by converting the result of the floating-
11482 -- point expression to an appropriate integer type, and then
11483 -- performing an unchecked conversion to the target fixed-point
11484 -- type. The range check can then use the corresponding integer
11485 -- value of the bounds instead of requiring further conversions.
11486 -- This preserves the identity:
11488 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11490 -- which used to fail when Fix_Val was a bound of the type and
11491 -- the 'Small was not a representable number.
11492 -- This transformation requires an integer type large enough to
11493 -- accommodate a fixed-point value.
11495 if Is_Ordinary_Fixed_Point_Type
(Target_Type
)
11496 and then Is_Floating_Point_Type
(Etype
(Expr
))
11497 and then RM_Size
(Btyp
) <= System_Max_Integer_Size
11498 and then Nkind
(Lo
) = N_Real_Literal
11499 and then Nkind
(Hi
) = N_Real_Literal
11502 Expr_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Conv
);
11503 Int_Typ
: constant Entity_Id
:=
11504 Small_Integer_Type_For
(RM_Size
(Btyp
), Uns
=> False);
11505 Trunc
: constant Boolean := Float_Truncate
(Conv
);
11508 Conv
:= Convert_To
(Int_Typ
, Expression
(Conv
));
11509 Set_Float_Truncate
(Conv
, Trunc
);
11511 -- Generate a temporary with the integer value. Required in the
11512 -- CCG compiler to ensure that run-time checks reference this
11513 -- integer expression (instead of the resulting fixed-point
11514 -- value because fixed-point values are handled by means of
11515 -- unsigned integer types).
11518 Make_Object_Declaration
(Loc
,
11519 Defining_Identifier
=> Expr_Id
,
11520 Object_Definition
=> New_Occurrence_Of
(Int_Typ
, Loc
),
11521 Constant_Present
=> True,
11522 Expression
=> Conv
));
11524 -- Create integer objects for range checking of result.
11527 Unchecked_Convert_To
11528 (Int_Typ
, New_Occurrence_Of
(Expr_Id
, Loc
));
11531 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Lo
));
11534 Unchecked_Convert_To
11535 (Int_Typ
, New_Occurrence_Of
(Expr_Id
, Loc
));
11538 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Hi
));
11540 -- Rewrite conversion as an integer conversion of the
11541 -- original floating-point expression, followed by an
11542 -- unchecked conversion to the target fixed-point type.
11545 Unchecked_Convert_To
11546 (Target_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11549 -- All other conversions
11552 Lo_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11554 Make_Attribute_Reference
(Loc
,
11555 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11556 Attribute_Name
=> Name_First
);
11558 Hi_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11560 Make_Attribute_Reference
(Loc
,
11561 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11562 Attribute_Name
=> Name_Last
);
11565 -- Build code for range checking. Note that checks are suppressed
11566 -- here since we don't want a recursive range check popping up.
11568 Insert_Actions
(N
, New_List
(
11569 Make_Object_Declaration
(Loc
,
11570 Defining_Identifier
=> Tnn
,
11571 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
11572 Constant_Present
=> True,
11573 Expression
=> Conv
),
11575 Make_Raise_Constraint_Error
(Loc
,
11580 Left_Opnd
=> Lo_Arg
,
11581 Right_Opnd
=> Lo_Val
),
11585 Left_Opnd
=> Hi_Arg
,
11586 Right_Opnd
=> Hi_Val
)),
11587 Reason
=> CE_Range_Check_Failed
)),
11588 Suppress
=> All_Checks
);
11590 Rewrite
(Expr
, New_Occurrence_Of
(Tnn
, Loc
));
11591 end Real_Range_Check
;
11593 -----------------------------
11594 -- Has_Extra_Accessibility --
11595 -----------------------------
11597 -- Returns true for a formal of an anonymous access type or for an Ada
11598 -- 2012-style stand-alone object of an anonymous access type.
11600 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
11602 if Is_Formal
(Id
) or else Ekind
(Id
) in E_Constant | E_Variable
then
11603 return Present
(Effective_Extra_Accessibility
(Id
));
11607 end Has_Extra_Accessibility
;
11609 ----------------------------------------
11610 -- Statically_Deeper_Relation_Applies --
11611 ----------------------------------------
11613 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
11617 -- The case where the target type is an anonymous access type is
11618 -- ignored since they have different semantics and get covered by
11619 -- various runtime checks depending on context.
11621 -- Note, the current implementation of this predicate is incomplete
11622 -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
11625 return Ekind
(Targ_Typ
) /= E_Anonymous_Access_Type
;
11626 end Statically_Deeper_Relation_Applies
;
11628 -- Start of processing for Expand_N_Type_Conversion
11631 -- First remove check marks put by the semantic analysis on the type
11632 -- conversion between array types. We need these checks, and they will
11633 -- be generated by this expansion routine, but we do not depend on these
11634 -- flags being set, and since we do intend to expand the checks in the
11635 -- front end, we don't want them on the tree passed to the back end.
11637 if Is_Array_Type
(Target_Type
) then
11638 if Is_Constrained
(Target_Type
) then
11639 Set_Do_Length_Check
(N
, False);
11641 Set_Do_Range_Check
(Operand
, False);
11645 -- Nothing at all to do if conversion is to the identical type so remove
11646 -- the conversion completely, it is useless, except that it may carry
11647 -- an Assignment_OK attribute, which must be propagated to the operand
11648 -- and the Do_Range_Check flag on the operand must be cleared, if any.
11650 if Operand_Type
= Target_Type
then
11651 if Assignment_OK
(N
) then
11652 Set_Assignment_OK
(Operand
);
11655 Set_Do_Range_Check
(Operand
, False);
11657 Rewrite
(N
, Relocate_Node
(Operand
));
11662 -- Nothing to do if this is the second argument of read. This is a
11663 -- "backwards" conversion that will be handled by the specialized code
11664 -- in attribute processing.
11666 if Nkind
(Parent
(N
)) = N_Attribute_Reference
11667 and then Attribute_Name
(Parent
(N
)) = Name_Read
11668 and then Next
(First
(Expressions
(Parent
(N
)))) = N
11673 -- Check for case of converting to a type that has an invariant
11674 -- associated with it. This requires an invariant check. We insert
11677 -- invariant_check (typ (expr))
11679 -- in the code, after removing side effects from the expression.
11680 -- This is clearer than replacing the conversion into an expression
11681 -- with actions, because the context may impose additional actions
11682 -- (tag checks, membership tests, etc.) that conflict with this
11683 -- rewriting (used previously).
11685 -- Note: the Comes_From_Source check, and then the resetting of this
11686 -- flag prevents what would otherwise be an infinite recursion.
11688 if Has_Invariants
(Target_Type
)
11689 and then Present
(Invariant_Procedure
(Target_Type
))
11690 and then Comes_From_Source
(N
)
11692 Set_Comes_From_Source
(N
, False);
11693 Remove_Side_Effects
(N
);
11694 Insert_Action
(N
, Make_Invariant_Call
(Duplicate_Subexpr
(N
)));
11697 -- AI12-0042: For a view conversion to a class-wide type occurring
11698 -- within the immediate scope of T, from a specific type that is
11699 -- a descendant of T (including T itself), an invariant check is
11700 -- performed on the part of the object that is of type T. (We don't
11701 -- need to explicitly check for the operand type being a descendant,
11702 -- just that it's a specific type, because the conversion would be
11703 -- illegal if it's specific and not a descendant -- downward conversion
11704 -- is not allowed).
11706 elsif Is_Class_Wide_Type
(Target_Type
)
11707 and then not Is_Class_Wide_Type
(Etype
(Expression
(N
)))
11708 and then Present
(Invariant_Procedure
(Root_Type
(Target_Type
)))
11709 and then Comes_From_Source
(N
)
11710 and then Within_Scope
(Find_Enclosing_Scope
(N
), Scope
(Target_Type
))
11712 Remove_Side_Effects
(N
);
11714 -- Perform the invariant check on a conversion to the class-wide
11715 -- type's root type.
11718 Root_Conv
: constant Node_Id
:=
11719 Make_Type_Conversion
(Loc
,
11721 New_Occurrence_Of
(Root_Type
(Target_Type
), Loc
),
11722 Expression
=> Duplicate_Subexpr
(Expression
(N
)));
11724 Set_Etype
(Root_Conv
, Root_Type
(Target_Type
));
11726 Insert_Action
(N
, Make_Invariant_Call
(Root_Conv
));
11731 -- Here if we may need to expand conversion
11733 -- If the operand of the type conversion is an arithmetic operation on
11734 -- signed integers, and the based type of the signed integer type in
11735 -- question is smaller than Standard.Integer, we promote both of the
11736 -- operands to type Integer.
11738 -- For example, if we have
11740 -- target-type (opnd1 + opnd2)
11742 -- and opnd1 and opnd2 are of type short integer, then we rewrite
11745 -- target-type (integer(opnd1) + integer(opnd2))
11747 -- We do this because we are always allowed to compute in a larger type
11748 -- if we do the right thing with the result, and in this case we are
11749 -- going to do a conversion which will do an appropriate check to make
11750 -- sure that things are in range of the target type in any case. This
11751 -- avoids some unnecessary intermediate overflows.
11753 -- We might consider a similar transformation in the case where the
11754 -- target is a real type or a 64-bit integer type, and the operand
11755 -- is an arithmetic operation using a 32-bit integer type. However,
11756 -- we do not bother with this case, because it could cause significant
11757 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
11758 -- much cheaper, but we don't want different behavior on 32-bit and
11759 -- 64-bit machines. Note that the exclusion of the 64-bit case also
11760 -- handles the configurable run-time cases where 64-bit arithmetic
11761 -- may simply be unavailable.
11763 -- Note: this circuit is partially redundant with respect to the circuit
11764 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
11765 -- the processing here. Also we still need the Checks circuit, since we
11766 -- have to be sure not to generate junk overflow checks in the first
11767 -- place, since it would be tricky to remove them here.
11769 if Integer_Promotion_Possible
(N
) then
11771 -- All conditions met, go ahead with transformation
11778 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
11780 R
:= Convert_To
(Standard_Integer
, Right_Opnd
(Operand
));
11781 Set_Right_Opnd
(Opnd
, R
);
11783 if Nkind
(Operand
) in N_Binary_Op
then
11784 L
:= Convert_To
(Standard_Integer
, Left_Opnd
(Operand
));
11785 Set_Left_Opnd
(Opnd
, L
);
11789 Make_Type_Conversion
(Loc
,
11790 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
11791 Expression
=> Opnd
));
11793 Analyze_And_Resolve
(N
, Target_Type
);
11798 -- If the conversion is from Universal_Integer and requires an overflow
11799 -- check, try to do an intermediate conversion to a narrower type first
11800 -- without overflow check, in order to avoid doing the overflow check
11801 -- in Universal_Integer, which can be a very large type.
11803 if Operand_Type
= Universal_Integer
and then Do_Overflow_Check
(N
) then
11805 Lo
, Hi
, Siz
: Uint
;
11810 Determine_Range
(Operand
, OK
, Lo
, Hi
, Assume_Valid
=> True);
11813 Siz
:= Get_Size_For_Range
(Lo
, Hi
);
11815 -- We use the base type instead of the first subtype because
11816 -- overflow checks are done in the base type, so this avoids
11817 -- the need for useless conversions.
11819 if Siz
< System_Max_Integer_Size
then
11820 Typ
:= Etype
(Integer_Type_For
(Siz
, Uns
=> False));
11822 Convert_To_And_Rewrite
(Typ
, Operand
);
11823 Analyze_And_Resolve
11824 (Operand
, Typ
, Suppress
=> Overflow_Check
);
11826 Analyze_And_Resolve
(N
, Target_Type
);
11833 -- Do validity check if validity checking operands
11835 if Validity_Checks_On
and Validity_Check_Operands
then
11836 Ensure_Valid
(Operand
);
11839 -- Special case of converting from non-standard boolean type
11841 if Is_Boolean_Type
(Operand_Type
)
11842 and then Nonzero_Is_True
(Operand_Type
)
11844 Adjust_Condition
(Operand
);
11845 Set_Etype
(Operand
, Standard_Boolean
);
11846 Operand_Type
:= Standard_Boolean
;
11849 -- Case of converting to an access type
11851 if Is_Access_Type
(Target_Type
) then
11852 -- In terms of accessibility rules, an anonymous access discriminant
11853 -- is not considered separate from its parent object.
11855 if Nkind
(Operand
) = N_Selected_Component
11856 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
11857 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
11859 Operand_Acc
:= Original_Node
(Prefix
(Operand
));
11862 -- If this type conversion was internally generated by the front end
11863 -- to displace the pointer to the object to reference an interface
11864 -- type and the original node was an Unrestricted_Access attribute,
11865 -- then skip applying accessibility checks (because, according to the
11866 -- GNAT Reference Manual, this attribute is similar to 'Access except
11867 -- that all accessibility and aliased view checks are omitted).
11869 if not Comes_From_Source
(N
)
11870 and then Is_Interface
(Designated_Type
(Target_Type
))
11871 and then Nkind
(Original_Node
(N
)) = N_Attribute_Reference
11872 and then Attribute_Name
(Original_Node
(N
)) =
11873 Name_Unrestricted_Access
11877 -- Apply an accessibility check when the conversion operand is an
11878 -- access parameter (or a renaming thereof), unless conversion was
11879 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
11880 -- or for the actual of a class-wide interface parameter. Note that
11881 -- other checks may still need to be applied below (such as tagged
11884 elsif Is_Entity_Name
(Operand_Acc
)
11885 and then Has_Extra_Accessibility
(Entity
(Operand_Acc
))
11886 and then Ekind
(Etype
(Operand_Acc
)) = E_Anonymous_Access_Type
11887 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
11888 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
11889 and then not No_Dynamic_Accessibility_Checks_Enabled
(N
)
11891 if not Comes_From_Source
(N
)
11892 and then Nkind
(Parent
(N
)) in N_Function_Call
11893 | N_Parameter_Association
11894 | N_Procedure_Call_Statement
11895 and then Is_Interface
(Designated_Type
(Target_Type
))
11896 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
11901 Apply_Accessibility_Check
11902 (Operand
, Target_Type
, Insert_Node
=> Operand
);
11905 -- If the level of the operand type is statically deeper than the
11906 -- level of the target type, then force Program_Error. Note that this
11907 -- can only occur for cases where the attribute is within the body of
11908 -- an instantiation, otherwise the conversion will already have been
11909 -- rejected as illegal.
11911 -- Note: warnings are issued by the analyzer for the instance cases,
11912 -- and, since we are late in expansion, a check is performed to
11913 -- verify that neither the target type nor the operand type are
11914 -- internally generated - as this can lead to spurious errors when,
11915 -- for example, the operand type is a result of BIP expansion.
11917 elsif In_Instance_Body
11918 and then Statically_Deeper_Relation_Applies
(Target_Type
)
11919 and then not Is_Internal
(Target_Type
)
11920 and then not Is_Internal
(Operand_Type
)
11922 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
11924 Raise_Accessibility_Error
;
11927 -- When the operand is a selected access discriminant the check needs
11928 -- to be made against the level of the object denoted by the prefix
11929 -- of the selected name. Force Program_Error for this case as well
11930 -- (this accessibility violation can only happen if within the body
11931 -- of an instantiation).
11933 elsif In_Instance_Body
11934 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
11935 and then Nkind
(Operand
) = N_Selected_Component
11936 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
11937 and then Static_Accessibility_Level
(Operand
, Zero_On_Dynamic_Level
)
11938 > Type_Access_Level
(Target_Type
)
11940 Raise_Accessibility_Error
;
11945 -- Case of conversions of tagged types and access to tagged types
11947 -- When needed, that is to say when the expression is class-wide, Add
11948 -- runtime a tag check for (strict) downward conversion by using the
11949 -- membership test, generating:
11951 -- [constraint_error when Operand not in Target_Type'Class]
11953 -- or in the access type case
11955 -- [constraint_error
11956 -- when Operand /= null
11957 -- and then Operand.all not in
11958 -- Designated_Type (Target_Type)'Class]
11960 if (Is_Access_Type
(Target_Type
)
11961 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
11962 or else Is_Tagged_Type
(Target_Type
)
11964 -- Do not do any expansion in the access type case if the parent is a
11965 -- renaming, since this is an error situation which will be caught by
11966 -- Sem_Ch8, and the expansion can interfere with this error check.
11968 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
11972 -- Otherwise, proceed with processing tagged conversion
11974 Tagged_Conversion
: declare
11975 Actual_Op_Typ
: Entity_Id
;
11976 Actual_Targ_Typ
: Entity_Id
;
11977 Root_Op_Typ
: Entity_Id
;
11979 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
11980 -- Create a membership check to test whether Operand is a member
11981 -- of Targ_Typ. If the original Target_Type is an access, include
11982 -- a test for null value. The check is inserted at N.
11984 --------------------
11985 -- Make_Tag_Check --
11986 --------------------
11988 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
11993 -- [Constraint_Error
11994 -- when Operand /= null
11995 -- and then Operand.all not in Targ_Typ]
11997 if Is_Access_Type
(Target_Type
) then
11999 Make_And_Then
(Loc
,
12002 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12003 Right_Opnd
=> Make_Null
(Loc
)),
12008 Make_Explicit_Dereference
(Loc
,
12009 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
12010 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
12013 -- [Constraint_Error when Operand not in Targ_Typ]
12018 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12019 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
12023 Make_Raise_Constraint_Error
(Loc
,
12025 Reason
=> CE_Tag_Check_Failed
),
12026 Suppress
=> All_Checks
);
12027 end Make_Tag_Check
;
12029 -- Start of processing for Tagged_Conversion
12032 -- Handle entities from the limited view
12034 if Is_Access_Type
(Operand_Type
) then
12036 Available_View
(Designated_Type
(Operand_Type
));
12038 Actual_Op_Typ
:= Operand_Type
;
12041 if Is_Access_Type
(Target_Type
) then
12043 Available_View
(Designated_Type
(Target_Type
));
12045 Actual_Targ_Typ
:= Target_Type
;
12048 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
12050 -- Ada 2005 (AI-251): Handle interface type conversion
12052 if Is_Interface
(Actual_Op_Typ
)
12054 Is_Interface
(Actual_Targ_Typ
)
12056 Expand_Interface_Conversion
(N
);
12060 -- Create a runtime tag check for a downward CW type conversion
12062 if Is_Class_Wide_Type
(Actual_Op_Typ
)
12063 and then Actual_Op_Typ
/= Actual_Targ_Typ
12064 and then Root_Op_Typ
/= Actual_Targ_Typ
12065 and then Is_Ancestor
12066 (Root_Op_Typ
, Actual_Targ_Typ
, Use_Full_View
=> True)
12067 and then not Tag_Checks_Suppressed
(Actual_Targ_Typ
)
12072 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
12073 Conv
:= Unchecked_Convert_To
(Target_Type
, Expression
(N
));
12075 Analyze_And_Resolve
(N
, Target_Type
);
12078 end Tagged_Conversion
;
12080 -- Case of other access type conversions
12082 elsif Is_Access_Type
(Target_Type
) then
12083 Apply_Constraint_Check
(Operand
, Target_Type
);
12085 -- Case of conversions from a fixed-point type
12087 -- These conversions require special expansion and processing, found in
12088 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12089 -- since from a semantic point of view, these are simple integer
12090 -- conversions, which do not need further processing except for the
12091 -- generation of range checks, which is performed at the end of this
12094 elsif Is_Fixed_Point_Type
(Operand_Type
)
12095 and then not Conversion_OK
(N
)
12097 -- We should never see universal fixed at this case, since the
12098 -- expansion of the constituent divide or multiply should have
12099 -- eliminated the explicit mention of universal fixed.
12101 pragma Assert
(Operand_Type
/= Universal_Fixed
);
12103 -- Check for special case of the conversion to universal real that
12104 -- occurs as a result of the use of a round attribute. In this case,
12105 -- the real type for the conversion is taken from the target type of
12106 -- the Round attribute and the result must be marked as rounded.
12108 if Target_Type
= Universal_Real
12109 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
12110 and then Attribute_Name
(Parent
(N
)) = Name_Round
12112 Set_Etype
(N
, Etype
(Parent
(N
)));
12113 Target_Type
:= Etype
(N
);
12114 Set_Rounded_Result
(N
);
12117 if Is_Fixed_Point_Type
(Target_Type
) then
12118 Expand_Convert_Fixed_To_Fixed
(N
);
12119 elsif Is_Integer_Type
(Target_Type
) then
12120 Expand_Convert_Fixed_To_Integer
(N
);
12122 pragma Assert
(Is_Floating_Point_Type
(Target_Type
));
12123 Expand_Convert_Fixed_To_Float
(N
);
12126 -- Case of conversions to a fixed-point type
12128 -- These conversions require special expansion and processing, found in
12129 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12130 -- since from a semantic point of view, these are simple integer
12131 -- conversions, which do not need further processing.
12133 elsif Is_Fixed_Point_Type
(Target_Type
)
12134 and then not Conversion_OK
(N
)
12136 if Is_Integer_Type
(Operand_Type
) then
12137 Expand_Convert_Integer_To_Fixed
(N
);
12139 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
12140 Expand_Convert_Float_To_Fixed
(N
);
12143 -- Case of array conversions
12145 -- Expansion of array conversions, add required length/range checks but
12146 -- only do this if there is no change of representation. For handling of
12147 -- this case, see Handle_Changed_Representation.
12149 elsif Is_Array_Type
(Target_Type
) then
12150 if Is_Constrained
(Target_Type
) then
12151 Apply_Length_Check
(Operand
, Target_Type
);
12153 -- If the object has an unconstrained array subtype with fixed
12154 -- lower bound, then sliding to that bound may be needed.
12156 if Is_Fixed_Lower_Bound_Array_Subtype
(Target_Type
) then
12157 Expand_Sliding_Conversion
(Operand
, Target_Type
);
12160 Apply_Range_Check
(Operand
, Target_Type
);
12163 Handle_Changed_Representation
;
12165 -- Case of conversions of discriminated types
12167 -- Add required discriminant checks if target is constrained. Again this
12168 -- change is skipped if we have a change of representation.
12170 elsif Has_Discriminants
(Target_Type
)
12171 and then Is_Constrained
(Target_Type
)
12173 Apply_Discriminant_Check
(Operand
, Target_Type
);
12174 Handle_Changed_Representation
;
12176 -- Case of all other record conversions. The only processing required
12177 -- is to check for a change of representation requiring the special
12178 -- assignment processing.
12180 elsif Is_Record_Type
(Target_Type
) then
12182 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12183 -- a derived Unchecked_Union type to an unconstrained type that is
12184 -- not Unchecked_Union if the operand lacks inferable discriminants.
12186 if Is_Derived_Type
(Operand_Type
)
12187 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
12188 and then not Is_Constrained
(Target_Type
)
12189 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
12190 and then not Has_Inferable_Discriminants
(Operand
)
12192 -- To prevent Gigi from generating illegal code, we generate a
12193 -- Program_Error node, but we give it the target type of the
12194 -- conversion (is this requirement documented somewhere ???)
12197 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
12198 Reason
=> PE_Unchecked_Union_Restriction
);
12201 Set_Etype
(PE
, Target_Type
);
12206 Handle_Changed_Representation
;
12209 -- Case of conversions of enumeration types
12211 elsif Is_Enumeration_Type
(Target_Type
) then
12213 -- Special processing is required if there is a change of
12214 -- representation (from enumeration representation clauses).
12216 if not Has_Compatible_Representation
(Target_Type
, Operand_Type
)
12217 and then not Conversion_OK
(N
)
12219 if Optimization_Level
> 0
12220 and then Is_Boolean_Type
(Target_Type
)
12222 -- Convert x(y) to (if y then x'(True) else x'(False)).
12223 -- Use literals, instead of indexing x'val, to enable
12224 -- further optimizations in the middle-end.
12227 Make_If_Expression
(Loc
,
12228 Expressions
=> New_List
(
12230 Convert_To
(Target_Type
,
12231 New_Occurrence_Of
(Standard_True
, Loc
)),
12232 Convert_To
(Target_Type
,
12233 New_Occurrence_Of
(Standard_False
, Loc
)))));
12236 -- Convert: x(y) to x'val (ytyp'pos (y))
12239 Make_Attribute_Reference
(Loc
,
12240 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
12241 Attribute_Name
=> Name_Val
,
12242 Expressions
=> New_List
(
12243 Make_Attribute_Reference
(Loc
,
12244 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
12245 Attribute_Name
=> Name_Pos
,
12246 Expressions
=> New_List
(Operand
)))));
12249 Analyze_And_Resolve
(N
, Target_Type
);
12253 -- At this stage, either the conversion node has been transformed into
12254 -- some other equivalent expression, or left as a conversion that can be
12255 -- handled by Gigi.
12257 -- The only remaining step is to generate a range check if we still have
12258 -- a type conversion at this stage and Do_Range_Check is set. Note that
12259 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12260 -- conversions here, because the float-to-integer case is entirely dealt
12261 -- with by Apply_Float_Conversion_Check.
12263 if Nkind
(N
) = N_Type_Conversion
12264 and then Do_Range_Check
(Expression
(N
))
12266 -- Float-to-float conversions
12268 if Is_Floating_Point_Type
(Target_Type
)
12269 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
12271 -- Reset overflow flag, since the range check will include
12272 -- dealing with possible overflow, and generate the check.
12274 Set_Do_Overflow_Check
(N
, False);
12276 Generate_Range_Check
12277 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
12279 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12280 -- conversions when Conversion_OK is set.
12282 elsif Is_Discrete_Type
(Target_Type
)
12283 and then (Is_Discrete_Type
(Etype
(Expression
(N
)))
12284 or else (Is_Fixed_Point_Type
(Etype
(Expression
(N
)))
12285 and then Conversion_OK
(N
)))
12287 -- If Address is either a source type or target type,
12288 -- suppress range check to avoid typing anomalies when
12289 -- it is a visible integer type.
12291 if Is_Descendant_Of_Address
(Etype
(Expression
(N
)))
12292 or else Is_Descendant_Of_Address
(Target_Type
)
12294 Set_Do_Range_Check
(Expression
(N
), False);
12296 Discrete_Range_Check
;
12299 -- Conversions to floating- or fixed-point when Conversion_OK is set
12301 elsif Is_Floating_Point_Type
(Target_Type
)
12302 or else (Is_Fixed_Point_Type
(Target_Type
)
12303 and then Conversion_OK
(N
))
12308 pragma Assert
(not Do_Range_Check
(Expression
(N
)));
12311 -- Here at end of processing
12314 -- Apply predicate check if required. Note that we can't just call
12315 -- Apply_Predicate_Check here, because the type looks right after
12316 -- the conversion and it would omit the check. The Comes_From_Source
12317 -- guard is necessary to prevent infinite recursions when we generate
12318 -- internal conversions for the purpose of checking predicates.
12320 -- A view conversion of a tagged object is an object and can appear
12321 -- in an assignment context, in which case no predicate check applies
12322 -- to the now-dead value.
12324 if Nkind
(Parent
(N
)) = N_Assignment_Statement
12325 and then N
= Name
(Parent
(N
))
12329 elsif Predicate_Enabled
(Target_Type
)
12330 and then Target_Type
/= Operand_Type
12331 and then Comes_From_Source
(N
)
12334 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
12337 -- Avoid infinite recursion on the subsequent expansion of the
12338 -- copy of the original type conversion. When needed, a range
12339 -- check has already been applied to the expression.
12341 Set_Comes_From_Source
(New_Expr
, False);
12343 Make_Predicate_Check
(Target_Type
, New_Expr
),
12344 Suppress
=> Range_Check
);
12347 end Expand_N_Type_Conversion
;
12349 -----------------------------------
12350 -- Expand_N_Unchecked_Expression --
12351 -----------------------------------
12353 -- Remove the unchecked expression node from the tree. Its job was simply
12354 -- to make sure that its constituent expression was handled with checks
12355 -- off, and now that is done, we can remove it from the tree, and indeed
12356 -- must, since Gigi does not expect to see these nodes.
12358 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
12359 Exp
: constant Node_Id
:= Expression
(N
);
12361 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
12363 end Expand_N_Unchecked_Expression
;
12365 ----------------------------------------
12366 -- Expand_N_Unchecked_Type_Conversion --
12367 ----------------------------------------
12369 -- If this cannot be handled by Gigi and we haven't already made a
12370 -- temporary for it, do it now.
12372 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
12373 Target_Type
: constant Entity_Id
:= Etype
(N
);
12374 Operand
: constant Node_Id
:= Expression
(N
);
12375 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12378 -- Nothing at all to do if conversion is to the identical type so remove
12379 -- the conversion completely, it is useless, except that it may carry
12380 -- an Assignment_OK indication which must be propagated to the operand.
12382 if Operand_Type
= Target_Type
then
12383 Expand_N_Unchecked_Expression
(N
);
12387 -- Generate an extra temporary for cases unsupported by the C backend
12389 if Modify_Tree_For_C
then
12391 Source
: constant Node_Id
:= Unqual_Conv
(Expression
(N
));
12392 Source_Typ
: Entity_Id
:= Get_Full_View
(Etype
(Source
));
12395 if Is_Packed_Array
(Source_Typ
) then
12396 Source_Typ
:= Packed_Array_Impl_Type
(Source_Typ
);
12399 if Nkind
(Source
) = N_Function_Call
12400 and then (Is_Composite_Type
(Etype
(Source
))
12401 or else Is_Composite_Type
(Target_Type
))
12403 Force_Evaluation
(Source
);
12408 -- Nothing to do if conversion is safe
12410 if Safe_Unchecked_Type_Conversion
(N
) then
12414 if Assignment_OK
(N
) then
12417 Force_Evaluation
(N
);
12419 end Expand_N_Unchecked_Type_Conversion
;
12421 ----------------------------
12422 -- Expand_Record_Equality --
12423 ----------------------------
12425 -- For non-variant records, Equality is expanded when needed into:
12427 -- and then Lhs.Discr1 = Rhs.Discr1
12429 -- and then Lhs.Discrn = Rhs.Discrn
12430 -- and then Lhs.Cmp1 = Rhs.Cmp1
12432 -- and then Lhs.Cmpn = Rhs.Cmpn
12434 -- The expression is folded by the back end for adjacent fields. This
12435 -- function is called for tagged record in only one occasion: for imple-
12436 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12437 -- otherwise the primitive "=" is used directly.
12439 function Expand_Record_Equality
12443 Rhs
: Node_Id
) return Node_Id
12445 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12450 First_Time
: Boolean := True;
12452 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
12453 -- Return the next discriminant or component to compare, starting with
12454 -- C, skipping inherited components.
12456 ------------------------
12457 -- Element_To_Compare --
12458 ------------------------
12460 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
12461 Comp
: Entity_Id
:= C
;
12464 while Present
(Comp
) loop
12465 -- Skip inherited components
12467 -- Note: for a tagged type, we always generate the "=" primitive
12468 -- for the base type (not on the first subtype), so the test for
12469 -- Comp /= Original_Record_Component (Comp) is True for inherited
12470 -- components only.
12472 if (Is_Tagged_Type
(Typ
)
12473 and then Comp
/= Original_Record_Component
(Comp
))
12477 or else Chars
(Comp
) = Name_uTag
12479 -- Skip interface elements (secondary tags???)
12481 or else Is_Interface
(Etype
(Comp
))
12483 Next_Component_Or_Discriminant
(Comp
);
12490 end Element_To_Compare
;
12492 -- Start of processing for Expand_Record_Equality
12495 -- Generates the following code: (assuming that Typ has one Discr and
12496 -- component C2 is also a record)
12498 -- Lhs.Discr1 = Rhs.Discr1
12499 -- and then Lhs.C1 = Rhs.C1
12500 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12502 -- and then Lhs.Cmpn = Rhs.Cmpn
12504 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
12505 C
:= Element_To_Compare
(First_Component_Or_Discriminant
(Typ
));
12506 while Present
(C
) loop
12517 New_Lhs
:= New_Copy_Tree
(Lhs
);
12518 New_Rhs
:= New_Copy_Tree
(Rhs
);
12522 Expand_Composite_Equality
12523 (Outer_Type
=> Typ
, Nod
=> Nod
, Comp_Type
=> Etype
(C
),
12525 Make_Selected_Component
(Loc
,
12527 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12529 Make_Selected_Component
(Loc
,
12531 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)));
12533 -- If some (sub)component is an unchecked_union, the whole
12534 -- operation will raise program error.
12536 if Nkind
(Check
) = N_Raise_Program_Error
then
12538 Set_Etype
(Result
, Standard_Boolean
);
12544 -- Generate logical "and" for CodePeer to simplify the
12545 -- generated code and analysis.
12547 elsif CodePeer_Mode
then
12550 Left_Opnd
=> Result
,
12551 Right_Opnd
=> Check
);
12555 Make_And_Then
(Loc
,
12556 Left_Opnd
=> Result
,
12557 Right_Opnd
=> Check
);
12562 First_Time
:= False;
12563 C
:= Element_To_Compare
(Next_Component_Or_Discriminant
(C
));
12567 end Expand_Record_Equality
;
12569 ---------------------------
12570 -- Expand_Set_Membership --
12571 ---------------------------
12573 procedure Expand_Set_Membership
(N
: Node_Id
) is
12574 Lop
: constant Node_Id
:= Left_Opnd
(N
);
12576 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
12577 -- If the alternative is a subtype mark, create a simple membership
12578 -- test. Otherwise create an equality test for it.
12584 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
12586 L
: constant Node_Id
:= New_Copy_Tree
(Lop
);
12587 R
: constant Node_Id
:= Relocate_Node
(Alt
);
12590 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
12591 or else Nkind
(Alt
) = N_Range
12593 Cond
:= Make_In
(Sloc
(Alt
), Left_Opnd
=> L
, Right_Opnd
=> R
);
12596 Cond
:= Make_Op_Eq
(Sloc
(Alt
), Left_Opnd
=> L
, Right_Opnd
=> R
);
12597 Resolve_Membership_Equality
(Cond
, Etype
(Alt
));
12606 Res
: Node_Id
:= Empty
;
12608 -- Start of processing for Expand_Set_Membership
12611 Remove_Side_Effects
(Lop
);
12613 -- We use left associativity as in the equivalent boolean case. This
12614 -- kind of canonicalization helps the optimizer of the code generator.
12616 Alt
:= First
(Alternatives
(N
));
12617 while Present
(Alt
) loop
12618 Evolve_Or_Else
(Res
, Make_Cond
(Alt
));
12623 Analyze_And_Resolve
(N
, Standard_Boolean
);
12624 end Expand_Set_Membership
;
12626 -----------------------------------
12627 -- Expand_Short_Circuit_Operator --
12628 -----------------------------------
12630 -- Deal with special expansion if actions are present for the right operand
12631 -- and deal with optimizing case of arguments being True or False. We also
12632 -- deal with the special case of non-standard boolean values.
12634 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
12635 Loc
: constant Source_Ptr
:= Sloc
(N
);
12636 Typ
: constant Entity_Id
:= Etype
(N
);
12637 Left
: constant Node_Id
:= Left_Opnd
(N
);
12638 Right
: constant Node_Id
:= Right_Opnd
(N
);
12639 LocR
: constant Source_Ptr
:= Sloc
(Right
);
12642 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
12643 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
12644 -- If Left = Shortcut_Value then Right need not be evaluated
12646 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
12647 -- For Opnd a boolean expression, return a Boolean expression equivalent
12648 -- to Opnd /= Shortcut_Value.
12650 function Useful
(Actions
: List_Id
) return Boolean;
12651 -- Return True if Actions contains useful nodes to process
12653 --------------------
12654 -- Make_Test_Expr --
12655 --------------------
12657 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
12659 if Shortcut_Value
then
12660 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
12664 end Make_Test_Expr
;
12670 function Useful
(Actions
: List_Id
) return Boolean is
12673 Action
:= First
(Actions
);
12675 -- For now "useful" means not N_Variable_Reference_Marker. Consider
12676 -- stripping other nodes in the future.
12678 while Present
(Action
) loop
12679 if Nkind
(Action
) /= N_Variable_Reference_Marker
then
12691 Op_Var
: Entity_Id
;
12692 -- Entity for a temporary variable holding the value of the operator,
12693 -- used for expansion in the case where actions are present.
12695 -- Start of processing for Expand_Short_Circuit_Operator
12698 -- Deal with non-standard booleans
12700 if Is_Boolean_Type
(Typ
) then
12701 Adjust_Condition
(Left
);
12702 Adjust_Condition
(Right
);
12703 Set_Etype
(N
, Standard_Boolean
);
12706 -- Check for cases where left argument is known to be True or False
12708 if Compile_Time_Known_Value
(Left
) then
12710 -- Mark SCO for left condition as compile time known
12712 if Generate_SCO
and then Comes_From_Source
(Left
) then
12713 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
12716 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
12717 -- Any actions associated with Right will be executed unconditionally
12718 -- and can thus be inserted into the tree unconditionally.
12720 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
12721 if Present
(Actions
(N
)) then
12722 Insert_Actions
(N
, Actions
(N
));
12725 Rewrite
(N
, Right
);
12727 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
12728 -- In this case we can forget the actions associated with Right,
12729 -- since they will never be executed.
12732 Kill_Dead_Code
(Right
);
12733 Kill_Dead_Code
(Actions
(N
));
12734 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
12737 Adjust_Result_Type
(N
, Typ
);
12741 -- If Actions are present for the right operand, we have to do some
12742 -- special processing. We can't just let these actions filter back into
12743 -- code preceding the short circuit (which is what would have happened
12744 -- if we had not trapped them in the short-circuit form), since they
12745 -- must only be executed if the right operand of the short circuit is
12746 -- executed and not otherwise.
12748 if Useful
(Actions
(N
)) then
12749 Actlist
:= Actions
(N
);
12751 -- The old approach is to expand:
12753 -- left AND THEN right
12757 -- C : Boolean := False;
12765 -- and finally rewrite the operator into a reference to C. Similarly
12766 -- for left OR ELSE right, with negated values. Note that this
12767 -- rewrite causes some difficulties for coverage analysis because
12768 -- of the introduction of the new variable C, which obscures the
12769 -- structure of the test.
12771 -- We use this "old approach" if Minimize_Expression_With_Actions
12774 if Minimize_Expression_With_Actions
then
12775 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
12778 Make_Object_Declaration
(Loc
,
12779 Defining_Identifier
=> Op_Var
,
12780 Object_Definition
=>
12781 New_Occurrence_Of
(Standard_Boolean
, Loc
),
12783 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
12785 Append_To
(Actlist
,
12786 Make_Implicit_If_Statement
(Right
,
12787 Condition
=> Make_Test_Expr
(Right
),
12788 Then_Statements
=> New_List
(
12789 Make_Assignment_Statement
(LocR
,
12790 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
12793 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
12796 Make_Implicit_If_Statement
(Left
,
12797 Condition
=> Make_Test_Expr
(Left
),
12798 Then_Statements
=> Actlist
));
12800 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
12801 Analyze_And_Resolve
(N
, Standard_Boolean
);
12803 -- The new approach (the default) is to use an
12804 -- Expression_With_Actions node for the right operand of the
12805 -- short-circuit form. Note that this solves the traceability
12806 -- problems for coverage analysis.
12810 Make_Expression_With_Actions
(LocR
,
12811 Expression
=> Relocate_Node
(Right
),
12812 Actions
=> Actlist
));
12814 Set_Actions
(N
, No_List
);
12815 Analyze_And_Resolve
(Right
, Standard_Boolean
);
12818 Adjust_Result_Type
(N
, Typ
);
12822 -- No actions present, check for cases of right argument True/False
12824 if Compile_Time_Known_Value
(Right
) then
12826 -- Mark SCO for left condition as compile time known
12828 if Generate_SCO
and then Comes_From_Source
(Right
) then
12829 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
12832 -- Change (Left and then True), (Left or else False) to Left. Note
12833 -- that we know there are no actions associated with the right
12834 -- operand, since we just checked for this case above.
12836 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
12839 -- Change (Left and then False), (Left or else True) to Right,
12840 -- making sure to preserve any side effects associated with the Left
12844 Remove_Side_Effects
(Left
);
12845 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
12849 Adjust_Result_Type
(N
, Typ
);
12850 end Expand_Short_Circuit_Operator
;
12852 -------------------------------------
12853 -- Expand_Unchecked_Union_Equality --
12854 -------------------------------------
12856 procedure Expand_Unchecked_Union_Equality
(N
: Node_Id
) is
12857 Loc
: constant Source_Ptr
:= Sloc
(N
);
12858 Eq
: constant Entity_Id
:= Entity
(Name
(N
));
12859 Lhs
: constant Node_Id
:= First_Actual
(N
);
12860 Rhs
: constant Node_Id
:= Next_Actual
(Lhs
);
12862 function Get_Discr_Values
(Op
: Node_Id
; Lhs
: Boolean) return Elist_Id
;
12863 -- Return the list of inferred discriminant values for Op
12865 ----------------------
12866 -- Get_Discr_Values --
12867 ----------------------
12869 function Get_Discr_Values
(Op
: Node_Id
; Lhs
: Boolean) return Elist_Id
12871 Typ
: constant Entity_Id
:= Etype
(Op
);
12872 Values
: constant Elist_Id
:= New_Elmt_List
;
12874 function Get_Extra_Formal
(Nam
: Name_Id
) return Entity_Id
;
12875 -- Return the extra formal Nam from the current scope, which must be
12876 -- an equality function for an unchecked union type.
12878 ----------------------
12879 -- Get_Extra_Formal --
12880 ----------------------
12882 function Get_Extra_Formal
(Nam
: Name_Id
) return Entity_Id
is
12883 Func
: constant Entity_Id
:= Current_Scope
;
12885 Formal
: Entity_Id
;
12888 pragma Assert
(Ekind
(Func
) = E_Function
);
12890 Formal
:= Extra_Formals
(Func
);
12891 while Present
(Formal
) loop
12892 if Chars
(Formal
) = Nam
then
12896 Formal
:= Extra_Formal
(Formal
);
12899 -- An extra formal of the proper name must be found
12901 raise Program_Error
;
12902 end Get_Extra_Formal
;
12908 -- Start of processing for Get_Discr_Values
12911 -- Per-object constrained selected components require special
12912 -- attention. If the enclosing scope of the component is an
12913 -- Unchecked_Union, we cannot reference its discriminants
12914 -- directly. This is why we use the extra parameters of the
12915 -- equality function of the enclosing Unchecked_Union.
12917 -- type UU_Type (Discr : Integer := 0) is
12920 -- pragma Unchecked_Union (UU_Type);
12922 -- 1. Unchecked_Union enclosing record:
12924 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
12926 -- Comp : UU_Type (Discr);
12928 -- end Enclosing_UU_Type;
12929 -- pragma Unchecked_Union (Enclosing_UU_Type);
12931 -- Obj1 : Enclosing_UU_Type;
12932 -- Obj2 : Enclosing_UU_Type (1);
12934 -- [. . .] Obj1 = Obj2 [. . .]
12938 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
12940 -- A and B are the formal parameters of the equality function
12941 -- of Enclosing_UU_Type. The function always has two extra
12942 -- formals to capture the inferred discriminant values for
12943 -- each discriminant of the type.
12945 -- 2. Non-Unchecked_Union enclosing record:
12948 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
12951 -- Comp : UU_Type (Discr);
12953 -- end Enclosing_Non_UU_Type;
12955 -- Obj1 : Enclosing_Non_UU_Type;
12956 -- Obj2 : Enclosing_Non_UU_Type (1);
12958 -- ... Obj1 = Obj2 ...
12962 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
12963 -- obj1.discr, obj2.discr)) then
12965 -- In this case we can directly reference the discriminants of
12966 -- the enclosing record.
12968 if Nkind
(Op
) = N_Selected_Component
12969 and then Has_Per_Object_Constraint
(Entity
(Selector_Name
(Op
)))
12971 -- If enclosing record is an Unchecked_Union, use formals
12972 -- corresponding to each discriminant. The name of the
12973 -- formal is that of the discriminant, with added suffix,
12974 -- see Exp_Ch3.Build_Variant_Record_Equality for details.
12976 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Op
)))) then
12979 (Scope
(Entity
(Selector_Name
(Op
))));
12980 while Present
(Discr
) loop
12985 (Chars
(Discr
), (if Lhs
then 'A' else 'B'))), Loc
),
12987 Next_Discriminant
(Discr
);
12990 -- If enclosing record is of a non-Unchecked_Union type, it
12991 -- is possible to reference its discriminants directly.
12994 Discr
:= First_Discriminant
(Typ
);
12995 while Present
(Discr
) loop
12997 (Make_Selected_Component
(Loc
,
12998 Prefix
=> Prefix
(Op
),
13001 (Get_Discriminant_Value
(Discr
,
13003 Stored_Constraint
(Typ
)))),
13005 Next_Discriminant
(Discr
);
13009 -- Otherwise operand is on object with a constrained type.
13010 -- Infer the discriminant values from the constraint.
13013 Discr
:= First_Discriminant
(Typ
);
13014 while Present
(Discr
) loop
13017 (Get_Discriminant_Value
(Discr
,
13019 Stored_Constraint
(Typ
))),
13021 Next_Discriminant
(Discr
);
13026 end Get_Discr_Values
;
13028 -- Start of processing for Expand_Unchecked_Union_Equality
13031 -- Guard against repeated invocation on the same node
13033 if Present
(Next_Actual
(Rhs
)) then
13037 -- If we can infer the discriminants of the operands, make a call to Eq
13039 if Has_Inferable_Discriminants
(Lhs
)
13041 Has_Inferable_Discriminants
(Rhs
)
13044 Lhs_Values
: constant Elist_Id
:= Get_Discr_Values
(Lhs
, True);
13045 Rhs_Values
: constant Elist_Id
:= Get_Discr_Values
(Rhs
, False);
13047 Formal
: Entity_Id
;
13052 -- Add the inferred discriminant values as extra actuals
13054 Formal
:= Extra_Formals
(Eq
);
13055 L_Elmt
:= First_Elmt
(Lhs_Values
);
13056 R_Elmt
:= First_Elmt
(Rhs_Values
);
13058 while Present
(L_Elmt
) loop
13059 Analyze_And_Resolve
(Node
(L_Elmt
), Etype
(Formal
));
13060 Add_Extra_Actual_To_Call
(N
, Formal
, Node
(L_Elmt
));
13062 Formal
:= Extra_Formal
(Formal
);
13064 Analyze_And_Resolve
(Node
(R_Elmt
), Etype
(Formal
));
13065 Add_Extra_Actual_To_Call
(N
, Formal
, Node
(R_Elmt
));
13067 Formal
:= Extra_Formal
(Formal
);
13068 Next_Elmt
(L_Elmt
);
13069 Next_Elmt
(R_Elmt
);
13073 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
13074 -- the predefined equality operator for an Unchecked_Union type
13075 -- if either of the operands lack inferable discriminants.
13079 Make_Raise_Program_Error
(Loc
,
13080 Reason
=> PE_Unchecked_Union_Restriction
));
13082 -- Give a warning on source equalities only, otherwise the message
13083 -- may appear out of place due to internal use. It is unconditional
13084 -- because it is required by the language.
13086 if Comes_From_Source
(Original_Node
(N
)) then
13088 ("Unchecked_Union discriminants cannot be determined??", N
);
13090 ("\Program_Error will be raised for equality operation??", N
);
13093 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
13095 end Expand_Unchecked_Union_Equality
;
13097 ------------------------------------
13098 -- Fixup_Universal_Fixed_Operation --
13099 -------------------------------------
13101 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
13102 Conv
: constant Node_Id
:= Parent
(N
);
13105 -- We must have a type conversion immediately above us
13107 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
13109 -- Normally the type conversion gives our target type. The exception
13110 -- occurs in the case of the Round attribute, where the conversion
13111 -- will be to universal real, and our real type comes from the Round
13112 -- attribute (as well as an indication that we must round the result)
13114 if Etype
(Conv
) = Universal_Real
13115 and then Nkind
(Parent
(Conv
)) = N_Attribute_Reference
13116 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
13118 Set_Etype
(N
, Base_Type
(Etype
(Parent
(Conv
))));
13119 Set_Rounded_Result
(N
);
13121 -- Normal case where type comes from conversion above us
13124 Set_Etype
(N
, Base_Type
(Etype
(Conv
)));
13126 end Fixup_Universal_Fixed_Operation
;
13128 ----------------------------
13129 -- Get_First_Index_Bounds --
13130 ----------------------------
13132 procedure Get_First_Index_Bounds
(T
: Entity_Id
; Lo
, Hi
: out Uint
) is
13136 pragma Assert
(Is_Array_Type
(T
));
13138 -- This follows Sem_Eval.Compile_Time_Known_Bounds
13140 if Ekind
(T
) = E_String_Literal_Subtype
then
13141 Lo
:= Expr_Value
(String_Literal_Low_Bound
(T
));
13142 Hi
:= Lo
+ String_Literal_Length
(T
) - 1;
13145 Typ
:= Underlying_Type
(Etype
(First_Index
(T
)));
13147 Lo
:= Expr_Value
(Type_Low_Bound
(Typ
));
13148 Hi
:= Expr_Value
(Type_High_Bound
(Typ
));
13150 end Get_First_Index_Bounds
;
13152 ------------------------
13153 -- Get_Size_For_Range --
13154 ------------------------
13156 function Get_Size_For_Range
(Lo
, Hi
: Uint
) return Uint
is
13158 function Is_OK_For_Range
(Siz
: Uint
) return Boolean;
13159 -- Return True if a signed integer with given size can cover Lo .. Hi
13161 --------------------------
13162 -- Is_OK_For_Range --
13163 --------------------------
13165 function Is_OK_For_Range
(Siz
: Uint
) return Boolean is
13166 B
: constant Uint
:= Uint_2
** (Siz
- 1);
13169 -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
13171 return Lo
>= -B
and then Hi
>= -B
and then Lo
< B
and then Hi
< B
;
13172 end Is_OK_For_Range
;
13175 -- This is (almost always) the size of Integer
13177 if Is_OK_For_Range
(Uint_32
) then
13182 elsif Is_OK_For_Range
(Uint_63
) then
13185 -- This is (almost always) the size of Long_Long_Integer
13187 elsif Is_OK_For_Range
(Uint_64
) then
13192 elsif Is_OK_For_Range
(Uint_127
) then
13198 end Get_Size_For_Range
;
13200 -------------------------------
13201 -- Insert_Dereference_Action --
13202 -------------------------------
13204 procedure Insert_Dereference_Action
(N
: Node_Id
) is
13205 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
13206 -- Return true if type of P is derived from Checked_Pool;
13208 -----------------------------
13209 -- Is_Checked_Storage_Pool --
13210 -----------------------------
13212 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
13221 while T
/= Etype
(T
) loop
13222 if Is_RTE
(T
, RE_Checked_Pool
) then
13230 end Is_Checked_Storage_Pool
;
13234 Context
: constant Node_Id
:= Parent
(N
);
13235 Ptr_Typ
: constant Entity_Id
:= Etype
(N
);
13236 Desig_Typ
: constant Entity_Id
:=
13237 Available_View
(Designated_Type
(Ptr_Typ
));
13238 Loc
: constant Source_Ptr
:= Sloc
(N
);
13239 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
13245 Size_Bits
: Node_Id
;
13248 -- Start of processing for Insert_Dereference_Action
13251 pragma Assert
(Nkind
(Context
) = N_Explicit_Dereference
);
13253 -- Do not re-expand a dereference which has already been processed by
13256 if Has_Dereference_Action
(Context
) then
13259 -- Do not perform this type of expansion for internally-generated
13262 elsif not Comes_From_Source
(Original_Node
(Context
)) then
13265 -- A dereference action is only applicable to objects which have been
13266 -- allocated on a checked pool.
13268 elsif not Is_Checked_Storage_Pool
(Pool
) then
13272 -- Extract the address of the dereferenced object. Generate:
13274 -- Addr : System.Address := <N>'Pool_Address;
13276 Addr
:= Make_Temporary
(Loc
, 'P');
13279 Make_Object_Declaration
(Loc
,
13280 Defining_Identifier
=> Addr
,
13281 Object_Definition
=>
13282 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
13284 Make_Attribute_Reference
(Loc
,
13285 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
13286 Attribute_Name
=> Name_Pool_Address
)));
13288 -- Calculate the size of the dereferenced object. Generate:
13290 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13293 Make_Explicit_Dereference
(Loc
,
13294 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13295 Set_Has_Dereference_Action
(Deref
);
13298 Make_Attribute_Reference
(Loc
,
13300 Attribute_Name
=> Name_Size
);
13302 -- Special case of an unconstrained array: need to add descriptor size
13304 if Is_Array_Type
(Desig_Typ
)
13305 and then not Is_Constrained
(First_Subtype
(Desig_Typ
))
13310 Make_Attribute_Reference
(Loc
,
13312 New_Occurrence_Of
(First_Subtype
(Desig_Typ
), Loc
),
13313 Attribute_Name
=> Name_Descriptor_Size
),
13314 Right_Opnd
=> Size_Bits
);
13317 Size
:= Make_Temporary
(Loc
, 'S');
13319 Make_Object_Declaration
(Loc
,
13320 Defining_Identifier
=> Size
,
13321 Object_Definition
=>
13322 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13324 Make_Op_Divide
(Loc
,
13325 Left_Opnd
=> Size_Bits
,
13326 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
13328 -- Calculate the alignment of the dereferenced object. Generate:
13329 -- Alig : constant Storage_Count := <N>.all'Alignment;
13332 Make_Explicit_Dereference
(Loc
,
13333 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13334 Set_Has_Dereference_Action
(Deref
);
13336 Alig
:= Make_Temporary
(Loc
, 'A');
13338 Make_Object_Declaration
(Loc
,
13339 Defining_Identifier
=> Alig
,
13340 Object_Definition
=>
13341 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13343 Make_Attribute_Reference
(Loc
,
13345 Attribute_Name
=> Name_Alignment
)));
13347 -- A dereference of a controlled object requires special processing. The
13348 -- finalization machinery requests additional space from the underlying
13349 -- pool to allocate and hide two pointers. As a result, a checked pool
13350 -- may mark the wrong memory as valid. Since checked pools do not have
13351 -- knowledge of hidden pointers, we have to bring the two pointers back
13352 -- in view in order to restore the original state of the object.
13354 -- The address manipulation is not performed for access types that are
13355 -- subject to pragma No_Heap_Finalization because the two pointers do
13356 -- not exist in the first place.
13358 if No_Heap_Finalization
(Ptr_Typ
) then
13361 elsif Needs_Finalization
(Desig_Typ
) then
13363 -- Adjust the address and size of the dereferenced object. Generate:
13364 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13367 Make_Procedure_Call_Statement
(Loc
,
13369 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
13370 Parameter_Associations
=> New_List
(
13371 New_Occurrence_Of
(Addr
, Loc
),
13372 New_Occurrence_Of
(Size
, Loc
),
13373 New_Occurrence_Of
(Alig
, Loc
)));
13375 -- Class-wide types complicate things because we cannot determine
13376 -- statically whether the actual object is truly controlled. We must
13377 -- generate a runtime check to detect this property. Generate:
13379 -- if Needs_Finalization (<N>.all'Tag) then
13383 if Is_Class_Wide_Type
(Desig_Typ
) then
13385 Make_Explicit_Dereference
(Loc
,
13386 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13387 Set_Has_Dereference_Action
(Deref
);
13390 Make_Implicit_If_Statement
(N
,
13392 Make_Function_Call
(Loc
,
13394 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
13395 Parameter_Associations
=> New_List
(
13396 Make_Attribute_Reference
(Loc
,
13398 Attribute_Name
=> Name_Tag
))),
13399 Then_Statements
=> New_List
(Stmt
));
13402 Insert_Action
(N
, Stmt
);
13406 -- Dereference (Pool, Addr, Size, Alig);
13409 Make_Procedure_Call_Statement
(Loc
,
13412 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
13413 Parameter_Associations
=> New_List
(
13414 New_Occurrence_Of
(Pool
, Loc
),
13415 New_Occurrence_Of
(Addr
, Loc
),
13416 New_Occurrence_Of
(Size
, Loc
),
13417 New_Occurrence_Of
(Alig
, Loc
))));
13419 -- Mark the explicit dereference as processed to avoid potential
13420 -- infinite expansion.
13422 Set_Has_Dereference_Action
(Context
);
13425 when RE_Not_Available
=>
13427 end Insert_Dereference_Action
;
13429 --------------------------------
13430 -- Integer_Promotion_Possible --
13431 --------------------------------
13433 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
13434 Operand
: constant Node_Id
:= Expression
(N
);
13435 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
13436 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
13439 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
13443 -- We only do the transformation for source constructs. We assume
13444 -- that the expander knows what it is doing when it generates code.
13446 Comes_From_Source
(N
)
13448 -- If the operand type is Short_Integer or Short_Short_Integer,
13449 -- then we will promote to Integer, which is available on all
13450 -- targets, and is sufficient to ensure no intermediate overflow.
13451 -- Furthermore it is likely to be as efficient or more efficient
13452 -- than using the smaller type for the computation so we do this
13453 -- unconditionally.
13456 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
13458 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
13460 -- Test for interesting operation, which includes addition,
13461 -- division, exponentiation, multiplication, subtraction, absolute
13462 -- value and unary negation. Unary "+" is omitted since it is a
13463 -- no-op and thus can't overflow.
13465 and then Nkind
(Operand
) in
13466 N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
13467 N_Op_Minus | N_Op_Multiply | N_Op_Subtract
;
13468 end Integer_Promotion_Possible
;
13470 ------------------------------
13471 -- Make_Array_Comparison_Op --
13472 ------------------------------
13474 -- This is a hand-coded expansion of the following generic function:
13477 -- type elem is (<>);
13478 -- type index is (<>);
13479 -- type a is array (index range <>) of elem;
13481 -- function Gnnn (X : a; Y: a) return boolean is
13482 -- J : index := Y'first;
13485 -- if X'length = 0 then
13488 -- elsif Y'length = 0 then
13492 -- for I in X'range loop
13493 -- if X (I) = Y (J) then
13494 -- if J = Y'last then
13497 -- J := index'succ (J);
13501 -- return X (I) > Y (J);
13505 -- return X'length > Y'length;
13509 -- Note that since we are essentially doing this expansion by hand, we
13510 -- do not need to generate an actual or formal generic part, just the
13511 -- instantiated function itself.
13513 function Make_Array_Comparison_Op
13515 Nod
: Node_Id
) return Node_Id
13517 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
13519 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
13520 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
13521 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
13522 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13524 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
13526 Loop_Statement
: Node_Id
;
13527 Loop_Body
: Node_Id
;
13529 Inner_If
: Node_Id
;
13530 Final_Expr
: Node_Id
;
13531 Func_Body
: Node_Id
;
13532 Func_Name
: Entity_Id
;
13538 -- if J = Y'last then
13541 -- J := index'succ (J);
13545 Make_Implicit_If_Statement
(Nod
,
13548 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
13550 Make_Attribute_Reference
(Loc
,
13551 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13552 Attribute_Name
=> Name_Last
)),
13554 Then_Statements
=> New_List
(
13555 Make_Exit_Statement
(Loc
)),
13559 Make_Assignment_Statement
(Loc
,
13560 Name
=> New_Occurrence_Of
(J
, Loc
),
13562 Make_Attribute_Reference
(Loc
,
13563 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
13564 Attribute_Name
=> Name_Succ
,
13565 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
13567 -- if X (I) = Y (J) then
13570 -- return X (I) > Y (J);
13574 Make_Implicit_If_Statement
(Nod
,
13578 Make_Indexed_Component
(Loc
,
13579 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13580 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13583 Make_Indexed_Component
(Loc
,
13584 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13585 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
13587 Then_Statements
=> New_List
(Inner_If
),
13589 Else_Statements
=> New_List
(
13590 Make_Simple_Return_Statement
(Loc
,
13594 Make_Indexed_Component
(Loc
,
13595 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13596 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13599 Make_Indexed_Component
(Loc
,
13600 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13601 Expressions
=> New_List
(
13602 New_Occurrence_Of
(J
, Loc
)))))));
13604 -- for I in X'range loop
13609 Make_Implicit_Loop_Statement
(Nod
,
13610 Identifier
=> Empty
,
13612 Iteration_Scheme
=>
13613 Make_Iteration_Scheme
(Loc
,
13614 Loop_Parameter_Specification
=>
13615 Make_Loop_Parameter_Specification
(Loc
,
13616 Defining_Identifier
=> I
,
13617 Discrete_Subtype_Definition
=>
13618 Make_Attribute_Reference
(Loc
,
13619 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13620 Attribute_Name
=> Name_Range
))),
13622 Statements
=> New_List
(Loop_Body
));
13624 -- if X'length = 0 then
13626 -- elsif Y'length = 0 then
13629 -- for ... loop ... end loop;
13630 -- return X'length > Y'length;
13634 Make_Attribute_Reference
(Loc
,
13635 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13636 Attribute_Name
=> Name_Length
);
13639 Make_Attribute_Reference
(Loc
,
13640 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13641 Attribute_Name
=> Name_Length
);
13645 Left_Opnd
=> Length1
,
13646 Right_Opnd
=> Length2
);
13649 Make_Implicit_If_Statement
(Nod
,
13653 Make_Attribute_Reference
(Loc
,
13654 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13655 Attribute_Name
=> Name_Length
),
13657 Make_Integer_Literal
(Loc
, 0)),
13661 Make_Simple_Return_Statement
(Loc
,
13662 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
13664 Elsif_Parts
=> New_List
(
13665 Make_Elsif_Part
(Loc
,
13669 Make_Attribute_Reference
(Loc
,
13670 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13671 Attribute_Name
=> Name_Length
),
13673 Make_Integer_Literal
(Loc
, 0)),
13677 Make_Simple_Return_Statement
(Loc
,
13678 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
13680 Else_Statements
=> New_List
(
13682 Make_Simple_Return_Statement
(Loc
,
13683 Expression
=> Final_Expr
)));
13687 Formals
:= New_List
(
13688 Make_Parameter_Specification
(Loc
,
13689 Defining_Identifier
=> X
,
13690 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13692 Make_Parameter_Specification
(Loc
,
13693 Defining_Identifier
=> Y
,
13694 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13696 -- function Gnnn (...) return boolean is
13697 -- J : index := Y'first;
13702 Func_Name
:= Make_Temporary
(Loc
, 'G');
13705 Make_Subprogram_Body
(Loc
,
13707 Make_Function_Specification
(Loc
,
13708 Defining_Unit_Name
=> Func_Name
,
13709 Parameter_Specifications
=> Formals
,
13710 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
13712 Declarations
=> New_List
(
13713 Make_Object_Declaration
(Loc
,
13714 Defining_Identifier
=> J
,
13715 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
13717 Make_Attribute_Reference
(Loc
,
13718 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13719 Attribute_Name
=> Name_First
))),
13721 Handled_Statement_Sequence
=>
13722 Make_Handled_Sequence_Of_Statements
(Loc
,
13723 Statements
=> New_List
(If_Stat
)));
13726 end Make_Array_Comparison_Op
;
13728 ---------------------------
13729 -- Make_Boolean_Array_Op --
13730 ---------------------------
13732 -- For logical operations on boolean arrays, expand in line the following,
13733 -- replacing 'and' with 'or' or 'xor' where needed:
13735 -- function Annn (A : typ; B: typ) return typ is
13738 -- for J in A'range loop
13739 -- C (J) := A (J) op B (J);
13744 -- or in the case of Transform_Function_Array:
13746 -- procedure Annn (A : typ; B: typ; RESULT: out typ) is
13748 -- for J in A'range loop
13749 -- RESULT (J) := A (J) op B (J);
13753 -- Here typ is the boolean array type
13755 function Make_Boolean_Array_Op
13757 N
: Node_Id
) return Node_Id
13759 Loc
: constant Source_Ptr
:= Sloc
(N
);
13761 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
13762 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
13763 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13773 Func_Name
: Entity_Id
;
13774 Func_Body
: Node_Id
;
13775 Loop_Statement
: Node_Id
;
13778 if Transform_Function_Array
then
13779 C
:= Make_Defining_Identifier
(Loc
, Name_UP_RESULT
);
13781 C
:= Make_Defining_Identifier
(Loc
, Name_uC
);
13785 Make_Indexed_Component
(Loc
,
13786 Prefix
=> New_Occurrence_Of
(A
, Loc
),
13787 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13790 Make_Indexed_Component
(Loc
,
13791 Prefix
=> New_Occurrence_Of
(B
, Loc
),
13792 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13795 Make_Indexed_Component
(Loc
,
13796 Prefix
=> New_Occurrence_Of
(C
, Loc
),
13797 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
13799 if Nkind
(N
) = N_Op_And
then
13803 Right_Opnd
=> B_J
);
13805 elsif Nkind
(N
) = N_Op_Or
then
13809 Right_Opnd
=> B_J
);
13815 Right_Opnd
=> B_J
);
13819 Make_Implicit_Loop_Statement
(N
,
13820 Identifier
=> Empty
,
13822 Iteration_Scheme
=>
13823 Make_Iteration_Scheme
(Loc
,
13824 Loop_Parameter_Specification
=>
13825 Make_Loop_Parameter_Specification
(Loc
,
13826 Defining_Identifier
=> J
,
13827 Discrete_Subtype_Definition
=>
13828 Make_Attribute_Reference
(Loc
,
13829 Prefix
=> New_Occurrence_Of
(A
, Loc
),
13830 Attribute_Name
=> Name_Range
))),
13832 Statements
=> New_List
(
13833 Make_Assignment_Statement
(Loc
,
13835 Expression
=> Op
)));
13837 Formals
:= New_List
(
13838 Make_Parameter_Specification
(Loc
,
13839 Defining_Identifier
=> A
,
13840 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13842 Make_Parameter_Specification
(Loc
,
13843 Defining_Identifier
=> B
,
13844 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13846 if Transform_Function_Array
then
13847 Append_To
(Formals
,
13848 Make_Parameter_Specification
(Loc
,
13849 Defining_Identifier
=> C
,
13850 Out_Present
=> True,
13851 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13854 Func_Name
:= Make_Temporary
(Loc
, 'A');
13855 Set_Is_Inlined
(Func_Name
);
13857 if Transform_Function_Array
then
13859 Make_Subprogram_Body
(Loc
,
13861 Make_Procedure_Specification
(Loc
,
13862 Defining_Unit_Name
=> Func_Name
,
13863 Parameter_Specifications
=> Formals
),
13865 Declarations
=> New_List
,
13867 Handled_Statement_Sequence
=>
13868 Make_Handled_Sequence_Of_Statements
(Loc
,
13869 Statements
=> New_List
(Loop_Statement
)));
13873 Make_Subprogram_Body
(Loc
,
13875 Make_Function_Specification
(Loc
,
13876 Defining_Unit_Name
=> Func_Name
,
13877 Parameter_Specifications
=> Formals
,
13878 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
13880 Declarations
=> New_List
(
13881 Make_Object_Declaration
(Loc
,
13882 Defining_Identifier
=> C
,
13883 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
13885 Handled_Statement_Sequence
=>
13886 Make_Handled_Sequence_Of_Statements
(Loc
,
13887 Statements
=> New_List
(
13889 Make_Simple_Return_Statement
(Loc
,
13890 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
13894 end Make_Boolean_Array_Op
;
13896 -----------------------------------------
13897 -- Minimized_Eliminated_Overflow_Check --
13898 -----------------------------------------
13900 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
13902 -- The MINIMIZED mode operates in Long_Long_Integer so we cannot use it
13903 -- if the type of the expression is already larger.
13906 Is_Signed_Integer_Type
(Etype
(N
))
13907 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
13908 and then not (Overflow_Check_Mode
= Minimized
13910 Esize
(Etype
(N
)) > Standard_Long_Long_Integer_Size
);
13911 end Minimized_Eliminated_Overflow_Check
;
13913 ----------------------------
13914 -- Narrow_Large_Operation --
13915 ----------------------------
13917 procedure Narrow_Large_Operation
(N
: Node_Id
) is
13918 Kind
: constant Node_Kind
:= Nkind
(N
);
13919 Otyp
: constant Entity_Id
:= Etype
(N
);
13920 In_Rng
: constant Boolean := Kind
= N_In
;
13921 Binary
: constant Boolean := Kind
in N_Binary_Op
or else In_Rng
;
13922 Compar
: constant Boolean := Kind
in N_Op_Compare
or else In_Rng
;
13923 R
: constant Node_Id
:= Right_Opnd
(N
);
13924 Typ
: constant Entity_Id
:= Etype
(R
);
13925 Tsiz
: constant Uint
:= RM_Size
(Typ
);
13939 -- Start of processing for Narrow_Large_Operation
13942 -- First, determine the range of the left operand, if any
13945 L
:= Left_Opnd
(N
);
13946 Determine_Range
(L
, OK
, Llo
, Lhi
, Assume_Valid
=> True);
13957 -- Second, determine the range of the right operand, which can itself
13958 -- be a range, in which case we take the lower bound of the low bound
13959 -- and the upper bound of the high bound.
13967 (Low_Bound
(R
), OK
, Rlo
, Zhi
, Assume_Valid
=> True);
13973 (High_Bound
(R
), OK
, Zlo
, Rhi
, Assume_Valid
=> True);
13980 Determine_Range
(R
, OK
, Rlo
, Rhi
, Assume_Valid
=> True);
13986 -- Then compute a size suitable for each range
13989 Lsiz
:= Get_Size_For_Range
(Llo
, Lhi
);
13994 Rsiz
:= Get_Size_For_Range
(Rlo
, Rhi
);
13996 -- Now compute the size of the narrower type
13999 -- The type must be able to accommodate the operands
14001 Nsiz
:= UI_Max
(Lsiz
, Rsiz
);
14004 -- The type must be able to accommodate the operand(s) and result.
14006 -- Note that Determine_Range typically does not report the bounds of
14007 -- the value as being larger than those of the base type, which means
14008 -- that it does not report overflow (see also Enable_Overflow_Check).
14010 Determine_Range
(N
, OK
, Nlo
, Nhi
, Assume_Valid
=> True);
14015 -- Therefore, if Nsiz is not lower than the size of the original type
14016 -- here, we cannot be sure that the operation does not overflow.
14018 Nsiz
:= Get_Size_For_Range
(Nlo
, Nhi
);
14019 Nsiz
:= UI_Max
(Nsiz
, Lsiz
);
14020 Nsiz
:= UI_Max
(Nsiz
, Rsiz
);
14023 -- If the size is not lower than the size of the original type, then
14024 -- there is no point in changing the type, except in the case where
14025 -- we can remove a conversion to the original type from an operand.
14028 and then not (Binary
14029 and then Nkind
(L
) = N_Type_Conversion
14030 and then Entity
(Subtype_Mark
(L
)) = Typ
)
14031 and then not (Nkind
(R
) = N_Type_Conversion
14032 and then Entity
(Subtype_Mark
(R
)) = Typ
)
14037 -- Now pick the narrower type according to the size. We use the base
14038 -- type instead of the first subtype because operations are done in
14039 -- the base type, so this avoids the need for useless conversions.
14041 if Nsiz
<= System_Max_Integer_Size
then
14042 Ntyp
:= Etype
(Integer_Type_For
(Nsiz
, Uns
=> False));
14047 -- Finally, rewrite the operation in the narrower type, but make sure
14048 -- not to perform name resolution for the operator again.
14050 Nop
:= New_Op_Node
(Kind
, Sloc
(N
));
14051 if Nkind
(N
) in N_Has_Entity
then
14052 Set_Entity
(Nop
, Entity
(N
));
14056 Set_Left_Opnd
(Nop
, Convert_To
(Ntyp
, L
));
14060 Set_Right_Opnd
(Nop
,
14061 Make_Range
(Sloc
(N
),
14062 Convert_To
(Ntyp
, Low_Bound
(R
)),
14063 Convert_To
(Ntyp
, High_Bound
(R
))));
14065 Set_Right_Opnd
(Nop
, Convert_To
(Ntyp
, R
));
14071 -- Analyze it with the comparison type and checks suppressed since
14072 -- the conversions of the operands cannot overflow.
14074 Analyze_And_Resolve
(N
, Otyp
, Suppress
=> Overflow_Check
);
14077 -- Analyze it with the narrower type and checks suppressed, but only
14078 -- when we are sure that the operation does not overflow, see above.
14080 if Nsiz
< Tsiz
then
14081 Analyze_And_Resolve
(N
, Ntyp
, Suppress
=> Overflow_Check
);
14083 Analyze_And_Resolve
(N
, Ntyp
);
14086 -- Put back a conversion to the original type
14088 Convert_To_And_Rewrite
(Typ
, N
);
14090 end Narrow_Large_Operation
;
14092 --------------------------------
14093 -- Optimize_Length_Comparison --
14094 --------------------------------
14096 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
14097 Loc
: constant Source_Ptr
:= Sloc
(N
);
14098 Typ
: constant Entity_Id
:= Etype
(N
);
14103 -- First and Last attribute reference nodes, which end up as left and
14104 -- right operands of the optimized result.
14107 -- True for comparison operand of zero
14109 Maybe_Superflat
: Boolean;
14110 -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set
14111 -- to false but the comparison operand can be zero at run time. In this
14112 -- case, we normally cannot do anything because the canonical formula of
14113 -- the length is not valid, but there is one exception: when the operand
14114 -- is itself the length of an array with the same bounds as the array on
14115 -- the LHS, we can entirely optimize away the comparison.
14118 -- Comparison operand, set only if Is_Zero is false
14120 Ent
: array (Pos
range 1 .. 2) of Entity_Id
:= (Empty
, Empty
);
14121 -- Entities whose length is being compared
14123 Index
: array (Pos
range 1 .. 2) of Node_Id
:= (Empty
, Empty
);
14124 -- Integer_Literal nodes for length attribute expressions, or Empty
14125 -- if there is no such expression present.
14127 Op
: Node_Kind
:= Nkind
(N
);
14128 -- Kind of comparison operator, gets flipped if operands backwards
14130 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
;
14131 -- Given a discrete expression, returns a Long_Long_Integer typed
14132 -- expression representing the underlying value of the expression.
14133 -- This is done with an unchecked conversion to Long_Long_Integer.
14134 -- We use unchecked conversion to handle the enumeration type case.
14136 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean;
14137 -- Tests if N is a length attribute applied to a simple entity. If so,
14138 -- returns True, and sets Ent to the entity, and Index to the integer
14139 -- literal provided as an attribute expression, or to Empty if none.
14140 -- Num is the index designating the relevant slot in Ent and Index.
14141 -- Also returns True if the expression is a generated type conversion
14142 -- whose expression is of the desired form. This latter case arises
14143 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
14144 -- to check for being in range, which is not needed in this context.
14145 -- Returns False if neither condition holds.
14147 function Is_Optimizable
(N
: Node_Id
) return Boolean;
14148 -- Tests N to see if it is an optimizable comparison value (defined as
14149 -- constant zero or one, or something else where the value is known to
14150 -- be nonnegative and in the 32-bit range and where the corresponding
14151 -- Length value is also known to be 32 bits). If result is true, sets
14152 -- Is_Zero, Maybe_Superflat and Comp accordingly.
14154 procedure Rewrite_For_Equal_Lengths
;
14155 -- Rewrite the comparison of two equal lengths into either True or False
14157 ----------------------------------
14158 -- Convert_To_Long_Long_Integer --
14159 ----------------------------------
14161 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
is
14163 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
14164 end Convert_To_Long_Long_Integer
;
14166 ----------------------
14167 -- Is_Entity_Length --
14168 ----------------------
14170 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean is
14172 if Nkind
(N
) = N_Attribute_Reference
14173 and then Attribute_Name
(N
) = Name_Length
14174 and then Is_Entity_Name
(Prefix
(N
))
14176 Ent
(Num
) := Entity
(Prefix
(N
));
14178 if Present
(Expressions
(N
)) then
14179 Index
(Num
) := First
(Expressions
(N
));
14181 Index
(Num
) := Empty
;
14186 elsif Nkind
(N
) = N_Type_Conversion
14187 and then not Comes_From_Source
(N
)
14189 return Is_Entity_Length
(Expression
(N
), Num
);
14194 end Is_Entity_Length
;
14196 --------------------
14197 -- Is_Optimizable --
14198 --------------------
14200 function Is_Optimizable
(N
: Node_Id
) return Boolean is
14210 if Compile_Time_Known_Value
(N
) then
14211 Val
:= Expr_Value
(N
);
14213 if Val
= Uint_0
then
14215 Maybe_Superflat
:= False;
14219 elsif Val
= Uint_1
then
14221 Maybe_Superflat
:= False;
14227 -- Here we have to make sure of being within a 32-bit range (take the
14228 -- full unsigned range so the length of 32-bit arrays is accepted).
14230 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
14233 or else Lo
< Uint_0
14234 or else Hi
> Uint_2
** 32
14239 Maybe_Superflat
:= (Lo
= Uint_0
);
14241 -- Tests if N is also a length attribute applied to a simple entity
14243 Dbl
:= Is_Entity_Length
(N
, 2);
14245 -- We can deal with the superflat case only if N is also a length
14247 if Maybe_Superflat
and then not Dbl
then
14251 -- Comparison value was within range, so now we must check the index
14252 -- value to make sure it is also within 32 bits.
14254 for K
in Pos
range 1 .. 2 loop
14255 Indx
:= First_Index
(Etype
(Ent
(K
)));
14257 if Present
(Index
(K
)) then
14258 for J
in 2 .. UI_To_Int
(Intval
(Index
(K
))) loop
14263 Ityp
:= Etype
(Indx
);
14265 if Esize
(Ityp
) > 32 then
14275 end Is_Optimizable
;
14277 -------------------------------
14278 -- Rewrite_For_Equal_Lengths --
14279 -------------------------------
14281 procedure Rewrite_For_Equal_Lengths
is
14290 New_Occurrence_Of
(Standard_True
, Sloc
(N
))));
14298 New_Occurrence_Of
(Standard_False
, Sloc
(N
))));
14301 raise Program_Error
;
14304 Analyze_And_Resolve
(N
, Typ
);
14305 end Rewrite_For_Equal_Lengths
;
14307 -- Start of processing for Optimize_Length_Comparison
14310 -- Nothing to do if not a comparison
14312 if Op
not in N_Op_Compare
then
14316 -- Nothing to do if special -gnatd.P debug flag set.
14318 if Debug_Flag_Dot_PP
then
14322 -- Ent'Length op 0/1
14324 if Is_Entity_Length
(Left_Opnd
(N
), 1)
14325 and then Is_Optimizable
(Right_Opnd
(N
))
14329 -- 0/1 op Ent'Length
14331 elsif Is_Entity_Length
(Right_Opnd
(N
), 1)
14332 and then Is_Optimizable
(Left_Opnd
(N
))
14334 -- Flip comparison to opposite sense
14337 when N_Op_Lt
=> Op
:= N_Op_Gt
;
14338 when N_Op_Le
=> Op
:= N_Op_Ge
;
14339 when N_Op_Gt
=> Op
:= N_Op_Lt
;
14340 when N_Op_Ge
=> Op
:= N_Op_Le
;
14341 when others => null;
14344 -- Else optimization not possible
14350 -- Fall through if we will do the optimization
14352 -- Cases to handle:
14354 -- X'Length = 0 => X'First > X'Last
14355 -- X'Length = 1 => X'First = X'Last
14356 -- X'Length = n => X'First + (n - 1) = X'Last
14358 -- X'Length /= 0 => X'First <= X'Last
14359 -- X'Length /= 1 => X'First /= X'Last
14360 -- X'Length /= n => X'First + (n - 1) /= X'Last
14362 -- X'Length >= 0 => always true, warn
14363 -- X'Length >= 1 => X'First <= X'Last
14364 -- X'Length >= n => X'First + (n - 1) <= X'Last
14366 -- X'Length > 0 => X'First <= X'Last
14367 -- X'Length > 1 => X'First < X'Last
14368 -- X'Length > n => X'First + (n - 1) < X'Last
14370 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
14371 -- X'Length <= 1 => X'First >= X'Last
14372 -- X'Length <= n => X'First + (n - 1) >= X'Last
14374 -- X'Length < 0 => always false (warn)
14375 -- X'Length < 1 => X'First > X'Last
14376 -- X'Length < n => X'First + (n - 1) > X'Last
14378 -- Note: for the cases of n (not constant 0,1), we require that the
14379 -- corresponding index type be integer or shorter (i.e. not 64-bit),
14380 -- and the same for the comparison value. Then we do the comparison
14381 -- using 64-bit arithmetic (actually long long integer), so that we
14382 -- cannot have overflow intefering with the result.
14384 -- First deal with warning cases
14393 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
14394 Analyze_And_Resolve
(N
, Typ
);
14395 Warn_On_Known_Condition
(N
);
14402 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
14403 Analyze_And_Resolve
(N
, Typ
);
14404 Warn_On_Known_Condition
(N
);
14408 if Constant_Condition_Warnings
14409 and then Comes_From_Source
(Original_Node
(N
))
14411 Error_Msg_N
("could replace by ""'=""?c?", N
);
14421 -- Build the First reference we will use
14424 Make_Attribute_Reference
(Loc
,
14425 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14426 Attribute_Name
=> Name_First
);
14428 if Present
(Index
(1)) then
14429 Set_Expressions
(Left
, New_List
(New_Copy
(Index
(1))));
14432 -- Build the Last reference we will use
14435 Make_Attribute_Reference
(Loc
,
14436 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14437 Attribute_Name
=> Name_Last
);
14439 if Present
(Index
(1)) then
14440 Set_Expressions
(Right
, New_List
(New_Copy
(Index
(1))));
14443 -- If general value case, then do the addition of (n - 1), and
14444 -- also add the needed conversions to type Long_Long_Integer.
14446 -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into:
14448 -- Y'Last + (X'First - Y'First) op X'Last
14450 -- in the hope that X'First - Y'First can be computed statically.
14452 if Present
(Comp
) then
14453 if Present
(Ent
(2)) then
14455 Y_First
: constant Node_Id
:=
14456 Make_Attribute_Reference
(Loc
,
14457 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14458 Attribute_Name
=> Name_First
);
14459 Y_Last
: constant Node_Id
:=
14460 Make_Attribute_Reference
(Loc
,
14461 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14462 Attribute_Name
=> Name_Last
);
14463 R
: Compare_Result
;
14466 if Present
(Index
(2)) then
14467 Set_Expressions
(Y_First
, New_List
(New_Copy
(Index
(2))));
14468 Set_Expressions
(Y_Last
, New_List
(New_Copy
(Index
(2))));
14474 -- If X'First = Y'First, simplify the above formula into a
14475 -- direct comparison of Y'Last and X'Last.
14477 R
:= Compile_Time_Compare
(Left
, Y_First
, Assume_Valid
=> True);
14483 R
:= Compile_Time_Compare
14484 (Right
, Y_Last
, Assume_Valid
=> True);
14486 -- If the pairs of attributes are equal, we are done
14489 Rewrite_For_Equal_Lengths
;
14493 -- If the base types are different, convert both operands to
14494 -- Long_Long_Integer, else compare them directly.
14496 if Base_Type
(Etype
(Right
)) /= Base_Type
(Etype
(Y_Last
))
14498 Left
:= Convert_To_Long_Long_Integer
(Y_Last
);
14504 -- Otherwise, use the above formula as-is
14510 Convert_To_Long_Long_Integer
(Y_Last
),
14512 Make_Op_Subtract
(Loc
,
14514 Convert_To_Long_Long_Integer
(Left
),
14516 Convert_To_Long_Long_Integer
(Y_First
)));
14520 -- General value case
14525 Left_Opnd
=> Convert_To_Long_Long_Integer
(Left
),
14527 Make_Op_Subtract
(Loc
,
14528 Left_Opnd
=> Convert_To_Long_Long_Integer
(Comp
),
14529 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
14533 -- We cannot do anything in the superflat case past this point
14535 if Maybe_Superflat
then
14539 -- If general operand, convert Last reference to Long_Long_Integer
14541 if Present
(Comp
) then
14542 Right
:= Convert_To_Long_Long_Integer
(Right
);
14545 -- Check for cases to optimize
14547 -- X'Length = 0 => X'First > X'Last
14548 -- X'Length < 1 => X'First > X'Last
14549 -- X'Length < n => X'First + (n - 1) > X'Last
14551 if (Is_Zero
and then Op
= N_Op_Eq
)
14552 or else (not Is_Zero
and then Op
= N_Op_Lt
)
14557 Right_Opnd
=> Right
);
14559 -- X'Length = 1 => X'First = X'Last
14560 -- X'Length = n => X'First + (n - 1) = X'Last
14562 elsif not Is_Zero
and then Op
= N_Op_Eq
then
14566 Right_Opnd
=> Right
);
14568 -- X'Length /= 0 => X'First <= X'Last
14569 -- X'Length > 0 => X'First <= X'Last
14571 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
14575 Right_Opnd
=> Right
);
14577 -- X'Length /= 1 => X'First /= X'Last
14578 -- X'Length /= n => X'First + (n - 1) /= X'Last
14580 elsif not Is_Zero
and then Op
= N_Op_Ne
then
14584 Right_Opnd
=> Right
);
14586 -- X'Length >= 1 => X'First <= X'Last
14587 -- X'Length >= n => X'First + (n - 1) <= X'Last
14589 elsif not Is_Zero
and then Op
= N_Op_Ge
then
14593 Right_Opnd
=> Right
);
14595 -- X'Length > 1 => X'First < X'Last
14596 -- X'Length > n => X'First + (n = 1) < X'Last
14598 elsif not Is_Zero
and then Op
= N_Op_Gt
then
14602 Right_Opnd
=> Right
);
14604 -- X'Length <= 1 => X'First >= X'Last
14605 -- X'Length <= n => X'First + (n - 1) >= X'Last
14607 elsif not Is_Zero
and then Op
= N_Op_Le
then
14611 Right_Opnd
=> Right
);
14613 -- Should not happen at this stage
14616 raise Program_Error
;
14619 -- Rewrite and finish up (we can suppress overflow checks, see above)
14621 Rewrite
(N
, Result
);
14622 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Overflow_Check
);
14623 end Optimize_Length_Comparison
;
14625 --------------------------------------
14626 -- Process_Transients_In_Expression --
14627 --------------------------------------
14629 procedure Process_Transients_In_Expression
14633 procedure Process_Transient_In_Expression
(Obj_Decl
: Node_Id
);
14634 -- Process the object whose declaration Obj_Decl is present in Stmts
14636 -------------------------------------
14637 -- Process_Transient_In_Expression --
14638 -------------------------------------
14640 procedure Process_Transient_In_Expression
(Obj_Decl
: Node_Id
) is
14641 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
14642 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Obj_Decl
);
14644 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Expr
);
14645 -- The node after which to insert deferred finalization actions. This
14646 -- is usually the innermost enclosing non-transient construct.
14648 Fin_Context
: Node_Id
;
14649 -- The node after which to insert the finalization actions
14651 Master_Node_Decl
: Node_Id
;
14652 Master_Node_Id
: Entity_Id
;
14653 -- Declaration and entity of the Master_Node respectively
14656 -- When the context is a Boolean evaluation, all three nodes capture
14657 -- the result of their computation in a local temporary:
14660 -- Trans_Id : Ctrl_Typ := ...;
14661 -- Result : constant Boolean := ... Trans_Id ...;
14662 -- <finalize Trans_Id>
14665 -- As a result, the finalization of any transient objects can take
14666 -- place just after the result is captured, except for the case of
14667 -- conditional expressions in a simple return statement because the
14668 -- return statement will be distributed into dependent expressions
14669 -- (see the special handling of simple return statements below).
14671 -- ??? could this be extended to elementary types?
14673 if Is_Boolean_Type
(Etype
(Expr
))
14675 (Nkind
(Expr
) = N_Expression_With_Actions
14676 or else Nkind
(Parent
(Expr
)) /= N_Simple_Return_Statement
)
14678 Fin_Context
:= Last
(Stmts
);
14680 -- Otherwise the immediate context may not be safe enough to carry
14681 -- out transient object finalization due to aliasing and nesting of
14682 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14683 -- enclosing non-transient construct.
14686 Fin_Context
:= Hook_Context
;
14689 -- Create the declaration of the Master_Node for the object and
14690 -- insert it before the context. It will later be picked up by
14691 -- the general finalization mechanism (see Build_Finalizer).
14693 Master_Node_Id
:= Make_Temporary
(Loc
, 'N');
14694 Master_Node_Decl
:=
14695 Make_Master_Node_Declaration
(Loc
, Master_Node_Id
, Obj_Id
);
14696 Insert_Action
(Hook_Context
, Master_Node_Decl
);
14698 -- Generate the attachment of the object to the Master_Node
14700 Attach_Object_To_Master_Node
(Obj_Decl
, Master_Node_Id
);
14702 -- When the node is part of a return statement, there is no need
14703 -- to insert a finalization call, as the general finalization
14704 -- mechanism (see Build_Finalizer) would take care of the master
14705 -- on subprogram exit. Note that it would also be impossible to
14706 -- insert the finalization call after the return statement as
14707 -- this will render it unreachable.
14709 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
14712 -- Finalize the object after the context has been evaluated
14714 -- Note that the node returned by Find_Hook_Context above may be an
14715 -- operator, which is not a list member. We must locate the proper
14716 -- node in the tree after which to insert the finalization call.
14719 while not Is_List_Member
(Fin_Context
) loop
14720 Fin_Context
:= Parent
(Fin_Context
);
14723 pragma Assert
(Present
(Fin_Context
));
14725 Insert_Action_After
(Fin_Context
,
14726 Make_Procedure_Call_Statement
(Loc
,
14728 New_Occurrence_Of
(RTE
(RE_Finalize_Object
), Loc
),
14729 Parameter_Associations
=> New_List
(
14730 New_Occurrence_Of
(Master_Node_Id
, Loc
))));
14733 -- Mark the transient object to avoid double finalization
14735 Set_Is_Finalized_Transient
(Obj_Id
);
14736 end Process_Transient_In_Expression
;
14742 -- Start of processing for Process_Transients_In_Expression
14745 pragma Assert
(Nkind
(Expr
) in N_Case_Expression
14746 | N_Expression_With_Actions
14747 | N_If_Expression
);
14749 Decl
:= First
(Stmts
);
14750 while Present
(Decl
) loop
14751 if Nkind
(Decl
) = N_Object_Declaration
14752 and then Is_Finalizable_Transient
(Decl
, Expr
)
14754 Process_Transient_In_Expression
(Decl
);
14759 end Process_Transients_In_Expression
;
14761 ------------------------
14762 -- Rewrite_Comparison --
14763 ------------------------
14765 procedure Rewrite_Comparison
(N
: Node_Id
) is
14766 Typ
: constant Entity_Id
:= Etype
(N
);
14768 False_Result
: Boolean;
14769 True_Result
: Boolean;
14772 if Nkind
(N
) = N_Type_Conversion
then
14773 Rewrite_Comparison
(Expression
(N
));
14776 elsif Nkind
(N
) not in N_Op_Compare
then
14780 -- If both operands are static, then the comparison has been already
14781 -- folded in evaluation.
14784 (not Is_Static_Expression
(Left_Opnd
(N
))
14786 not Is_Static_Expression
(Right_Opnd
(N
)));
14788 -- Determine the potential outcome of the comparison assuming that the
14789 -- operands are valid and emit a warning when the comparison evaluates
14790 -- to True or False only in the presence of invalid values.
14792 Warn_On_Constant_Valid_Condition
(N
);
14794 -- Determine the potential outcome of the comparison assuming that the
14795 -- operands are not valid.
14799 Assume_Valid
=> False,
14800 True_Result
=> True_Result
,
14801 False_Result
=> False_Result
);
14803 -- The outcome is a decisive False or True, rewrite the operator into a
14804 -- non-static literal.
14806 if False_Result
or True_Result
then
14809 New_Occurrence_Of
(Boolean_Literals
(True_Result
), Sloc
(N
))));
14811 Analyze_And_Resolve
(N
, Typ
);
14812 Set_Is_Static_Expression
(N
, False);
14813 Warn_On_Known_Condition
(N
);
14815 end Rewrite_Comparison
;
14817 ----------------------------
14818 -- Safe_In_Place_Array_Op --
14819 ----------------------------
14821 function Safe_In_Place_Array_Op
14824 Op2
: Node_Id
) return Boolean
14826 Target
: Entity_Id
;
14828 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
14829 -- Operand is safe if it cannot overlap part of the target of the
14830 -- operation. If the operand and the target are identical, the operand
14831 -- is safe. The operand can be empty in the case of negation.
14833 function Is_Unaliased
(N
: Node_Id
) return Boolean;
14834 -- Check that N is a stand-alone entity
14840 function Is_Unaliased
(N
: Node_Id
) return Boolean is
14844 and then No
(Address_Clause
(Entity
(N
)))
14845 and then No
(Renamed_Object
(Entity
(N
)));
14848 ---------------------
14849 -- Is_Safe_Operand --
14850 ---------------------
14852 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
14857 elsif Is_Entity_Name
(Op
) then
14858 return Is_Unaliased
(Op
);
14860 elsif Nkind
(Op
) in N_Indexed_Component | N_Selected_Component
then
14861 return Is_Unaliased
(Prefix
(Op
));
14863 elsif Nkind
(Op
) = N_Slice
then
14865 Is_Unaliased
(Prefix
(Op
))
14866 and then Entity
(Prefix
(Op
)) /= Target
;
14868 elsif Nkind
(Op
) = N_Op_Not
then
14869 return Is_Safe_Operand
(Right_Opnd
(Op
));
14874 end Is_Safe_Operand
;
14876 -- Start of processing for Safe_In_Place_Array_Op
14879 -- Skip this processing if the component size is different from system
14880 -- storage unit (since at least for NOT this would cause problems).
14882 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
14885 -- Cannot do in place stuff if non-standard Boolean representation
14887 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
14890 elsif not Is_Unaliased
(Lhs
) then
14894 Target
:= Entity
(Lhs
);
14895 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
14897 end Safe_In_Place_Array_Op
;
14899 -----------------------
14900 -- Tagged_Membership --
14901 -----------------------
14903 -- There are two different cases to consider depending on whether the right
14904 -- operand is a class-wide type or not. If not we just compare the actual
14905 -- tag of the left expr to the target type tag:
14907 -- Left_Expr.Tag = Right_Type'Tag;
14909 -- If it is a class-wide type we use the RT function CW_Membership which is
14910 -- usually implemented by looking in the ancestor tables contained in the
14911 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
14913 -- In both cases if Left_Expr is an access type, we first check whether it
14916 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
14917 -- function IW_Membership which is usually implemented by looking in the
14918 -- table of abstract interface types plus the ancestor table contained in
14919 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
14921 procedure Tagged_Membership
14923 SCIL_Node
: out Node_Id
;
14924 Result
: out Node_Id
)
14926 Left
: constant Node_Id
:= Left_Opnd
(N
);
14927 Right
: constant Node_Id
:= Right_Opnd
(N
);
14928 Loc
: constant Source_Ptr
:= Sloc
(N
);
14930 -- Handle entities from the limited view
14932 Orig_Right_Type
: constant Entity_Id
:= Available_View
(Etype
(Right
));
14934 Full_R_Typ
: Entity_Id
;
14935 Left_Type
: Entity_Id
:= Available_View
(Etype
(Left
));
14936 Right_Type
: Entity_Id
:= Orig_Right_Type
;
14940 SCIL_Node
:= Empty
;
14942 -- We have to examine the corresponding record type when dealing with
14943 -- protected types instead of the original, unexpanded, type.
14945 if Ekind
(Right_Type
) = E_Protected_Type
then
14946 Right_Type
:= Corresponding_Record_Type
(Right_Type
);
14949 if Ekind
(Left_Type
) = E_Protected_Type
then
14950 Left_Type
:= Corresponding_Record_Type
(Left_Type
);
14953 -- In the case where the type is an access type, the test is applied
14954 -- using the designated types (needed in Ada 2012 for implicit anonymous
14955 -- access conversions, for AI05-0149).
14957 if Is_Access_Type
(Right_Type
) then
14958 Left_Type
:= Designated_Type
(Left_Type
);
14959 Right_Type
:= Designated_Type
(Right_Type
);
14962 if Is_Class_Wide_Type
(Left_Type
) then
14963 Left_Type
:= Root_Type
(Left_Type
);
14966 if Is_Class_Wide_Type
(Right_Type
) then
14967 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
14969 Full_R_Typ
:= Underlying_Type
(Right_Type
);
14973 Make_Selected_Component
(Loc
,
14974 Prefix
=> Relocate_Node
(Left
),
14976 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
14978 if Is_Class_Wide_Type
(Right_Type
) then
14980 -- No need to issue a run-time check if we statically know that the
14981 -- result of this membership test is always true. For example,
14982 -- considering the following declarations:
14984 -- type Iface is interface;
14985 -- type T is tagged null record;
14986 -- type DT is new T and Iface with null record;
14991 -- These membership tests are always true:
14994 -- Obj2 in T'Class;
14995 -- Obj2 in Iface'Class;
14997 -- We do not need to handle cases where the membership is illegal.
15000 -- Obj1 in DT'Class; -- Compile time error
15001 -- Obj1 in Iface'Class; -- Compile time error
15003 if not Is_Interface
(Left_Type
)
15004 and then not Is_Class_Wide_Type
(Left_Type
)
15005 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
15006 Use_Full_View
=> True)
15007 or else (Is_Interface
(Etype
(Right_Type
))
15008 and then Interface_Present_In_Ancestor
15010 Iface
=> Etype
(Right_Type
))))
15012 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
15016 -- Ada 2005 (AI-251): Class-wide applied to interfaces
15018 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
15020 -- Support to: "Iface_CW_Typ in Typ'Class"
15022 or else Is_Interface
(Left_Type
)
15024 -- Issue error if IW_Membership operation not available in a
15025 -- configurable run-time setting.
15027 if not RTE_Available
(RE_IW_Membership
) then
15029 ("dynamic membership test on interface types", N
);
15035 Make_Function_Call
(Loc
,
15036 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
15037 Parameter_Associations
=> New_List
(
15038 Make_Attribute_Reference
(Loc
,
15040 Attribute_Name
=> Name_Address
),
15041 New_Occurrence_Of
(
15042 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15045 -- Ada 95: Normal case
15048 -- Issue error if CW_Membership operation not available in a
15049 -- configurable run-time setting.
15051 if not RTE_Available
(RE_CW_Membership
) then
15053 ("dynamic membership test on tagged types", N
);
15059 Make_Function_Call
(Loc
,
15060 Name
=> New_Occurrence_Of
(RTE
(RE_CW_Membership
), Loc
),
15061 Parameter_Associations
=> New_List
(
15063 New_Occurrence_Of
(
15064 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15067 -- Generate the SCIL node for this class-wide membership test.
15069 if Generate_SCIL
then
15070 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
15071 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
15072 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
15076 -- Right_Type is not a class-wide type
15079 -- No need to check the tag of the object if Right_Typ is abstract
15081 if Is_Abstract_Type
(Right_Type
) then
15082 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
15087 Left_Opnd
=> Obj_Tag
,
15090 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
15094 -- if Left is an access object then generate test of the form:
15095 -- * if Right_Type excludes null: Left /= null and then ...
15096 -- * if Right_Type includes null: Left = null or else ...
15098 if Is_Access_Type
(Orig_Right_Type
) then
15099 if Can_Never_Be_Null
(Orig_Right_Type
) then
15100 Result
:= Make_And_Then
(Loc
,
15104 Right_Opnd
=> Make_Null
(Loc
)),
15105 Right_Opnd
=> Result
);
15108 Result
:= Make_Or_Else
(Loc
,
15112 Right_Opnd
=> Make_Null
(Loc
)),
15113 Right_Opnd
=> Result
);
15116 end Tagged_Membership
;
15118 ------------------------------
15119 -- Unary_Op_Validity_Checks --
15120 ------------------------------
15122 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
15124 if Validity_Checks_On
and Validity_Check_Operands
then
15125 Ensure_Valid
(Right_Opnd
(N
));
15127 end Unary_Op_Validity_Checks
;