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
);
566 Aggr_In_Place
: Boolean;
571 TagT
: Entity_Id
:= Empty
;
572 -- Type used as source for tag assignment
574 TagR
: Node_Id
:= Empty
;
575 -- Target reference for tag assignment
578 -- Handle call to C++ constructor
580 if Is_CPP_Constructor_Call
(Exp
) then
581 Make_CPP_Constructor_Call_In_Allocator
583 Function_Call
=> Exp
);
588 -- type A is access T1;
589 -- X : A := new T2'(...);
590 -- T1 and T2 can be different subtypes, and we might need to check
591 -- both constraints. First check against the type of the qualified
594 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
596 Aggr_In_Place
:= Is_Delayed_Aggregate
(Exp
);
598 -- If the expression is an aggregate to be built in place, then we need
599 -- to delay applying predicate checks, because this would result in the
600 -- creation of a temporary, which is illegal for limited types,
602 if not Aggr_In_Place
then
603 Apply_Predicate_Check
(Exp
, T
);
606 -- Check that any anonymous access discriminants are suitable
607 -- for use in an allocator.
609 -- Note: This check is performed here instead of during analysis so that
610 -- we can check against the fully resolved etype of Exp.
612 if Is_Entity_Name
(Exp
)
613 and then Has_Anonymous_Access_Discriminant
(Etype
(Exp
))
614 and then Static_Accessibility_Level
(Exp
, Object_Decl_Level
)
615 > Static_Accessibility_Level
(N
, Object_Decl_Level
)
617 -- A dynamic check and a warning are generated when we are within
622 Make_Raise_Program_Error
(Loc
,
623 Reason
=> PE_Accessibility_Check_Failed
));
625 Error_Msg_Warn
:= SPARK_Mode
/= On
;
626 Error_Msg_N
("anonymous access discriminant is too deep for use"
627 & " in allocator<<", N
);
628 Error_Msg_N
("\Program_Error [<<", N
);
630 -- Otherwise, make the error static
633 Error_Msg_N
("anonymous access discriminant is too deep for use"
634 & " in allocator", N
);
638 if Do_Range_Check
(Exp
) then
639 Generate_Range_Check
(Exp
, T
, CE_Range_Check_Failed
);
642 -- A check is also needed in cases where the designated subtype is
643 -- constrained and differs from the subtype given in the qualified
644 -- expression. Note that the check on the qualified expression does
645 -- not allow sliding, but this check does (a relaxation from Ada 83).
647 if Is_Constrained
(DesigT
)
648 and then not Subtypes_Statically_Match
(T
, DesigT
)
650 Apply_Constraint_Check
(Exp
, DesigT
, No_Sliding
=> False);
652 Apply_Predicate_Check
(Exp
, DesigT
);
654 if Do_Range_Check
(Exp
) then
655 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
659 if Nkind
(Exp
) = N_Raise_Constraint_Error
then
660 Rewrite
(N
, New_Copy
(Exp
));
665 -- Case of tagged type or type requiring finalization
667 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
669 -- Ada 2005 (AI-318-02): If the initialization expression is a call
670 -- to a build-in-place function, then access to the allocated object
671 -- must be passed to the function.
673 if Is_Build_In_Place_Function_Call
(Exp
) then
674 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
675 Apply_Accessibility_Check_For_Allocator
676 (N
, Exp
, N
, Built_In_Place
=> True);
679 -- Ada 2005 (AI-318-02): Specialization of the previous case for
680 -- expressions containing a build-in-place function call whose
681 -- returned object covers interface types, and Expr has calls to
682 -- Ada.Tags.Displace to displace the pointer to the returned build-
683 -- in-place object to reference the secondary dispatch table of a
684 -- covered interface type.
686 elsif Present
(Unqual_BIP_Iface_Function_Call
(Exp
)) then
687 Make_Build_In_Place_Iface_Call_In_Allocator
(N
, Exp
);
688 Apply_Accessibility_Check_For_Allocator
689 (N
, Exp
, N
, Built_In_Place
=> True);
693 -- Actions inserted before:
694 -- Temp : constant ptr_T := new T'(Expression);
695 -- Temp._tag = T'tag; -- when not class-wide
696 -- [Deep_]Adjust (Temp.all);
698 -- We analyze by hand the new internal allocator to avoid any
699 -- recursion and inappropriate call to Initialize.
701 -- We don't want to remove side effects when the expression must be
702 -- built in place and we don't need it when there is no storage pool
703 -- or this is a return/secondary stack allocation.
706 and then Present
(Storage_Pool
(N
))
707 and then not Is_RTE
(Storage_Pool
(N
), RE_RS_Pool
)
708 and then not Is_RTE
(Storage_Pool
(N
), RE_SS_Pool
)
710 Remove_Side_Effects
(Exp
);
713 Temp
:= Make_Temporary
(Loc
, 'P', N
);
715 -- For a class wide allocation generate the following code:
717 -- type Equiv_Record is record ... end record;
718 -- implicit subtype CW is <Class_Wide_Subytpe>;
719 -- temp : PtrT := new CW'(CW!(expr));
721 if Is_Class_Wide_Type
(T
) then
722 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
724 -- Ada 2005 (AI-251): If the expression is a class-wide interface
725 -- object we generate code to move up "this" to reference the
726 -- base of the object before allocating the new object.
728 -- Note that Exp'Address is recursively expanded into a call
729 -- to Base_Address (Exp.Tag)
731 if Is_Class_Wide_Type
(Etype
(Exp
))
732 and then Is_Interface
(Etype
(Exp
))
733 and then Tagged_Type_Expansion
737 Unchecked_Convert_To
(Entity
(Indic
),
738 Make_Explicit_Dereference
(Loc
,
739 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
740 Make_Attribute_Reference
(Loc
,
742 Attribute_Name
=> Name_Address
)))));
746 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
749 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
752 -- Processing for allocators returning non-interface types
754 if not Is_Interface
(DesigT
) then
755 if Aggr_In_Place
then
757 Make_Object_Declaration
(Loc
,
758 Defining_Identifier
=> Temp
,
759 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
763 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
765 -- Copy the Comes_From_Source flag for the allocator we just
766 -- built, since logically this allocator is a replacement of
767 -- the original allocator node. This is for proper handling of
768 -- restriction No_Implicit_Heap_Allocations.
770 Preserve_Comes_From_Source
771 (Expression
(Temp_Decl
), N
);
773 Set_No_Initialization
(Expression
(Temp_Decl
));
774 Insert_Action
(N
, Temp_Decl
);
776 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
777 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
780 Node
:= Relocate_Node
(N
);
784 Make_Object_Declaration
(Loc
,
785 Defining_Identifier
=> Temp
,
786 Constant_Present
=> True,
787 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
790 Insert_Action
(N
, Temp_Decl
);
791 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
794 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
795 -- interface type. In this case we use the type of the qualified
796 -- expression to allocate the object.
800 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
805 Make_Full_Type_Declaration
(Loc
,
806 Defining_Identifier
=> Def_Id
,
808 Make_Access_To_Object_Definition
(Loc
,
810 Null_Exclusion_Present
=> False,
812 Is_Access_Constant
(Etype
(N
)),
813 Subtype_Indication
=>
814 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
816 Insert_Action
(N
, New_Decl
);
818 -- Inherit the allocation-related attributes from the original
821 Set_Finalization_Master
822 (Def_Id
, Finalization_Master
(PtrT
));
824 Set_Associated_Storage_Pool
825 (Def_Id
, Associated_Storage_Pool
(PtrT
));
827 -- Declare the object using the previous type declaration
829 if Aggr_In_Place
then
831 Make_Object_Declaration
(Loc
,
832 Defining_Identifier
=> Temp
,
833 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
836 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
838 -- Copy the Comes_From_Source flag for the allocator we just
839 -- built, since logically this allocator is a replacement of
840 -- the original allocator node. This is for proper handling
841 -- of restriction No_Implicit_Heap_Allocations.
843 Set_Comes_From_Source
844 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
846 Set_No_Initialization
(Expression
(Temp_Decl
));
847 Insert_Action
(N
, Temp_Decl
);
849 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
850 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
853 Node
:= Relocate_Node
(N
);
857 Make_Object_Declaration
(Loc
,
858 Defining_Identifier
=> Temp
,
859 Constant_Present
=> True,
860 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
863 Insert_Action
(N
, Temp_Decl
);
864 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
867 -- Generate an additional object containing the address of the
868 -- returned object. The type of this second object declaration
869 -- is the correct type required for the common processing that
870 -- is still performed by this subprogram. The displacement of
871 -- this pointer to reference the component associated with the
872 -- interface type will be done at the end of common processing.
875 Make_Object_Declaration
(Loc
,
876 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
877 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
879 Unchecked_Convert_To
(PtrT
,
880 New_Occurrence_Of
(Temp
, Loc
)));
882 Insert_Action
(N
, New_Decl
);
884 Temp_Decl
:= New_Decl
;
885 Temp
:= Defining_Identifier
(New_Decl
);
889 -- Generate the tag assignment
891 -- Suppress the tag assignment for VM targets because VM tags are
892 -- represented implicitly in objects.
894 if not Tagged_Type_Expansion
then
897 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
898 -- interface objects because in this case the tag does not change.
900 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
901 pragma Assert
(Is_Class_Wide_Type
902 (Directly_Designated_Type
(Etype
(N
))));
905 -- Likewise if the allocator is made for a special return object
907 elsif Special_Return
then
910 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
913 Make_Explicit_Dereference
(Loc
,
914 Prefix
=> New_Occurrence_Of
(Temp
, Loc
));
916 elsif Is_Private_Type
(T
)
917 and then Is_Tagged_Type
(Underlying_Type
(T
))
919 TagT
:= Underlying_Type
(T
);
921 Unchecked_Convert_To
(Underlying_Type
(T
),
922 Make_Explicit_Dereference
(Loc
,
923 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
926 if Present
(TagT
) then
928 Make_Tag_Assignment_From_Type
929 (Loc
, TagR
, Underlying_Type
(TagT
)));
932 -- Generate an Adjust call if the object will be moved. In Ada 2005,
933 -- the object may be inherently limited, in which case there is no
934 -- Adjust procedure, and the object is built in place. In Ada 95, the
935 -- object can be limited but not inherently limited if this allocator
936 -- came from a return statement (we're allocating the result on the
937 -- secondary stack); in that case, the object will be moved, so we do
938 -- want to Adjust. But the call is always skipped if the allocator is
939 -- made for a special return object because it's generated elsewhere.
941 -- Needs_Finalization (DesigT) may differ from Needs_Finalization (T)
942 -- if one of the two types is class-wide, and the other is not.
944 if Needs_Finalization
(DesigT
)
945 and then Needs_Finalization
(T
)
946 and then not Is_Inherently_Limited_Type
(T
)
947 and then not Aggr_In_Place
948 and then Nkind
(Exp
) /= N_Function_Call
949 and then not Special_Return
951 -- An unchecked conversion is needed in the classwide case because
952 -- the designated type can be an ancestor of the subtype mark of
958 Unchecked_Convert_To
(T
,
959 Make_Explicit_Dereference
(Loc
,
960 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
963 if Present
(Adj_Call
) then
964 Insert_Action
(N
, Adj_Call
);
968 -- Note: the accessibility check must be inserted after the call to
969 -- [Deep_]Adjust to ensure proper completion of the assignment.
971 Apply_Accessibility_Check_For_Allocator
(N
, Exp
, Temp
);
973 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
974 Analyze_And_Resolve
(N
, PtrT
);
976 if Aggr_In_Place
then
977 Apply_Predicate_Check
(N
, T
, Deref
=> True);
980 -- Ada 2005 (AI-251): Displace the pointer to reference the record
981 -- component containing the secondary dispatch table of the interface
984 if Is_Interface
(DesigT
) then
985 Displace_Allocator_Pointer
(N
);
988 -- Always force the generation of a temporary for aggregates when
989 -- generating C code, to simplify the work in the code generator.
992 or else (Modify_Tree_For_C
and then Nkind
(Exp
) = N_Aggregate
)
994 Temp
:= Make_Temporary
(Loc
, 'P', N
);
996 Make_Object_Declaration
(Loc
,
997 Defining_Identifier
=> Temp
,
998 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1000 Make_Allocator
(Loc
,
1001 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1003 -- Copy the Comes_From_Source flag for the allocator we just built,
1004 -- since logically this allocator is a replacement of the original
1005 -- allocator node. This is for proper handling of restriction
1006 -- No_Implicit_Heap_Allocations.
1008 Set_Comes_From_Source
1009 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1011 Set_No_Initialization
(Expression
(Temp_Decl
));
1012 Insert_Action
(N
, Temp_Decl
);
1014 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1015 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1017 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1018 Analyze_And_Resolve
(N
, PtrT
);
1020 if Aggr_In_Place
then
1021 Apply_Predicate_Check
(N
, T
, Deref
=> True);
1024 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1025 Install_Null_Excluding_Check
(Exp
);
1027 elsif Is_Access_Type
(DesigT
)
1028 and then Nkind
(Exp
) = N_Allocator
1029 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1031 -- Apply constraint to designated subtype indication
1033 Apply_Constraint_Check
1034 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1036 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1038 -- Propagate constraint_error to enclosing allocator
1040 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1044 Build_Allocate_Deallocate_Proc
(N
, True);
1046 -- For an access to unconstrained packed array, GIGI needs to see an
1047 -- expression with a constrained subtype in order to compute the
1048 -- proper size for the allocator.
1050 if Is_Packed_Array
(T
)
1051 and then not Is_Constrained
(T
)
1054 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1055 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1058 Make_Subtype_Declaration
(Loc
,
1059 Defining_Identifier
=> ConstrT
,
1060 Subtype_Indication
=>
1061 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1062 Freeze_Itype
(ConstrT
, Exp
);
1063 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1067 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1068 -- to a build-in-place function, then access to the allocated object
1069 -- must be passed to the function.
1071 if Is_Build_In_Place_Function_Call
(Exp
) then
1072 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1077 when RE_Not_Available
=>
1079 end Expand_Allocator_Expression
;
1081 -----------------------------
1082 -- Expand_Array_Comparison --
1083 -----------------------------
1085 -- Expansion is only required in the case of array types. For the unpacked
1086 -- case, an appropriate runtime routine is called. For packed cases, and
1087 -- also in some other cases where a runtime routine cannot be called, the
1088 -- form of the expansion is:
1090 -- [body for greater_nn; boolean_expression]
1092 -- The body is built by Make_Array_Comparison_Op, and the form of the
1093 -- Boolean expression depends on the operator involved.
1095 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1096 Loc
: constant Source_Ptr
:= Sloc
(N
);
1097 Op1
: Node_Id
:= Left_Opnd
(N
);
1098 Op2
: Node_Id
:= Right_Opnd
(N
);
1099 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1100 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1103 Func_Body
: Node_Id
;
1104 Func_Name
: Entity_Id
;
1108 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1109 -- True for byte addressable target
1111 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1112 -- Returns True if the length of the given operand is known to be less
1113 -- than 4. Returns False if this length is known to be four or greater
1114 -- or is not known at compile time.
1116 ------------------------
1117 -- Length_Less_Than_4 --
1118 ------------------------
1120 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1121 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1124 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1125 return String_Literal_Length
(Otyp
) < 4;
1127 elsif Compile_Time_Known_Bounds
(Otyp
) then
1132 Get_First_Index_Bounds
(Otyp
, Lo
, Hi
);
1139 end Length_Less_Than_4
;
1141 -- Start of processing for Expand_Array_Comparison
1144 -- Deal first with unpacked case, where we can call a runtime routine
1145 -- except that we avoid this for targets for which are not addressable
1148 if not Is_Bit_Packed_Array
(Typ1
) and then Byte_Addressable
then
1149 -- The call we generate is:
1151 -- Compare_Array_xn[_Unaligned]
1152 -- (left'address, right'address, left'length, right'length) <op> 0
1154 -- x = U for unsigned, S for signed
1155 -- n = 8,16,32,64,128 for component size
1156 -- Add _Unaligned if length < 4 and component size is 8.
1157 -- <op> is the standard comparison operator
1159 if Component_Size
(Typ1
) = 8 then
1160 if Length_Less_Than_4
(Op1
)
1162 Length_Less_Than_4
(Op2
)
1164 if Is_Unsigned_Type
(Ctyp
) then
1165 Comp
:= RE_Compare_Array_U8_Unaligned
;
1167 Comp
:= RE_Compare_Array_S8_Unaligned
;
1171 if Is_Unsigned_Type
(Ctyp
) then
1172 Comp
:= RE_Compare_Array_U8
;
1174 Comp
:= RE_Compare_Array_S8
;
1178 elsif Component_Size
(Typ1
) = 16 then
1179 if Is_Unsigned_Type
(Ctyp
) then
1180 Comp
:= RE_Compare_Array_U16
;
1182 Comp
:= RE_Compare_Array_S16
;
1185 elsif Component_Size
(Typ1
) = 32 then
1186 if Is_Unsigned_Type
(Ctyp
) then
1187 Comp
:= RE_Compare_Array_U32
;
1189 Comp
:= RE_Compare_Array_S32
;
1192 elsif Component_Size
(Typ1
) = 64 then
1193 if Is_Unsigned_Type
(Ctyp
) then
1194 Comp
:= RE_Compare_Array_U64
;
1196 Comp
:= RE_Compare_Array_S64
;
1199 else pragma Assert
(Component_Size
(Typ1
) = 128);
1200 if Is_Unsigned_Type
(Ctyp
) then
1201 Comp
:= RE_Compare_Array_U128
;
1203 Comp
:= RE_Compare_Array_S128
;
1207 if RTE_Available
(Comp
) then
1209 -- Expand to a call only if the runtime function is available,
1210 -- otherwise fall back to inline code.
1212 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1213 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1216 Comp_Call
: constant Node_Id
:=
1217 Make_Function_Call
(Loc
,
1218 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1220 Parameter_Associations
=> New_List
(
1221 Make_Attribute_Reference
(Loc
,
1222 Prefix
=> Relocate_Node
(Op1
),
1223 Attribute_Name
=> Name_Address
),
1225 Make_Attribute_Reference
(Loc
,
1226 Prefix
=> Relocate_Node
(Op2
),
1227 Attribute_Name
=> Name_Address
),
1229 Make_Attribute_Reference
(Loc
,
1230 Prefix
=> Relocate_Node
(Op1
),
1231 Attribute_Name
=> Name_Length
),
1233 Make_Attribute_Reference
(Loc
,
1234 Prefix
=> Relocate_Node
(Op2
),
1235 Attribute_Name
=> Name_Length
)));
1237 Zero
: constant Node_Id
:=
1238 Make_Integer_Literal
(Loc
,
1246 Comp_Op
:= Make_Op_Lt
(Loc
, Comp_Call
, Zero
);
1248 Comp_Op
:= Make_Op_Le
(Loc
, Comp_Call
, Zero
);
1250 Comp_Op
:= Make_Op_Gt
(Loc
, Comp_Call
, Zero
);
1252 Comp_Op
:= Make_Op_Ge
(Loc
, Comp_Call
, Zero
);
1254 raise Program_Error
;
1257 Rewrite
(N
, Comp_Op
);
1260 Analyze_And_Resolve
(N
, Standard_Boolean
);
1265 -- Cases where we cannot make runtime call
1267 -- For (a <= b) we convert to not (a > b)
1269 if Chars
(N
) = Name_Op_Le
then
1275 Right_Opnd
=> Op2
)));
1276 Analyze_And_Resolve
(N
, Standard_Boolean
);
1279 -- For < the Boolean expression is
1280 -- greater__nn (op2, op1)
1282 elsif Chars
(N
) = Name_Op_Lt
then
1283 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1287 Op1
:= Right_Opnd
(N
);
1288 Op2
:= Left_Opnd
(N
);
1290 -- For (a >= b) we convert to not (a < b)
1292 elsif Chars
(N
) = Name_Op_Ge
then
1298 Right_Opnd
=> Op2
)));
1299 Analyze_And_Resolve
(N
, Standard_Boolean
);
1302 -- For > the Boolean expression is
1303 -- greater__nn (op1, op2)
1306 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1307 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1310 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1312 Make_Function_Call
(Loc
,
1313 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1314 Parameter_Associations
=> New_List
(Op1
, Op2
));
1316 Insert_Action
(N
, Func_Body
);
1318 Analyze_And_Resolve
(N
, Standard_Boolean
);
1319 end Expand_Array_Comparison
;
1321 ---------------------------
1322 -- Expand_Array_Equality --
1323 ---------------------------
1325 -- Expand an equality function for multi-dimensional arrays. Here is an
1326 -- example of such a function for Nb_Dimension = 2
1328 -- function Enn (A : atyp; B : btyp) return boolean is
1330 -- if (A'length (1) = 0 or else A'length (2) = 0)
1332 -- (B'length (1) = 0 or else B'length (2) = 0)
1334 -- return true; -- RM 4.5.2(22)
1337 -- if A'length (1) /= B'length (1)
1339 -- A'length (2) /= B'length (2)
1341 -- return false; -- RM 4.5.2(23)
1345 -- A1 : Index_T1 := A'first (1);
1346 -- B1 : Index_T1 := B'first (1);
1350 -- A2 : Index_T2 := A'first (2);
1351 -- B2 : Index_T2 := B'first (2);
1354 -- if A (A1, A2) /= B (B1, B2) then
1358 -- exit when A2 = A'last (2);
1359 -- A2 := Index_T2'succ (A2);
1360 -- B2 := Index_T2'succ (B2);
1364 -- exit when A1 = A'last (1);
1365 -- A1 := Index_T1'succ (A1);
1366 -- B1 := Index_T1'succ (B1);
1373 -- Note on the formal types used (atyp and btyp). If either of the arrays
1374 -- is of a private type, we use the underlying type, and do an unchecked
1375 -- conversion of the actual. If either of the arrays has a bound depending
1376 -- on a discriminant, then we use the base type since otherwise we have an
1377 -- escaped discriminant in the function.
1379 -- If both arrays are constrained and have the same bounds, we can generate
1380 -- a loop with an explicit iteration scheme using a 'Range attribute over
1383 function Expand_Array_Equality
1388 Typ
: Entity_Id
) return Node_Id
1390 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1391 Decls
: constant List_Id
:= New_List
;
1392 Index_List1
: constant List_Id
:= New_List
;
1393 Index_List2
: constant List_Id
:= New_List
;
1395 First_Idx
: Node_Id
;
1397 Func_Name
: Entity_Id
;
1398 Func_Body
: Node_Id
;
1400 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1401 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1405 -- The parameter types to be used for the formals
1409 -- The LHS and RHS converted to the parameter types
1414 Dim
: Pos
) return Node_Id
;
1415 -- This builds the attribute reference Arr'Nam (Dim)
1417 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1418 -- Create one statement to compare corresponding components, designated
1419 -- by a full set of indexes.
1421 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1422 -- Given one of the arguments, computes the appropriate type to be used
1423 -- for that argument in the corresponding function formal
1425 function Handle_One_Dimension
1427 Index
: Node_Id
) return Node_Id
;
1428 -- This procedure returns the following code
1431 -- An : Index_T := A'First (N);
1432 -- Bn : Index_T := B'First (N);
1436 -- exit when An = A'Last (N);
1437 -- An := Index_T'Succ (An)
1438 -- Bn := Index_T'Succ (Bn)
1442 -- If both indexes are constrained and identical, the procedure
1443 -- returns a simpler loop:
1445 -- for An in A'Range (N) loop
1449 -- N is the dimension for which we are generating a loop. Index is the
1450 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1451 -- xxx statement is either the loop or declare for the next dimension
1452 -- or if this is the last dimension the comparison of corresponding
1453 -- components of the arrays.
1455 -- The actual way the code works is to return the comparison of
1456 -- corresponding components for the N+1 call. That's neater.
1458 function Test_Empty_Arrays
return Node_Id
;
1459 -- This function constructs the test for both arrays being empty
1460 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1462 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1464 function Test_Lengths_Correspond
return Node_Id
;
1465 -- This function constructs the test for arrays having different lengths
1466 -- in at least one index position, in which case the resulting code is:
1468 -- A'length (1) /= B'length (1)
1470 -- A'length (2) /= B'length (2)
1481 Dim
: Pos
) return Node_Id
1485 Make_Attribute_Reference
(Loc
,
1486 Attribute_Name
=> Nam
,
1487 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1488 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
1491 ------------------------
1492 -- Component_Equality --
1493 ------------------------
1495 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1500 -- if a(i1...) /= b(j1...) then return false; end if;
1503 Make_Indexed_Component
(Loc
,
1504 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1505 Expressions
=> Index_List1
);
1508 Make_Indexed_Component
(Loc
,
1509 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1510 Expressions
=> Index_List2
);
1512 Test
:= Expand_Composite_Equality
1513 (Outer_Type
=> Typ
, Nod
=> Nod
, Comp_Type
=> Component_Type
(Typ
),
1514 Lhs
=> L
, Rhs
=> R
);
1516 -- If some (sub)component is an unchecked_union, the whole operation
1517 -- will raise program error.
1519 if Nkind
(Test
) = N_Raise_Program_Error
then
1521 -- This node is going to be inserted at a location where a
1522 -- statement is expected: clear its Etype so analysis will set
1523 -- it to the expected Standard_Void_Type.
1525 Set_Etype
(Test
, Empty
);
1530 Make_Implicit_If_Statement
(Nod
,
1531 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1532 Then_Statements
=> New_List
(
1533 Make_Simple_Return_Statement
(Loc
,
1534 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1536 end Component_Equality
;
1542 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1553 T
:= Underlying_Type
(T
);
1555 X
:= First_Index
(T
);
1556 while Present
(X
) loop
1557 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1559 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1572 --------------------------
1573 -- Handle_One_Dimension --
1574 ---------------------------
1576 function Handle_One_Dimension
1578 Index
: Node_Id
) return Node_Id
1580 Need_Separate_Indexes
: constant Boolean :=
1581 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1582 -- If the index types are identical, and we are working with
1583 -- constrained types, then we can use the same index for both
1586 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1589 Index_T
: Entity_Id
;
1594 if N
> Number_Dimensions
(Ltyp
) then
1595 return Component_Equality
(Ltyp
);
1598 -- Case where we generate a loop
1600 Index_T
:= Base_Type
(Etype
(Index
));
1602 if Need_Separate_Indexes
then
1603 Bn
:= Make_Temporary
(Loc
, 'B');
1608 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1609 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1611 Stm_List
:= New_List
(
1612 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1614 if Need_Separate_Indexes
then
1616 -- Generate guard for loop, followed by increments of indexes
1618 Append_To
(Stm_List
,
1619 Make_Exit_Statement
(Loc
,
1622 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1623 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1625 Append_To
(Stm_List
,
1626 Make_Assignment_Statement
(Loc
,
1627 Name
=> New_Occurrence_Of
(An
, Loc
),
1629 Make_Attribute_Reference
(Loc
,
1630 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1631 Attribute_Name
=> Name_Succ
,
1632 Expressions
=> New_List
(
1633 New_Occurrence_Of
(An
, Loc
)))));
1635 Append_To
(Stm_List
,
1636 Make_Assignment_Statement
(Loc
,
1637 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1639 Make_Attribute_Reference
(Loc
,
1640 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1641 Attribute_Name
=> Name_Succ
,
1642 Expressions
=> New_List
(
1643 New_Occurrence_Of
(Bn
, Loc
)))));
1646 -- If separate indexes, we need a declare block for An and Bn, and a
1647 -- loop without an iteration scheme.
1649 if Need_Separate_Indexes
then
1651 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1654 Make_Block_Statement
(Loc
,
1655 Declarations
=> New_List
(
1656 Make_Object_Declaration
(Loc
,
1657 Defining_Identifier
=> An
,
1658 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1659 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1661 Make_Object_Declaration
(Loc
,
1662 Defining_Identifier
=> Bn
,
1663 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1664 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1666 Handled_Statement_Sequence
=>
1667 Make_Handled_Sequence_Of_Statements
(Loc
,
1668 Statements
=> New_List
(Loop_Stm
)));
1670 -- If no separate indexes, return loop statement with explicit
1671 -- iteration scheme on its own.
1675 Make_Implicit_Loop_Statement
(Nod
,
1676 Statements
=> Stm_List
,
1678 Make_Iteration_Scheme
(Loc
,
1679 Loop_Parameter_Specification
=>
1680 Make_Loop_Parameter_Specification
(Loc
,
1681 Defining_Identifier
=> An
,
1682 Discrete_Subtype_Definition
=>
1683 Arr_Attr
(A
, Name_Range
, N
))));
1686 end Handle_One_Dimension
;
1688 -----------------------
1689 -- Test_Empty_Arrays --
1690 -----------------------
1692 function Test_Empty_Arrays
return Node_Id
is
1693 Alist
: Node_Id
:= Empty
;
1694 Blist
: Node_Id
:= Empty
;
1697 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1698 Evolve_Or_Else
(Alist
,
1700 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1701 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
1703 Evolve_Or_Else
(Blist
,
1705 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1706 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
1712 Right_Opnd
=> Blist
);
1713 end Test_Empty_Arrays
;
1715 -----------------------------
1716 -- Test_Lengths_Correspond --
1717 -----------------------------
1719 function Test_Lengths_Correspond
return Node_Id
is
1720 Result
: Node_Id
:= Empty
;
1723 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1724 Evolve_Or_Else
(Result
,
1726 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1727 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
)));
1731 end Test_Lengths_Correspond
;
1733 -- Start of processing for Expand_Array_Equality
1736 Ltyp
:= Get_Arg_Type
(Lhs
);
1737 Rtyp
:= Get_Arg_Type
(Rhs
);
1739 -- For now, if the argument types are not the same, go to the base type,
1740 -- since the code assumes that the formals have the same type. This is
1741 -- fixable in future ???
1743 if Ltyp
/= Rtyp
then
1744 Ltyp
:= Base_Type
(Ltyp
);
1745 Rtyp
:= Base_Type
(Rtyp
);
1748 -- If the array type is distinct from the type of the arguments, it
1749 -- is the full view of a private type. Apply an unchecked conversion
1750 -- to ensure that analysis of the code below succeeds.
1753 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1755 New_Lhs
:= OK_Convert_To
(Ltyp
, Lhs
);
1761 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1763 New_Rhs
:= OK_Convert_To
(Rtyp
, Rhs
);
1768 pragma Assert
(Ltyp
= Rtyp
);
1769 First_Idx
:= First_Index
(Ltyp
);
1771 -- If optimization is enabled and the array boils down to a couple of
1772 -- consecutive elements, generate a simple conjunction of comparisons
1773 -- which should be easier to optimize by the code generator.
1775 if Optimization_Level
> 0
1776 and then Is_Constrained
(Ltyp
)
1777 and then Number_Dimensions
(Ltyp
) = 1
1778 and then Compile_Time_Known_Bounds
(Ltyp
)
1779 and then Expr_Value
(Type_High_Bound
(Etype
(First_Idx
))) =
1780 Expr_Value
(Type_Low_Bound
(Etype
(First_Idx
))) + 1
1783 Ctyp
: constant Entity_Id
:= Component_Type
(Ltyp
);
1784 Low_B
: constant Node_Id
:=
1785 Type_Low_Bound
(Etype
(First_Idx
));
1786 High_B
: constant Node_Id
:=
1787 Type_High_Bound
(Etype
(First_Idx
));
1789 TestL
, TestH
: Node_Id
;
1793 Make_Indexed_Component
(Loc
,
1794 Prefix
=> New_Copy_Tree
(New_Lhs
),
1795 Expressions
=> New_List
(New_Copy_Tree
(Low_B
)));
1798 Make_Indexed_Component
(Loc
,
1799 Prefix
=> New_Copy_Tree
(New_Rhs
),
1800 Expressions
=> New_List
(New_Copy_Tree
(Low_B
)));
1802 TestL
:= Expand_Composite_Equality
1803 (Outer_Type
=> Ltyp
, Nod
=> Nod
, Comp_Type
=> Ctyp
,
1804 Lhs
=> L
, Rhs
=> R
);
1807 Make_Indexed_Component
(Loc
,
1809 Expressions
=> New_List
(New_Copy_Tree
(High_B
)));
1812 Make_Indexed_Component
(Loc
,
1814 Expressions
=> New_List
(New_Copy_Tree
(High_B
)));
1816 TestH
:= Expand_Composite_Equality
1817 (Outer_Type
=> Ltyp
, Nod
=> Nod
, Comp_Type
=> Ctyp
,
1818 Lhs
=> L
, Rhs
=> R
);
1821 Make_And_Then
(Loc
, Left_Opnd
=> TestL
, Right_Opnd
=> TestH
);
1825 -- Build list of formals for function
1827 Formals
:= New_List
(
1828 Make_Parameter_Specification
(Loc
,
1829 Defining_Identifier
=> A
,
1830 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
1832 Make_Parameter_Specification
(Loc
,
1833 Defining_Identifier
=> B
,
1834 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
1836 Func_Name
:= Make_Temporary
(Loc
, 'E');
1838 -- Build statement sequence for function
1841 Make_Subprogram_Body
(Loc
,
1843 Make_Function_Specification
(Loc
,
1844 Defining_Unit_Name
=> Func_Name
,
1845 Parameter_Specifications
=> Formals
,
1846 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1848 Declarations
=> Decls
,
1850 Handled_Statement_Sequence
=>
1851 Make_Handled_Sequence_Of_Statements
(Loc
,
1852 Statements
=> New_List
(
1854 Make_Implicit_If_Statement
(Nod
,
1855 Condition
=> Test_Empty_Arrays
,
1856 Then_Statements
=> New_List
(
1857 Make_Simple_Return_Statement
(Loc
,
1859 New_Occurrence_Of
(Standard_True
, Loc
)))),
1861 Make_Implicit_If_Statement
(Nod
,
1862 Condition
=> Test_Lengths_Correspond
,
1863 Then_Statements
=> New_List
(
1864 Make_Simple_Return_Statement
(Loc
,
1865 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
1867 Handle_One_Dimension
(1, First_Idx
),
1869 Make_Simple_Return_Statement
(Loc
,
1870 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1872 Set_Has_Completion
(Func_Name
, True);
1873 Set_Is_Inlined
(Func_Name
);
1875 Append_To
(Bodies
, Func_Body
);
1878 Make_Function_Call
(Loc
,
1879 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1880 Parameter_Associations
=> New_List
(New_Lhs
, New_Rhs
));
1881 end Expand_Array_Equality
;
1883 -----------------------------
1884 -- Expand_Boolean_Operator --
1885 -----------------------------
1887 -- Note that we first get the actual subtypes of the operands, since we
1888 -- always want to deal with types that have bounds.
1890 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
1891 Typ
: constant Entity_Id
:= Etype
(N
);
1894 -- Special case of bit packed array where both operands are known to be
1895 -- properly aligned. In this case we use an efficient run time routine
1896 -- to carry out the operation (see System.Bit_Ops).
1898 if Is_Bit_Packed_Array
(Typ
)
1899 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
1900 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
1902 Expand_Packed_Boolean_Operator
(N
);
1906 -- For the normal non-packed case, the general expansion is to build
1907 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1908 -- and then inserting it into the tree. The original operator node is
1909 -- then rewritten as a call to this function. We also use this in the
1910 -- packed case if either operand is a possibly unaligned object.
1913 Loc
: constant Source_Ptr
:= Sloc
(N
);
1914 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
1915 R
: Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
1916 Func_Body
: Node_Id
;
1917 Func_Name
: Entity_Id
;
1920 Convert_To_Actual_Subtype
(L
);
1921 Convert_To_Actual_Subtype
(R
);
1922 Ensure_Defined
(Etype
(L
), N
);
1923 Ensure_Defined
(Etype
(R
), N
);
1924 Apply_Length_Check
(R
, Etype
(L
));
1926 if Nkind
(N
) = N_Op_Xor
then
1927 R
:= Duplicate_Subexpr
(R
);
1928 Silly_Boolean_Array_Xor_Test
(N
, R
, Etype
(L
));
1931 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1932 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
1934 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
1936 elsif Nkind
(Parent
(N
)) = N_Op_Not
1937 and then Nkind
(N
) = N_Op_And
1938 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1939 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
1943 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
1944 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1945 Insert_Action
(N
, Func_Body
);
1947 -- Now rewrite the expression with a call
1949 if Transform_Function_Array
then
1951 Temp_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1960 Make_Object_Declaration
(Loc
,
1961 Defining_Identifier
=> Temp_Id
,
1962 Object_Definition
=>
1963 New_Occurrence_Of
(Etype
(L
), Loc
));
1966 -- Proc_Call (L, R, Temp);
1969 Make_Procedure_Call_Statement
(Loc
,
1970 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1971 Parameter_Associations
=>
1974 Make_Type_Conversion
1975 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
),
1976 New_Occurrence_Of
(Temp_Id
, Loc
)));
1978 Insert_Actions
(Parent
(N
), New_List
(Decl
, Call
));
1979 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1983 Make_Function_Call
(Loc
,
1984 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1985 Parameter_Associations
=>
1988 Make_Type_Conversion
1989 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
1992 Analyze_And_Resolve
(N
, Typ
);
1995 end Expand_Boolean_Operator
;
1997 ------------------------------------------------
1998 -- Expand_Compare_Minimize_Eliminate_Overflow --
1999 ------------------------------------------------
2001 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2002 Loc
: constant Source_Ptr
:= Sloc
(N
);
2004 Result_Type
: constant Entity_Id
:= Etype
(N
);
2005 -- Capture result type (could be a derived boolean type)
2010 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2011 -- Entity for Long_Long_Integer'Base
2014 procedure Set_False
;
2015 -- These procedures rewrite N with an occurrence of Standard_True or
2016 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2022 procedure Set_False
is
2024 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2025 Warn_On_Known_Condition
(N
);
2032 procedure Set_True
is
2034 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2035 Warn_On_Known_Condition
(N
);
2038 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2041 -- OK, this is the case we are interested in. First step is to process
2042 -- our operands using the Minimize_Eliminate circuitry which applies
2043 -- this processing to the two operand subtrees.
2045 Minimize_Eliminate_Overflows
2046 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2047 Minimize_Eliminate_Overflows
2048 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2050 -- See if the range information decides the result of the comparison.
2051 -- We can only do this if we in fact have full range information (which
2052 -- won't be the case if either operand is bignum at this stage).
2054 if Present
(Llo
) and then Present
(Rlo
) then
2055 case N_Op_Compare
(Nkind
(N
)) is
2057 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2059 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2066 elsif Lhi
< Rlo
then
2073 elsif Lhi
<= Rlo
then
2080 elsif Lhi
<= Rlo
then
2087 elsif Lhi
< Rlo
then
2092 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2094 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2099 -- All done if we did the rewrite
2101 if Nkind
(N
) not in N_Op_Compare
then
2106 -- Otherwise, time to do the comparison
2109 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2110 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2113 -- If the two operands have the same signed integer type we are
2114 -- all set, nothing more to do. This is the case where either
2115 -- both operands were unchanged, or we rewrote both of them to
2116 -- be Long_Long_Integer.
2118 -- Note: Entity for the comparison may be wrong, but it's not worth
2119 -- the effort to change it, since the back end does not use it.
2121 if Is_Signed_Integer_Type
(Ltype
)
2122 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2126 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2128 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2130 Left
: Node_Id
:= Left_Opnd
(N
);
2131 Right
: Node_Id
:= Right_Opnd
(N
);
2132 -- Bignum references for left and right operands
2135 if not Is_RTE
(Ltype
, RE_Bignum
) then
2136 Left
:= Convert_To_Bignum
(Left
);
2137 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2138 Right
:= Convert_To_Bignum
(Right
);
2141 -- We rewrite our node with:
2144 -- Bnn : Result_Type;
2146 -- M : Mark_Id := SS_Mark;
2148 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2156 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2157 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2161 case N_Op_Compare
(Nkind
(N
)) is
2162 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2163 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2164 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2165 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2166 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2167 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2170 -- Insert assignment to Bnn into the bignum block
2173 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2174 Make_Assignment_Statement
(Loc
,
2175 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2177 Make_Function_Call
(Loc
,
2179 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2180 Parameter_Associations
=> New_List
(Left
, Right
))));
2182 -- Now do the rewrite with expression actions
2185 Make_Expression_With_Actions
(Loc
,
2186 Actions
=> New_List
(
2187 Make_Object_Declaration
(Loc
,
2188 Defining_Identifier
=> Bnn
,
2189 Object_Definition
=>
2190 New_Occurrence_Of
(Result_Type
, Loc
)),
2192 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2193 Analyze_And_Resolve
(N
, Result_Type
);
2197 -- No bignums involved, but types are different, so we must have
2198 -- rewritten one of the operands as a Long_Long_Integer but not
2201 -- If left operand is Long_Long_Integer, convert right operand
2202 -- and we are done (with a comparison of two Long_Long_Integers).
2204 elsif Ltype
= LLIB
then
2205 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2206 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2209 -- If right operand is Long_Long_Integer, convert left operand
2210 -- and we are done (with a comparison of two Long_Long_Integers).
2212 -- This is the only remaining possibility
2214 else pragma Assert
(Rtype
= LLIB
);
2215 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2216 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2220 end Expand_Compare_Minimize_Eliminate_Overflow
;
2222 -------------------------------
2223 -- Expand_Composite_Equality --
2224 -------------------------------
2226 -- This function is only called for comparing internal fields of composite
2227 -- types when these fields are themselves composites. This is a special
2228 -- case because it is not possible to respect normal Ada visibility rules.
2230 function Expand_Composite_Equality
2231 (Outer_Type
: Entity_Id
;
2233 Comp_Type
: Entity_Id
;
2235 Rhs
: Node_Id
) return Node_Id
2237 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2238 Full_Type
: Entity_Id
;
2242 if Is_Private_Type
(Comp_Type
) then
2243 Full_Type
:= Underlying_Type
(Comp_Type
);
2245 Full_Type
:= Comp_Type
;
2248 -- If the private type has no completion the context may be the
2249 -- expansion of a composite equality for a composite type with some
2250 -- still incomplete components. The expression will not be analyzed
2251 -- until the enclosing type is completed, at which point this will be
2252 -- properly expanded, unless there is a bona fide completion error.
2254 if No
(Full_Type
) then
2255 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2258 Full_Type
:= Base_Type
(Full_Type
);
2260 -- When the base type itself is private, use the full view to expand
2261 -- the composite equality.
2263 if Is_Private_Type
(Full_Type
) then
2264 Full_Type
:= Underlying_Type
(Full_Type
);
2267 -- Case of tagged record types
2269 if Is_Tagged_Type
(Full_Type
) then
2270 Eq_Op
:= Find_Primitive_Eq
(Comp_Type
);
2271 pragma Assert
(Present
(Eq_Op
));
2274 Make_Function_Call
(Loc
,
2275 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2276 Parameter_Associations
=>
2278 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2279 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2281 -- Case of untagged record types
2283 elsif Is_Record_Type
(Full_Type
) then
2284 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2286 if Present
(Eq_Op
) then
2288 Op_Typ
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2290 L_Exp
, R_Exp
: Node_Id
;
2293 -- Adjust operands if necessary to comparison type
2295 if Base_Type
(Full_Type
) /= Base_Type
(Op_Typ
) then
2296 L_Exp
:= OK_Convert_To
(Op_Typ
, Lhs
);
2297 R_Exp
:= OK_Convert_To
(Op_Typ
, Rhs
);
2300 L_Exp
:= Relocate_Node
(Lhs
);
2301 R_Exp
:= Relocate_Node
(Rhs
);
2305 Make_Function_Call
(Loc
,
2306 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2307 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
));
2310 -- Equality composes in Ada 2012 for untagged record types. It also
2311 -- composes for bounded strings, because they are part of the
2312 -- predefined environment (see 4.5.2(32.1/1)). We could make it
2313 -- compose for bounded strings by making them tagged, or by making
2314 -- sure all subcomponents are set to the same value, even when not
2315 -- used. Instead, we have this special case in the compiler, because
2316 -- it's more efficient.
2318 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Comp_Type
)
2320 -- If no TSS has been created for the type, check whether there is
2321 -- a primitive equality declared for it.
2324 Op
: constant Node_Id
:=
2325 Build_Eq_Call
(Comp_Type
, Loc
, Lhs
, Rhs
);
2328 -- Use user-defined primitive if it exists, otherwise use
2329 -- predefined equality.
2331 if Present
(Op
) then
2334 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2339 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
);
2342 -- Case of non-record types (always use predefined equality)
2345 -- Print a warning if there is a user-defined "=", because it can be
2346 -- surprising that the predefined "=" takes precedence over it.
2348 -- Suppress the warning if the "user-defined" one is in the
2349 -- predefined library, because those are defined to compose
2350 -- properly by RM-4.5.2(32.1/1). Intrinsics also compose.
2353 Op
: constant Entity_Id
:= Find_Primitive_Eq
(Comp_Type
);
2355 if Warn_On_Ignored_Equality
2356 and then Present
(Op
)
2357 and then not In_Predefined_Unit
(Base_Type
(Comp_Type
))
2358 and then not Is_Intrinsic_Subprogram
(Op
)
2361 (Is_First_Subtype
(Outer_Type
)
2362 or else Is_Generic_Actual_Type
(Outer_Type
));
2363 Error_Msg_Node_1
:= Outer_Type
;
2364 Error_Msg_Node_2
:= Comp_Type
;
2366 ("?_q?""="" for type & uses predefined ""="" for }", Loc
);
2367 Error_Msg_Sloc
:= Sloc
(Op
);
2368 Error_Msg
("\?_q?""="" # is ignored here", Loc
);
2372 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2374 end Expand_Composite_Equality
;
2376 ------------------------
2377 -- Expand_Concatenate --
2378 ------------------------
2380 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2381 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2383 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2384 -- Result type of concatenation
2386 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2387 -- Component type. Elements of this component type can appear as one
2388 -- of the operands of concatenation as well as arrays.
2390 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2393 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2394 -- Index type. This is the base type of the index subtype, and is used
2395 -- for all computed bounds (which may be out of range of Istyp in the
2396 -- case of null ranges).
2399 -- This is the type we use to do arithmetic to compute the bounds and
2400 -- lengths of operands. The choice of this type is a little subtle and
2401 -- is discussed in a separate section at the start of the body code.
2403 Result_May_Be_Null
: Boolean := True;
2404 -- Reset to False if at least one operand is encountered which is known
2405 -- at compile time to be non-null. Used for handling the special case
2406 -- of setting the high bound to the last operand high bound for a null
2407 -- result, thus ensuring a proper high bound in the superflat case.
2409 N
: constant Nat
:= List_Length
(Opnds
);
2410 -- Number of concatenation operands including possibly null operands
2413 -- Number of operands excluding any known to be null, except that the
2414 -- last operand is always retained, in case it provides the bounds for
2417 Opnd
: Node_Id
:= Empty
;
2418 -- Current operand being processed in the loop through operands. After
2419 -- this loop is complete, always contains the last operand (which is not
2420 -- the same as Operands (NN), since null operands are skipped).
2422 -- Arrays describing the operands, only the first NN entries of each
2423 -- array are set (NN < N when we exclude known null operands).
2425 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2426 -- True if length of corresponding operand known at compile time
2428 Operands
: array (1 .. N
) of Node_Id
;
2429 -- Set to the corresponding entry in the Opnds list (but note that null
2430 -- operands are excluded, so not all entries in the list are stored).
2432 Fixed_Length
: array (1 .. N
) of Unat
;
2433 -- Set to length of operand. Entries in this array are set only if the
2434 -- corresponding entry in Is_Fixed_Length is True.
2436 Max_Length
: array (1 .. N
) of Unat
;
2437 -- Set to the maximum length of operand, or Too_Large_Length_For_Array
2438 -- if it is not known. Entries in this array are set only if the
2439 -- corresponding entry in Is_Fixed_Length is False;
2441 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2442 -- Set to lower bound of operand. Either an integer literal in the case
2443 -- where the bound is known at compile time, else actual lower bound.
2444 -- The operand low bound is of type Ityp.
2446 Var_Length
: array (1 .. N
) of Entity_Id
;
2447 -- Set to an entity of type Natural that contains the length of an
2448 -- operand whose length is not known at compile time. Entries in this
2449 -- array are set only if the corresponding entry in Is_Fixed_Length
2450 -- is False. The entity is of type Artyp.
2452 Aggr_Length
: array (0 .. N
) of Node_Id
;
2453 -- The J'th entry is an expression node that represents the total length
2454 -- of operands 1 through J. It is either an integer literal node, or a
2455 -- reference to a constant entity with the right value, so it is fine
2456 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth
2457 -- entry always is set to zero. The length is of type Artyp.
2459 Max_Aggr_Length
: Unat
:= Too_Large_Length_For_Array
;
2460 -- Set to the maximum total length, or Too_Large_Length_For_Array at
2461 -- least if it is not known.
2463 Low_Bound
: Node_Id
:= Empty
;
2464 -- A tree node representing the low bound of the result (of type Ityp).
2465 -- This is either an integer literal node, or an identifier reference to
2466 -- a constant entity initialized to the appropriate value.
2468 High_Bound
: Node_Id
:= Empty
;
2469 -- A tree node representing the high bound of the result (of type Ityp)
2471 Last_Opnd_Low_Bound
: Node_Id
:= Empty
;
2472 -- A tree node representing the low bound of the last operand. This
2473 -- need only be set if the result could be null. It is used for the
2474 -- special case of setting the right low bound for a null result.
2475 -- This is of type Ityp.
2477 Last_Opnd_High_Bound
: Node_Id
:= Empty
;
2478 -- A tree node representing the high bound of the last operand. This
2479 -- need only be set if the result could be null. It is used for the
2480 -- special case of setting the right high bound for a null result.
2481 -- This is of type Ityp.
2483 Result
: Node_Id
:= Empty
;
2484 -- Result of the concatenation (of type Ityp)
2486 Actions
: constant List_Id
:= New_List
;
2487 -- Collect actions to be inserted
2489 Known_Non_Null_Operand_Seen
: Boolean;
2490 -- Set True during generation of the assignments of operands into
2491 -- result once an operand known to be non-null has been seen.
2493 function Library_Level_Target
return Boolean;
2494 -- Return True if the concatenation is within the expression of the
2495 -- declaration of a library-level object.
2497 function Make_Artyp_Literal
(Val
: Uint
) return Node_Id
;
2498 -- This function makes an N_Integer_Literal node that is returned in
2499 -- analyzed form with the type set to Artyp. Importantly this literal
2500 -- is not flagged as static, so that if we do computations with it that
2501 -- result in statically detected out of range conditions, we will not
2502 -- generate error messages but instead warning messages.
2504 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2505 -- Given a node of type Ityp, returns the corresponding value of type
2506 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2507 -- For enum types, the Pos of the value is returned.
2509 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2510 -- The inverse function (uses Val in the case of enumeration types)
2512 --------------------------
2513 -- Library_Level_Target --
2514 --------------------------
2516 function Library_Level_Target
return Boolean is
2517 P
: Node_Id
:= Parent
(Cnode
);
2520 while Present
(P
) loop
2521 if Nkind
(P
) = N_Object_Declaration
then
2522 return Is_Library_Level_Entity
(Defining_Identifier
(P
));
2524 -- Prevent the search from going too far
2526 elsif Is_Body_Or_Package_Declaration
(P
) then
2534 end Library_Level_Target
;
2536 ------------------------
2537 -- Make_Artyp_Literal --
2538 ------------------------
2540 function Make_Artyp_Literal
(Val
: Uint
) return Node_Id
is
2541 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2543 Set_Etype
(Result
, Artyp
);
2544 Set_Analyzed
(Result
, True);
2545 Set_Is_Static_Expression
(Result
, False);
2547 end Make_Artyp_Literal
;
2553 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2555 if Ityp
= Base_Type
(Artyp
) then
2558 elsif Is_Enumeration_Type
(Ityp
) then
2560 Make_Attribute_Reference
(Loc
,
2561 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2562 Attribute_Name
=> Name_Pos
,
2563 Expressions
=> New_List
(X
));
2566 return Convert_To
(Artyp
, X
);
2574 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2576 if Is_Enumeration_Type
(Ityp
) then
2578 Make_Attribute_Reference
(Loc
,
2579 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2580 Attribute_Name
=> Name_Val
,
2581 Expressions
=> New_List
(X
));
2583 -- Case where we will do a type conversion
2586 if Ityp
= Base_Type
(Artyp
) then
2589 return Convert_To
(Ityp
, X
);
2594 -- Local Declarations
2596 Opnd_Typ
: Entity_Id
;
2597 Slice_Rng
: Node_Id
;
2598 Subtyp_Ind
: Node_Id
;
2599 Subtyp_Rng
: Node_Id
;
2606 -- Start of processing for Expand_Concatenate
2609 -- Choose an appropriate computational type
2611 -- We will be doing calculations of lengths and bounds in this routine
2612 -- and computing one from the other in some cases, e.g. getting the high
2613 -- bound by adding the length-1 to the low bound.
2615 -- We can't just use the index type, or even its base type for this
2616 -- purpose for two reasons. First it might be an enumeration type which
2617 -- is not suitable for computations of any kind, and second it may
2618 -- simply not have enough range. For example if the index type is
2619 -- -128..+127 then lengths can be up to 256, which is out of range of
2622 -- For enumeration types, we can simply use Standard_Integer, this is
2623 -- sufficient since the actual number of enumeration literals cannot
2624 -- possibly exceed the range of integer (remember we will be doing the
2625 -- arithmetic with POS values, not representation values).
2627 if Is_Enumeration_Type
(Ityp
) then
2628 Artyp
:= Standard_Integer
;
2630 -- For modular types, we use a 32-bit modular type for types whose size
2631 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2632 -- identity type, and for larger unsigned types we use a 64-bit type.
2634 elsif Is_Modular_Integer_Type
(Ityp
) then
2635 if RM_Size
(Ityp
) < Standard_Integer_Size
then
2636 Artyp
:= Standard_Unsigned
;
2637 elsif RM_Size
(Ityp
) = Standard_Integer_Size
then
2640 Artyp
:= Standard_Long_Long_Unsigned
;
2643 -- Similar treatment for signed types
2646 if RM_Size
(Ityp
) < Standard_Integer_Size
then
2647 Artyp
:= Standard_Integer
;
2648 elsif RM_Size
(Ityp
) = Standard_Integer_Size
then
2651 Artyp
:= Standard_Long_Long_Integer
;
2655 -- Supply dummy entry at start of length array
2657 Aggr_Length
(0) := Make_Artyp_Literal
(Uint_0
);
2659 -- Go through operands setting up the above arrays
2663 Opnd
:= Remove_Head
(Opnds
);
2664 Opnd_Typ
:= Etype
(Opnd
);
2666 -- The parent got messed up when we put the operands in a list,
2667 -- so now put back the proper parent for the saved operand, that
2668 -- is to say the concatenation node, to make sure that each operand
2669 -- is seen as a subexpression, e.g. if actions must be inserted.
2671 Set_Parent
(Opnd
, Cnode
);
2673 -- Set will be True when we have setup one entry in the array
2677 -- Singleton element (or character literal) case
2679 if Base_Type
(Opnd_Typ
) = Ctyp
then
2681 Operands
(NN
) := Opnd
;
2682 Is_Fixed_Length
(NN
) := True;
2683 Fixed_Length
(NN
) := Uint_1
;
2684 Result_May_Be_Null
:= False;
2686 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2687 -- since we know that the result cannot be null).
2689 Opnd_Low_Bound
(NN
) :=
2690 Make_Attribute_Reference
(Loc
,
2691 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
2692 Attribute_Name
=> Name_First
);
2696 -- String literal case (can only occur for strings of course)
2698 elsif Nkind
(Opnd
) = N_String_Literal
then
2699 Len
:= String_Literal_Length
(Opnd_Typ
);
2702 Result_May_Be_Null
:= False;
2705 -- Capture last operand low and high bound if result could be null
2707 if J
= N
and then Result_May_Be_Null
then
2708 Last_Opnd_Low_Bound
:=
2709 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2711 Last_Opnd_High_Bound
:=
2712 Make_Op_Subtract
(Loc
,
2714 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
2715 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
2718 -- Skip null string literal
2720 if J
< N
and then Len
= 0 then
2725 Operands
(NN
) := Opnd
;
2726 Is_Fixed_Length
(NN
) := True;
2728 -- Set length and bounds
2730 Fixed_Length
(NN
) := Len
;
2732 Opnd_Low_Bound
(NN
) :=
2733 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2740 -- Check constrained case with known bounds
2742 if Is_Constrained
(Opnd_Typ
)
2743 and then Compile_Time_Known_Bounds
(Opnd_Typ
)
2749 -- Fixed length constrained array type with known at compile
2750 -- time bounds is last case of fixed length operand.
2752 Get_First_Index_Bounds
(Opnd_Typ
, Lo
, Hi
);
2753 Len
:= UI_Max
(Hi
- Lo
+ 1, Uint_0
);
2756 Result_May_Be_Null
:= False;
2759 -- Capture last operand bounds if result could be null
2761 if J
= N
and then Result_May_Be_Null
then
2762 Last_Opnd_Low_Bound
:=
2763 To_Ityp
(Make_Integer_Literal
(Loc
, Lo
));
2765 Last_Opnd_High_Bound
:=
2766 To_Ityp
(Make_Integer_Literal
(Loc
, Hi
));
2769 -- Exclude null length case unless last operand
2771 if J
< N
and then Len
= 0 then
2776 Operands
(NN
) := Opnd
;
2777 Is_Fixed_Length
(NN
) := True;
2778 Fixed_Length
(NN
) := Len
;
2780 Opnd_Low_Bound
(NN
) :=
2781 To_Ityp
(Make_Integer_Literal
(Loc
, Lo
));
2786 -- All cases where the length is not known at compile time, or the
2787 -- special case of an operand which is known to be null but has a
2788 -- lower bound other than 1 or is other than a string type.
2793 -- Capture operand bounds
2795 Opnd_Low_Bound
(NN
) :=
2796 Make_Attribute_Reference
(Loc
,
2798 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2799 Attribute_Name
=> Name_First
);
2801 -- Capture last operand bounds if result could be null
2803 if J
= N
and Result_May_Be_Null
then
2804 Last_Opnd_Low_Bound
:=
2806 Make_Attribute_Reference
(Loc
,
2808 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2809 Attribute_Name
=> Name_First
));
2811 Last_Opnd_High_Bound
:=
2813 Make_Attribute_Reference
(Loc
,
2815 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2816 Attribute_Name
=> Name_Last
));
2819 -- Capture length of operand in entity
2821 Operands
(NN
) := Opnd
;
2822 Is_Fixed_Length
(NN
) := False;
2824 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
2826 -- If the operand is a slice, try to compute an upper bound for
2829 if Nkind
(Opnd
) = N_Slice
2830 and then Is_Constrained
(Etype
(Prefix
(Opnd
)))
2831 and then Compile_Time_Known_Bounds
(Etype
(Prefix
(Opnd
)))
2837 Get_First_Index_Bounds
(Etype
(Prefix
(Opnd
)), Lo
, Hi
);
2838 Max_Length
(NN
) := UI_Max
(Hi
- Lo
+ 1, Uint_0
);
2842 Max_Length
(NN
) := Too_Large_Length_For_Array
;
2846 Make_Object_Declaration
(Loc
,
2847 Defining_Identifier
=> Var_Length
(NN
),
2848 Constant_Present
=> True,
2849 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
2851 Make_Attribute_Reference
(Loc
,
2853 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2854 Attribute_Name
=> Name_Length
)));
2858 -- Set next entry in aggregate length array
2860 -- For first entry, make either integer literal for fixed length
2861 -- or a reference to the saved length for variable length.
2864 if Is_Fixed_Length
(1) then
2865 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
2866 Max_Aggr_Length
:= Fixed_Length
(1);
2868 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
2869 Max_Aggr_Length
:= Max_Length
(1);
2872 -- If entry is fixed length and only fixed lengths so far, make
2873 -- appropriate new integer literal adding new length.
2875 elsif Is_Fixed_Length
(NN
)
2876 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
2879 Make_Integer_Literal
(Loc
,
2880 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
2881 Max_Aggr_Length
:= Intval
(Aggr_Length
(NN
));
2883 -- All other cases, construct an addition node for the length and
2884 -- create an entity initialized to this length.
2887 Ent
:= Make_Temporary
(Loc
, 'L');
2889 if Is_Fixed_Length
(NN
) then
2890 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
2891 Max_Aggr_Length
:= Max_Aggr_Length
+ Fixed_Length
(NN
);
2894 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
2895 Max_Aggr_Length
:= Max_Aggr_Length
+ Max_Length
(NN
);
2899 Make_Object_Declaration
(Loc
,
2900 Defining_Identifier
=> Ent
,
2901 Constant_Present
=> True,
2902 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
2905 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
- 1)),
2906 Right_Opnd
=> Clen
)));
2908 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
2915 -- If we have only skipped null operands, return the last operand
2922 -- If we have only one non-null operand, return it and we are done.
2923 -- There is one case in which this cannot be done, and that is when
2924 -- the sole operand is of the element type, in which case it must be
2925 -- converted to an array, and the easiest way of doing that is to go
2926 -- through the normal general circuit.
2928 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
2929 Result
:= Operands
(1);
2933 -- Cases where we have a real concatenation
2935 -- Next step is to find the low bound for the result array that we
2936 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
2938 -- If the ultimate ancestor of the index subtype is a constrained array
2939 -- definition, then the lower bound is that of the index subtype as
2940 -- specified by (RM 4.5.3(6)).
2942 -- The right test here is to go to the root type, and then the ultimate
2943 -- ancestor is the first subtype of this root type.
2945 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
2947 Make_Attribute_Reference
(Loc
,
2949 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
2950 Attribute_Name
=> Name_First
);
2952 -- If the first operand in the list has known length we know that
2953 -- the lower bound of the result is the lower bound of this operand.
2955 elsif Is_Fixed_Length
(1) then
2956 Low_Bound
:= Opnd_Low_Bound
(1);
2958 -- OK, we don't know the lower bound, we have to build a horrible
2959 -- if expression node of the form
2961 -- if Cond1'Length /= 0 then
2964 -- if Opnd2'Length /= 0 then
2969 -- The nesting ends either when we hit an operand whose length is known
2970 -- at compile time, or on reaching the last operand, whose low bound we
2971 -- take unconditionally whether or not it is null. It's easiest to do
2972 -- this with a recursive procedure:
2976 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
2977 -- Returns the lower bound determined by operands J .. NN
2979 ---------------------
2980 -- Get_Known_Bound --
2981 ---------------------
2983 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
2985 if Is_Fixed_Length
(J
) or else J
= NN
then
2986 return New_Copy_Tree
(Opnd_Low_Bound
(J
));
2990 Make_If_Expression
(Loc
,
2991 Expressions
=> New_List
(
2995 New_Occurrence_Of
(Var_Length
(J
), Loc
),
2997 Make_Integer_Literal
(Loc
, 0)),
2999 New_Copy_Tree
(Opnd_Low_Bound
(J
)),
3000 Get_Known_Bound
(J
+ 1)));
3002 end Get_Known_Bound
;
3005 Ent
:= Make_Temporary
(Loc
, 'L');
3008 Make_Object_Declaration
(Loc
,
3009 Defining_Identifier
=> Ent
,
3010 Constant_Present
=> True,
3011 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3012 Expression
=> Get_Known_Bound
(1)));
3014 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3018 pragma Assert
(Present
(Low_Bound
));
3020 -- Now we can compute the high bound as Low_Bound + Length - 1
3022 if Compile_Time_Known_Value
(Low_Bound
)
3023 and then Nkind
(Aggr_Length
(NN
)) = N_Integer_Literal
3028 (Expr_Value
(Low_Bound
) + Intval
(Aggr_Length
(NN
)) - 1));
3034 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3036 Make_Op_Subtract
(Loc
,
3037 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3038 Right_Opnd
=> Make_Artyp_Literal
(Uint_1
))));
3040 -- Note that calculation of the high bound may cause overflow in some
3041 -- very weird cases, so in the general case we need an overflow check
3042 -- on the high bound. We can avoid this for the common case of string
3043 -- types and other types whose index is Positive, since we chose a
3044 -- wider range for the arithmetic type. If checks are suppressed, we
3045 -- do not set the flag so superfluous warnings may be omitted.
3047 if Istyp
/= Standard_Positive
3048 and then not Overflow_Checks_Suppressed
(Istyp
)
3050 Activate_Overflow_Check
(High_Bound
);
3054 -- Handle the exceptional case where the result is null, in which case
3055 -- case the bounds come from the last operand (so that we get the proper
3056 -- bounds if the last operand is superflat).
3058 if Result_May_Be_Null
then
3060 Make_If_Expression
(Loc
,
3061 Expressions
=> New_List
(
3063 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3064 Right_Opnd
=> Make_Artyp_Literal
(Uint_0
)),
3065 Last_Opnd_Low_Bound
,
3069 Make_If_Expression
(Loc
,
3070 Expressions
=> New_List
(
3072 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3073 Right_Opnd
=> Make_Artyp_Literal
(Uint_0
)),
3074 Last_Opnd_High_Bound
,
3078 -- Here is where we insert the saved up actions
3080 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3082 -- If the low bound is known at compile time and not the high bound, but
3083 -- we have computed a sensible upper bound for the length, then adjust
3084 -- the high bound for the subtype of the array. This will change it into
3085 -- a static subtype and thus help the code generator.
3087 if Compile_Time_Known_Value
(Low_Bound
)
3088 and then not Compile_Time_Known_Value
(High_Bound
)
3089 and then Max_Aggr_Length
< Too_Large_Length_For_Array
3092 Known_High_Bound
: constant Node_Id
:=
3095 (Expr_Value
(Low_Bound
) + Max_Aggr_Length
- 1));
3098 if not Is_Out_Of_Range
(Known_High_Bound
, Ityp
) then
3099 Slice_Rng
:= Make_Range
(Loc
, Low_Bound
, High_Bound
);
3100 High_Bound
:= Known_High_Bound
;
3111 Subtyp_Rng
:= Make_Range
(Loc
, Low_Bound
, High_Bound
);
3113 -- If the result cannot be null then the range cannot be superflat
3115 Set_Cannot_Be_Superflat
(Subtyp_Rng
, not Result_May_Be_Null
);
3117 -- Now we construct an array object with appropriate bounds. We mark
3118 -- the target as internal to prevent useless initialization when
3119 -- Initialize_Scalars is enabled. Also since this is the actual result
3120 -- entity, we make sure we have debug information for the result.
3123 Make_Subtype_Indication
(Loc
,
3124 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3126 Make_Index_Or_Discriminant_Constraint
(Loc
,
3127 Constraints
=> New_List
(Subtyp_Rng
)));
3129 Ent
:= Make_Temporary
(Loc
, 'S');
3130 Set_Is_Internal
(Ent
);
3131 Set_Debug_Info_Needed
(Ent
);
3133 -- If we are concatenating strings and the current scope already uses
3134 -- the secondary stack, allocate the result also on the secondary stack
3135 -- to avoid putting too much pressure on the primary stack.
3137 -- Don't do this if -gnatd.h is set, as this will break the wrapping of
3138 -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat.
3140 if Atyp
= Standard_String
3141 and then Uses_Sec_Stack
(Current_Scope
)
3142 and then RTE_Available
(RE_SS_Pool
)
3143 and then not Debug_Flag_Dot_H
3146 -- subtype Axx is String (<low-bound> .. <high-bound>)
3147 -- type Ayy is access Axx;
3148 -- Rxx : Ayy := new <Axx> [storage_pool = ss_pool];
3149 -- Sxx : Axx renames Rxx.all;
3152 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3153 Acc_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3159 Insert_Action
(Cnode
,
3160 Make_Subtype_Declaration
(Loc
,
3161 Defining_Identifier
=> ConstrT
,
3162 Subtype_Indication
=> Subtyp_Ind
),
3163 Suppress
=> All_Checks
);
3165 Freeze_Itype
(ConstrT
, Cnode
);
3167 Insert_Action
(Cnode
,
3168 Make_Full_Type_Declaration
(Loc
,
3169 Defining_Identifier
=> Acc_Typ
,
3171 Make_Access_To_Object_Definition
(Loc
,
3172 Subtype_Indication
=> New_Occurrence_Of
(ConstrT
, Loc
))),
3173 Suppress
=> All_Checks
);
3175 Mutate_Ekind
(Acc_Typ
, E_Access_Type
);
3176 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_SS_Pool
));
3179 Make_Allocator
(Loc
,
3180 Expression
=> New_Occurrence_Of
(ConstrT
, Loc
));
3182 -- This is currently done only for type String, which normally
3183 -- doesn't have default initialization, but we need to set the
3184 -- No_Initialization flag in case of either Initialize_Scalars
3185 -- or Normalize_Scalars.
3187 Set_No_Initialization
(Alloc
);
3189 Temp
:= Make_Temporary
(Loc
, 'R', Alloc
);
3190 Insert_Action
(Cnode
,
3191 Make_Object_Declaration
(Loc
,
3192 Defining_Identifier
=> Temp
,
3193 Object_Definition
=> New_Occurrence_Of
(Acc_Typ
, Loc
),
3194 Expression
=> Alloc
),
3195 Suppress
=> All_Checks
);
3197 Insert_Action
(Cnode
,
3198 Make_Object_Renaming_Declaration
(Loc
,
3199 Defining_Identifier
=> Ent
,
3200 Subtype_Mark
=> New_Occurrence_Of
(ConstrT
, Loc
),
3202 Make_Explicit_Dereference
(Loc
,
3203 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
3204 Suppress
=> All_Checks
);
3208 -- If the bound is statically known to be out of range, we do not
3209 -- want to abort, we want a warning and a runtime constraint error.
3210 -- Note that we have arranged that the result will not be treated
3211 -- as a static constant, so we won't get an illegality during this
3212 -- insertion. We also enable checks (in particular range checks) in
3213 -- case the bounds of Subtyp_Ind are out of range.
3215 Insert_Action
(Cnode
,
3216 Make_Object_Declaration
(Loc
,
3217 Defining_Identifier
=> Ent
,
3218 Object_Definition
=> Subtyp_Ind
));
3221 -- If the result of the concatenation appears as the initializing
3222 -- expression of an object declaration, we can just rename the
3223 -- result, rather than copying it.
3225 Set_OK_To_Rename
(Ent
);
3227 -- Catch the static out of range case now
3229 if Raises_Constraint_Error
(High_Bound
)
3230 or else Is_Out_Of_Range
(High_Bound
, Ityp
)
3232 -- Kill warning generated for the declaration of the static out of
3233 -- range high bound, and instead generate a Constraint_Error with
3234 -- an appropriate specific message.
3236 if Nkind
(High_Bound
) = N_Integer_Literal
then
3237 Kill_Dead_Code
(High_Bound
);
3238 Rewrite
(High_Bound
, New_Copy_Tree
(Low_Bound
));
3241 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3244 Apply_Compile_Time_Constraint_Error
3246 Msg
=> "concatenation result upper bound out of range??",
3247 Reason
=> CE_Range_Check_Failed
);
3252 -- Now we will generate the assignments to do the actual concatenation
3254 -- There is one case in which we will not do this, namely when all the
3255 -- following conditions are met:
3257 -- The result type is Standard.String
3259 -- There are nine or fewer retained (non-null) operands
3261 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3262 -- and the debug flag gnatd.c is not set.
3264 -- The corresponding System.Concat_n.Str_Concat_n routine is
3265 -- available in the run time.
3267 -- If all these conditions are met then we generate a call to the
3268 -- relevant concatenation routine. The purpose of this is to avoid
3269 -- undesirable code bloat at -O0.
3271 -- If the concatenation is within the declaration of a library-level
3272 -- object, we call the built-in concatenation routines to prevent code
3273 -- bloat, regardless of the optimization level. This is space efficient
3274 -- and prevents linking problems when units are compiled with different
3275 -- optimization levels.
3277 if Atyp
= Standard_String
3278 and then NN
in 2 .. 9
3279 and then (((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3280 and then not Debug_Flag_Dot_C
)
3281 or else Library_Level_Target
)
3284 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3295 if RTE_Available
(RR
(NN
)) then
3297 Opnds
: constant List_Id
:=
3298 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3301 for J
in 1 .. NN
loop
3302 if Is_List_Member
(Operands
(J
)) then
3303 Remove
(Operands
(J
));
3306 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3308 Make_Aggregate
(Loc
,
3309 Component_Associations
=> New_List
(
3310 Make_Component_Association
(Loc
,
3311 Choices
=> New_List
(
3312 Make_Integer_Literal
(Loc
, 1)),
3313 Expression
=> Operands
(J
)))));
3316 Append_To
(Opnds
, Operands
(J
));
3320 Insert_Action
(Cnode
,
3321 Make_Procedure_Call_Statement
(Loc
,
3322 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3323 Parameter_Associations
=> Opnds
));
3325 -- No assignments left to do below
3333 -- Not special case so generate the assignments
3335 Known_Non_Null_Operand_Seen
:= False;
3337 for J
in 1 .. NN
loop
3339 Lo
: constant Node_Id
:=
3341 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3342 Right_Opnd
=> Aggr_Length
(J
- 1));
3344 Hi
: constant Node_Id
:=
3346 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3348 Make_Op_Subtract
(Loc
,
3349 Left_Opnd
=> Aggr_Length
(J
),
3350 Right_Opnd
=> Make_Artyp_Literal
(Uint_1
)));
3353 -- Singleton case, simple assignment
3355 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3356 Known_Non_Null_Operand_Seen
:= True;
3357 Insert_Action
(Cnode
,
3358 Make_Assignment_Statement
(Loc
,
3360 Make_Indexed_Component
(Loc
,
3361 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3362 Expressions
=> New_List
(To_Ityp
(Lo
))),
3363 Expression
=> Operands
(J
)),
3364 Suppress
=> All_Checks
);
3366 -- Array case, slice assignment, skipped when argument is fixed
3367 -- length and known to be null.
3369 elsif not Is_Fixed_Length
(J
) or else Fixed_Length
(J
) > 0 then
3372 Make_Assignment_Statement
(Loc
,
3376 New_Occurrence_Of
(Ent
, Loc
),
3379 Low_Bound
=> To_Ityp
(Lo
),
3380 High_Bound
=> To_Ityp
(Hi
))),
3381 Expression
=> Operands
(J
));
3383 if Is_Fixed_Length
(J
) then
3384 Known_Non_Null_Operand_Seen
:= True;
3386 elsif not Known_Non_Null_Operand_Seen
then
3388 -- Here if operand length is not statically known and no
3389 -- operand known to be non-null has been processed yet.
3390 -- If operand length is 0, we do not need to perform the
3391 -- assignment, and we must avoid the evaluation of the
3392 -- high bound of the slice, since it may underflow if the
3393 -- low bound is Ityp'First.
3396 Make_Implicit_If_Statement
(Cnode
,
3400 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3401 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3402 Then_Statements
=> New_List
(Assign
));
3405 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3411 -- Finally we build the result, which is either a direct reference to
3412 -- the array object or a slice of it.
3414 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3416 if Present
(Slice_Rng
) then
3417 Result
:= Make_Slice
(Loc
, Result
, Slice_Rng
);
3421 pragma Assert
(Present
(Result
));
3422 Rewrite
(Cnode
, Result
);
3423 Analyze_And_Resolve
(Cnode
, Atyp
);
3424 end Expand_Concatenate
;
3426 ---------------------------------------------------
3427 -- Expand_Membership_Minimize_Eliminate_Overflow --
3428 ---------------------------------------------------
3430 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3431 pragma Assert
(Nkind
(N
) = N_In
);
3432 -- Despite the name, this routine applies only to N_In, not to
3433 -- N_Not_In. The latter is always rewritten as not (X in Y).
3435 Result_Type
: constant Entity_Id
:= Etype
(N
);
3436 -- Capture result type, may be a derived boolean type
3438 Loc
: constant Source_Ptr
:= Sloc
(N
);
3439 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3440 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3442 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3443 -- is thus tempting to capture these values, but due to the rewrites
3444 -- that occur as a result of overflow checking, these values change
3445 -- as we go along, and it is safe just to always use Etype explicitly.
3447 Restype
: constant Entity_Id
:= Etype
(N
);
3451 -- Bounds in Minimize calls, not used currently
3453 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3454 -- Entity for Long_Long_Integer'Base
3457 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3459 -- If right operand is a subtype name, and the subtype name has no
3460 -- predicate, then we can just replace the right operand with an
3461 -- explicit range T'First .. T'Last, and use the explicit range code.
3463 if Nkind
(Rop
) /= N_Range
3464 and then No
(Predicate_Function
(Etype
(Rop
)))
3467 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3472 Make_Attribute_Reference
(Loc
,
3473 Attribute_Name
=> Name_First
,
3474 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3476 Make_Attribute_Reference
(Loc
,
3477 Attribute_Name
=> Name_Last
,
3478 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3479 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3483 -- Here for the explicit range case. Note that the bounds of the range
3484 -- have not been processed for minimized or eliminated checks.
3486 if Nkind
(Rop
) = N_Range
then
3487 Minimize_Eliminate_Overflows
3488 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3489 Minimize_Eliminate_Overflows
3490 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3492 -- We have A in B .. C, treated as A >= B and then A <= C
3496 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3497 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3498 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3501 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3502 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3503 L
: constant Entity_Id
:=
3504 Make_Defining_Identifier
(Loc
, Name_uL
);
3505 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3506 Lbound
: constant Node_Id
:=
3507 Convert_To_Bignum
(Low_Bound
(Rop
));
3508 Hbound
: constant Node_Id
:=
3509 Convert_To_Bignum
(High_Bound
(Rop
));
3511 -- Now we rewrite the membership test node to look like
3514 -- Bnn : Result_Type;
3516 -- M : Mark_Id := SS_Mark;
3517 -- L : Bignum := Lopnd;
3519 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3527 -- Insert declaration of L into declarations of bignum block
3530 (Last
(Declarations
(Blk
)),
3531 Make_Object_Declaration
(Loc
,
3532 Defining_Identifier
=> L
,
3533 Object_Definition
=>
3534 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3535 Expression
=> Lopnd
));
3537 -- Insert assignment to Bnn into expressions of bignum block
3540 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3541 Make_Assignment_Statement
(Loc
,
3542 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3546 Make_Function_Call
(Loc
,
3548 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3549 Parameter_Associations
=> New_List
(
3550 New_Occurrence_Of
(L
, Loc
),
3554 Make_Function_Call
(Loc
,
3556 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3557 Parameter_Associations
=> New_List
(
3558 New_Occurrence_Of
(L
, Loc
),
3561 -- Now rewrite the node
3564 Make_Expression_With_Actions
(Loc
,
3565 Actions
=> New_List
(
3566 Make_Object_Declaration
(Loc
,
3567 Defining_Identifier
=> Bnn
,
3568 Object_Definition
=>
3569 New_Occurrence_Of
(Result_Type
, Loc
)),
3571 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3572 Analyze_And_Resolve
(N
, Result_Type
);
3576 -- Here if no bignums around
3579 -- Case where types are all the same
3581 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3583 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3587 -- If types are not all the same, it means that we have rewritten
3588 -- at least one of them to be of type Long_Long_Integer, and we
3589 -- will convert the other operands to Long_Long_Integer.
3592 Convert_To_And_Rewrite
(LLIB
, Lop
);
3593 Set_Analyzed
(Lop
, False);
3594 Analyze_And_Resolve
(Lop
, LLIB
);
3596 -- For the right operand, avoid unnecessary recursion into
3597 -- this routine, we know that overflow is not possible.
3599 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3600 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3601 Set_Analyzed
(Rop
, False);
3602 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3605 -- Now the three operands are of the same signed integer type,
3606 -- so we can use the normal expansion routine for membership,
3607 -- setting the flag to prevent recursion into this procedure.
3609 Set_No_Minimize_Eliminate
(N
);
3613 -- Right operand is a subtype name and the subtype has a predicate. We
3614 -- have to make sure the predicate is checked, and for that we need to
3615 -- use the standard N_In circuitry with appropriate types.
3618 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3620 -- If types are "right", just call Expand_N_In preventing recursion
3622 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3623 Set_No_Minimize_Eliminate
(N
);
3628 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3630 -- For X in T, we want to rewrite our node as
3633 -- Bnn : Result_Type;
3636 -- M : Mark_Id := SS_Mark;
3637 -- Lnn : Long_Long_Integer'Base
3643 -- if not Bignum_In_LLI_Range (Nnn) then
3646 -- Lnn := From_Bignum (Nnn);
3648 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3649 -- and then T'Base (Lnn) in T;
3658 -- A bit gruesome, but there doesn't seem to be a simpler way
3661 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3662 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3663 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3664 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3665 T
: constant Entity_Id
:= Etype
(Rop
);
3666 TB
: constant Entity_Id
:= Base_Type
(T
);
3670 -- Mark the last membership operation to prevent recursion
3674 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3675 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3676 Set_No_Minimize_Eliminate
(Nin
);
3678 -- Now decorate the block
3681 (Last
(Declarations
(Blk
)),
3682 Make_Object_Declaration
(Loc
,
3683 Defining_Identifier
=> Lnn
,
3684 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3687 (Last
(Declarations
(Blk
)),
3688 Make_Object_Declaration
(Loc
,
3689 Defining_Identifier
=> Nnn
,
3690 Object_Definition
=>
3691 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3694 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3696 Make_Assignment_Statement
(Loc
,
3697 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3698 Expression
=> Relocate_Node
(Lop
)),
3700 Make_Implicit_If_Statement
(N
,
3704 Make_Function_Call
(Loc
,
3707 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3708 Parameter_Associations
=> New_List
(
3709 New_Occurrence_Of
(Nnn
, Loc
)))),
3711 Then_Statements
=> New_List
(
3712 Make_Assignment_Statement
(Loc
,
3713 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3715 New_Occurrence_Of
(Standard_False
, Loc
))),
3717 Else_Statements
=> New_List
(
3718 Make_Assignment_Statement
(Loc
,
3719 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3721 Make_Function_Call
(Loc
,
3723 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3724 Parameter_Associations
=> New_List
(
3725 New_Occurrence_Of
(Nnn
, Loc
)))),
3727 Make_Assignment_Statement
(Loc
,
3728 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3733 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3738 Make_Attribute_Reference
(Loc
,
3739 Attribute_Name
=> Name_First
,
3741 New_Occurrence_Of
(TB
, Loc
))),
3745 Make_Attribute_Reference
(Loc
,
3746 Attribute_Name
=> Name_Last
,
3748 New_Occurrence_Of
(TB
, Loc
))))),
3750 Right_Opnd
=> Nin
))))));
3752 -- Now we can do the rewrite
3755 Make_Expression_With_Actions
(Loc
,
3756 Actions
=> New_List
(
3757 Make_Object_Declaration
(Loc
,
3758 Defining_Identifier
=> Bnn
,
3759 Object_Definition
=>
3760 New_Occurrence_Of
(Result_Type
, Loc
)),
3762 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3763 Analyze_And_Resolve
(N
, Result_Type
);
3767 -- Not bignum case, but types don't match (this means we rewrote the
3768 -- left operand to be Long_Long_Integer).
3771 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
3773 -- We rewrite the membership test as (where T is the type with
3774 -- the predicate, i.e. the type of the right operand)
3776 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3777 -- and then T'Base (Lop) in T
3780 T
: constant Entity_Id
:= Etype
(Rop
);
3781 TB
: constant Entity_Id
:= Base_Type
(T
);
3785 -- The last membership test is marked to prevent recursion
3789 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
3790 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3791 Set_No_Minimize_Eliminate
(Nin
);
3793 -- Now do the rewrite
3804 Make_Attribute_Reference
(Loc
,
3805 Attribute_Name
=> Name_First
,
3807 New_Occurrence_Of
(TB
, Loc
))),
3810 Make_Attribute_Reference
(Loc
,
3811 Attribute_Name
=> Name_Last
,
3813 New_Occurrence_Of
(TB
, Loc
))))),
3814 Right_Opnd
=> Nin
));
3815 Set_Analyzed
(N
, False);
3816 Analyze_And_Resolve
(N
, Restype
);
3820 end Expand_Membership_Minimize_Eliminate_Overflow
;
3822 ---------------------------------
3823 -- Expand_Nonbinary_Modular_Op --
3824 ---------------------------------
3826 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
) is
3827 Loc
: constant Source_Ptr
:= Sloc
(N
);
3828 Typ
: constant Entity_Id
:= Etype
(N
);
3830 procedure Expand_Modular_Addition
;
3831 -- Expand the modular addition, handling the special case of adding a
3834 procedure Expand_Modular_Op
;
3835 -- Compute the general rule: (lhs OP rhs) mod Modulus
3837 procedure Expand_Modular_Subtraction
;
3838 -- Expand the modular addition, handling the special case of subtracting
3841 -----------------------------
3842 -- Expand_Modular_Addition --
3843 -----------------------------
3845 procedure Expand_Modular_Addition
is
3847 -- If this is not the addition of a constant then compute it using
3848 -- the general rule: (lhs + rhs) mod Modulus
3850 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
3853 -- If this is an addition of a constant, convert it to a subtraction
3854 -- plus a conditional expression since we can compute it faster than
3855 -- computing the modulus.
3857 -- modMinusRhs = Modulus - rhs
3858 -- if lhs < modMinusRhs then lhs + rhs
3859 -- else lhs - modMinusRhs
3863 Mod_Minus_Right
: constant Uint
:=
3864 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
3866 Cond_Expr
: Node_Id
;
3867 Then_Expr
: Node_Id
;
3868 Else_Expr
: Node_Id
;
3870 -- To prevent spurious visibility issues, convert all
3871 -- operands to Standard.Unsigned.
3876 Unchecked_Convert_To
(Standard_Unsigned
,
3877 New_Copy_Tree
(Left_Opnd
(N
))),
3879 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
3884 Unchecked_Convert_To
(Standard_Unsigned
,
3885 New_Copy_Tree
(Left_Opnd
(N
))),
3887 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
3890 Make_Op_Subtract
(Loc
,
3892 Unchecked_Convert_To
(Standard_Unsigned
,
3893 New_Copy_Tree
(Left_Opnd
(N
))),
3895 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
3898 Unchecked_Convert_To
(Typ
,
3899 Make_If_Expression
(Loc
,
3901 New_List
(Cond_Expr
, Then_Expr
, Else_Expr
))));
3904 end Expand_Modular_Addition
;
3906 -----------------------
3907 -- Expand_Modular_Op --
3908 -----------------------
3910 procedure Expand_Modular_Op
is
3911 -- We will convert to another type (not a nonbinary-modulus modular
3912 -- type), evaluate the op in that representation, reduce the result,
3913 -- and convert back to the original type. This means that the
3914 -- backend does not have to deal with nonbinary-modulus ops.
3916 Op_Expr
: constant Node_Id
:= New_Op_Node
(Nkind
(N
), Loc
);
3919 Target_Type
: Entity_Id
;
3921 -- Select a target type that is large enough to avoid spurious
3922 -- intermediate overflow on pre-reduction computation (for
3923 -- correctness) but is no larger than is needed (for performance).
3926 Required_Size
: Uint
:= RM_Size
(Etype
(N
));
3927 Use_Unsigned
: Boolean := True;
3931 -- For example, if modulus is 255 then RM_Size will be 8
3932 -- and the range of possible values (before reduction) will
3933 -- be 0 .. 508; that range requires 9 bits.
3934 Required_Size
:= Required_Size
+ 1;
3936 when N_Op_Subtract
=>
3937 -- For example, if modulus is 255 then RM_Size will be 8
3938 -- and the range of possible values (before reduction) will
3939 -- be -254 .. 254; that range requires 9 bits, signed.
3940 Use_Unsigned
:= False;
3941 Required_Size
:= Required_Size
+ 1;
3943 when N_Op_Multiply
=>
3944 -- For example, if modulus is 255 then RM_Size will be 8
3945 -- and the range of possible values (before reduction) will
3946 -- be 0 .. 64,516; that range requires 16 bits.
3947 Required_Size
:= Required_Size
* 2;
3953 if Use_Unsigned
then
3954 if Required_Size
<= Standard_Short_Short_Integer_Size
then
3955 Target_Type
:= Standard_Short_Short_Unsigned
;
3956 elsif Required_Size
<= Standard_Short_Integer_Size
then
3957 Target_Type
:= Standard_Short_Unsigned
;
3958 elsif Required_Size
<= Standard_Integer_Size
then
3959 Target_Type
:= Standard_Unsigned
;
3961 pragma Assert
(Required_Size
<= 64);
3962 Target_Type
:= Standard_Unsigned_64
;
3964 elsif Required_Size
<= 8 then
3965 Target_Type
:= Standard_Integer_8
;
3966 elsif Required_Size
<= 16 then
3967 Target_Type
:= Standard_Integer_16
;
3968 elsif Required_Size
<= 32 then
3969 Target_Type
:= Standard_Integer_32
;
3971 pragma Assert
(Required_Size
<= 64);
3972 Target_Type
:= Standard_Integer_64
;
3975 pragma Assert
(Present
(Target_Type
));
3978 Set_Left_Opnd
(Op_Expr
,
3979 Unchecked_Convert_To
(Target_Type
,
3980 New_Copy_Tree
(Left_Opnd
(N
))));
3981 Set_Right_Opnd
(Op_Expr
,
3982 Unchecked_Convert_To
(Target_Type
,
3983 New_Copy_Tree
(Right_Opnd
(N
))));
3985 -- ??? Why do this stuff for some ops and not others?
3986 if Nkind
(N
) not in N_Op_And | N_Op_Or | N_Op_Xor
then
3988 -- Link this node to the tree to analyze it
3990 -- If the parent node is an expression with actions we link it to
3991 -- N since otherwise Force_Evaluation cannot identify if this node
3992 -- comes from the Expression and rejects generating the temporary.
3994 if Nkind
(Parent
(N
)) = N_Expression_With_Actions
then
3995 Set_Parent
(Op_Expr
, N
);
4000 Set_Parent
(Op_Expr
, Parent
(N
));
4005 -- Force generating a temporary because in the expansion of this
4006 -- expression we may generate code that performs this computation
4009 Force_Evaluation
(Op_Expr
, Mode
=> Strict
);
4014 Left_Opnd
=> Op_Expr
,
4015 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modulus
(Typ
)));
4018 Unchecked_Convert_To
(Typ
, Mod_Expr
));
4019 end Expand_Modular_Op
;
4021 --------------------------------
4022 -- Expand_Modular_Subtraction --
4023 --------------------------------
4025 procedure Expand_Modular_Subtraction
is
4027 -- If this is not the addition of a constant then compute it using
4028 -- the general rule: (lhs + rhs) mod Modulus
4030 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4033 -- If this is an addition of a constant, convert it to a subtraction
4034 -- plus a conditional expression since we can compute it faster than
4035 -- computing the modulus.
4037 -- modMinusRhs = Modulus - rhs
4038 -- if lhs < rhs then lhs + modMinusRhs
4043 Mod_Minus_Right
: constant Uint
:=
4044 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4046 Cond_Expr
: Node_Id
;
4047 Then_Expr
: Node_Id
;
4048 Else_Expr
: Node_Id
;
4053 Unchecked_Convert_To
(Standard_Unsigned
,
4054 New_Copy_Tree
(Left_Opnd
(N
))),
4056 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4061 Unchecked_Convert_To
(Standard_Unsigned
,
4062 New_Copy_Tree
(Left_Opnd
(N
))),
4064 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4067 Make_Op_Subtract
(Loc
,
4069 Unchecked_Convert_To
(Standard_Unsigned
,
4070 New_Copy_Tree
(Left_Opnd
(N
))),
4072 Unchecked_Convert_To
(Standard_Unsigned
,
4073 New_Copy_Tree
(Right_Opnd
(N
))));
4076 Unchecked_Convert_To
(Typ
,
4077 Make_If_Expression
(Loc
,
4079 New_List
(Cond_Expr
, Then_Expr
, Else_Expr
))));
4082 end Expand_Modular_Subtraction
;
4084 -- Start of processing for Expand_Nonbinary_Modular_Op
4087 -- No action needed if front-end expansion is not required or if we
4088 -- have a binary modular operand.
4090 if not Expand_Nonbinary_Modular_Ops
4091 or else not Non_Binary_Modulus
(Typ
)
4098 Expand_Modular_Addition
;
4100 when N_Op_Subtract
=>
4101 Expand_Modular_Subtraction
;
4105 -- Expand -expr into (0 - expr)
4108 Make_Op_Subtract
(Loc
,
4109 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
4110 Right_Opnd
=> Right_Opnd
(N
)));
4111 Analyze_And_Resolve
(N
, Typ
);
4117 Analyze_And_Resolve
(N
, Typ
);
4118 end Expand_Nonbinary_Modular_Op
;
4120 ------------------------
4121 -- Expand_N_Allocator --
4122 ------------------------
4124 procedure Expand_N_Allocator
(N
: Node_Id
) is
4125 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4126 Loc
: constant Source_Ptr
:= Sloc
(N
);
4127 PtrT
: constant Entity_Id
:= Etype
(N
);
4129 procedure Rewrite_Coextension
(N
: Node_Id
);
4130 -- Static coextensions have the same lifetime as the entity they
4131 -- constrain. Such occurrences can be rewritten as aliased objects
4132 -- and their unrestricted access used instead of the coextension.
4134 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4135 -- Given a constrained array type E, returns a node representing the
4136 -- code to compute a close approximation of the size in storage elements
4137 -- for the given type; for indexes that are modular types we compute
4138 -- 'Last - First (instead of 'Length) because for large arrays computing
4139 -- 'Last -'First + 1 causes overflow. This is done without using the
4140 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4143 -------------------------
4144 -- Rewrite_Coextension --
4145 -------------------------
4147 procedure Rewrite_Coextension
(N
: Node_Id
) is
4148 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4149 Temp_Decl
: Node_Id
;
4153 -- Cnn : aliased Etyp;
4156 Make_Object_Declaration
(Loc
,
4157 Defining_Identifier
=> Temp_Id
,
4158 Aliased_Present
=> True,
4159 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4161 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4162 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4165 Insert_Action
(N
, Temp_Decl
);
4167 Make_Attribute_Reference
(Loc
,
4168 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4169 Attribute_Name
=> Name_Unrestricted_Access
));
4171 Analyze_And_Resolve
(N
, PtrT
);
4172 end Rewrite_Coextension
;
4174 ------------------------------
4175 -- Size_In_Storage_Elements --
4176 ------------------------------
4178 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4179 Idx
: Node_Id
:= First_Index
(E
);
4181 Res
: Node_Id
:= Empty
;
4184 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4185 -- However, the reason for the existence of this function is to
4186 -- construct a test for sizes too large, which means near the 32-bit
4187 -- limit on a 32-bit machine, and precisely the trouble is that we
4188 -- get overflows when sizes are greater than 2**31.
4190 -- So what we end up doing for array types is to use the expression:
4192 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4194 -- which avoids this problem. All this is a bit bogus, but it does
4195 -- mean we catch common cases of trying to allocate arrays that are
4196 -- too large, and which in the absence of a check results in
4197 -- undetected chaos ???
4199 for J
in 1 .. Number_Dimensions
(E
) loop
4201 if not Is_Modular_Integer_Type
(Etype
(Idx
)) then
4203 Make_Attribute_Reference
(Loc
,
4204 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4205 Attribute_Name
=> Name_Length
,
4206 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4208 -- For indexes that are modular types we cannot generate code to
4209 -- compute 'Length since for large arrays 'Last -'First + 1 causes
4210 -- overflow; therefore we compute 'Last - 'First (which is not the
4211 -- exact number of components but it is valid for the purpose of
4212 -- this runtime check on 32-bit targets).
4216 Len_Minus_1_Expr
: Node_Id
;
4222 Make_Attribute_Reference
(Loc
,
4223 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4224 Attribute_Name
=> Name_Last
,
4226 New_List
(Make_Integer_Literal
(Loc
, J
))),
4227 Make_Attribute_Reference
(Loc
,
4228 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4229 Attribute_Name
=> Name_First
,
4231 New_List
(Make_Integer_Literal
(Loc
, J
))));
4234 Convert_To
(Standard_Unsigned
,
4235 Make_Op_Subtract
(Loc
,
4236 Make_Attribute_Reference
(Loc
,
4237 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4238 Attribute_Name
=> Name_Last
,
4240 New_List
(Make_Integer_Literal
(Loc
, J
))),
4241 Make_Attribute_Reference
(Loc
,
4242 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4243 Attribute_Name
=> Name_First
,
4245 New_List
(Make_Integer_Literal
(Loc
, J
)))));
4247 -- Handle superflat arrays, i.e. arrays with such bounds as
4248 -- 4 .. 2, to ensure that the result is correct.
4251 -- (if X'Last > X'First then X'Last - X'First else 0)
4254 Make_If_Expression
(Loc
,
4255 Expressions
=> New_List
(
4258 Make_Integer_Literal
(Loc
, Uint_0
)));
4266 pragma Assert
(Present
(Res
));
4268 Make_Op_Multiply
(Loc
,
4277 Make_Op_Multiply
(Loc
,
4280 Make_Attribute_Reference
(Loc
,
4281 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4282 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4283 end Size_In_Storage_Elements
;
4287 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4291 Rel_Typ
: Entity_Id
;
4294 -- Start of processing for Expand_N_Allocator
4297 -- Warn on the presence of an allocator of an anonymous access type when
4298 -- enabled, except when it's an object declaration at library level.
4300 if Warn_On_Anonymous_Allocators
4301 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
4302 and then not (Is_Library_Level_Entity
(PtrT
)
4303 and then Nkind
(Associated_Node_For_Itype
(PtrT
)) =
4304 N_Object_Declaration
)
4306 Error_Msg_N
("?_a?use of an anonymous access type allocator", N
);
4309 -- RM E.2.2(17). We enforce that the expected type of an allocator
4310 -- shall not be a remote access-to-class-wide-limited-private type.
4311 -- We probably shouldn't be doing this legality check during expansion,
4312 -- but this is only an issue for Annex E users, and is unlikely to be a
4313 -- problem in practice.
4315 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4317 -- Processing for anonymous access-to-controlled types. These access
4318 -- types receive a special finalization master which appears in the
4319 -- declarations of the enclosing semantic unit. This expansion is done
4320 -- now to ensure that any additional types generated by this routine or
4321 -- Expand_Allocator_Expression inherit the proper type attributes.
4323 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4324 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4325 and then Needs_Finalization
(Dtyp
)
4327 -- Detect the allocation of an anonymous controlled object where the
4328 -- type of the context is named. For example:
4330 -- procedure Proc (Ptr : Named_Access_Typ);
4331 -- Proc (new Designated_Typ);
4333 -- Regardless of the anonymous-to-named access type conversion, the
4334 -- lifetime of the object must be associated with the named access
4335 -- type. Use the finalization-related attributes of this type.
4337 if Nkind
(Parent
(N
)) in N_Type_Conversion
4338 | N_Unchecked_Type_Conversion
4339 and then Ekind
(Etype
(Parent
(N
))) in E_Access_Subtype
4341 | E_General_Access_Type
4343 Rel_Typ
:= Etype
(Parent
(N
));
4348 -- Anonymous access-to-controlled types allocate on the global pool.
4349 -- Note that this is a "root type only" attribute.
4351 if No
(Associated_Storage_Pool
(PtrT
)) then
4352 if Present
(Rel_Typ
) then
4353 Set_Associated_Storage_Pool
4354 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4356 Set_Associated_Storage_Pool
4357 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4361 -- The finalization master must be inserted and analyzed as part of
4362 -- the current semantic unit. Note that the master is updated when
4363 -- analysis changes current units. Note that this is a "root type
4366 if Present
(Rel_Typ
) then
4367 Set_Finalization_Master
4368 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4370 Build_Anonymous_Master
(Root_Type
(PtrT
));
4374 -- Set the storage pool and find the appropriate version of Allocate to
4375 -- call. Do not overwrite the storage pool if it is already set, which
4376 -- can happen for build-in-place function returns (see
4377 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4379 if No
(Storage_Pool
(N
)) then
4380 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4382 if Present
(Pool
) then
4383 Set_Storage_Pool
(N
, Pool
);
4385 if Is_RTE
(Pool
, RE_RS_Pool
) then
4386 Set_Procedure_To_Call
(N
, RTE
(RE_RS_Allocate
));
4388 elsif Is_RTE
(Pool
, RE_SS_Pool
) then
4389 Check_Restriction
(No_Secondary_Stack
, N
);
4390 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4392 -- In the case of an allocator for a simple storage pool, locate
4393 -- and save a reference to the pool type's Allocate routine.
4395 elsif Present
(Get_Rep_Pragma
4396 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4399 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4400 Alloc_Op
: Entity_Id
;
4402 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4403 while Present
(Alloc_Op
) loop
4404 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4405 and then Present
(First_Formal
(Alloc_Op
))
4406 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4408 Set_Procedure_To_Call
(N
, Alloc_Op
);
4411 Alloc_Op
:= Homonym
(Alloc_Op
);
4416 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4417 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4420 Set_Procedure_To_Call
(N
,
4421 Find_Storage_Op
(Etype
(Pool
), Name_Allocate
));
4426 -- Under certain circumstances we can replace an allocator by an access
4427 -- to statically allocated storage. The conditions, as noted in AARM
4428 -- 3.10 (10c) are as follows:
4430 -- Size and initial value is known at compile time
4431 -- Access type is access-to-constant
4433 -- The allocator is not part of a constraint on a record component,
4434 -- because in that case the inserted actions are delayed until the
4435 -- record declaration is fully analyzed, which is too late for the
4436 -- analysis of the rewritten allocator.
4438 if Is_Access_Constant
(PtrT
)
4439 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4440 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4441 and then Size_Known_At_Compile_Time
4442 (Etype
(Expression
(Expression
(N
))))
4443 and then not Is_Record_Type
(Current_Scope
)
4445 -- Here we can do the optimization. For the allocator
4449 -- We insert an object declaration
4451 -- Tnn : aliased x := y;
4453 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4454 -- marked as requiring static allocation.
4456 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4457 Desig
:= Subtype_Mark
(Expression
(N
));
4459 -- If context is constrained, use constrained subtype directly,
4460 -- so that the constant is not labelled as having a nominally
4461 -- unconstrained subtype.
4463 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4464 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4468 Make_Object_Declaration
(Loc
,
4469 Defining_Identifier
=> Temp
,
4470 Aliased_Present
=> True,
4471 Constant_Present
=> Is_Access_Constant
(PtrT
),
4472 Object_Definition
=> Desig
,
4473 Expression
=> Expression
(Expression
(N
))));
4476 Make_Attribute_Reference
(Loc
,
4477 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4478 Attribute_Name
=> Name_Unrestricted_Access
));
4480 Analyze_And_Resolve
(N
, PtrT
);
4482 -- We set the variable as statically allocated, since we don't want
4483 -- it going on the stack of the current procedure.
4485 Set_Is_Statically_Allocated
(Temp
);
4489 -- Same if the allocator is an access discriminant for a local object:
4490 -- instead of an allocator we create a local value and constrain the
4491 -- enclosing object with the corresponding access attribute.
4493 if Is_Static_Coextension
(N
) then
4494 Rewrite_Coextension
(N
);
4498 -- Check for size too large, we do this because the back end misses
4499 -- proper checks here and can generate rubbish allocation calls when
4500 -- we are near the limit. We only do this for the 32-bit address case
4501 -- since that is from a practical point of view where we see a problem.
4503 if System_Address_Size
= 32
4504 and then not Storage_Checks_Suppressed
(PtrT
)
4505 and then not Storage_Checks_Suppressed
(Dtyp
)
4506 and then not Storage_Checks_Suppressed
(Etyp
)
4508 -- The check we want to generate should look like
4510 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4511 -- raise Storage_Error;
4514 -- where 3.5 gigabytes is a constant large enough to accommodate any
4515 -- reasonable request for. But we can't do it this way because at
4516 -- least at the moment we don't compute this attribute right, and
4517 -- can silently give wrong results when the result gets large. Since
4518 -- this is all about large results, that's bad, so instead we only
4519 -- apply the check for constrained arrays, and manually compute the
4520 -- value of the attribute ???
4522 -- The check on No_Initialization is used here to prevent generating
4523 -- this runtime check twice when the allocator is locally replaced by
4524 -- the expander with another one.
4526 if Is_Array_Type
(Etyp
) and then not No_Initialization
(N
) then
4529 Ins_Nod
: Node_Id
:= N
;
4530 Siz_Typ
: Entity_Id
:= Etyp
;
4534 -- For unconstrained array types initialized with a qualified
4535 -- expression we use its type to perform this check
4537 if not Is_Constrained
(Etyp
)
4538 and then not No_Initialization
(N
)
4539 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4541 Expr
:= Expression
(Expression
(N
));
4542 Siz_Typ
:= Etype
(Expression
(Expression
(N
)));
4544 -- If the qualified expression has been moved to an internal
4545 -- temporary (to remove side effects) then we must insert
4546 -- the runtime check before its declaration to ensure that
4547 -- the check is performed before the execution of the code
4548 -- computing the qualified expression.
4550 if Nkind
(Expr
) = N_Identifier
4551 and then Is_Internal_Name
(Chars
(Expr
))
4553 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
4555 Ins_Nod
:= Parent
(Entity
(Expr
));
4561 if Is_Constrained
(Siz_Typ
)
4562 and then Ekind
(Siz_Typ
) /= E_String_Literal_Subtype
4564 -- For CCG targets, the largest array may have up to 2**31-1
4565 -- components (i.e. 2 gigabytes if each array component is
4566 -- one byte). This ensures that fat pointer fields do not
4567 -- overflow, since they are 32-bit integer types, and also
4568 -- ensures that 'Length can be computed at run time.
4570 if Modify_Tree_For_C
then
4573 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4574 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4575 Uint_2
** 31 - Uint_1
));
4577 -- For native targets the largest object is 3.5 gigabytes
4582 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4583 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4584 Uint_7
* (Uint_2
** 29)));
4587 Insert_Action
(Ins_Nod
,
4588 Make_Raise_Storage_Error
(Loc
,
4590 Reason
=> SE_Object_Too_Large
));
4592 if Entity
(Cond
) = Standard_True
then
4594 ("object too large: Storage_Error will be raised at "
4602 -- If no storage pool has been specified, or the storage pool
4603 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4604 -- No_Standard_Allocators_After_Elaboration is present, then generate
4605 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4607 if Nkind
(N
) = N_Allocator
4608 and then (No
(Storage_Pool
(N
))
4609 or else Is_RTE
(Storage_Pool
(N
), RE_Global_Pool_Object
))
4610 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4613 Make_Procedure_Call_Statement
(Loc
,
4615 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4618 -- Handle case of qualified expression (other than optimization above)
4620 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4621 Expand_Allocator_Expression
(N
);
4625 -- If the allocator is for a type which requires initialization, and
4626 -- there is no initial value (i.e. operand is a subtype indication
4627 -- rather than a qualified expression), then we must generate a call to
4628 -- the initialization routine using an expressions action node:
4630 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4632 -- Here ptr_T is the pointer type for the allocator, and T is the
4633 -- subtype of the allocator. A special case arises if the designated
4634 -- type of the access type is a task or contains tasks. In this case
4635 -- the call to Init (Temp.all ...) is replaced by code that ensures
4636 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4637 -- for details). In addition, if the type T is a task type, then the
4638 -- first argument to Init must be converted to the task record type.
4641 T
: constant Entity_Id
:= Etype
(Expression
(N
));
4647 Init_Arg1
: Node_Id
;
4648 Init_Call
: Node_Id
;
4649 Temp_Decl
: Node_Id
;
4650 Temp_Type
: Entity_Id
;
4653 -- Apply constraint checks against designated subtype (RM 4.8(10/2))
4654 -- but ignore the expression if the No_Initialization flag is set.
4655 -- Discriminant checks will be generated by the expansion below.
4657 if Is_Array_Type
(Dtyp
) and then not No_Initialization
(N
) then
4658 Apply_Constraint_Check
(Expression
(N
), Dtyp
, No_Sliding
=> True);
4660 if Nkind
(Expression
(N
)) = N_Raise_Constraint_Error
then
4661 Rewrite
(N
, New_Copy
(Expression
(N
)));
4662 Set_Etype
(N
, PtrT
);
4667 if No_Initialization
(N
) then
4669 -- Even though this might be a simple allocation, create a custom
4670 -- Allocate if the context requires it.
4672 if Present
(Finalization_Master
(PtrT
)) then
4673 Build_Allocate_Deallocate_Proc
4675 Is_Allocate
=> True);
4678 -- Optimize the default allocation of an array object when pragma
4679 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4680 -- in-place initialization aggregate which may be convert into a fast
4681 -- memset by the backend.
4683 elsif Init_Or_Norm_Scalars
4684 and then Is_Array_Type
(T
)
4686 -- The array must lack atomic components because they are treated
4687 -- as non-static, and as a result the backend will not initialize
4688 -- the memory in one go.
4690 and then not Has_Atomic_Components
(T
)
4692 -- The array must not be packed because the invalid values in
4693 -- System.Scalar_Values are multiples of Storage_Unit.
4695 and then not Is_Packed
(T
)
4697 -- The array must have static non-empty ranges, otherwise the
4698 -- backend cannot initialize the memory in one go.
4700 and then Has_Static_Non_Empty_Array_Bounds
(T
)
4702 -- The optimization is only relevant for arrays of scalar types
4704 and then Is_Scalar_Type
(Component_Type
(T
))
4706 -- Similar to regular array initialization using a type init proc,
4707 -- predicate checks are not performed because the initialization
4708 -- values are intentionally invalid, and may violate the predicate.
4710 and then not Has_Predicates
(Component_Type
(T
))
4712 -- The component type must have a single initialization value
4714 and then Needs_Simple_Initialization
4715 (Typ
=> Component_Type
(T
),
4716 Consider_IS
=> True)
4719 Temp
:= Make_Temporary
(Loc
, 'P');
4722 -- Temp : Ptr_Typ := new ...;
4727 Make_Object_Declaration
(Loc
,
4728 Defining_Identifier
=> Temp
,
4729 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
4730 Expression
=> Relocate_Node
(N
)),
4731 Suppress
=> All_Checks
);
4734 -- Temp.all := (others => ...);
4739 Make_Assignment_Statement
(Loc
,
4741 Make_Explicit_Dereference
(Loc
,
4742 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
4747 Size
=> Esize
(Component_Type
(T
)))),
4748 Suppress
=> All_Checks
);
4750 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4751 Analyze_And_Resolve
(N
, PtrT
);
4753 Apply_Predicate_Check
(N
, Dtyp
, Deref
=> True);
4755 -- Case of no initialization procedure present
4757 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4759 -- Case of simple initialization required
4761 if Needs_Simple_Initialization
(T
) then
4762 Check_Restriction
(No_Default_Initialization
, N
);
4763 Rewrite
(Expression
(N
),
4764 Make_Qualified_Expression
(Loc
,
4765 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4766 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4768 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4769 Analyze_And_Resolve
(Expression
(N
), T
);
4770 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4771 Expand_N_Allocator
(N
);
4773 -- No initialization required
4776 Build_Allocate_Deallocate_Proc
4778 Is_Allocate
=> True);
4781 -- Case of initialization procedure present, must be called
4783 -- NOTE: There is a *huge* amount of code duplication here from
4784 -- Build_Initialization_Call. We should probably refactor???
4787 Check_Restriction
(No_Default_Initialization
, N
);
4789 if not Restriction_Active
(No_Default_Initialization
) then
4790 Init
:= Base_Init_Proc
(T
);
4792 Temp
:= Make_Temporary
(Loc
, 'P');
4794 -- Construct argument list for the initialization routine call
4797 Make_Explicit_Dereference
(Loc
,
4799 New_Occurrence_Of
(Temp
, Loc
));
4801 Set_Assignment_OK
(Init_Arg1
);
4804 -- The initialization procedure expects a specific type. if the
4805 -- context is access to class wide, indicate that the object
4806 -- being allocated has the right specific type.
4808 if Is_Class_Wide_Type
(Dtyp
) then
4809 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4812 -- If designated type is a concurrent type or if it is private
4813 -- type whose definition is a concurrent type, the first
4814 -- argument in the Init routine has to be unchecked conversion
4815 -- to the corresponding record type. If the designated type is
4816 -- a derived type, also convert the argument to its root type.
4818 if Is_Concurrent_Type
(T
) then
4820 Unchecked_Convert_To
(
4821 Corresponding_Record_Type
(T
), Init_Arg1
);
4823 elsif Is_Private_Type
(T
)
4824 and then Present
(Full_View
(T
))
4825 and then Is_Concurrent_Type
(Full_View
(T
))
4828 Unchecked_Convert_To
4829 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4831 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4833 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4836 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4837 Set_Etype
(Init_Arg1
, Ftyp
);
4841 Args
:= New_List
(Init_Arg1
);
4843 -- For the task case, pass the Master_Id of the access type as
4844 -- the value of the _Master parameter, and _Chain as the value
4845 -- of the _Chain parameter (_Chain will be defined as part of
4846 -- the generated code for the allocator).
4848 -- In Ada 2005, the context may be a function that returns an
4849 -- anonymous access type. In that case the Master_Id has been
4850 -- created when expanding the function declaration.
4852 if Has_Task
(T
) then
4853 if No
(Master_Id
(Base_Type
(PtrT
))) then
4855 -- The designated type was an incomplete type, and the
4856 -- access type did not get expanded. Salvage it now.
4858 if Present
(Parent
(Base_Type
(PtrT
))) then
4859 Expand_N_Full_Type_Declaration
4860 (Parent
(Base_Type
(PtrT
)));
4862 -- When the allocator has a subtype indication then a
4863 -- constraint is present and an itype has been added by
4864 -- Analyze_Allocator as the subtype of this allocator.
4866 -- If an allocator with constraints is called in the
4867 -- return statement of a function returning a general
4868 -- access type, then propagate to the itype the master
4869 -- of the general access type (since it is the master
4870 -- associated with the returned object).
4872 elsif Is_Itype
(PtrT
)
4873 and then Ekind
(Current_Scope
) = E_Function
4874 and then Ekind
(Etype
(Current_Scope
))
4875 = E_General_Access_Type
4876 and then In_Return_Value
(N
)
4878 Set_Master_Id
(PtrT
,
4879 Master_Id
(Etype
(Current_Scope
)));
4881 -- The only other possibility is an itype. For this
4882 -- case, the master must exist in the context. This is
4883 -- the case when the allocator initializes an access
4884 -- component in an init-proc.
4887 pragma Assert
(Is_Itype
(PtrT
));
4888 Build_Master_Renaming
(PtrT
, N
);
4892 -- If the context of the allocator is a declaration or an
4893 -- assignment, we can generate a meaningful image for it,
4894 -- even though subsequent assignments might remove the
4895 -- connection between task and entity. We build this image
4896 -- when the left-hand side is a simple variable, a simple
4897 -- indexed assignment or a simple selected component.
4899 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4901 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4904 if Is_Entity_Name
(Nam
) then
4906 Build_Task_Image_Decls
4909 (Entity
(Nam
), Sloc
(Nam
)), T
);
4911 elsif Nkind
(Nam
) in N_Indexed_Component
4912 | N_Selected_Component
4913 and then Is_Entity_Name
(Prefix
(Nam
))
4916 Build_Task_Image_Decls
4917 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4919 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4923 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4925 Build_Task_Image_Decls
4926 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4929 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4932 if Restriction_Active
(No_Task_Hierarchy
) then
4934 (Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
4938 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4941 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4943 Decl
:= Last
(Decls
);
4945 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4947 -- Has_Task is false, Decls not used
4953 -- Add discriminants if discriminated type
4956 Dis
: Boolean := False;
4957 Typ
: Entity_Id
:= T
;
4960 if Has_Discriminants
(T
) then
4963 -- Type may be a private type with no visible discriminants
4964 -- in which case check full view if in scope, or the
4965 -- underlying_full_view if dealing with a type whose full
4966 -- view may be derived from a private type whose own full
4967 -- view has discriminants.
4969 elsif Is_Private_Type
(T
) then
4970 if Present
(Full_View
(T
))
4971 and then Has_Discriminants
(Full_View
(T
))
4974 Typ
:= Full_View
(T
);
4976 elsif Present
(Underlying_Full_View
(T
))
4977 and then Has_Discriminants
(Underlying_Full_View
(T
))
4980 Typ
:= Underlying_Full_View
(T
);
4986 -- If the allocated object will be constrained by the
4987 -- default values for discriminants, then build a subtype
4988 -- with those defaults, and change the allocated subtype
4989 -- to that. Note that this happens in fewer cases in Ada
4992 if not Is_Constrained
(Typ
)
4993 and then Present
(Discriminant_Default_Value
4994 (First_Discriminant
(Typ
)))
4995 and then (Ada_Version
< Ada_2005
4997 Object_Type_Has_Constrained_Partial_View
4998 (Typ
, Current_Scope
))
5000 Typ
:= Build_Default_Subtype
(Typ
, N
);
5001 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
5004 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
5005 while Present
(Discr
) loop
5006 Nod
:= Node
(Discr
);
5007 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
5009 -- AI-416: when the discriminant constraint is an
5010 -- anonymous access type make sure an accessibility
5011 -- check is inserted if necessary (3.10.2(22.q/2))
5013 if Ada_Version
>= Ada_2005
5015 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
5017 No_Dynamic_Accessibility_Checks_Enabled
(Nod
)
5019 Apply_Accessibility_Check
5020 (Nod
, Typ
, Insert_Node
=> Nod
);
5027 -- When the designated subtype is unconstrained and
5028 -- the allocator specifies a constrained subtype (or
5029 -- such a subtype has been created, such as above by
5030 -- Build_Default_Subtype), associate that subtype with
5031 -- the dereference of the allocator's access value.
5032 -- This is needed by the expander for cases where the
5033 -- access type has a Designated_Storage_Model in order
5034 -- to support allocation of a host object of the right
5035 -- size for passing to the initialization procedure.
5037 if not Is_Constrained
(Dtyp
)
5038 and then Is_Constrained
(Typ
)
5041 Deref
: constant Node_Id
:= Unqual_Conv
(Init_Arg1
);
5044 pragma Assert
(Nkind
(Deref
) = N_Explicit_Dereference
);
5046 Set_Actual_Designated_Subtype
(Deref
, Typ
);
5051 -- We set the allocator as analyzed so that when we analyze
5052 -- the if expression node, we do not get an unwanted recursive
5053 -- expansion of the allocator expression.
5055 Set_Analyzed
(N
, True);
5056 Nod
:= Relocate_Node
(N
);
5058 -- Here is the transformation:
5059 -- input: new Ctrl_Typ
5060 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5061 -- Ctrl_TypIP (Temp.all, ...);
5062 -- [Deep_]Initialize (Temp.all);
5064 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5065 -- is the subtype of the allocator.
5068 Make_Object_Declaration
(Loc
,
5069 Defining_Identifier
=> Temp
,
5070 Constant_Present
=> True,
5071 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
5074 Set_Assignment_OK
(Temp_Decl
);
5075 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
5077 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
5079 -- If the designated type is a task type or contains tasks,
5080 -- create block to activate created tasks, and insert
5081 -- declaration for Task_Image variable ahead of call.
5083 if Has_Task
(T
) then
5085 L
: constant List_Id
:= New_List
;
5088 Build_Task_Allocate_Block
(L
, Nod
, Args
);
5090 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
5091 Insert_Actions
(N
, L
);
5096 Make_Procedure_Call_Statement
(Loc
,
5097 Name
=> New_Occurrence_Of
(Init
, Loc
),
5098 Parameter_Associations
=> Args
));
5101 if Needs_Finalization
(T
) then
5104 -- [Deep_]Initialize (Init_Arg1);
5108 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
5111 -- Guard against a missing [Deep_]Initialize when the
5112 -- designated type was not properly frozen.
5114 if Present
(Init_Call
) then
5115 Insert_Action
(N
, Init_Call
);
5119 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5120 Analyze_And_Resolve
(N
, PtrT
);
5122 Apply_Predicate_Check
(N
, Dtyp
, Deref
=> True);
5124 -- When designated type has Default_Initial_Condition aspects,
5125 -- make a call to the type's DIC procedure to perform the
5126 -- checks. Theoretically this might also be needed for cases
5127 -- where the type doesn't have an init proc, but those should
5128 -- be very uncommon, and for now we only support the init proc
5132 and then Present
(DIC_Procedure
(Dtyp
))
5133 and then not Has_Null_Body
(DIC_Procedure
(Dtyp
))
5136 Build_DIC_Call
(Loc
,
5137 Make_Explicit_Dereference
(Loc
,
5138 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
5145 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5146 -- object that has been rewritten as a reference, we displace "this"
5147 -- to reference properly its secondary dispatch table.
5149 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
5150 Displace_Allocator_Pointer
(N
);
5154 when RE_Not_Available
=>
5156 end Expand_N_Allocator
;
5158 -----------------------
5159 -- Expand_N_And_Then --
5160 -----------------------
5162 procedure Expand_N_And_Then
(N
: Node_Id
)
5163 renames Expand_Short_Circuit_Operator
;
5165 ------------------------------
5166 -- Expand_N_Case_Expression --
5167 ------------------------------
5169 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
5170 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean;
5171 -- Return True if we can copy objects of this type when expanding a case
5178 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean is
5180 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5181 -- large objects, as long as they are constrained and not limited.
5184 Is_Elementary_Type
(Underlying_Type
(Typ
))
5186 (Minimize_Expression_With_Actions
5187 and then Is_Constrained
(Underlying_Type
(Typ
))
5188 and then not Is_Limited_Type
(Underlying_Type
(Typ
)));
5193 Loc
: constant Source_Ptr
:= Sloc
(N
);
5194 Par
: constant Node_Id
:= Parent
(N
);
5195 Typ
: constant Entity_Id
:= Etype
(N
);
5199 Case_Stmt
: Node_Id
;
5201 Target
: Entity_Id
:= Empty
;
5202 Target_Typ
: Entity_Id
;
5204 In_Predicate
: Boolean := False;
5205 -- Flag set when the case expression appears within a predicate
5207 Optimize_Return_Stmt
: Boolean := False;
5208 -- Flag set when the case expression can be optimized in the context of
5209 -- a simple return statement.
5211 -- Start of processing for Expand_N_Case_Expression
5214 -- Check for MINIMIZED/ELIMINATED overflow mode
5216 if Minimized_Eliminated_Overflow_Check
(N
) then
5217 Apply_Arithmetic_Overflow_Check
(N
);
5221 -- If the case expression is a predicate specification, and the type
5222 -- to which it applies has a static predicate aspect, do not expand,
5223 -- because it will be converted to the proper predicate form later.
5225 if Ekind
(Current_Scope
) in E_Function | E_Procedure
5226 and then Is_Predicate_Function
(Current_Scope
)
5228 In_Predicate
:= True;
5230 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
5236 -- When the type of the case expression is elementary, expand
5238 -- (case X is when A => AX, when B => BX ...)
5253 -- In all other cases expand into
5255 -- type Ptr_Typ is access all Typ;
5256 -- Target : Ptr_Typ;
5259 -- Target := AX'Unrestricted_Access;
5261 -- Target := BX'Unrestricted_Access;
5265 -- and replace the case expression by a reference to Target.all.
5267 -- This approach avoids extra copies of potentially large objects. It
5268 -- also allows handling of values of limited or unconstrained types.
5269 -- Note that we do the copy also for constrained, nonlimited types
5270 -- when minimizing expressions with actions (e.g. when generating C
5271 -- code) since it allows us to do the optimization below in more cases.
5274 Make_Case_Statement
(Loc
,
5275 Expression
=> Expression
(N
),
5276 Alternatives
=> New_List
);
5278 -- Preserve the original context for which the case statement is being
5279 -- generated. This is needed by the finalization machinery to prevent
5280 -- the premature finalization of controlled objects found within the
5283 Set_From_Conditional_Expression
(Case_Stmt
);
5286 -- Small optimization: when the case expression appears in the context
5287 -- of a simple return statement, expand into
5297 -- This makes the expansion much easier when expressions are calls to
5298 -- a BIP function. But do not perform it when the return statement is
5299 -- within a predicate function, as this causes spurious errors.
5301 Optimize_Return_Stmt
:=
5302 Nkind
(Par
) = N_Simple_Return_Statement
and then not In_Predicate
;
5306 if Is_Copy_Type
(Typ
) then
5309 -- Otherwise create an access type to handle the general case using
5310 -- 'Unrestricted_Access.
5313 -- type Ptr_Typ is access all Typ;
5316 if Generate_C_Code
then
5318 -- We cannot ensure that correct C code will be generated if any
5319 -- temporary is created down the line (to e.g. handle checks or
5320 -- capture values) since we might end up with dangling references
5321 -- to local variables, so better be safe and reject the construct.
5324 ("case expression too complex, use case statement instead", N
);
5327 Target_Typ
:= Make_Temporary
(Loc
, 'P');
5330 Make_Full_Type_Declaration
(Loc
,
5331 Defining_Identifier
=> Target_Typ
,
5333 Make_Access_To_Object_Definition
(Loc
,
5334 All_Present
=> True,
5335 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5338 -- Create the declaration of the target which captures the value of the
5342 -- Target : [Ptr_]Typ;
5344 if not Optimize_Return_Stmt
then
5345 Target
:= Make_Temporary
(Loc
, 'T');
5348 Make_Object_Declaration
(Loc
,
5349 Defining_Identifier
=> Target
,
5350 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
5351 Set_No_Initialization
(Decl
);
5353 Append_To
(Acts
, Decl
);
5356 -- Process the alternatives
5358 Alt
:= First
(Alternatives
(N
));
5359 while Present
(Alt
) loop
5361 Alt_Expr
: Node_Id
:= Expression
(Alt
);
5362 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
5367 -- Take the unrestricted access of the expression value for non-
5368 -- scalar types. This approach avoids big copies and covers the
5369 -- limited and unconstrained cases.
5372 -- return AX['Unrestricted_Access];
5374 if Optimize_Return_Stmt
then
5376 Make_Simple_Return_Statement
(Alt_Loc
,
5377 Expression
=> Alt_Expr
));
5380 -- Target := AX['Unrestricted_Access];
5383 if not Is_Copy_Type
(Typ
) then
5385 Make_Attribute_Reference
(Alt_Loc
,
5386 Prefix
=> Relocate_Node
(Alt_Expr
),
5387 Attribute_Name
=> Name_Unrestricted_Access
);
5390 LHS
:= New_Occurrence_Of
(Target
, Loc
);
5391 Set_Assignment_OK
(LHS
);
5394 Make_Assignment_Statement
(Alt_Loc
,
5396 Expression
=> Alt_Expr
));
5399 -- Propagate declarations inserted in the node by Insert_Actions
5400 -- (for example, temporaries generated to remove side effects).
5401 -- These actions must remain attached to the alternative, given
5402 -- that they are generated by the corresponding expression.
5404 if Present
(Actions
(Alt
)) then
5405 Prepend_List
(Actions
(Alt
), Stmts
);
5409 (Alternatives
(Case_Stmt
),
5410 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5411 Discrete_Choices
=> Discrete_Choices
(Alt
),
5412 Statements
=> Stmts
));
5414 -- Finalize any transient objects on exit from the alternative.
5415 -- Note that this needs to be done only after Stmts is attached
5416 -- to the Alternatives list above (for Safe_To_Capture_Value).
5418 Process_Transients_In_Expression
(N
, Stmts
);
5424 -- Rewrite the parent return statement as a case statement
5426 if Optimize_Return_Stmt
then
5427 Rewrite
(Par
, Case_Stmt
);
5430 -- Otherwise rewrite the case expression itself
5433 Append_To
(Acts
, Case_Stmt
);
5435 if Is_Copy_Type
(Typ
) then
5437 Make_Expression_With_Actions
(Loc
,
5438 Expression
=> New_Occurrence_Of
(Target
, Loc
),
5442 Insert_Actions
(N
, Acts
);
5444 Make_Explicit_Dereference
(Loc
,
5445 Prefix
=> New_Occurrence_Of
(Target
, Loc
)));
5448 Analyze_And_Resolve
(N
, Typ
);
5450 end Expand_N_Case_Expression
;
5452 -----------------------------------
5453 -- Expand_N_Explicit_Dereference --
5454 -----------------------------------
5456 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5458 -- Insert explicit dereference call for the checked storage pool case
5460 Insert_Dereference_Action
(Prefix
(N
));
5462 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5463 -- we set the atomic sync flag.
5465 if Is_Atomic
(Etype
(N
))
5466 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5468 Activate_Atomic_Synchronization
(N
);
5470 end Expand_N_Explicit_Dereference
;
5472 --------------------------------------
5473 -- Expand_N_Expression_With_Actions --
5474 --------------------------------------
5476 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5477 Acts
: constant List_Id
:= Actions
(N
);
5479 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
5480 -- Force the evaluation of Boolean expression Expr
5482 ------------------------------
5483 -- Force_Boolean_Evaluation --
5484 ------------------------------
5486 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
5487 Loc
: constant Source_Ptr
:= Sloc
(N
);
5488 Flag_Decl
: Node_Id
;
5489 Flag_Id
: Entity_Id
;
5492 -- Relocate the expression to the actions list by capturing its value
5493 -- in a Boolean flag. Generate:
5494 -- Flag : constant Boolean := Expr;
5496 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5499 Make_Object_Declaration
(Loc
,
5500 Defining_Identifier
=> Flag_Id
,
5501 Constant_Present
=> True,
5502 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5503 Expression
=> Relocate_Node
(Expr
));
5505 Append
(Flag_Decl
, Acts
);
5506 Analyze
(Flag_Decl
);
5508 -- Replace the expression with a reference to the flag
5510 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
5511 Analyze
(Expression
(N
));
5512 end Force_Boolean_Evaluation
;
5514 -- Start of processing for Expand_N_Expression_With_Actions
5517 -- Do not evaluate the expression when it denotes an entity because the
5518 -- expression_with_actions node will be replaced by the reference.
5520 if Is_Entity_Name
(Expression
(N
)) then
5523 -- Do not evaluate the expression when there are no actions because the
5524 -- expression_with_actions node will be replaced by the expression.
5526 elsif Is_Empty_List
(Acts
) then
5529 -- Force the evaluation of the expression by capturing its value in a
5530 -- temporary. This ensures that aliases of transient objects do not leak
5531 -- to the expression of the expression_with_actions node:
5534 -- Trans_Id : Ctrl_Typ := ...;
5535 -- Alias : ... := Trans_Id;
5536 -- in ... Alias ... end;
5538 -- In the example above, Trans_Id cannot be finalized at the end of the
5539 -- actions list because this may affect the alias and the final value of
5540 -- the expression_with_actions. Forcing the evaluation encapsulates the
5541 -- reference to the Alias within the actions list:
5544 -- Trans_Id : Ctrl_Typ := ...;
5545 -- Alias : ... := Trans_Id;
5546 -- Val : constant Boolean := ... Alias ...;
5547 -- <finalize Trans_Id>
5550 -- Once this transformation is performed, it is safe to finalize the
5551 -- transient object at the end of the actions list.
5553 -- Note that Force_Evaluation does not remove side effects in operators
5554 -- because it assumes that all operands are evaluated and side effect
5555 -- free. This is not the case when an operand depends implicitly on the
5556 -- transient object through the use of access types.
5558 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5559 Force_Boolean_Evaluation
(Expression
(N
));
5561 -- The expression of an expression_with_actions node may not necessarily
5562 -- be Boolean when the node appears in an if expression. In this case do
5563 -- the usual forced evaluation to encapsulate potential aliasing.
5566 -- A check is also needed since the subtype of the EWA node and the
5567 -- subtype of the expression may differ (for example, the EWA node
5568 -- may have a null-excluding access subtype).
5570 Apply_Constraint_Check
(Expression
(N
), Etype
(N
));
5571 Force_Evaluation
(Expression
(N
));
5574 -- Process transient objects found within the actions of the EWA node
5576 Process_Transients_In_Expression
(N
, Acts
);
5578 -- Deal with case where there are no actions. In this case we simply
5579 -- rewrite the node with its expression since we don't need the actions
5580 -- and the specification of this node does not allow a null action list.
5582 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5583 -- the expanded tree and relying on being able to retrieve the original
5584 -- tree in cases like this. This raises a whole lot of issues of whether
5585 -- we have problems elsewhere, which will be addressed in the future???
5587 if Is_Empty_List
(Acts
) then
5588 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5590 end Expand_N_Expression_With_Actions
;
5592 ----------------------------
5593 -- Expand_N_If_Expression --
5594 ----------------------------
5596 -- Deal with limited types and condition actions
5598 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5599 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5600 Loc
: constant Source_Ptr
:= Sloc
(N
);
5601 Thenx
: constant Node_Id
:= Next
(Cond
);
5602 Elsex
: constant Node_Id
:= Next
(Thenx
);
5603 Par
: constant Node_Id
:= Parent
(N
);
5604 Typ
: constant Entity_Id
:= Etype
(N
);
5606 Force_Expand
: constant Boolean := Is_Anonymous_Access_Actual
(N
);
5607 -- Determine if we are dealing with a special case of a conditional
5608 -- expression used as an actual for an anonymous access type which
5609 -- forces us to transform the if expression into an expression with
5610 -- actions in order to create a temporary to capture the level of the
5611 -- expression in each branch.
5613 function OK_For_Single_Subtype
(T1
, T2
: Entity_Id
) return Boolean;
5614 -- Return true if it is acceptable to use a single subtype for two
5615 -- dependent expressions of subtype T1 and T2 respectively, which are
5616 -- unidimensional arrays whose index bounds are known at compile time.
5618 ---------------------------
5619 -- OK_For_Single_Subtype --
5620 ---------------------------
5622 function OK_For_Single_Subtype
(T1
, T2
: Entity_Id
) return Boolean is
5627 Get_First_Index_Bounds
(T1
, Lo1
, Hi1
);
5628 Get_First_Index_Bounds
(T2
, Lo2
, Hi2
);
5630 -- Return true if the length of the covering subtype is not too large
5633 UI_Max
(Hi1
, Hi2
) - UI_Min
(Lo1
, Lo2
) < Too_Large_Length_For_Array
;
5634 end OK_For_Single_Subtype
;
5644 Optimize_Return_Stmt
: Boolean := False;
5645 -- Flag set when the if expression can be optimized in the context of
5646 -- a simple return statement.
5648 -- Start of processing for Expand_N_If_Expression
5651 -- Deal with non-standard booleans
5653 Adjust_Condition
(Cond
);
5655 -- Check for MINIMIZED/ELIMINATED overflow mode.
5656 -- Apply_Arithmetic_Overflow_Check will not deal with Then/Else_Actions
5657 -- so skip this step if any actions are present.
5659 if Minimized_Eliminated_Overflow_Check
(N
)
5660 and then No
(Then_Actions
(N
))
5661 and then No
(Else_Actions
(N
))
5663 Apply_Arithmetic_Overflow_Check
(N
);
5667 -- Fold at compile time if condition known. We have already folded
5668 -- static if expressions, but it is possible to fold any case in which
5669 -- the condition is known at compile time, even though the result is
5672 -- Note that we don't do the fold of such cases in Sem_Elab because
5673 -- it can cause infinite loops with the expander adding a conditional
5674 -- expression, and Sem_Elab circuitry removing it repeatedly.
5676 if Compile_Time_Known_Value
(Cond
) then
5678 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5679 -- Fold at compile time. Assumes condition known. Return True if
5680 -- folding occurred, meaning we're done.
5682 ----------------------
5683 -- Fold_Known_Value --
5684 ----------------------
5686 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5688 if Is_True
(Expr_Value
(Cond
)) then
5690 Actions
:= Then_Actions
(N
);
5693 Actions
:= Else_Actions
(N
);
5698 if Present
(Actions
) then
5700 -- To minimize the use of Expression_With_Actions, just skip
5701 -- the optimization as it is not critical for correctness.
5703 if Minimize_Expression_With_Actions
then
5708 Make_Expression_With_Actions
(Loc
,
5709 Expression
=> Relocate_Node
(Expr
),
5710 Actions
=> Actions
));
5711 Analyze_And_Resolve
(N
, Typ
);
5714 Rewrite
(N
, Relocate_Node
(Expr
));
5717 -- Note that the result is never static (legitimate cases of
5718 -- static if expressions were folded in Sem_Eval).
5720 Set_Is_Static_Expression
(N
, False);
5722 end Fold_Known_Value
;
5725 if Fold_Known_Value
(Cond
) then
5731 -- Small optimization: when the if expression appears in the context of
5732 -- a simple return statement, expand into
5737 -- return else-expr;
5740 -- This makes the expansion much easier when expressions are calls to
5741 -- a BIP function. But do not perform it when the return statement is
5742 -- within a predicate function, as this causes spurious errors.
5744 Optimize_Return_Stmt
:=
5745 Nkind
(Par
) = N_Simple_Return_Statement
5746 and then not (Ekind
(Current_Scope
) in E_Function | E_Procedure
5747 and then Is_Predicate_Function
(Current_Scope
));
5749 if Optimize_Return_Stmt
then
5750 -- When the "then" or "else" expressions involve controlled function
5751 -- calls, generated temporaries are chained on the corresponding list
5752 -- of actions. These temporaries need to be finalized after the if
5753 -- expression is evaluated.
5755 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5756 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5759 Make_Implicit_If_Statement
(N
,
5760 Condition
=> Relocate_Node
(Cond
),
5761 Then_Statements
=> New_List
(
5762 Make_Simple_Return_Statement
(Sloc
(Thenx
),
5763 Expression
=> Relocate_Node
(Thenx
))),
5764 Else_Statements
=> New_List
(
5765 Make_Simple_Return_Statement
(Sloc
(Elsex
),
5766 Expression
=> Relocate_Node
(Elsex
))));
5768 -- Preserve the original context for which the if statement is
5769 -- being generated. This is needed by the finalization machinery
5770 -- to prevent the premature finalization of controlled objects
5771 -- found within the if statement.
5773 Set_From_Conditional_Expression
(New_If
);
5775 -- If the type is by reference, then we expand as follows to avoid the
5776 -- possibility of improper copying.
5778 -- type Ptr is access all Typ;
5782 -- Cnn := then-expr'Unrestricted_Access;
5785 -- Cnn := else-expr'Unrestricted_Access;
5788 -- and replace the if expression by a reference to Cnn.all.
5790 elsif Is_By_Reference_Type
(Typ
) then
5791 -- When the "then" or "else" expressions involve controlled function
5792 -- calls, generated temporaries are chained on the corresponding list
5793 -- of actions. These temporaries need to be finalized after the if
5794 -- expression is evaluated.
5796 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5797 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5800 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C', N
);
5801 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5805 -- type Ann is access all Typ;
5808 Make_Full_Type_Declaration
(Loc
,
5809 Defining_Identifier
=> Ptr_Typ
,
5811 Make_Access_To_Object_Definition
(Loc
,
5812 All_Present
=> True,
5813 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5819 Make_Object_Declaration
(Loc
,
5820 Defining_Identifier
=> Cnn
,
5821 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5825 -- Cnn := <Thenx>'Unrestricted_Access;
5827 -- Cnn := <Elsex>'Unrestricted_Access;
5831 Make_Implicit_If_Statement
(N
,
5832 Condition
=> Relocate_Node
(Cond
),
5833 Then_Statements
=> New_List
(
5834 Make_Assignment_Statement
(Sloc
(Thenx
),
5835 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5837 Make_Attribute_Reference
(Loc
,
5838 Prefix
=> Relocate_Node
(Thenx
),
5839 Attribute_Name
=> Name_Unrestricted_Access
))),
5841 Else_Statements
=> New_List
(
5842 Make_Assignment_Statement
(Sloc
(Elsex
),
5843 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5845 Make_Attribute_Reference
(Loc
,
5846 Prefix
=> Relocate_Node
(Elsex
),
5847 Attribute_Name
=> Name_Unrestricted_Access
))));
5849 -- Preserve the original context for which the if statement is
5850 -- being generated. This is needed by the finalization machinery
5851 -- to prevent the premature finalization of controlled objects
5852 -- found within the if statement.
5854 Set_From_Conditional_Expression
(New_If
);
5857 Make_Explicit_Dereference
(Loc
,
5858 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5861 -- If the result is a unidimensional unconstrained array but the two
5862 -- dependent expressions have constrained subtypes with known bounds,
5863 -- then we expand as follows:
5865 -- subtype Txx is Typ (<static low-bound> .. <static high-bound>);
5869 -- Cnn (<then low-bound .. then high-bound>) := then-expr;
5872 -- Cnn (<else low bound .. else high-bound>) := else-expr;
5875 -- and replace the if expression by a slice of Cnn, provided that Txx
5876 -- is not too large. This will create a static temporary instead of the
5877 -- dynamic one of the next case and thus help the code generator.
5879 -- Note that we need to deal with the case where the else expression is
5880 -- itself such a slice, in order to catch if expressions with more than
5881 -- two dependent expressions in the source code.
5883 -- Also note that this creates variables on branches without an explicit
5884 -- scope, causing troubles with e.g. the LLVM IR, so disable this
5885 -- optimization when Unnest_Subprogram_Mode (enabled for LLVM).
5887 elsif Is_Array_Type
(Typ
)
5888 and then Number_Dimensions
(Typ
) = 1
5889 and then not Is_Constrained
(Typ
)
5890 and then Is_Constrained
(Etype
(Thenx
))
5891 and then Compile_Time_Known_Bounds
(Etype
(Thenx
))
5893 ((Is_Constrained
(Etype
(Elsex
))
5894 and then Compile_Time_Known_Bounds
(Etype
(Elsex
))
5895 and then OK_For_Single_Subtype
(Etype
(Thenx
), Etype
(Elsex
)))
5897 (Nkind
(Elsex
) = N_Slice
5898 and then Is_Constrained
(Etype
(Prefix
(Elsex
)))
5899 and then Compile_Time_Known_Bounds
(Etype
(Prefix
(Elsex
)))
5901 OK_For_Single_Subtype
(Etype
(Thenx
), Etype
(Prefix
(Elsex
)))))
5902 and then not Generate_C_Code
5903 and then not Unnest_Subprogram_Mode
5905 -- When the "then" or "else" expressions involve controlled function
5906 -- calls, generated temporaries are chained on the corresponding list
5907 -- of actions. These temporaries need to be finalized after the if
5908 -- expression is evaluated.
5910 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5911 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5914 Ityp
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
5916 function Build_New_Bound
5919 Slice_Bnd
: Node_Id
) return Node_Id
;
5920 -- Build a new bound from the bounds of the if expression
5922 function To_Ityp
(V
: Uint
) return Node_Id
;
5923 -- Convert V to an index value in Ityp
5925 ---------------------
5926 -- Build_New_Bound --
5927 ---------------------
5929 function Build_New_Bound
5932 Slice_Bnd
: Node_Id
) return Node_Id
is
5935 -- We need to use the special processing for slices only if
5936 -- they do not have compile-time known bounds; if they do, they
5937 -- can be treated like any other expressions.
5939 if Nkind
(Elsex
) = N_Slice
5940 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
5942 if Compile_Time_Known_Value
(Slice_Bnd
)
5943 and then Expr_Value
(Slice_Bnd
) = Then_Bnd
5945 return To_Ityp
(Then_Bnd
);
5948 return Make_If_Expression
(Loc
,
5949 Expressions
=> New_List
(
5950 Duplicate_Subexpr
(Cond
),
5952 New_Copy_Tree
(Slice_Bnd
)));
5955 elsif Then_Bnd
= Else_Bnd
then
5956 return To_Ityp
(Then_Bnd
);
5959 return Make_If_Expression
(Loc
,
5960 Expressions
=> New_List
(
5961 Duplicate_Subexpr
(Cond
),
5963 To_Ityp
(Else_Bnd
)));
5965 end Build_New_Bound
;
5971 function To_Ityp
(V
: Uint
) return Node_Id
is
5972 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, V
);
5975 if Is_Enumeration_Type
(Ityp
) then
5977 Make_Attribute_Reference
(Loc
,
5978 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
5979 Attribute_Name
=> Name_Val
,
5980 Expressions
=> New_List
(Result
));
5987 Slice_Lo
, Slice_Hi
: Node_Id
;
5988 Subtyp_Ind
: Node_Id
;
5989 Else_Lo
, Else_Hi
: Uint
;
5990 Min_Lo
, Max_Hi
: Uint
;
5991 Then_Lo
, Then_Hi
: Uint
;
5992 Then_List
, Else_List
: List_Id
;
5995 Get_First_Index_Bounds
(Etype
(Thenx
), Then_Lo
, Then_Hi
);
5997 -- See the rationale in Build_New_Bound
5999 if Nkind
(Elsex
) = N_Slice
6000 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
6002 Slice_Lo
:= Low_Bound
(Discrete_Range
(Elsex
));
6003 Slice_Hi
:= High_Bound
(Discrete_Range
(Elsex
));
6004 Get_First_Index_Bounds
6005 (Etype
(Prefix
(Elsex
)), Else_Lo
, Else_Hi
);
6010 Get_First_Index_Bounds
(Etype
(Elsex
), Else_Lo
, Else_Hi
);
6013 Min_Lo
:= UI_Min
(Then_Lo
, Else_Lo
);
6014 Max_Hi
:= UI_Max
(Then_Hi
, Else_Hi
);
6016 -- Now we construct an array object with appropriate bounds and
6017 -- mark it as internal to prevent useless initialization when
6018 -- Initialize_Scalars is enabled. Also since this is the actual
6019 -- result entity, we make sure we have debug information for it.
6022 Make_Subtype_Indication
(Loc
,
6023 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
6025 Make_Index_Or_Discriminant_Constraint
(Loc
,
6026 Constraints
=> New_List
(
6028 Low_Bound
=> To_Ityp
(Min_Lo
),
6029 High_Bound
=> To_Ityp
(Max_Hi
)))));
6031 Ent
:= Make_Temporary
(Loc
, 'C');
6032 Set_Is_Internal
(Ent
);
6033 Set_Debug_Info_Needed
(Ent
);
6036 Make_Object_Declaration
(Loc
,
6037 Defining_Identifier
=> Ent
,
6038 Object_Definition
=> Subtyp_Ind
);
6040 -- If the result of the expression appears as the initializing
6041 -- expression of an object declaration, we can just rename the
6042 -- result, rather than copying it.
6044 Mutate_Ekind
(Ent
, E_Variable
);
6045 Set_OK_To_Rename
(Ent
);
6047 Then_List
:= New_List
(
6048 Make_Assignment_Statement
(Loc
,
6051 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6054 Low_Bound
=> To_Ityp
(Then_Lo
),
6055 High_Bound
=> To_Ityp
(Then_Hi
))),
6056 Expression
=> Relocate_Node
(Thenx
)));
6058 Set_Suppress_Assignment_Checks
(Last
(Then_List
));
6060 -- See the rationale in Build_New_Bound
6062 if Nkind
(Elsex
) = N_Slice
6063 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
6065 Else_List
:= New_List
(
6066 Make_Assignment_Statement
(Loc
,
6069 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6072 Low_Bound
=> New_Copy_Tree
(Slice_Lo
),
6073 High_Bound
=> New_Copy_Tree
(Slice_Hi
))),
6074 Expression
=> Relocate_Node
(Elsex
)));
6077 Else_List
:= New_List
(
6078 Make_Assignment_Statement
(Loc
,
6081 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6084 Low_Bound
=> To_Ityp
(Else_Lo
),
6085 High_Bound
=> To_Ityp
(Else_Hi
))),
6086 Expression
=> Relocate_Node
(Elsex
)));
6089 Set_Suppress_Assignment_Checks
(Last
(Else_List
));
6092 Make_Implicit_If_Statement
(N
,
6093 Condition
=> Duplicate_Subexpr
(Cond
),
6094 Then_Statements
=> Then_List
,
6095 Else_Statements
=> Else_List
);
6099 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6100 Discrete_Range
=> Make_Range
(Loc
,
6101 Low_Bound
=> Build_New_Bound
(Then_Lo
, Else_Lo
, Slice_Lo
),
6102 High_Bound
=> Build_New_Bound
(Then_Hi
, Else_Hi
, Slice_Hi
)));
6105 -- If the result is an unconstrained array and the if expression is in a
6106 -- context other than the initializing expression of the declaration of
6107 -- an object, then we pull out the if expression as follows:
6109 -- Cnn : constant typ := if-expression
6111 -- and then replace the if expression with an occurrence of Cnn. This
6112 -- avoids the need in the back end to create on-the-fly variable length
6113 -- temporaries (which it cannot do!)
6115 -- Note that the test for being in an object declaration avoids doing an
6116 -- unnecessary expansion, and also avoids infinite recursion.
6118 elsif Is_Array_Type
(Typ
)
6119 and then not Is_Constrained
(Typ
)
6120 and then not (Nkind
(Par
) = N_Object_Declaration
6121 and then Expression
(Par
) = N
)
6124 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6128 Make_Object_Declaration
(Loc
,
6129 Defining_Identifier
=> Cnn
,
6130 Constant_Present
=> True,
6131 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6132 Expression
=> Relocate_Node
(N
),
6133 Has_Init_Expression
=> True));
6135 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
6139 -- For other types, we only need to expand if there are other actions
6140 -- associated with either branch or we need to force expansion to deal
6141 -- with if expressions used as an actual of an anonymous access type.
6143 elsif Present
(Then_Actions
(N
))
6144 or else Present
(Else_Actions
(N
))
6145 or else Force_Expand
6147 -- We now wrap the actions into the appropriate expression
6149 if Minimize_Expression_With_Actions
6150 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
6151 or else Is_Constrained
(Underlying_Type
(Typ
)))
6153 -- When the "then" or "else" expressions involve controlled
6154 -- function calls, generated temporaries are chained on the
6155 -- corresponding list of actions. These temporaries need to
6156 -- be finalized after the if expression is evaluated.
6158 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
6159 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
6161 -- If we can't use N_Expression_With_Actions nodes, then we insert
6162 -- the following sequence of actions (using Insert_Actions):
6167 -- Cnn := then-expr;
6173 -- and replace the if expression by a reference to Cnn
6176 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6180 Make_Object_Declaration
(Loc
,
6181 Defining_Identifier
=> Cnn
,
6182 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6185 Make_Implicit_If_Statement
(N
,
6186 Condition
=> Relocate_Node
(Cond
),
6188 Then_Statements
=> New_List
(
6189 Make_Assignment_Statement
(Sloc
(Thenx
),
6190 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6191 Expression
=> Relocate_Node
(Thenx
))),
6193 Else_Statements
=> New_List
(
6194 Make_Assignment_Statement
(Sloc
(Elsex
),
6195 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6196 Expression
=> Relocate_Node
(Elsex
))));
6198 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
6199 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
6201 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
6204 -- Regular path using Expression_With_Actions
6207 -- We do not need to call Process_Transients_In_Expression on
6208 -- the list of actions in this case, because the expansion of
6209 -- Expression_With_Actions will do it.
6211 if Present
(Then_Actions
(N
)) then
6213 Make_Expression_With_Actions
(Sloc
(Thenx
),
6214 Actions
=> Then_Actions
(N
),
6215 Expression
=> Relocate_Node
(Thenx
)));
6217 Set_Then_Actions
(N
, No_List
);
6218 Analyze_And_Resolve
(Thenx
, Typ
);
6221 if Present
(Else_Actions
(N
)) then
6223 Make_Expression_With_Actions
(Sloc
(Elsex
),
6224 Actions
=> Else_Actions
(N
),
6225 Expression
=> Relocate_Node
(Elsex
)));
6227 Set_Else_Actions
(N
, No_List
);
6228 Analyze_And_Resolve
(Elsex
, Typ
);
6231 -- We must force expansion into an expression with actions when
6232 -- an if expression gets used directly as an actual for an
6233 -- anonymous access type.
6235 if Force_Expand
then
6237 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
6246 Make_Object_Declaration
(Loc
,
6247 Defining_Identifier
=> Cnn
,
6248 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6249 Append_To
(Acts
, Decl
);
6251 Set_No_Initialization
(Decl
);
6261 Make_Implicit_If_Statement
(N
,
6262 Condition
=> Relocate_Node
(Cond
),
6263 Then_Statements
=> New_List
(
6264 Make_Assignment_Statement
(Sloc
(Thenx
),
6265 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6266 Expression
=> Relocate_Node
(Thenx
))),
6268 Else_Statements
=> New_List
(
6269 Make_Assignment_Statement
(Sloc
(Elsex
),
6270 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6271 Expression
=> Relocate_Node
(Elsex
))));
6272 Append_To
(Acts
, New_If
);
6280 Make_Expression_With_Actions
(Loc
,
6281 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6283 Analyze_And_Resolve
(N
, Typ
);
6290 -- For the sake of GNATcoverage, generate an intermediate temporary in
6291 -- the case where the if expression is a condition in an outer decision,
6292 -- in order to make sure that no branch is shared between the decisions.
6294 elsif Opt
.Suppress_Control_Flow_Optimizations
6295 and then Nkind
(Original_Node
(Par
)) in N_Case_Expression
6299 | N_Goto_When_Statement
6301 | N_Return_When_Statement
6305 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
6311 -- Cnn : constant Typ := N;
6315 Make_Object_Declaration
(Loc
,
6316 Defining_Identifier
=> Cnn
,
6317 Constant_Present
=> True,
6318 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6319 Expression
=> Relocate_Node
(N
)));
6322 Make_Expression_With_Actions
(Loc
,
6323 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6326 Analyze_And_Resolve
(N
, Typ
);
6330 -- If no actions then no expansion needed, gigi will handle it using the
6331 -- same approach as a C conditional expression.
6337 -- Fall through here for either the limited expansion, or the case of
6338 -- inserting actions for nonlimited types. In both these cases, we must
6339 -- move the SLOC of the parent If statement to the newly created one and
6340 -- change it to the SLOC of the expression which, after expansion, will
6341 -- correspond to what is being evaluated.
6343 if Present
(Par
) and then Nkind
(Par
) = N_If_Statement
then
6344 Set_Sloc
(New_If
, Sloc
(Par
));
6345 Set_Sloc
(Par
, Loc
);
6348 -- Move Then_Actions and Else_Actions, if any, to the new if statement
6350 if Present
(Then_Actions
(N
)) then
6351 Prepend_List
(Then_Actions
(N
), Then_Statements
(New_If
));
6354 if Present
(Else_Actions
(N
)) then
6355 Prepend_List
(Else_Actions
(N
), Else_Statements
(New_If
));
6358 -- Rewrite the parent return statement as an if statement
6360 if Optimize_Return_Stmt
then
6361 Rewrite
(Par
, New_If
);
6364 -- Otherwise rewrite the if expression itself
6367 Insert_Action
(N
, Decl
);
6368 Insert_Action
(N
, New_If
);
6370 Analyze_And_Resolve
(N
, Typ
);
6372 end Expand_N_If_Expression
;
6378 procedure Expand_N_In
(N
: Node_Id
) is
6379 Loc
: constant Source_Ptr
:= Sloc
(N
);
6380 Restyp
: constant Entity_Id
:= Etype
(N
);
6381 Lop
: constant Node_Id
:= Left_Opnd
(N
);
6382 Rop
: constant Node_Id
:= Right_Opnd
(N
);
6383 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
6385 procedure Substitute_Valid_Test
;
6386 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6387 -- test for the left operand being in range of its subtype.
6389 ---------------------------
6390 -- Substitute_Valid_Test --
6391 ---------------------------
6393 procedure Substitute_Valid_Test
is
6394 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
6395 -- Determine whether arbitrary node Nod denotes a source object that
6396 -- may safely act as prefix of attribute 'Valid.
6398 ----------------------------
6399 -- Is_OK_Object_Reference --
6400 ----------------------------
6402 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
6403 Obj_Ref
: constant Node_Id
:= Original_Node
(Nod
);
6404 -- The original operand
6407 -- The object reference must be a source construct, otherwise the
6408 -- codefix suggestion may refer to nonexistent code from a user
6411 return Comes_From_Source
(Obj_Ref
)
6412 and then Is_Object_Reference
(Unqual_Conv
(Obj_Ref
));
6413 end Is_OK_Object_Reference
;
6415 -- Start of processing for Substitute_Valid_Test
6419 Make_Attribute_Reference
(Loc
,
6420 Prefix
=> Relocate_Node
(Lop
),
6421 Attribute_Name
=> Name_Valid
));
6423 Analyze_And_Resolve
(N
, Restyp
);
6425 -- Emit a warning when the left-hand operand of the membership test
6426 -- is a source object, otherwise the use of attribute 'Valid would be
6427 -- illegal. The warning is not given when overflow checking is either
6428 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6429 -- eliminated above.
6431 if Is_OK_Object_Reference
(Lop
)
6432 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
6435 ("??explicit membership test may be optimized away", N
);
6436 Error_Msg_N
-- CODEFIX
6437 ("\??use ''Valid attribute instead", N
);
6439 end Substitute_Valid_Test
;
6446 -- Start of processing for Expand_N_In
6449 -- If set membership case, expand with separate procedure
6451 if Present
(Alternatives
(N
)) then
6452 Expand_Set_Membership
(N
);
6456 -- Not set membership, proceed with expansion
6458 Ltyp
:= Etype
(Left_Opnd
(N
));
6459 Rtyp
:= Etype
(Right_Opnd
(N
));
6461 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6462 -- type, then expand with a separate procedure. Note the use of the
6463 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6465 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
))
6466 and then not No_Minimize_Eliminate
(N
)
6468 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
6472 -- Check case of explicit test for an expression in range of its
6473 -- subtype. This is suspicious usage and we replace it with a 'Valid
6474 -- test and give a warning for scalar types.
6476 if Is_Scalar_Type
(Ltyp
)
6478 -- Only relevant for source comparisons
6480 and then Comes_From_Source
(N
)
6482 -- In floating-point this is a standard way to check for finite values
6483 -- and using 'Valid would typically be a pessimization.
6485 and then not Is_Floating_Point_Type
(Ltyp
)
6487 -- Don't give the message unless right operand is a type entity and
6488 -- the type of the left operand matches this type. Note that this
6489 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6490 -- checks have changed the type of the left operand.
6492 and then Is_Entity_Name
(Rop
)
6493 and then Ltyp
= Entity
(Rop
)
6495 -- Skip this for predicated types, where such expressions are a
6496 -- reasonable way of testing if something meets the predicate.
6498 and then No
(Predicate_Function
(Ltyp
))
6500 Substitute_Valid_Test
;
6504 -- Do validity check on operands
6506 if Validity_Checks_On
and Validity_Check_Operands
then
6507 Ensure_Valid
(Left_Opnd
(N
));
6508 Validity_Check_Range
(Right_Opnd
(N
));
6511 -- Case of explicit range
6513 if Nkind
(Rop
) = N_Range
then
6515 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
6516 Hi
: constant Node_Id
:= High_Bound
(Rop
);
6518 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
6519 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
6520 Rop_Orig
: constant Node_Id
:= Original_Node
(Rop
);
6522 Comes_From_Simple_Range_In_Source
: constant Boolean :=
6523 Comes_From_Source
(N
)
6525 (Is_Entity_Name
(Rop_Orig
)
6526 and then Is_Type
(Entity
(Rop_Orig
))
6527 and then Present
(Predicate_Function
(Entity
(Rop_Orig
))));
6528 -- This is true for a membership test present in the source with a
6529 -- range or mark for a subtype that is not predicated. As already
6530 -- explained a few lines above, we do not want to give warnings on
6531 -- a test with a mark for a subtype that is predicated.
6533 Warn
: constant Boolean :=
6534 Constant_Condition_Warnings
6535 and then Comes_From_Simple_Range_In_Source
6536 and then not In_Instance
;
6537 -- This must be true for any of the optimization warnings, we
6538 -- clearly want to give them only for source with the flag on. We
6539 -- also skip these warnings in an instance since it may be the
6540 -- case that different instantiations have different ranges.
6542 Lcheck
: Compare_Result
;
6543 Ucheck
: Compare_Result
;
6546 -- If test is explicit x'First .. x'Last, replace by 'Valid test
6548 if Is_Scalar_Type
(Ltyp
)
6550 -- Only relevant for source comparisons
6552 and then Comes_From_Simple_Range_In_Source
6554 -- And left operand is X'First where X matches left operand
6555 -- type (this eliminates cases of type mismatch, including
6556 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6557 -- type of the left operand.
6559 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
6560 and then Attribute_Name
(Lo_Orig
) = Name_First
6561 and then Is_Entity_Name
(Prefix
(Lo_Orig
))
6562 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
6564 -- Same tests for right operand
6566 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
6567 and then Attribute_Name
(Hi_Orig
) = Name_Last
6568 and then Is_Entity_Name
(Prefix
(Hi_Orig
))
6569 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
6571 Substitute_Valid_Test
;
6575 -- If bounds of type are known at compile time, and the end points
6576 -- are known at compile time and identical, this is another case
6577 -- for substituting a valid test. We only do this for discrete
6578 -- types, since it won't arise in practice for float types.
6580 if Comes_From_Simple_Range_In_Source
6581 and then Is_Discrete_Type
(Ltyp
)
6582 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
6583 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
6584 and then Compile_Time_Known_Value
(Lo
)
6585 and then Compile_Time_Known_Value
(Hi
)
6586 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
6587 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
6589 -- Kill warnings in instances, since they may be cases where we
6590 -- have a test in the generic that makes sense with some types
6591 -- and not with other types.
6593 -- Similarly, do not rewrite membership as a 'Valid test if
6594 -- within the predicate function for the type.
6596 -- Finally, if the original bounds are type conversions, even
6597 -- if they have been folded into constants, there are different
6598 -- types involved and 'Valid is not appropriate.
6602 or else (Ekind
(Current_Scope
) = E_Function
6603 and then Is_Predicate_Function
(Current_Scope
))
6607 elsif Nkind
(Lo_Orig
) = N_Type_Conversion
6608 or else Nkind
(Hi_Orig
) = N_Type_Conversion
6613 Substitute_Valid_Test
;
6618 -- If we have an explicit range, do a bit of optimization based on
6619 -- range analysis (we may be able to kill one or both checks).
6621 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
6622 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
6624 -- If either check is known to fail, replace result by False since
6625 -- the other check does not matter. Preserve the static flag for
6626 -- legality checks, because we are constant-folding beyond RM 4.9.
6628 if Lcheck
= LT
or else Ucheck
= GT
then
6630 Error_Msg_N
("?c?range test optimized away", N
);
6631 Error_Msg_N
("\?c?value is known to be out of range", N
);
6634 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6635 Analyze_And_Resolve
(N
, Restyp
);
6636 Set_Is_Static_Expression
(N
, Static
);
6639 -- If both checks are known to succeed, replace result by True,
6640 -- since we know we are in range.
6642 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6644 Error_Msg_N
("?c?range test optimized away", N
);
6645 Error_Msg_N
("\?c?value is known to be in range", N
);
6648 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6649 Analyze_And_Resolve
(N
, Restyp
);
6650 Set_Is_Static_Expression
(N
, Static
);
6653 -- If lower bound check succeeds and upper bound check is not
6654 -- known to succeed or fail, then replace the range check with
6655 -- a comparison against the upper bound.
6657 elsif Lcheck
in Compare_GE
then
6661 Right_Opnd
=> High_Bound
(Rop
)));
6662 Analyze_And_Resolve
(N
, Restyp
);
6665 -- Inverse of previous case.
6667 elsif Ucheck
in Compare_LE
then
6671 Right_Opnd
=> Low_Bound
(Rop
)));
6672 Analyze_And_Resolve
(N
, Restyp
);
6676 -- We couldn't optimize away the range check, but there is one
6677 -- more issue. If we are checking constant conditionals, then we
6678 -- see if we can determine the outcome assuming everything is
6679 -- valid, and if so give an appropriate warning.
6681 if Warn
and then not Assume_No_Invalid_Values
then
6682 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
6683 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
6685 -- Result is out of range for valid value
6687 if Lcheck
= LT
or else Ucheck
= GT
then
6689 ("?c?value can only be in range if it is invalid", N
);
6691 -- Result is in range for valid value
6693 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6695 ("?c?value can only be out of range if it is invalid", N
);
6700 -- Try to narrow the operation
6702 if Ltyp
= Universal_Integer
and then Nkind
(N
) = N_In
then
6703 Narrow_Large_Operation
(N
);
6706 -- For all other cases of an explicit range, nothing to be done
6710 -- Here right operand is a subtype mark
6714 Typ
: Entity_Id
:= Etype
(Rop
);
6715 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
6716 Check_Null_Exclusion
: Boolean;
6717 Cond
: Node_Id
:= Empty
;
6719 Obj
: Node_Id
:= Lop
;
6720 SCIL_Node
: Node_Id
;
6723 Remove_Side_Effects
(Obj
);
6725 -- For tagged type, do tagged membership operation
6727 if Is_Tagged_Type
(Typ
) then
6729 -- No expansion will be performed for VM targets, as the VM
6730 -- back ends will handle the membership tests directly.
6732 if Tagged_Type_Expansion
then
6733 Tagged_Membership
(N
, SCIL_Node
, New_N
);
6735 Analyze_And_Resolve
(N
, Restyp
, Suppress
=> All_Checks
);
6737 -- Update decoration of relocated node referenced by the
6740 if Generate_SCIL
and then Present
(SCIL_Node
) then
6741 Set_SCIL_Node
(N
, SCIL_Node
);
6747 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6748 -- The reason we do this is that the bounds may have the wrong
6749 -- type if they come from the original type definition. Also this
6750 -- way we get all the processing above for an explicit range.
6752 -- Don't do this for predicated types, since in this case we want
6753 -- to generate the predicate check at the end of the function.
6755 elsif Is_Scalar_Type
(Typ
) then
6756 if No
(Predicate_Function
(Typ
)) then
6760 Make_Attribute_Reference
(Loc
,
6761 Attribute_Name
=> Name_First
,
6762 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
6765 Make_Attribute_Reference
(Loc
,
6766 Attribute_Name
=> Name_Last
,
6767 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
6769 Analyze_And_Resolve
(N
, Restyp
);
6774 -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is
6775 -- raised when evaluating an individual membership test if the
6776 -- subtype mark denotes a constrained Unchecked_Union subtype
6777 -- and the expression lacks inferable discriminants.
6779 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
6780 and then Is_Constrained
(Typ
)
6781 and then not Has_Inferable_Discriminants
(Lop
)
6784 Make_Expression_With_Actions
(Loc
,
6786 New_List
(Make_Raise_Program_Error
(Loc
,
6787 Reason
=> PE_Unchecked_Union_Restriction
)),
6789 New_Occurrence_Of
(Standard_False
, Loc
)));
6790 Analyze_And_Resolve
(N
, Restyp
);
6795 -- Here we have a non-scalar type
6799 -- If the null exclusion checks are not compatible, need to
6800 -- perform further checks. In other words, we cannot have
6801 -- Ltyp including null or Lop being null, and Typ excluding
6802 -- null. All other cases are OK.
6804 Check_Null_Exclusion
:=
6805 Can_Never_Be_Null
(Typ
)
6806 and then (not Can_Never_Be_Null
(Ltyp
)
6807 or else Nkind
(Lop
) = N_Null
);
6808 Typ
:= Designated_Type
(Typ
);
6811 if not Is_Constrained
(Typ
) then
6812 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6814 -- For the constrained array case, we have to check the subscripts
6815 -- for an exact match if the lengths are non-zero (the lengths
6816 -- must match in any case).
6818 elsif Is_Array_Type
(Typ
) then
6819 Check_Subscripts
: declare
6820 function Build_Attribute_Reference
6823 Dim
: Nat
) return Node_Id
;
6824 -- Build attribute reference E'Nam (Dim)
6826 -------------------------------
6827 -- Build_Attribute_Reference --
6828 -------------------------------
6830 function Build_Attribute_Reference
6833 Dim
: Nat
) return Node_Id
6837 Make_Attribute_Reference
(Loc
,
6839 Attribute_Name
=> Nam
,
6840 Expressions
=> New_List
(
6841 Make_Integer_Literal
(Loc
, Dim
)));
6842 end Build_Attribute_Reference
;
6844 -- Start of processing for Check_Subscripts
6847 for J
in 1 .. Number_Dimensions
(Typ
) loop
6848 Evolve_And_Then
(Cond
,
6851 Build_Attribute_Reference
6852 (Duplicate_Subexpr_No_Checks
(Obj
),
6855 Build_Attribute_Reference
6856 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
6858 Evolve_And_Then
(Cond
,
6861 Build_Attribute_Reference
6862 (Duplicate_Subexpr_No_Checks
(Obj
),
6865 Build_Attribute_Reference
6866 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
6868 end Check_Subscripts
;
6870 -- These are the cases where constraint checks may be required,
6871 -- e.g. records with possible discriminants
6874 -- Expand the test into a series of discriminant comparisons.
6875 -- The expression that is built is the negation of the one that
6876 -- is used for checking discriminant constraints.
6878 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6880 if Has_Discriminants
(Typ
) then
6881 Cond
:= Make_Op_Not
(Loc
,
6882 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6884 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6889 if Check_Null_Exclusion
then
6890 Cond
:= Make_And_Then
(Loc
,
6894 Right_Opnd
=> Make_Null
(Loc
)),
6895 Right_Opnd
=> Cond
);
6897 Cond
:= Make_Or_Else
(Loc
,
6901 Right_Opnd
=> Make_Null
(Loc
)),
6902 Right_Opnd
=> Cond
);
6907 Analyze_And_Resolve
(N
, Restyp
);
6909 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6910 -- expression of an anonymous access type. This can involve an
6911 -- accessibility test and a tagged type membership test in the
6912 -- case of tagged designated types.
6914 if Ada_Version
>= Ada_2012
6916 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6919 Expr_Entity
: Entity_Id
:= Empty
;
6921 Param_Level
: Node_Id
;
6922 Type_Level
: Node_Id
;
6925 if Is_Entity_Name
(Lop
) then
6926 Expr_Entity
:= Param_Entity
(Lop
);
6928 if No
(Expr_Entity
) then
6929 Expr_Entity
:= Entity
(Lop
);
6933 -- When restriction No_Dynamic_Accessibility_Checks is in
6934 -- effect, expand the membership test to a static value
6935 -- since we cannot rely on dynamic levels.
6937 if No_Dynamic_Accessibility_Checks_Enabled
(Lop
) then
6938 if Static_Accessibility_Level
6939 (Lop
, Object_Decl_Level
)
6940 > Type_Access_Level
(Rtyp
)
6942 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6944 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6946 Analyze_And_Resolve
(N
, Restyp
);
6948 -- If a conversion of the anonymous access value to the
6949 -- tested type would be illegal, then the result is False.
6951 elsif not Valid_Conversion
6952 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6954 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6955 Analyze_And_Resolve
(N
, Restyp
);
6957 -- Apply an accessibility check if the access object has an
6958 -- associated access level and when the level of the type is
6959 -- less deep than the level of the access parameter. This
6960 -- can only occur for access parameters and stand-alone
6961 -- objects of an anonymous access type.
6964 Param_Level
:= Accessibility_Level
6965 (Expr_Entity
, Dynamic_Level
);
6968 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6970 -- Return True only if the accessibility level of the
6971 -- expression entity is not deeper than the level of
6972 -- the tested access type.
6976 Left_Opnd
=> Relocate_Node
(N
),
6977 Right_Opnd
=> Make_Op_Le
(Loc
,
6978 Left_Opnd
=> Param_Level
,
6979 Right_Opnd
=> Type_Level
)));
6981 Analyze_And_Resolve
(N
);
6983 -- If the designated type is tagged, do tagged membership
6986 if Is_Tagged_Type
(Typ
) then
6988 -- No expansion will be performed for VM targets, as
6989 -- the VM back ends will handle the membership tests
6992 if Tagged_Type_Expansion
then
6994 -- Note that we have to pass Original_Node, because
6995 -- the membership test might already have been
6996 -- rewritten by earlier parts of membership test.
6999 (Original_Node
(N
), SCIL_Node
, New_N
);
7001 -- Update decoration of relocated node referenced
7002 -- by the SCIL node.
7004 if Generate_SCIL
and then Present
(SCIL_Node
) then
7005 Set_SCIL_Node
(New_N
, SCIL_Node
);
7010 Left_Opnd
=> Relocate_Node
(N
),
7011 Right_Opnd
=> New_N
));
7013 Analyze_And_Resolve
(N
, Restyp
);
7022 -- At this point, we have done the processing required for the basic
7023 -- membership test, but not yet dealt with the predicate.
7027 -- If a predicate is present, then we do the predicate test, but we
7028 -- most certainly want to omit this if we are within the predicate
7029 -- function itself, since otherwise we have an infinite recursion.
7030 -- The check should also not be emitted when testing against a range
7031 -- (the check is only done when the right operand is a subtype; see
7032 -- RM12-4.5.2 (28.1/3-30/3)).
7034 Predicate_Check
: declare
7035 function In_Range_Check
return Boolean;
7036 -- Within an expanded range check that may raise Constraint_Error do
7037 -- not generate a predicate check as well. It is redundant because
7038 -- the context will add an explicit predicate check, and it will
7039 -- raise the wrong exception if it fails.
7041 --------------------
7042 -- In_Range_Check --
7043 --------------------
7045 function In_Range_Check
return Boolean is
7049 while Present
(P
) loop
7050 if Nkind
(P
) = N_Raise_Constraint_Error
then
7053 elsif Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
7054 or else Nkind
(P
) = N_Procedure_Call_Statement
7055 or else Nkind
(P
) in N_Declaration
7068 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
7071 -- Start of processing for Predicate_Check
7075 and then Current_Scope
/= PFunc
7076 and then Nkind
(Rop
) /= N_Range
7078 -- First apply the transformation that was skipped above
7080 if Is_Scalar_Type
(Rtyp
) then
7084 Make_Attribute_Reference
(Loc
,
7085 Attribute_Name
=> Name_First
,
7086 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
7089 Make_Attribute_Reference
(Loc
,
7090 Attribute_Name
=> Name_Last
,
7091 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
7093 Analyze_And_Resolve
(N
, Restyp
);
7096 if not In_Range_Check
then
7097 -- Indicate via Static_Mem parameter that this predicate
7098 -- evaluation is for a membership test.
7099 R_Op
:= Make_Predicate_Call
(Rtyp
, Lop
, Static_Mem
=> True);
7101 R_Op
:= New_Occurrence_Of
(Standard_True
, Loc
);
7106 Left_Opnd
=> Relocate_Node
(N
),
7107 Right_Opnd
=> R_Op
));
7109 -- Analyze new expression, mark left operand as analyzed to
7110 -- avoid infinite recursion adding predicate calls. Similarly,
7111 -- suppress further range checks on the call.
7113 Set_Analyzed
(Left_Opnd
(N
));
7114 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7116 end Predicate_Check
;
7119 --------------------------------
7120 -- Expand_N_Indexed_Component --
7121 --------------------------------
7123 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
7125 Wild_Reads_May_Have_Bad_Side_Effects
: Boolean
7126 renames Validity_Check_Subscripts
;
7127 -- This Boolean needs to be True if reading from a bad address can
7128 -- have a bad side effect (e.g., a segmentation fault that is not
7129 -- transformed into a Storage_Error exception, or interactions with
7130 -- memory-mapped I/O) that needs to be prevented. This refers to the
7131 -- act of reading itself, not to any damage that might be caused later
7132 -- by making use of whatever value was read. We assume here that
7133 -- Validity_Check_Subscripts meets this requirement, but introduce
7134 -- this declaration in order to document this assumption.
7136 function Is_Renamed_Variable_Name
(N
: Node_Id
) return Boolean;
7137 -- Returns True if the given name occurs as part of the renaming
7138 -- of a variable. In this case, the indexing operation should be
7139 -- treated as a write, rather than a read, with respect to validity
7140 -- checking. This is because the renamed variable can later be
7143 function Type_Requires_Subscript_Validity_Checks_For_Reads
7144 (Typ
: Entity_Id
) return Boolean;
7145 -- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing
7146 -- into an array of characters in order to read an element, it is ok
7147 -- if an invalid index value goes undetected. But if it is an array of
7148 -- pointers or an array of tasks, the consequences of such a read are
7149 -- potentially more severe and so we want to detect an invalid index
7150 -- value. This function captures that distinction; this is intended to
7151 -- be consistent with the "but does not by itself lead to erroneous
7152 -- ... execution" rule of RM 13.9.1(11).
7154 ------------------------------
7155 -- Is_Renamed_Variable_Name --
7156 ------------------------------
7158 function Is_Renamed_Variable_Name
(N
: Node_Id
) return Boolean is
7159 Rover
: Node_Id
:= N
;
7161 if Is_Variable
(N
) then
7164 Rover_Parent
: constant Node_Id
:= Parent
(Rover
);
7166 case Nkind
(Rover_Parent
) is
7167 when N_Object_Renaming_Declaration
=>
7168 return Rover
= Name
(Rover_Parent
);
7170 when N_Indexed_Component
7172 | N_Selected_Component
7174 exit when Rover
/= Prefix
(Rover_Parent
);
7175 Rover
:= Rover_Parent
;
7177 -- No need to check for qualified expressions or type
7178 -- conversions here, mostly because of the Is_Variable
7179 -- test. It is possible to have a view conversion for
7180 -- which Is_Variable yields True and which occurs as
7181 -- part of an object renaming, but only if the type is
7182 -- tagged; in that case this function will not be called.
7191 end Is_Renamed_Variable_Name
;
7193 -------------------------------------------------------
7194 -- Type_Requires_Subscript_Validity_Checks_For_Reads --
7195 -------------------------------------------------------
7197 function Type_Requires_Subscript_Validity_Checks_For_Reads
7198 (Typ
: Entity_Id
) return Boolean
7200 -- a shorter name for recursive calls
7201 function Needs_Check
(Typ
: Entity_Id
) return Boolean renames
7202 Type_Requires_Subscript_Validity_Checks_For_Reads
;
7204 if Is_Access_Type
(Typ
)
7205 or else Is_Tagged_Type
(Typ
)
7206 or else Is_Concurrent_Type
(Typ
)
7207 or else (Is_Array_Type
(Typ
)
7208 and then Needs_Check
(Component_Type
(Typ
)))
7209 or else (Is_Scalar_Type
(Typ
)
7210 and then Has_Aspect
(Typ
, Aspect_Default_Value
))
7215 if Is_Record_Type
(Typ
) then
7217 Comp
: Entity_Id
:= First_Component_Or_Discriminant
(Typ
);
7219 while Present
(Comp
) loop
7220 if Needs_Check
(Etype
(Comp
)) then
7224 Next_Component_Or_Discriminant
(Comp
);
7230 end Type_Requires_Subscript_Validity_Checks_For_Reads
;
7234 Loc
: constant Source_Ptr
:= Sloc
(N
);
7235 Typ
: constant Entity_Id
:= Etype
(N
);
7236 P
: constant Node_Id
:= Prefix
(N
);
7237 T
: constant Entity_Id
:= Etype
(P
);
7239 -- Start of processing for Expand_N_Indexed_Component
7242 -- A special optimization, if we have an indexed component that is
7243 -- selecting from a slice, then we can eliminate the slice, since, for
7244 -- example, x (i .. j)(k) is identical to x(k). The only difference is
7245 -- the range check required by the slice. The range check for the slice
7246 -- itself has already been generated. The range check for the
7247 -- subscripting operation is ensured by converting the subject to
7248 -- the subtype of the slice.
7250 -- This optimization not only generates better code, avoiding slice
7251 -- messing especially in the packed case, but more importantly bypasses
7252 -- some problems in handling this peculiar case, for example, the issue
7253 -- of dealing specially with object renamings.
7255 if Nkind
(P
) = N_Slice
7257 -- This optimization is disabled for CodePeer because it can transform
7258 -- an index-check constraint_error into a range-check constraint_error
7259 -- and CodePeer cares about that distinction.
7261 and then not CodePeer_Mode
7264 Make_Indexed_Component
(Loc
,
7265 Prefix
=> Prefix
(P
),
7266 Expressions
=> New_List
(
7268 (Etype
(First_Index
(Etype
(P
))),
7269 First
(Expressions
(N
))))));
7270 Analyze_And_Resolve
(N
, Typ
);
7274 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7275 -- function, then additional actuals must be passed.
7277 if Is_Build_In_Place_Function_Call
(P
) then
7278 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
7280 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
7281 -- containing build-in-place function calls whose returned object covers
7284 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
7285 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
7288 -- Generate index and validity checks
7291 Dims_Checked
: Dimension_Set
(Dimensions
=>
7292 (if Is_Array_Type
(T
)
7293 then Number_Dimensions
(T
)
7295 -- Dims_Checked is used to avoid generating two checks (one in
7296 -- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks)
7297 -- for the same index value in cases where the index check eliminates
7298 -- the need for the validity check. The Is_Array_Type test avoids
7299 -- cascading errors.
7302 Generate_Index_Checks
(N
, Checks_Generated
=> Dims_Checked
);
7304 if Validity_Checks_On
7305 and then (Validity_Check_Subscripts
7306 or else Wild_Reads_May_Have_Bad_Side_Effects
7307 or else Type_Requires_Subscript_Validity_Checks_For_Reads
7309 or else Is_Renamed_Variable_Name
(N
))
7311 if Validity_Check_Subscripts
then
7312 -- If we index into an array with an uninitialized variable
7313 -- and we generate an index check that passes at run time,
7314 -- passing that check does not ensure that the variable is
7315 -- valid (although it does in the common case where the
7316 -- object's subtype matches the index subtype).
7317 -- Consider an uninitialized variable with subtype 1 .. 10
7318 -- used to index into an array with bounds 1 .. 20 when the
7319 -- value of the uninitialized variable happens to be 15.
7320 -- The index check will succeed but the variable is invalid.
7321 -- If Validity_Check_Subscripts is True then we need to
7322 -- ensure validity, so we adjust Dims_Checked accordingly.
7323 Dims_Checked
.Elements
:= (others => False);
7325 elsif Is_Array_Type
(T
) then
7326 -- We are only adding extra validity checks here to
7327 -- deal with uninitialized variables (but this includes
7328 -- assigning one uninitialized variable to another). Other
7329 -- ways of producing invalid objects imply erroneousness, so
7330 -- the compiler can do whatever it wants for those cases.
7331 -- If an index type has the Default_Value aspect specified,
7332 -- then we don't have to worry about the possibility of an
7333 -- uninitialized variable, so no need for these extra
7337 Idx
: Node_Id
:= First_Index
(T
);
7339 for No_Check_Needed
of Dims_Checked
.Elements
loop
7340 No_Check_Needed
:= No_Check_Needed
7341 or else Has_Aspect
(Etype
(Idx
), Aspect_Default_Value
);
7347 Apply_Subscript_Validity_Checks
7348 (N
, No_Check_Needed
=> Dims_Checked
);
7352 -- If selecting from an array with atomic components, and atomic sync
7353 -- is not suppressed for this array type, set atomic sync flag.
7355 if (Has_Atomic_Components
(T
)
7356 and then not Atomic_Synchronization_Disabled
(T
))
7357 or else (Is_Atomic
(Typ
)
7358 and then not Atomic_Synchronization_Disabled
(Typ
))
7359 or else (Is_Entity_Name
(P
)
7360 and then Has_Atomic_Components
(Entity
(P
))
7361 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
7363 Activate_Atomic_Synchronization
(N
);
7366 -- All done if the prefix is not a packed array implemented specially
7368 if not (Is_Packed
(Etype
(Prefix
(N
)))
7369 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(N
)))))
7374 -- For packed arrays that are not bit-packed (i.e. the case of an array
7375 -- with one or more index types with a non-contiguous enumeration type),
7376 -- we can always use the normal packed element get circuit.
7378 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
7379 Expand_Packed_Element_Reference
(N
);
7383 -- For a reference to a component of a bit packed array, we convert it
7384 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
7385 -- want to do this for simple references, and not for:
7387 -- Left side of assignment, or prefix of left side of assignment, or
7388 -- prefix of the prefix, to handle packed arrays of packed arrays,
7389 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
7391 -- Renaming objects in renaming associations
7392 -- This case is handled when a use of the renamed variable occurs
7394 -- Actual parameters for a subprogram call
7395 -- This case is handled in Exp_Ch6.Expand_Actuals
7397 -- The second expression in a 'Read attribute reference
7399 -- The prefix of an address or bit or size attribute reference
7401 -- The following circuit detects these exceptions. Note that we need to
7402 -- deal with implicit dereferences when climbing up the parent chain,
7403 -- with the additional difficulty that the type of parents may have yet
7404 -- to be resolved since prefixes are usually resolved first.
7407 Child
: Node_Id
:= N
;
7408 Parnt
: Node_Id
:= Parent
(N
);
7412 if Nkind
(Parnt
) = N_Unchecked_Expression
then
7415 elsif Nkind
(Parnt
) = N_Object_Renaming_Declaration
then
7418 elsif Nkind
(Parnt
) in N_Subprogram_Call
7419 or else (Nkind
(Parnt
) = N_Parameter_Association
7420 and then Nkind
(Parent
(Parnt
)) in N_Subprogram_Call
)
7424 elsif Nkind
(Parnt
) = N_Attribute_Reference
7425 and then Attribute_Name
(Parnt
) in Name_Address
7428 and then Prefix
(Parnt
) = Child
7432 elsif Nkind
(Parnt
) = N_Assignment_Statement
7433 and then Name
(Parnt
) = Child
7437 -- If the expression is an index of an indexed component, it must
7438 -- be expanded regardless of context.
7440 elsif Nkind
(Parnt
) = N_Indexed_Component
7441 and then Child
/= Prefix
(Parnt
)
7443 Expand_Packed_Element_Reference
(N
);
7446 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
7447 and then Name
(Parent
(Parnt
)) = Parnt
7451 elsif Nkind
(Parnt
) = N_Attribute_Reference
7452 and then Attribute_Name
(Parnt
) = Name_Read
7453 and then Next
(First
(Expressions
(Parnt
))) = Child
7457 elsif Nkind
(Parnt
) = N_Indexed_Component
7458 and then Prefix
(Parnt
) = Child
7462 elsif Nkind
(Parnt
) = N_Selected_Component
7463 and then Prefix
(Parnt
) = Child
7464 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
7466 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
7470 -- If the parent is a dereference, either implicit or explicit,
7471 -- then the packed reference needs to be expanded.
7474 Expand_Packed_Element_Reference
(N
);
7478 -- Keep looking up tree for unchecked expression, or if we are the
7479 -- prefix of a possible assignment left side.
7482 Parnt
:= Parent
(Child
);
7485 end Expand_N_Indexed_Component
;
7487 ---------------------
7488 -- Expand_N_Not_In --
7489 ---------------------
7491 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7492 -- can be done. This avoids needing to duplicate this expansion code.
7494 procedure Expand_N_Not_In
(N
: Node_Id
) is
7495 Loc
: constant Source_Ptr
:= Sloc
(N
);
7496 Typ
: constant Entity_Id
:= Etype
(N
);
7497 Cfs
: constant Boolean := Comes_From_Source
(N
);
7504 Left_Opnd
=> Left_Opnd
(N
),
7505 Right_Opnd
=> Right_Opnd
(N
))));
7507 -- If this is a set membership, preserve list of alternatives
7509 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
7511 -- We want this to appear as coming from source if original does (see
7512 -- transformations in Expand_N_In).
7514 Set_Comes_From_Source
(N
, Cfs
);
7515 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
7517 -- Now analyze transformed node
7519 Analyze_And_Resolve
(N
, Typ
);
7520 end Expand_N_Not_In
;
7526 -- The only replacement required is for the case of a null of a type that
7527 -- is an access to protected subprogram, or a subtype thereof. We represent
7528 -- such access values as a record, and so we must replace the occurrence of
7529 -- null by the equivalent record (with a null address and a null pointer in
7530 -- it), so that the back end creates the proper value.
7532 procedure Expand_N_Null
(N
: Node_Id
) is
7533 Loc
: constant Source_Ptr
:= Sloc
(N
);
7534 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
7538 if Is_Access_Protected_Subprogram_Type
(Typ
) then
7540 Make_Aggregate
(Loc
,
7541 Expressions
=> New_List
(
7542 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
7546 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
7548 -- For subsequent semantic analysis, the node must retain its type.
7549 -- Gigi in any case replaces this type by the corresponding record
7550 -- type before processing the node.
7556 when RE_Not_Available
=>
7560 ---------------------
7561 -- Expand_N_Op_Abs --
7562 ---------------------
7564 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
7565 Loc
: constant Source_Ptr
:= Sloc
(N
);
7566 Expr
: constant Node_Id
:= Right_Opnd
(N
);
7567 Typ
: constant Entity_Id
:= Etype
(N
);
7570 Unary_Op_Validity_Checks
(N
);
7572 -- Check for MINIMIZED/ELIMINATED overflow mode
7574 if Minimized_Eliminated_Overflow_Check
(N
) then
7575 Apply_Arithmetic_Overflow_Check
(N
);
7579 -- Try to narrow the operation
7581 if Typ
= Universal_Integer
then
7582 Narrow_Large_Operation
(N
);
7584 if Nkind
(N
) /= N_Op_Abs
then
7589 -- Deal with software overflow checking
7591 if Is_Signed_Integer_Type
(Typ
)
7592 and then Do_Overflow_Check
(N
)
7594 -- The only case to worry about is when the argument is equal to the
7595 -- largest negative number, so what we do is to insert the check:
7597 -- [constraint_error when Expr = typ'Base'First]
7599 -- with the usual Duplicate_Subexpr use coding for expr
7602 Make_Raise_Constraint_Error
(Loc
,
7605 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
7607 Make_Attribute_Reference
(Loc
,
7609 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
7610 Attribute_Name
=> Name_First
)),
7611 Reason
=> CE_Overflow_Check_Failed
));
7613 Set_Do_Overflow_Check
(N
, False);
7615 end Expand_N_Op_Abs
;
7617 ---------------------
7618 -- Expand_N_Op_Add --
7619 ---------------------
7621 procedure Expand_N_Op_Add
(N
: Node_Id
) is
7622 Typ
: constant Entity_Id
:= Etype
(N
);
7625 Binary_Op_Validity_Checks
(N
);
7627 -- Check for MINIMIZED/ELIMINATED overflow mode
7629 if Minimized_Eliminated_Overflow_Check
(N
) then
7630 Apply_Arithmetic_Overflow_Check
(N
);
7634 -- N + 0 = 0 + N = N for integer types
7636 if Is_Integer_Type
(Typ
) then
7637 if Compile_Time_Known_Value
(Right_Opnd
(N
))
7638 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
7640 Rewrite
(N
, Left_Opnd
(N
));
7643 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
7644 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
7646 Rewrite
(N
, Right_Opnd
(N
));
7651 -- Try to narrow the operation
7653 if Typ
= Universal_Integer
then
7654 Narrow_Large_Operation
(N
);
7656 if Nkind
(N
) /= N_Op_Add
then
7661 -- Arithmetic overflow checks for signed integer/fixed point types
7663 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
7664 Apply_Arithmetic_Overflow_Check
(N
);
7668 -- Overflow checks for floating-point if -gnateF mode active
7670 Check_Float_Op_Overflow
(N
);
7672 Expand_Nonbinary_Modular_Op
(N
);
7673 end Expand_N_Op_Add
;
7675 ---------------------
7676 -- Expand_N_Op_And --
7677 ---------------------
7679 procedure Expand_N_Op_And
(N
: Node_Id
) is
7680 Typ
: constant Entity_Id
:= Etype
(N
);
7683 Binary_Op_Validity_Checks
(N
);
7685 if Is_Array_Type
(Etype
(N
)) then
7686 Expand_Boolean_Operator
(N
);
7688 elsif Is_Boolean_Type
(Etype
(N
)) then
7689 Adjust_Condition
(Left_Opnd
(N
));
7690 Adjust_Condition
(Right_Opnd
(N
));
7691 Set_Etype
(N
, Standard_Boolean
);
7692 Adjust_Result_Type
(N
, Typ
);
7694 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
7695 Expand_Intrinsic_Call
(N
, Entity
(N
));
7698 Expand_Nonbinary_Modular_Op
(N
);
7699 end Expand_N_Op_And
;
7701 ------------------------
7702 -- Expand_N_Op_Concat --
7703 ------------------------
7705 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
7707 -- List of operands to be concatenated
7710 -- Node which is to be replaced by the result of concatenating the nodes
7711 -- in the list Opnds.
7714 -- Ensure validity of both operands
7716 Binary_Op_Validity_Checks
(N
);
7718 -- If we are the left operand of a concatenation higher up the tree,
7719 -- then do nothing for now, since we want to deal with a series of
7720 -- concatenations as a unit.
7722 if Nkind
(Parent
(N
)) = N_Op_Concat
7723 and then N
= Left_Opnd
(Parent
(N
))
7728 -- We get here with a concatenation whose left operand may be a
7729 -- concatenation itself with a consistent type. We need to process
7730 -- these concatenation operands from left to right, which means
7731 -- from the deepest node in the tree to the highest node.
7734 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
7735 Cnode
:= Left_Opnd
(Cnode
);
7738 -- Now Cnode is the deepest concatenation, and its parents are the
7739 -- concatenation nodes above, so now we process bottom up, doing the
7742 -- The outer loop runs more than once if more than one concatenation
7743 -- type is involved.
7746 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
7747 Set_Parent
(Opnds
, N
);
7749 -- The inner loop gathers concatenation operands
7751 Inner
: while Cnode
/= N
7752 and then Base_Type
(Etype
(Cnode
)) =
7753 Base_Type
(Etype
(Parent
(Cnode
)))
7755 Cnode
:= Parent
(Cnode
);
7756 Append
(Right_Opnd
(Cnode
), Opnds
);
7759 -- Note: The following code is a temporary workaround for N731-034
7760 -- and N829-028 and will be kept until the general issue of internal
7761 -- symbol serialization is addressed. The workaround is kept under a
7762 -- debug switch to avoid permiating into the general case.
7764 -- Wrap the node to concatenate into an expression actions node to
7765 -- keep it nicely packaged. This is useful in the case of an assert
7766 -- pragma with a concatenation where we want to be able to delete
7767 -- the concatenation and all its expansion stuff.
7769 if Debug_Flag_Dot_H
then
7771 Cnod
: constant Node_Id
:= New_Copy_Tree
(Cnode
);
7772 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
7775 -- Note: use Rewrite rather than Replace here, so that for
7776 -- example Why_Not_Static can find the original concatenation
7780 Make_Expression_With_Actions
(Sloc
(Cnode
),
7781 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
7782 Expression
=> Cnod
));
7784 Expand_Concatenate
(Cnod
, Opnds
);
7785 Analyze_And_Resolve
(Cnode
, Typ
);
7791 Expand_Concatenate
(Cnode
, Opnds
);
7794 exit Outer
when Cnode
= N
;
7795 Cnode
:= Parent
(Cnode
);
7797 end Expand_N_Op_Concat
;
7799 ------------------------
7800 -- Expand_N_Op_Divide --
7801 ------------------------
7803 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
7804 Loc
: constant Source_Ptr
:= Sloc
(N
);
7805 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
7806 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
7807 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
7808 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
7809 Typ
: Entity_Id
:= Etype
(N
);
7810 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
7812 Compile_Time_Known_Value
(Ropnd
);
7816 Binary_Op_Validity_Checks
(N
);
7818 -- Check for MINIMIZED/ELIMINATED overflow mode
7820 if Minimized_Eliminated_Overflow_Check
(N
) then
7821 Apply_Arithmetic_Overflow_Check
(N
);
7825 -- Otherwise proceed with expansion of division
7828 Rval
:= Expr_Value
(Ropnd
);
7831 -- N / 1 = N for integer types
7833 if Rknow
and then Rval
= Uint_1
then
7838 -- Try to narrow the operation
7840 if Typ
= Universal_Integer
then
7841 Narrow_Large_Operation
(N
);
7843 if Nkind
(N
) /= N_Op_Divide
then
7848 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7849 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7850 -- operand is an unsigned integer, as required for this to work.
7852 if Nkind
(Ropnd
) = N_Op_Expon
7853 and then Is_Power_Of_2_For_Shift
(Ropnd
)
7855 -- We cannot do this transformation in configurable run time mode if we
7856 -- have 64-bit integers and long shifts are not available.
7858 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
7861 Make_Op_Shift_Right
(Loc
,
7864 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
7865 Analyze_And_Resolve
(N
, Typ
);
7869 -- Do required fixup of universal fixed operation
7871 if Typ
= Universal_Fixed
then
7872 Fixup_Universal_Fixed_Operation
(N
);
7876 -- Divisions with fixed-point results
7878 if Is_Fixed_Point_Type
(Typ
) then
7880 if Is_Integer_Type
(Rtyp
) then
7881 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
7883 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
7886 -- Deal with divide-by-zero check if back end cannot handle them
7887 -- and the flag is set indicating that we need such a check. Note
7888 -- that we don't need to bother here with the case of mixed-mode
7889 -- (Right operand an integer type), since these will be rewritten
7890 -- with conversions to a divide with a fixed-point right operand.
7892 if Nkind
(N
) = N_Op_Divide
7893 and then Do_Division_Check
(N
)
7894 and then not Backend_Divide_Checks_On_Target
7895 and then not Is_Integer_Type
(Rtyp
)
7897 Set_Do_Division_Check
(N
, False);
7899 Make_Raise_Constraint_Error
(Loc
,
7902 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
7903 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
7904 Reason
=> CE_Divide_By_Zero
));
7907 -- Other cases of division of fixed-point operands
7909 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
7910 if Is_Integer_Type
(Typ
) then
7911 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
7913 pragma Assert
(Is_Floating_Point_Type
(Typ
));
7914 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
7917 -- Mixed-mode operations can appear in a non-static universal context,
7918 -- in which case the integer argument must be converted explicitly.
7920 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
7922 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
7924 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
7926 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
7928 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
7930 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
7932 -- Non-fixed point cases, do integer zero divide and overflow checks
7934 elsif Is_Integer_Type
(Typ
) then
7935 Apply_Divide_Checks
(N
);
7938 -- Overflow checks for floating-point if -gnateF mode active
7940 Check_Float_Op_Overflow
(N
);
7942 Expand_Nonbinary_Modular_Op
(N
);
7943 end Expand_N_Op_Divide
;
7945 --------------------
7946 -- Expand_N_Op_Eq --
7947 --------------------
7949 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
7950 Loc
: constant Source_Ptr
:= Sloc
(N
);
7951 Typ
: constant Entity_Id
:= Etype
(N
);
7952 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
7953 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
7954 Bodies
: constant List_Id
:= New_List
;
7955 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
7957 procedure Build_Equality_Call
(Eq
: Entity_Id
);
7958 -- If a constructed equality exists for the type or for its parent,
7959 -- build and analyze call, adding conversions if the operation is
7962 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
;
7963 -- Find a primitive equality function within primitive operation list
7966 function Has_Unconstrained_UU_Component
(Typ
: Entity_Id
) return Boolean;
7967 -- Determines whether a type has a subcomponent of an unconstrained
7968 -- Unchecked_Union subtype. Typ is a record type.
7970 -------------------------
7971 -- Build_Equality_Call --
7972 -------------------------
7974 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
7975 Op_Typ
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
7977 L_Exp
, R_Exp
: Node_Id
;
7980 -- Adjust operands if necessary to comparison type
7982 if Base_Type
(A_Typ
) /= Base_Type
(Op_Typ
)
7983 and then not Is_Class_Wide_Type
(A_Typ
)
7985 L_Exp
:= OK_Convert_To
(Op_Typ
, Lhs
);
7986 R_Exp
:= OK_Convert_To
(Op_Typ
, Rhs
);
7989 L_Exp
:= Relocate_Node
(Lhs
);
7990 R_Exp
:= Relocate_Node
(Rhs
);
7994 Make_Function_Call
(Loc
,
7995 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7996 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7998 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7999 end Build_Equality_Call
;
8005 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
is
8006 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
;
8007 -- Find an equality in a possible alias chain starting from primitive
8010 ---------------------------
8011 -- Find_Aliased_Equality --
8012 ---------------------------
8014 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
is
8018 -- Inspect each candidate in the alias chain, checking whether it
8019 -- denotes an equality.
8022 while Present
(Candid
) loop
8023 if Is_User_Defined_Equality
(Candid
) then
8027 Candid
:= Alias
(Candid
);
8031 end Find_Aliased_Equality
;
8035 Eq_Prim
: Entity_Id
;
8036 Prim_Elmt
: Elmt_Id
;
8038 -- Start of processing for Find_Equality
8041 -- Assume that the tagged type lacks an equality
8045 -- Inspect the list of primitives looking for a suitable equality
8046 -- within a possible chain of aliases.
8048 Prim_Elmt
:= First_Elmt
(Prims
);
8049 while Present
(Prim_Elmt
) and then No
(Eq_Prim
) loop
8050 Eq_Prim
:= Find_Aliased_Equality
(Node
(Prim_Elmt
));
8052 Next_Elmt
(Prim_Elmt
);
8055 -- A tagged type should always have an equality
8057 pragma Assert
(Present
(Eq_Prim
));
8062 ------------------------------------
8063 -- Has_Unconstrained_UU_Component --
8064 ------------------------------------
8066 function Has_Unconstrained_UU_Component
8067 (Typ
: Entity_Id
) return Boolean
8069 function Unconstrained_UU_In_Component_Declaration
8070 (N
: Node_Id
) return Boolean;
8072 function Unconstrained_UU_In_Component_Items
8073 (L
: List_Id
) return Boolean;
8075 function Unconstrained_UU_In_Component_List
8076 (N
: Node_Id
) return Boolean;
8078 function Unconstrained_UU_In_Variant_Part
8079 (N
: Node_Id
) return Boolean;
8080 -- A family of routines that determine whether a particular construct
8081 -- of a record type definition contains a subcomponent of an
8082 -- unchecked union type whose nominal subtype is unconstrained.
8084 -- Individual routines correspond to the production rules of the Ada
8085 -- grammar, as described in the Ada RM (P).
8087 -----------------------------------------------
8088 -- Unconstrained_UU_In_Component_Declaration --
8089 -----------------------------------------------
8091 function Unconstrained_UU_In_Component_Declaration
8092 (N
: Node_Id
) return Boolean
8094 pragma Assert
(Nkind
(N
) = N_Component_Declaration
);
8096 Sindic
: constant Node_Id
:=
8097 Subtype_Indication
(Component_Definition
(N
));
8099 -- If the component declaration includes a subtype indication
8100 -- it is not an unchecked_union. Otherwise verify that it carries
8101 -- the Unchecked_Union flag and is either a record or a private
8102 -- type. A Record_Subtype declared elsewhere does not qualify,
8103 -- even if its parent type carries the flag.
8105 return Nkind
(Sindic
) in N_Expanded_Name | N_Identifier
8106 and then Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)))
8107 and then Ekind
(Entity
(Sindic
)) in
8108 E_Private_Type | E_Record_Type
;
8109 end Unconstrained_UU_In_Component_Declaration
;
8111 -----------------------------------------
8112 -- Unconstrained_UU_In_Component_Items --
8113 -----------------------------------------
8115 function Unconstrained_UU_In_Component_Items
8116 (L
: List_Id
) return Boolean
8118 N
: Node_Id
:= First
(L
);
8120 while Present
(N
) loop
8121 if Nkind
(N
) = N_Component_Declaration
8122 and then Unconstrained_UU_In_Component_Declaration
(N
)
8131 end Unconstrained_UU_In_Component_Items
;
8133 ----------------------------------------
8134 -- Unconstrained_UU_In_Component_List --
8135 ----------------------------------------
8137 function Unconstrained_UU_In_Component_List
8138 (N
: Node_Id
) return Boolean
8140 pragma Assert
(Nkind
(N
) = N_Component_List
);
8142 Optional_Variant_Part
: Node_Id
;
8144 if Unconstrained_UU_In_Component_Items
(Component_Items
(N
)) then
8148 Optional_Variant_Part
:= Variant_Part
(N
);
8151 Present
(Optional_Variant_Part
)
8153 Unconstrained_UU_In_Variant_Part
(Optional_Variant_Part
);
8154 end Unconstrained_UU_In_Component_List
;
8156 --------------------------------------
8157 -- Unconstrained_UU_In_Variant_Part --
8158 --------------------------------------
8160 function Unconstrained_UU_In_Variant_Part
8161 (N
: Node_Id
) return Boolean
8163 pragma Assert
(Nkind
(N
) = N_Variant_Part
);
8165 Variant
: Node_Id
:= First
(Variants
(N
));
8168 if Unconstrained_UU_In_Component_List
(Component_List
(Variant
))
8174 exit when No
(Variant
);
8178 end Unconstrained_UU_In_Variant_Part
;
8180 Typ_Def
: constant Node_Id
:=
8181 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
8183 Optional_Component_List
: constant Node_Id
:=
8184 Component_List
(Typ_Def
);
8186 -- Start of processing for Has_Unconstrained_UU_Component
8189 return Present
(Optional_Component_List
)
8191 Unconstrained_UU_In_Component_List
(Optional_Component_List
);
8192 end Has_Unconstrained_UU_Component
;
8198 -- Start of processing for Expand_N_Op_Eq
8201 Binary_Op_Validity_Checks
(N
);
8203 -- Deal with private types
8205 Typl
:= Underlying_Type
(A_Typ
);
8207 -- It may happen in error situations that the underlying type is not
8208 -- set. The error will be detected later, here we just defend the
8215 -- Now get the implementation base type (note that plain Base_Type here
8216 -- might lead us back to the private type, which is not what we want!)
8218 Typl
:= Implementation_Base_Type
(Typl
);
8220 -- Equality between variant records results in a call to a routine
8221 -- that has conditional tests of the discriminant value(s), and hence
8222 -- violates the No_Implicit_Conditionals restriction.
8224 if Has_Variant_Part
(Typl
) then
8229 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
8233 ("\comparison of variant records tests discriminants", N
);
8239 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8240 -- means we no longer have a comparison operation, we are all done.
8242 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
)) then
8243 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8246 if Nkind
(N
) /= N_Op_Eq
then
8250 -- Boolean types (requiring handling of non-standard case)
8252 if Is_Boolean_Type
(Typl
) then
8253 Adjust_Condition
(Left_Opnd
(N
));
8254 Adjust_Condition
(Right_Opnd
(N
));
8255 Set_Etype
(N
, Standard_Boolean
);
8256 Adjust_Result_Type
(N
, Typ
);
8260 elsif Is_Array_Type
(Typl
) then
8262 -- If we are doing full validity checking, and it is possible for the
8263 -- array elements to be invalid then expand out array comparisons to
8264 -- make sure that we check the array elements.
8266 if Validity_Check_Operands
8267 and then not Is_Known_Valid
(Component_Type
(Typl
))
8270 Save_Force_Validity_Checks
: constant Boolean :=
8271 Force_Validity_Checks
;
8273 Force_Validity_Checks
:= True;
8275 Expand_Array_Equality
8277 Relocate_Node
(Lhs
),
8278 Relocate_Node
(Rhs
),
8281 Insert_Actions
(N
, Bodies
);
8282 Analyze_And_Resolve
(N
, Standard_Boolean
);
8283 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
8286 -- Packed case where both operands are known aligned
8288 elsif Is_Bit_Packed_Array
(Typl
)
8289 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8290 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8292 Expand_Packed_Eq
(N
);
8294 -- Where the component type is elementary we can use a block bit
8295 -- comparison (if supported on the target) exception in the case
8296 -- of floating-point (negative zero issues require element by
8297 -- element comparison), and full access types (where we must be sure
8298 -- to load elements independently) and possibly unaligned arrays.
8300 elsif Is_Elementary_Type
(Component_Type
(Typl
))
8301 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
8302 and then not Is_Full_Access
(Component_Type
(Typl
))
8303 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8304 and then not Is_Possibly_Unaligned_Slice
(Lhs
)
8305 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8306 and then not Is_Possibly_Unaligned_Slice
(Rhs
)
8307 and then Support_Composite_Compare_On_Target
8311 -- For composite and floating-point cases, expand equality loop to
8312 -- make sure of using proper comparisons for tagged types, and
8313 -- correctly handling the floating-point case.
8317 Expand_Array_Equality
8319 Relocate_Node
(Lhs
),
8320 Relocate_Node
(Rhs
),
8323 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8324 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8329 elsif Is_Record_Type
(Typl
) then
8331 -- For tagged types, use the primitive "="
8333 if Is_Tagged_Type
(Typl
) then
8335 -- No need to do anything else compiling under restriction
8336 -- No_Dispatching_Calls. During the semantic analysis we
8337 -- already notified such violation.
8339 if Restriction_Active
(No_Dispatching_Calls
) then
8343 -- If this is an untagged private type completed with a derivation
8344 -- of an untagged private type whose full view is a tagged type,
8345 -- we use the primitive operations of the private type (since it
8346 -- does not have a full view, and also because its equality
8347 -- primitive may have been overridden in its untagged full view).
8349 if Inherits_From_Tagged_Full_View
(A_Typ
) then
8351 (Find_Equality
(Collect_Primitive_Operations
(A_Typ
)));
8353 -- Find the type's predefined equality or an overriding
8354 -- user-defined equality. The reason for not simply calling
8355 -- Find_Prim_Op here is that there may be a user-defined
8356 -- overloaded equality op that precedes the equality that we
8357 -- want, so we have to explicitly search (e.g., there could be
8358 -- an equality with two different parameter types).
8361 if Is_Class_Wide_Type
(Typl
) then
8362 Typl
:= Find_Specific_Type
(Typl
);
8366 (Find_Equality
(Primitive_Operations
(Typl
)));
8369 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8370 -- predefined equality operator for a type which has a subcomponent
8371 -- of an unchecked union type whose nominal subtype is unconstrained.
8373 elsif Has_Unconstrained_UU_Component
(Typl
) then
8375 Make_Raise_Program_Error
(Loc
,
8376 Reason
=> PE_Unchecked_Union_Restriction
));
8379 New_Occurrence_Of
(Standard_False
, Loc
));
8381 -- If a type support function is present, e.g. if there is a variant
8382 -- part, including an unchecked union type, use it.
8384 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
8386 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8388 -- When comparing two Bounded_Strings, use the primitive equality of
8389 -- the root Super_String type.
8391 elsif Is_Bounded_String
(Typl
) then
8394 (Collect_Primitive_Operations
(Root_Type
(Typl
))));
8396 -- Otherwise expand the component by component equality. Note that
8397 -- we never use block-bit comparisons for records, because of the
8398 -- problems with gaps. The back end will often be able to recombine
8399 -- the separate comparisons that we generate here.
8402 Remove_Side_Effects
(Lhs
);
8403 Remove_Side_Effects
(Rhs
);
8404 Rewrite
(N
, Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
));
8406 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8409 -- If unnesting, handle elementary types whose Equivalent_Types are
8410 -- records because there may be padding or undefined fields.
8412 elsif Unnest_Subprogram_Mode
8413 and then Ekind
(Typl
) in E_Class_Wide_Type
8414 | E_Class_Wide_Subtype
8415 | E_Access_Subprogram_Type
8416 | E_Access_Protected_Subprogram_Type
8417 | E_Anonymous_Access_Protected_Subprogram_Type
8419 and then Present
(Equivalent_Type
(Typl
))
8420 and then Is_Record_Type
(Equivalent_Type
(Typl
))
8422 Typl
:= Equivalent_Type
(Typl
);
8423 Remove_Side_Effects
(Lhs
);
8424 Remove_Side_Effects
(Rhs
);
8426 Expand_Record_Equality
(N
, Typl
,
8427 Unchecked_Convert_To
(Typl
, Lhs
),
8428 Unchecked_Convert_To
(Typl
, Rhs
)));
8430 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8433 -- Test if result is known at compile time
8435 Rewrite_Comparison
(N
);
8437 -- Try to narrow the operation
8439 if Typl
= Universal_Integer
and then Nkind
(N
) = N_Op_Eq
then
8440 Narrow_Large_Operation
(N
);
8443 -- Special optimization of length comparison
8445 Optimize_Length_Comparison
(N
);
8447 -- One more special case: if we have a comparison of X'Result = expr
8448 -- in floating-point, then if not already there, change expr to be
8449 -- f'Machine (expr) to eliminate surprise from extra precision.
8451 if Is_Floating_Point_Type
(Typl
)
8452 and then Is_Attribute_Result
(Original_Node
(Lhs
))
8454 -- Stick in the Typ'Machine call if not already there
8456 if Nkind
(Rhs
) /= N_Attribute_Reference
8457 or else Attribute_Name
(Rhs
) /= Name_Machine
8460 Make_Attribute_Reference
(Loc
,
8461 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
8462 Attribute_Name
=> Name_Machine
,
8463 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
8464 Analyze_And_Resolve
(Rhs
, Typl
);
8469 -----------------------
8470 -- Expand_N_Op_Expon --
8471 -----------------------
8473 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
8474 Loc
: constant Source_Ptr
:= Sloc
(N
);
8475 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
8476 Typ
: constant Entity_Id
:= Etype
(N
);
8477 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
8481 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
8482 -- Given an expression Exp, if the root type is Float or Long_Float,
8483 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8484 -- extra precision. This is done to ensure that X**A = X**B when A is
8485 -- a static constant and B is a variable with the same value. For any
8486 -- other type, the node Exp is returned unchanged.
8492 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
8493 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
8496 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
8498 Make_Attribute_Reference
(Loc
,
8499 Attribute_Name
=> Name_Machine
,
8500 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
8501 Expressions
=> New_List
(Relocate_Node
(Exp
)));
8519 -- Start of processing for Expand_N_Op_Expon
8522 Binary_Op_Validity_Checks
(N
);
8524 -- CodePeer wants to see the unexpanded N_Op_Expon node
8526 if CodePeer_Mode
then
8530 -- Relocation of left and right operands must be done after performing
8531 -- the validity checks since the generation of validation checks may
8532 -- remove side effects.
8534 Base
:= Relocate_Node
(Left_Opnd
(N
));
8535 Bastyp
:= Etype
(Base
);
8536 Exp
:= Relocate_Node
(Right_Opnd
(N
));
8537 Exptyp
:= Etype
(Exp
);
8539 -- If either operand is of a private type, then we have the use of an
8540 -- intrinsic operator, and we get rid of the privateness, by using root
8541 -- types of underlying types for the actual operation. Otherwise the
8542 -- private types will cause trouble if we expand multiplications or
8543 -- shifts etc. We also do this transformation if the result type is
8544 -- different from the base type.
8546 if Is_Private_Type
(Etype
(Base
))
8547 or else Is_Private_Type
(Typ
)
8548 or else Is_Private_Type
(Exptyp
)
8549 or else Rtyp
/= Root_Type
(Bastyp
)
8552 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
8553 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
8556 Unchecked_Convert_To
(Typ
,
8558 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
8559 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
8560 Analyze_And_Resolve
(N
, Typ
);
8565 -- Check for MINIMIZED/ELIMINATED overflow mode
8567 if Minimized_Eliminated_Overflow_Check
(N
) then
8568 Apply_Arithmetic_Overflow_Check
(N
);
8572 -- Test for case of known right argument where we can replace the
8573 -- exponentiation by an equivalent expression using multiplication.
8575 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8576 -- configurable run-time mode, we may not have the exponentiation
8577 -- routine available, and we don't want the legality of the program
8578 -- to depend on how clever the compiler is in knowing values.
8580 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
8581 Expv
:= Expr_Value
(Exp
);
8583 -- We only fold small non-negative exponents. You might think we
8584 -- could fold small negative exponents for the real case, but we
8585 -- can't because we are required to raise Constraint_Error for
8586 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8587 -- See ACVC test C4A012B, and it is not worth generating the test.
8589 -- For small negative exponents, we return the reciprocal of
8590 -- the folding of the exponentiation for the opposite (positive)
8591 -- exponent, as required by Ada RM 4.5.6(11/3).
8593 if abs Expv
<= 4 then
8595 -- X ** 0 = 1 (or 1.0)
8599 -- Call Remove_Side_Effects to ensure that any side effects
8600 -- in the ignored left operand (in particular function calls
8601 -- to user defined functions) are properly executed.
8603 Remove_Side_Effects
(Base
);
8605 if Ekind
(Typ
) in Integer_Kind
then
8606 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
8608 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
8621 Make_Op_Multiply
(Loc
,
8622 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8623 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8625 -- X ** 3 = X * X * X
8630 Make_Op_Multiply
(Loc
,
8632 Make_Op_Multiply
(Loc
,
8633 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8634 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
8635 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8640 -- En : constant base'type := base * base;
8645 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
8648 Make_Expression_With_Actions
(Loc
,
8649 Actions
=> New_List
(
8650 Make_Object_Declaration
(Loc
,
8651 Defining_Identifier
=> Temp
,
8652 Constant_Present
=> True,
8653 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8656 Make_Op_Multiply
(Loc
,
8658 Duplicate_Subexpr
(Base
),
8660 Duplicate_Subexpr_No_Checks
(Base
))))),
8664 Make_Op_Multiply
(Loc
,
8665 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
8666 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
8668 -- X ** N = 1.0 / X ** (-N)
8673 (Expv
= -1 or Expv
= -2 or Expv
= -3 or Expv
= -4);
8676 Make_Op_Divide
(Loc
,
8678 Make_Float_Literal
(Loc
,
8680 Significand
=> Uint_1
,
8681 Exponent
=> Uint_0
),
8684 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8686 Make_Integer_Literal
(Loc
,
8691 Analyze_And_Resolve
(N
, Typ
);
8696 -- Optimize 2 ** expression to shift where possible
8698 -- Note: we used to check that Exptyp was an unsigned type. But that is
8699 -- an unnecessary check, since if Exp is negative, we have a run-time
8700 -- error that is either caught (so we get the right result) or we have
8701 -- suppressed the check, in which case the code is erroneous anyway.
8703 if Is_Integer_Type
(Rtyp
)
8705 -- The base value must be "safe compile-time known", and exactly 2
8707 and then Nkind
(Base
) = N_Integer_Literal
8708 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
8709 and then Expr_Value
(Base
) = Uint_2
8711 -- This transformation is not applicable for a modular type with a
8712 -- nonbinary modulus because shifting makes no sense in that case.
8714 and then not Non_Binary_Modulus
(Typ
)
8716 -- Handle the cases where our parent is a division or multiplication
8717 -- specially. In these cases we can convert to using a shift at the
8718 -- parent level if we are not doing overflow checking, since it is
8719 -- too tricky to combine the overflow check at the parent level.
8722 and then Nkind
(Parent
(N
)) in N_Op_Divide | N_Op_Multiply
8725 P
: constant Node_Id
:= Parent
(N
);
8726 L
: constant Node_Id
:= Left_Opnd
(P
);
8727 R
: constant Node_Id
:= Right_Opnd
(P
);
8730 if (Nkind
(P
) = N_Op_Multiply
8732 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
8734 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
8735 and then not Do_Overflow_Check
(P
))
8738 (Nkind
(P
) = N_Op_Divide
8739 and then Is_Integer_Type
(Etype
(L
))
8740 and then Is_Unsigned_Type
(Etype
(L
))
8742 and then not Do_Overflow_Check
(P
))
8744 Set_Is_Power_Of_2_For_Shift
(N
);
8749 -- Here we have 2 ** N on its own, so we can convert this into a
8753 -- Op_Shift_Left (generated below) has modular-shift semantics;
8754 -- therefore we might need to generate an overflow check here
8755 -- if the type is signed.
8757 if Is_Signed_Integer_Type
(Typ
) and then Ovflo
then
8763 MaxS
: constant Uint
:= Esize
(Rtyp
) - 2;
8764 -- Maximum shift count with no overflow
8766 Determine_Range
(Exp
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8768 if not OK
or else Hi
> MaxS
then
8770 Make_Raise_Constraint_Error
(Loc
,
8773 Left_Opnd
=> Duplicate_Subexpr
(Exp
),
8774 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
8775 Reason
=> CE_Overflow_Check_Failed
));
8780 -- Generate Shift_Left (1, Exp)
8783 Make_Op_Shift_Left
(Loc
,
8784 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8785 Right_Opnd
=> Exp
));
8787 Analyze_And_Resolve
(N
, Typ
);
8792 -- Fall through if exponentiation must be done using a runtime routine
8794 -- First deal with modular case
8796 if Is_Modular_Integer_Type
(Rtyp
) then
8798 -- Nonbinary modular case, we call the special exponentiation
8799 -- routine for the nonbinary case, converting the argument to
8800 -- Long_Long_Integer and passing the modulus value. Then the
8801 -- result is converted back to the base type.
8803 if Non_Binary_Modulus
(Rtyp
) then
8806 Make_Function_Call
(Loc
,
8808 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
8809 Parameter_Associations
=> New_List
(
8810 Convert_To
(RTE
(RE_Unsigned
), Base
),
8811 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
8814 -- Binary modular case, in this case, we call one of three routines,
8815 -- either the unsigned integer case, or the unsigned long long
8816 -- integer case, or the unsigned long long long integer case, with a
8817 -- final "and" operation to do the required mod.
8820 if Esize
(Rtyp
) <= Standard_Integer_Size
then
8821 Ent
:= RTE
(RE_Exp_Unsigned
);
8822 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
8823 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
8825 Ent
:= RTE
(RE_Exp_Long_Long_Long_Unsigned
);
8832 Make_Function_Call
(Loc
,
8833 Name
=> New_Occurrence_Of
(Ent
, Loc
),
8834 Parameter_Associations
=> New_List
(
8835 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
8838 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
8842 -- Common exit point for modular type case
8844 Analyze_And_Resolve
(N
, Typ
);
8847 -- Signed integer cases, using either Integer, Long_Long_Integer or
8848 -- Long_Long_Long_Integer. It is not worth also having routines for
8849 -- Short_[Short_]Integer, since for most machines it would not help,
8850 -- and it would generate more code that might need certification when
8851 -- a certified run time is required.
8853 -- In the integer cases, we have two routines, one for when overflow
8854 -- checks are required, and one when they are not required, since there
8855 -- is a real gain in omitting checks on many machines.
8857 elsif Is_Signed_Integer_Type
(Rtyp
) then
8858 if Esize
(Rtyp
) <= Standard_Integer_Size
then
8859 Etyp
:= Standard_Integer
;
8862 Rent
:= RE_Exp_Integer
;
8864 Rent
:= RE_Exn_Integer
;
8867 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
8868 Etyp
:= Standard_Long_Long_Integer
;
8871 Rent
:= RE_Exp_Long_Long_Integer
;
8873 Rent
:= RE_Exn_Long_Long_Integer
;
8877 Etyp
:= Standard_Long_Long_Long_Integer
;
8880 Rent
:= RE_Exp_Long_Long_Long_Integer
;
8882 Rent
:= RE_Exn_Long_Long_Long_Integer
;
8886 -- Floating-point cases. We do not need separate routines for the
8887 -- overflow case here, since in the case of floating-point, we generate
8888 -- infinities anyway as a rule (either that or we automatically trap
8889 -- overflow), and if there is an infinity generated and a range check
8890 -- is required, the check will fail anyway.
8893 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
8895 -- Short_Float and Float are the same type for GNAT
8897 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
8898 Etyp
:= Standard_Float
;
8899 Rent
:= RE_Exn_Float
;
8901 elsif Rtyp
= Standard_Long_Float
then
8902 Etyp
:= Standard_Long_Float
;
8903 Rent
:= RE_Exn_Long_Float
;
8906 Etyp
:= Standard_Long_Long_Float
;
8907 Rent
:= RE_Exn_Long_Long_Float
;
8911 -- Common processing for integer cases and floating-point cases.
8912 -- If we are in the right type, we can call runtime routine directly
8915 and then not Is_Universal_Numeric_Type
(Rtyp
)
8919 Make_Function_Call
(Loc
,
8920 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8921 Parameter_Associations
=> New_List
(Base
, Exp
))));
8923 -- Otherwise we have to introduce conversions (conversions are also
8924 -- required in the universal cases, since the runtime routine is
8925 -- typed using one of the standard types).
8930 Make_Function_Call
(Loc
,
8931 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8932 Parameter_Associations
=> New_List
(
8933 Convert_To
(Etyp
, Base
),
8937 Analyze_And_Resolve
(N
, Typ
);
8941 when RE_Not_Available
=>
8943 end Expand_N_Op_Expon
;
8945 --------------------
8946 -- Expand_N_Op_Ge --
8947 --------------------
8949 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
8950 Typ
: constant Entity_Id
:= Etype
(N
);
8951 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8952 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8953 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8956 Binary_Op_Validity_Checks
(N
);
8958 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8959 -- means we no longer have a comparison operation, we are all done.
8961 if Minimized_Eliminated_Overflow_Check
(Op1
) then
8962 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8965 if Nkind
(N
) /= N_Op_Ge
then
8971 if Is_Array_Type
(Typ1
) then
8972 Expand_Array_Comparison
(N
);
8976 -- Deal with boolean operands
8978 if Is_Boolean_Type
(Typ1
) then
8979 Adjust_Condition
(Op1
);
8980 Adjust_Condition
(Op2
);
8981 Set_Etype
(N
, Standard_Boolean
);
8982 Adjust_Result_Type
(N
, Typ
);
8985 Rewrite_Comparison
(N
);
8987 -- Try to narrow the operation
8989 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Ge
then
8990 Narrow_Large_Operation
(N
);
8993 Optimize_Length_Comparison
(N
);
8996 --------------------
8997 -- Expand_N_Op_Gt --
8998 --------------------
9000 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
9001 Typ
: constant Entity_Id
:= Etype
(N
);
9002 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9003 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9004 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9007 Binary_Op_Validity_Checks
(N
);
9009 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9010 -- means we no longer have a comparison operation, we are all done.
9012 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9013 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9016 if Nkind
(N
) /= N_Op_Gt
then
9020 -- Deal with array type operands
9022 if Is_Array_Type
(Typ1
) then
9023 Expand_Array_Comparison
(N
);
9027 -- Deal with boolean type operands
9029 if Is_Boolean_Type
(Typ1
) then
9030 Adjust_Condition
(Op1
);
9031 Adjust_Condition
(Op2
);
9032 Set_Etype
(N
, Standard_Boolean
);
9033 Adjust_Result_Type
(N
, Typ
);
9036 Rewrite_Comparison
(N
);
9038 -- Try to narrow the operation
9040 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Gt
then
9041 Narrow_Large_Operation
(N
);
9044 Optimize_Length_Comparison
(N
);
9047 --------------------
9048 -- Expand_N_Op_Le --
9049 --------------------
9051 procedure Expand_N_Op_Le
(N
: Node_Id
) is
9052 Typ
: constant Entity_Id
:= Etype
(N
);
9053 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9054 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9055 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9058 Binary_Op_Validity_Checks
(N
);
9060 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9061 -- means we no longer have a comparison operation, we are all done.
9063 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9064 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9067 if Nkind
(N
) /= N_Op_Le
then
9071 -- Deal with array type operands
9073 if Is_Array_Type
(Typ1
) then
9074 Expand_Array_Comparison
(N
);
9078 -- Deal with Boolean type operands
9080 if Is_Boolean_Type
(Typ1
) then
9081 Adjust_Condition
(Op1
);
9082 Adjust_Condition
(Op2
);
9083 Set_Etype
(N
, Standard_Boolean
);
9084 Adjust_Result_Type
(N
, Typ
);
9087 Rewrite_Comparison
(N
);
9089 -- Try to narrow the operation
9091 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Le
then
9092 Narrow_Large_Operation
(N
);
9095 Optimize_Length_Comparison
(N
);
9098 --------------------
9099 -- Expand_N_Op_Lt --
9100 --------------------
9102 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
9103 Typ
: constant Entity_Id
:= Etype
(N
);
9104 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9105 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9106 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9109 Binary_Op_Validity_Checks
(N
);
9111 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9112 -- means we no longer have a comparison operation, we are all done.
9114 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9115 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9118 if Nkind
(N
) /= N_Op_Lt
then
9122 -- Deal with array type operands
9124 if Is_Array_Type
(Typ1
) then
9125 Expand_Array_Comparison
(N
);
9129 -- Deal with Boolean type operands
9131 if Is_Boolean_Type
(Typ1
) then
9132 Adjust_Condition
(Op1
);
9133 Adjust_Condition
(Op2
);
9134 Set_Etype
(N
, Standard_Boolean
);
9135 Adjust_Result_Type
(N
, Typ
);
9138 Rewrite_Comparison
(N
);
9140 -- Try to narrow the operation
9142 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Lt
then
9143 Narrow_Large_Operation
(N
);
9146 Optimize_Length_Comparison
(N
);
9149 -----------------------
9150 -- Expand_N_Op_Minus --
9151 -----------------------
9153 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
9154 Loc
: constant Source_Ptr
:= Sloc
(N
);
9155 Typ
: constant Entity_Id
:= Etype
(N
);
9158 Unary_Op_Validity_Checks
(N
);
9160 -- Check for MINIMIZED/ELIMINATED overflow mode
9162 if Minimized_Eliminated_Overflow_Check
(N
) then
9163 Apply_Arithmetic_Overflow_Check
(N
);
9167 -- Try to narrow the operation
9169 if Typ
= Universal_Integer
then
9170 Narrow_Large_Operation
(N
);
9172 if Nkind
(N
) /= N_Op_Minus
then
9177 if not Backend_Overflow_Checks_On_Target
9178 and then Is_Signed_Integer_Type
(Typ
)
9179 and then Do_Overflow_Check
(N
)
9181 -- Software overflow checking expands -expr into (0 - expr)
9184 Make_Op_Subtract
(Loc
,
9185 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
9186 Right_Opnd
=> Right_Opnd
(N
)));
9188 Analyze_And_Resolve
(N
, Typ
);
9191 Expand_Nonbinary_Modular_Op
(N
);
9192 end Expand_N_Op_Minus
;
9194 ---------------------
9195 -- Expand_N_Op_Mod --
9196 ---------------------
9198 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
9199 Loc
: constant Source_Ptr
:= Sloc
(N
);
9200 Typ
: constant Entity_Id
:= Etype
(N
);
9201 DDC
: constant Boolean := Do_Division_Check
(N
);
9203 Is_Stoele_Mod
: constant Boolean :=
9204 Is_RTE
(Typ
, RE_Address
)
9205 and then Nkind
(Right_Opnd
(N
)) = N_Unchecked_Type_Conversion
9207 Is_RTE
(Etype
(Expression
(Right_Opnd
(N
))), RE_Storage_Offset
);
9208 -- True if this is the special mod operator of System.Storage_Elements
9221 pragma Warnings
(Off
, Lhi
);
9224 Binary_Op_Validity_Checks
(N
);
9226 -- Check for MINIMIZED/ELIMINATED overflow mode
9228 if Minimized_Eliminated_Overflow_Check
(N
) then
9229 Apply_Arithmetic_Overflow_Check
(N
);
9233 -- Try to narrow the operation
9235 if Typ
= Universal_Integer
then
9236 Narrow_Large_Operation
(N
);
9238 if Nkind
(N
) /= N_Op_Mod
then
9243 -- For the special mod operator of System.Storage_Elements, the checks
9244 -- are subsumed into the handling of the negative case below.
9246 if Is_Integer_Type
(Typ
) and then not Is_Stoele_Mod
then
9247 Apply_Divide_Checks
(N
);
9249 -- All done if we don't have a MOD any more, which can happen as a
9250 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9252 if Nkind
(N
) /= N_Op_Mod
then
9257 -- Proceed with expansion of mod operator
9259 Left
:= Left_Opnd
(N
);
9260 Right
:= Right_Opnd
(N
);
9262 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
9263 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
9265 -- Convert mod to rem if operands are both known to be non-negative, or
9266 -- both known to be non-positive (these are the cases in which rem and
9267 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9268 -- likely that this will improve the quality of code, (the operation now
9269 -- corresponds to the hardware remainder), and it does not seem likely
9270 -- that it could be harmful. It also avoids some cases of the elaborate
9271 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9274 and then ((Llo
>= 0 and then Rlo
>= 0)
9276 (Lhi
<= 0 and then Rhi
<= 0))
9277 and then not Is_Stoele_Mod
9280 Make_Op_Rem
(Sloc
(N
),
9281 Left_Opnd
=> Left_Opnd
(N
),
9282 Right_Opnd
=> Right_Opnd
(N
)));
9284 -- Instead of reanalyzing the node we do the analysis manually. This
9285 -- avoids anomalies when the replacement is done in an instance and
9286 -- is epsilon more efficient.
9288 pragma Assert
(Entity
(N
) = Standard_Op_Rem
);
9290 Set_Do_Division_Check
(N
, DDC
);
9291 Expand_N_Op_Rem
(N
);
9295 -- Otherwise, normal mod processing
9298 -- Apply optimization x mod 1 = 0. We don't really need that with
9299 -- gcc, but it is useful with other back ends and is certainly
9302 if Is_Integer_Type
(Etype
(N
))
9303 and then Compile_Time_Known_Value
(Right
)
9304 and then Expr_Value
(Right
) = Uint_1
9306 -- Call Remove_Side_Effects to ensure that any side effects in
9307 -- the ignored left operand (in particular function calls to
9308 -- user defined functions) are properly executed.
9310 Remove_Side_Effects
(Left
);
9312 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9313 Analyze_And_Resolve
(N
, Typ
);
9317 -- The negative case makes no sense since it is a case of a mod where
9318 -- the left argument is unsigned and the right argument is signed. In
9319 -- accordance with the (spirit of the) permission of RM 13.7.1(16),
9320 -- we raise CE, and also include the zero case here. Yes, the RM says
9321 -- PE, but this really is so obviously more like a constraint error.
9323 if Is_Stoele_Mod
and then (not ROK
or else Rlo
<= 0) then
9325 Make_Raise_Constraint_Error
(Loc
,
9329 Duplicate_Subexpr_No_Checks
(Expression
(Right
)),
9330 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9331 Reason
=> CE_Overflow_Check_Failed
));
9335 -- If we still have a mod operator and we are in Modify_Tree_For_C
9336 -- mode, and we have a signed integer type, then here is where we do
9337 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9338 -- for the special handling of the annoying case of largest negative
9339 -- number mod minus one.
9341 if Nkind
(N
) = N_Op_Mod
9342 and then Is_Signed_Integer_Type
(Typ
)
9343 and then Modify_Tree_For_C
9345 -- In the general case, we expand A mod B as
9347 -- Tnn : constant typ := A rem B;
9349 -- (if (A >= 0) = (B >= 0) then Tnn
9350 -- elsif Tnn = 0 then 0
9353 -- The comparison can be written simply as A >= 0 if we know that
9354 -- B >= 0 which is a very common case.
9356 -- An important optimization is when B is known at compile time
9357 -- to be 2**K for some constant. In this case we can simply AND
9358 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9359 -- and that works for both the positive and negative cases.
9362 P2
: constant Nat
:= Power_Of_Two
(Right
);
9367 Unchecked_Convert_To
(Typ
,
9370 Unchecked_Convert_To
9371 (Corresponding_Unsigned_Type
(Typ
), Left
),
9373 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
9374 Analyze_And_Resolve
(N
, Typ
);
9379 -- Here for the full rewrite
9382 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
9388 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9389 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
9391 if not LOK
or else Rlo
< 0 then
9397 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
9398 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
9402 Make_Object_Declaration
(Loc
,
9403 Defining_Identifier
=> Tnn
,
9404 Constant_Present
=> True,
9405 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9409 Right_Opnd
=> Right
)));
9412 Make_If_Expression
(Loc
,
9413 Expressions
=> New_List
(
9415 New_Occurrence_Of
(Tnn
, Loc
),
9416 Make_If_Expression
(Loc
,
9418 Expressions
=> New_List
(
9420 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9421 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9422 Make_Integer_Literal
(Loc
, 0),
9424 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9426 Duplicate_Subexpr_No_Checks
(Right
)))))));
9428 Analyze_And_Resolve
(N
, Typ
);
9433 -- Deal with annoying case of largest negative number mod minus one.
9434 -- Gigi may not handle this case correctly, because on some targets,
9435 -- the mod value is computed using a divide instruction which gives
9436 -- an overflow trap for this case.
9438 -- It would be a bit more efficient to figure out which targets
9439 -- this is really needed for, but in practice it is reasonable
9440 -- to do the following special check in all cases, since it means
9441 -- we get a clearer message, and also the overhead is minimal given
9442 -- that division is expensive in any case.
9444 -- In fact the check is quite easy, if the right operand is -1, then
9445 -- the mod value is always 0, and we can just ignore the left operand
9446 -- completely in this case.
9448 -- This only applies if we still have a mod operator. Skip if we
9449 -- have already rewritten this (e.g. in the case of eliminated
9450 -- overflow checks which have driven us into bignum mode).
9452 if Nkind
(N
) = N_Op_Mod
then
9454 -- The operand type may be private (e.g. in the expansion of an
9455 -- intrinsic operation) so we must use the underlying type to get
9456 -- the bounds, and convert the literals explicitly.
9460 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
9462 if (not ROK
or else (Rlo
<= (-1) and then (-1) <= Rhi
))
9463 and then (not LOK
or else Llo
= LLB
)
9464 and then not CodePeer_Mode
9467 Make_If_Expression
(Loc
,
9468 Expressions
=> New_List
(
9470 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9472 Unchecked_Convert_To
(Typ
,
9473 Make_Integer_Literal
(Loc
, -1))),
9474 Unchecked_Convert_To
(Typ
,
9475 Make_Integer_Literal
(Loc
, Uint_0
)),
9476 Relocate_Node
(N
))));
9478 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9479 Analyze_And_Resolve
(N
, Typ
);
9483 end Expand_N_Op_Mod
;
9485 --------------------------
9486 -- Expand_N_Op_Multiply --
9487 --------------------------
9489 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
9490 Loc
: constant Source_Ptr
:= Sloc
(N
);
9491 Lop
: constant Node_Id
:= Left_Opnd
(N
);
9492 Rop
: constant Node_Id
:= Right_Opnd
(N
);
9494 Lp2
: constant Boolean :=
9495 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
9496 Rp2
: constant Boolean :=
9497 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
9499 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
9500 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
9501 Typ
: Entity_Id
:= Etype
(N
);
9504 Binary_Op_Validity_Checks
(N
);
9506 -- Check for MINIMIZED/ELIMINATED overflow mode
9508 if Minimized_Eliminated_Overflow_Check
(N
) then
9509 Apply_Arithmetic_Overflow_Check
(N
);
9513 -- Special optimizations for integer types
9515 if Is_Integer_Type
(Typ
) then
9517 -- N * 0 = 0 for integer types
9519 if Compile_Time_Known_Value
(Rop
)
9520 and then Expr_Value
(Rop
) = Uint_0
9522 -- Call Remove_Side_Effects to ensure that any side effects in
9523 -- the ignored left operand (in particular function calls to
9524 -- user defined functions) are properly executed.
9526 Remove_Side_Effects
(Lop
);
9528 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9529 Analyze_And_Resolve
(N
, Typ
);
9533 -- Similar handling for 0 * N = 0
9535 if Compile_Time_Known_Value
(Lop
)
9536 and then Expr_Value
(Lop
) = Uint_0
9538 Remove_Side_Effects
(Rop
);
9539 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9540 Analyze_And_Resolve
(N
, Typ
);
9544 -- N * 1 = 1 * N = N for integer types
9546 -- This optimisation is not done if we are going to
9547 -- rewrite the product 1 * 2 ** N to a shift.
9549 if Compile_Time_Known_Value
(Rop
)
9550 and then Expr_Value
(Rop
) = Uint_1
9556 elsif Compile_Time_Known_Value
(Lop
)
9557 and then Expr_Value
(Lop
) = Uint_1
9565 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9566 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9567 -- operand is an integer, as required for this to work.
9572 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9576 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
9579 Left_Opnd
=> Right_Opnd
(Lop
),
9580 Right_Opnd
=> Right_Opnd
(Rop
))));
9581 Analyze_And_Resolve
(N
, Typ
);
9585 -- If the result is modular, perform the reduction of the result
9588 if Is_Modular_Integer_Type
(Typ
)
9589 and then not Non_Binary_Modulus
(Typ
)
9594 Make_Op_Shift_Left
(Loc
,
9597 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
9599 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9603 Make_Op_Shift_Left
(Loc
,
9606 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
9609 Analyze_And_Resolve
(N
, Typ
);
9613 -- Same processing for the operands the other way round
9616 if Is_Modular_Integer_Type
(Typ
)
9617 and then not Non_Binary_Modulus
(Typ
)
9622 Make_Op_Shift_Left
(Loc
,
9625 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
9627 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9631 Make_Op_Shift_Left
(Loc
,
9634 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
9637 Analyze_And_Resolve
(N
, Typ
);
9641 -- Try to narrow the operation
9643 if Typ
= Universal_Integer
then
9644 Narrow_Large_Operation
(N
);
9646 if Nkind
(N
) /= N_Op_Multiply
then
9651 -- Do required fixup of universal fixed operation
9653 if Typ
= Universal_Fixed
then
9654 Fixup_Universal_Fixed_Operation
(N
);
9658 -- Multiplications with fixed-point results
9660 if Is_Fixed_Point_Type
(Typ
) then
9662 -- Case of fixed * integer => fixed
9664 if Is_Integer_Type
(Rtyp
) then
9665 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
9667 -- Case of integer * fixed => fixed
9669 elsif Is_Integer_Type
(Ltyp
) then
9670 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
9672 -- Case of fixed * fixed => fixed
9675 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
9678 -- Other cases of multiplication of fixed-point operands
9680 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
9681 if Is_Integer_Type
(Typ
) then
9682 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
9684 pragma Assert
(Is_Floating_Point_Type
(Typ
));
9685 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
9688 -- Mixed-mode operations can appear in a non-static universal context,
9689 -- in which case the integer argument must be converted explicitly.
9691 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
9692 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
9693 Analyze_And_Resolve
(Rop
, Universal_Real
);
9695 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
9696 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
9697 Analyze_And_Resolve
(Lop
, Universal_Real
);
9699 -- Non-fixed point cases, check software overflow checking required
9701 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
9702 Apply_Arithmetic_Overflow_Check
(N
);
9705 -- Overflow checks for floating-point if -gnateF mode active
9707 Check_Float_Op_Overflow
(N
);
9709 Expand_Nonbinary_Modular_Op
(N
);
9710 end Expand_N_Op_Multiply
;
9712 --------------------
9713 -- Expand_N_Op_Ne --
9714 --------------------
9716 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
9717 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
9720 -- Case of elementary type with standard operator. But if unnesting,
9721 -- handle elementary types whose Equivalent_Types are records because
9722 -- there may be padding or undefined fields.
9724 if Is_Elementary_Type
(Typ
)
9725 and then Sloc
(Entity
(N
)) = Standard_Location
9726 and then not (Ekind
(Typ
) in E_Class_Wide_Type
9727 | E_Class_Wide_Subtype
9728 | E_Access_Subprogram_Type
9729 | E_Access_Protected_Subprogram_Type
9730 | E_Anonymous_Access_Protected_Subprogram_Type
9732 and then Present
(Equivalent_Type
(Typ
))
9733 and then Is_Record_Type
(Equivalent_Type
(Typ
)))
9735 Binary_Op_Validity_Checks
(N
);
9737 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9738 -- means we no longer have a /= operation, we are all done.
9740 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
)) then
9741 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9744 if Nkind
(N
) /= N_Op_Ne
then
9748 -- Boolean types (requiring handling of non-standard case)
9750 if Is_Boolean_Type
(Typ
) then
9751 Adjust_Condition
(Left_Opnd
(N
));
9752 Adjust_Condition
(Right_Opnd
(N
));
9753 Set_Etype
(N
, Standard_Boolean
);
9754 Adjust_Result_Type
(N
, Typ
);
9757 Rewrite_Comparison
(N
);
9759 -- Try to narrow the operation
9761 if Typ
= Universal_Integer
and then Nkind
(N
) = N_Op_Ne
then
9762 Narrow_Large_Operation
(N
);
9765 -- For all cases other than elementary types, we rewrite node as the
9766 -- negation of an equality operation, and reanalyze. The equality to be
9767 -- used is defined in the same scope and has the same signature. This
9768 -- signature must be set explicitly since in an instance it may not have
9769 -- the same visibility as in the generic unit. This avoids duplicating
9770 -- or factoring the complex code for record/array equality tests etc.
9772 -- This case is also used for the minimal expansion performed in
9777 Loc
: constant Source_Ptr
:= Sloc
(N
);
9779 Ne
: constant Entity_Id
:= Entity
(N
);
9782 Binary_Op_Validity_Checks
(N
);
9788 Left_Opnd
=> Left_Opnd
(N
),
9789 Right_Opnd
=> Right_Opnd
(N
)));
9791 if Scope
(Ne
) /= Standard_Standard
then
9792 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
9795 -- For navigation purposes, we want to treat the inequality as an
9796 -- implicit reference to the corresponding equality. Preserve the
9797 -- Comes_From_ source flag to generate proper Xref entries.
9799 Preserve_Comes_From_Source
(Neg
, N
);
9800 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
9802 Analyze_And_Resolve
(N
, Standard_Boolean
);
9806 -- No need for optimization in GNATprove mode, where we would rather see
9807 -- the original source expression.
9809 if not GNATprove_Mode
then
9810 Optimize_Length_Comparison
(N
);
9814 ---------------------
9815 -- Expand_N_Op_Not --
9816 ---------------------
9818 -- If the argument is other than a Boolean array type, there is no special
9819 -- expansion required, except for dealing with validity checks, and non-
9820 -- standard boolean representations.
9822 -- For the packed array case, we call the special routine in Exp_Pakd,
9823 -- except that if the component size is greater than one, we use the
9824 -- standard routine generating a gruesome loop (it is so peculiar to have
9825 -- packed arrays with non-standard Boolean representations anyway, so it
9826 -- does not matter that we do not handle this case efficiently).
9828 -- For the unpacked array case (and for the special packed case where we
9829 -- have non standard Booleans, as discussed above), we generate and insert
9830 -- into the tree the following function definition:
9832 -- function Nnnn (A : arr) is
9835 -- for J in a'range loop
9836 -- B (J) := not A (J);
9841 -- or in the case of Transform_Function_Array:
9843 -- procedure Nnnn (A : arr; RESULT : out arr) is
9845 -- for J in a'range loop
9846 -- RESULT (J) := not A (J);
9850 -- Here arr is the actual subtype of the parameter (and hence always
9851 -- constrained). Then we replace the not with a call to this subprogram.
9853 procedure Expand_N_Op_Not
(N
: Node_Id
) is
9854 Loc
: constant Source_Ptr
:= Sloc
(N
);
9855 Typ
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9864 Func_Name
: Entity_Id
;
9865 Loop_Statement
: Node_Id
;
9868 Unary_Op_Validity_Checks
(N
);
9870 -- For boolean operand, deal with non-standard booleans
9872 if Is_Boolean_Type
(Typ
) then
9873 Adjust_Condition
(Right_Opnd
(N
));
9874 Set_Etype
(N
, Standard_Boolean
);
9875 Adjust_Result_Type
(N
, Typ
);
9879 -- Only array types need any other processing
9881 if not Is_Array_Type
(Typ
) then
9885 -- Case of array operand. If bit packed with a component size of 1,
9886 -- handle it in Exp_Pakd if the operand is known to be aligned.
9888 if Is_Bit_Packed_Array
(Typ
)
9889 and then Component_Size
(Typ
) = 1
9890 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
9892 Expand_Packed_Not
(N
);
9896 -- Case of array operand which is not bit-packed. If the context is
9897 -- a safe assignment, call in-place operation, If context is a larger
9898 -- boolean expression in the context of a safe assignment, expansion is
9899 -- done by enclosing operation.
9901 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
9902 Convert_To_Actual_Subtype
(Opnd
);
9903 Arr
:= Etype
(Opnd
);
9904 Ensure_Defined
(Arr
, N
);
9905 Silly_Boolean_Array_Not_Test
(N
, Arr
);
9907 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9908 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
9909 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9912 -- Special case the negation of a binary operation
9914 elsif Nkind
(Opnd
) in N_Op_And | N_Op_Or | N_Op_Xor
9915 and then Safe_In_Place_Array_Op
9916 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
9918 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9922 elsif Nkind
(Parent
(N
)) in N_Binary_Op
9923 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9926 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
9927 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
9928 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
9931 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
9933 -- (not A) op (not B) can be reduced to a single call
9935 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
9938 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
9941 -- A xor (not B) can also be special-cased
9943 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
9950 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
9952 if Transform_Function_Array
then
9953 B
:= Make_Defining_Identifier
(Loc
, Name_UP_RESULT
);
9955 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
9958 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
9961 Make_Indexed_Component
(Loc
,
9962 Prefix
=> New_Occurrence_Of
(A
, Loc
),
9963 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9966 Make_Indexed_Component
(Loc
,
9967 Prefix
=> New_Occurrence_Of
(B
, Loc
),
9968 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9971 Make_Implicit_Loop_Statement
(N
,
9972 Identifier
=> Empty
,
9975 Make_Iteration_Scheme
(Loc
,
9976 Loop_Parameter_Specification
=>
9977 Make_Loop_Parameter_Specification
(Loc
,
9978 Defining_Identifier
=> J
,
9979 Discrete_Subtype_Definition
=>
9980 Make_Attribute_Reference
(Loc
,
9981 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
9982 Attribute_Name
=> Name_Range
))),
9984 Statements
=> New_List
(
9985 Make_Assignment_Statement
(Loc
,
9987 Expression
=> Make_Op_Not
(Loc
, A_J
))));
9989 Func_Name
:= Make_Temporary
(Loc
, 'N');
9990 Set_Is_Inlined
(Func_Name
);
9992 if Transform_Function_Array
then
9994 Make_Subprogram_Body
(Loc
,
9996 Make_Procedure_Specification
(Loc
,
9997 Defining_Unit_Name
=> Func_Name
,
9998 Parameter_Specifications
=> New_List
(
9999 Make_Parameter_Specification
(Loc
,
10000 Defining_Identifier
=> A
,
10001 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
10002 Make_Parameter_Specification
(Loc
,
10003 Defining_Identifier
=> B
,
10004 Out_Present
=> True,
10005 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
10007 Declarations
=> New_List
,
10009 Handled_Statement_Sequence
=>
10010 Make_Handled_Sequence_Of_Statements
(Loc
,
10011 Statements
=> New_List
(Loop_Statement
))));
10014 Temp_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
10023 Make_Object_Declaration
(Loc
,
10024 Defining_Identifier
=> Temp_Id
,
10025 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10028 -- Proc_Call (Opnd, Temp);
10031 Make_Procedure_Call_Statement
(Loc
,
10032 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
10033 Parameter_Associations
=>
10034 New_List
(Opnd
, New_Occurrence_Of
(Temp_Id
, Loc
)));
10036 Insert_Actions
(Parent
(N
), New_List
(Decl
, Call
));
10037 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
10041 Make_Subprogram_Body
(Loc
,
10043 Make_Function_Specification
(Loc
,
10044 Defining_Unit_Name
=> Func_Name
,
10045 Parameter_Specifications
=> New_List
(
10046 Make_Parameter_Specification
(Loc
,
10047 Defining_Identifier
=> A
,
10048 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
10049 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
10051 Declarations
=> New_List
(
10052 Make_Object_Declaration
(Loc
,
10053 Defining_Identifier
=> B
,
10054 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
10056 Handled_Statement_Sequence
=>
10057 Make_Handled_Sequence_Of_Statements
(Loc
,
10058 Statements
=> New_List
(
10060 Make_Simple_Return_Statement
(Loc
,
10061 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
10064 Make_Function_Call
(Loc
,
10065 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
10066 Parameter_Associations
=> New_List
(Opnd
)));
10069 Analyze_And_Resolve
(N
, Typ
);
10070 end Expand_N_Op_Not
;
10072 --------------------
10073 -- Expand_N_Op_Or --
10074 --------------------
10076 procedure Expand_N_Op_Or
(N
: Node_Id
) is
10077 Typ
: constant Entity_Id
:= Etype
(N
);
10080 Binary_Op_Validity_Checks
(N
);
10082 if Is_Array_Type
(Etype
(N
)) then
10083 Expand_Boolean_Operator
(N
);
10085 elsif Is_Boolean_Type
(Etype
(N
)) then
10086 Adjust_Condition
(Left_Opnd
(N
));
10087 Adjust_Condition
(Right_Opnd
(N
));
10088 Set_Etype
(N
, Standard_Boolean
);
10089 Adjust_Result_Type
(N
, Typ
);
10091 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10092 Expand_Intrinsic_Call
(N
, Entity
(N
));
10095 Expand_Nonbinary_Modular_Op
(N
);
10096 end Expand_N_Op_Or
;
10098 ----------------------
10099 -- Expand_N_Op_Plus --
10100 ----------------------
10102 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
10103 Typ
: constant Entity_Id
:= Etype
(N
);
10106 Unary_Op_Validity_Checks
(N
);
10108 -- Check for MINIMIZED/ELIMINATED overflow mode
10110 if Minimized_Eliminated_Overflow_Check
(N
) then
10111 Apply_Arithmetic_Overflow_Check
(N
);
10115 -- Try to narrow the operation
10117 if Typ
= Universal_Integer
then
10118 Narrow_Large_Operation
(N
);
10120 end Expand_N_Op_Plus
;
10122 ---------------------
10123 -- Expand_N_Op_Rem --
10124 ---------------------
10126 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
10127 Loc
: constant Source_Ptr
:= Sloc
(N
);
10128 Typ
: constant Entity_Id
:= Etype
(N
);
10139 -- Set if corresponding operand can be negative
10142 Binary_Op_Validity_Checks
(N
);
10144 -- Check for MINIMIZED/ELIMINATED overflow mode
10146 if Minimized_Eliminated_Overflow_Check
(N
) then
10147 Apply_Arithmetic_Overflow_Check
(N
);
10151 -- Try to narrow the operation
10153 if Typ
= Universal_Integer
then
10154 Narrow_Large_Operation
(N
);
10156 if Nkind
(N
) /= N_Op_Rem
then
10161 if Is_Integer_Type
(Etype
(N
)) then
10162 Apply_Divide_Checks
(N
);
10164 -- All done if we don't have a REM any more, which can happen as a
10165 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
10167 if Nkind
(N
) /= N_Op_Rem
then
10172 -- Proceed with expansion of REM
10174 Left
:= Left_Opnd
(N
);
10175 Right
:= Right_Opnd
(N
);
10177 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
10178 -- but it is useful with other back ends, and is certainly harmless.
10180 if Is_Integer_Type
(Etype
(N
))
10181 and then Compile_Time_Known_Value
(Right
)
10182 and then Expr_Value
(Right
) = Uint_1
10184 -- Call Remove_Side_Effects to ensure that any side effects in the
10185 -- ignored left operand (in particular function calls to user defined
10186 -- functions) are properly executed.
10188 Remove_Side_Effects
(Left
);
10190 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10191 Analyze_And_Resolve
(N
, Typ
);
10195 -- Deal with annoying case of largest negative number remainder minus
10196 -- one. Gigi may not handle this case correctly, because on some
10197 -- targets, the mod value is computed using a divide instruction
10198 -- which gives an overflow trap for this case.
10200 -- It would be a bit more efficient to figure out which targets this
10201 -- is really needed for, but in practice it is reasonable to do the
10202 -- following special check in all cases, since it means we get a clearer
10203 -- message, and also the overhead is minimal given that division is
10204 -- expensive in any case.
10206 -- In fact the check is quite easy, if the right operand is -1, then
10207 -- the remainder is always 0, and we can just ignore the left operand
10208 -- completely in this case.
10210 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10211 Lneg
:= not OK
or else Lo
< 0;
10213 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10214 Rneg
:= not OK
or else Lo
< 0;
10216 -- We won't mess with trying to find out if the left operand can really
10217 -- be the largest negative number (that's a pain in the case of private
10218 -- types and this is really marginal). We will just assume that we need
10219 -- the test if the left operand can be negative at all.
10222 and then not CodePeer_Mode
10225 Make_If_Expression
(Loc
,
10226 Expressions
=> New_List
(
10228 Left_Opnd
=> Duplicate_Subexpr
(Right
),
10230 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
10232 Unchecked_Convert_To
(Typ
,
10233 Make_Integer_Literal
(Loc
, Uint_0
)),
10235 Relocate_Node
(N
))));
10237 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
10238 Analyze_And_Resolve
(N
, Typ
);
10240 end Expand_N_Op_Rem
;
10242 -----------------------------
10243 -- Expand_N_Op_Rotate_Left --
10244 -----------------------------
10246 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
10248 Binary_Op_Validity_Checks
(N
);
10250 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10251 -- so we rewrite in terms of logical shifts
10253 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10255 -- where Bits is the shift count mod Esize (the mod operation here
10256 -- deals with ludicrous large shift counts, which are apparently OK).
10258 if Modify_Tree_For_C
then
10260 Loc
: constant Source_Ptr
:= Sloc
(N
);
10261 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10262 Typ
: constant Entity_Id
:= Etype
(N
);
10265 -- Sem_Intr should prevent getting there with a non binary modulus
10267 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10269 Rewrite
(Right_Opnd
(N
),
10271 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10272 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10274 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10279 Make_Op_Shift_Left
(Loc
,
10280 Left_Opnd
=> Left_Opnd
(N
),
10281 Right_Opnd
=> Right_Opnd
(N
)),
10284 Make_Op_Shift_Right
(Loc
,
10285 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10287 Make_Op_Subtract
(Loc
,
10288 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10290 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10292 Analyze_And_Resolve
(N
, Typ
);
10295 end Expand_N_Op_Rotate_Left
;
10297 ------------------------------
10298 -- Expand_N_Op_Rotate_Right --
10299 ------------------------------
10301 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
10303 Binary_Op_Validity_Checks
(N
);
10305 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10306 -- so we rewrite in terms of logical shifts
10308 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10310 -- where Bits is the shift count mod Esize (the mod operation here
10311 -- deals with ludicrous large shift counts, which are apparently OK).
10313 if Modify_Tree_For_C
then
10315 Loc
: constant Source_Ptr
:= Sloc
(N
);
10316 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10317 Typ
: constant Entity_Id
:= Etype
(N
);
10320 -- Sem_Intr should prevent getting there with a non binary modulus
10322 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10324 Rewrite
(Right_Opnd
(N
),
10326 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10327 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10329 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10334 Make_Op_Shift_Right
(Loc
,
10335 Left_Opnd
=> Left_Opnd
(N
),
10336 Right_Opnd
=> Right_Opnd
(N
)),
10339 Make_Op_Shift_Left
(Loc
,
10340 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10342 Make_Op_Subtract
(Loc
,
10343 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10345 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10347 Analyze_And_Resolve
(N
, Typ
);
10350 end Expand_N_Op_Rotate_Right
;
10352 ----------------------------
10353 -- Expand_N_Op_Shift_Left --
10354 ----------------------------
10356 -- Note: nothing in this routine depends on left as opposed to right shifts
10357 -- so we share the routine for expanding shift right operations.
10359 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
10361 Binary_Op_Validity_Checks
(N
);
10363 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10364 -- operand is not greater than the word size (since that would not
10365 -- be defined properly by the corresponding C shift operator).
10367 if Modify_Tree_For_C
then
10369 Right
: constant Node_Id
:= Right_Opnd
(N
);
10370 Loc
: constant Source_Ptr
:= Sloc
(Right
);
10371 Typ
: constant Entity_Id
:= Etype
(N
);
10372 Siz
: constant Uint
:= Esize
(Typ
);
10379 -- Sem_Intr should prevent getting there with a non binary modulus
10381 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10383 if Compile_Time_Known_Value
(Right
) then
10384 if Expr_Value
(Right
) >= Siz
then
10385 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10386 Analyze_And_Resolve
(N
, Typ
);
10389 -- Not compile time known, find range
10392 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10394 -- Nothing to do if known to be OK range, otherwise expand
10396 if not OK
or else Hi
>= Siz
then
10398 -- Prevent recursion on copy of shift node
10400 Orig
:= Relocate_Node
(N
);
10401 Set_Analyzed
(Orig
);
10403 -- Now do the rewrite
10406 Make_If_Expression
(Loc
,
10407 Expressions
=> New_List
(
10409 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
10410 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
10411 Make_Integer_Literal
(Loc
, 0),
10413 Analyze_And_Resolve
(N
, Typ
);
10418 end Expand_N_Op_Shift_Left
;
10420 -----------------------------
10421 -- Expand_N_Op_Shift_Right --
10422 -----------------------------
10424 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
10426 -- Share shift left circuit
10428 Expand_N_Op_Shift_Left
(N
);
10429 end Expand_N_Op_Shift_Right
;
10431 ----------------------------------------
10432 -- Expand_N_Op_Shift_Right_Arithmetic --
10433 ----------------------------------------
10435 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
10437 Binary_Op_Validity_Checks
(N
);
10439 -- If we are in Modify_Tree_For_C mode, there is no shift right
10440 -- arithmetic in C, so we rewrite in terms of logical shifts for
10441 -- modular integers, and keep the Shift_Right intrinsic for signed
10442 -- integers: even though doing a shift on a signed integer is not
10443 -- fully guaranteed by the C standard, this is what C compilers
10444 -- implement in practice.
10445 -- Consider also taking advantage of this for modular integers by first
10446 -- performing an unchecked conversion of the modular integer to a signed
10447 -- integer of the same sign, and then convert back.
10449 -- Shift_Right (Num, Bits) or
10451 -- then not (Shift_Right (Mask, bits))
10454 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10456 -- Note: the above works fine for shift counts greater than or equal
10457 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10458 -- generates all 1'bits.
10460 if Modify_Tree_For_C
and then Is_Modular_Integer_Type
(Etype
(N
)) then
10462 Loc
: constant Source_Ptr
:= Sloc
(N
);
10463 Typ
: constant Entity_Id
:= Etype
(N
);
10464 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
10465 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
10466 Left
: constant Node_Id
:= Left_Opnd
(N
);
10467 Right
: constant Node_Id
:= Right_Opnd
(N
);
10471 -- Sem_Intr should prevent getting there with a non binary modulus
10473 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10475 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10476 -- compile time as a single constant.
10478 if Compile_Time_Known_Value
(Right
) then
10480 Val
: constant Uint
:= Expr_Value
(Right
);
10483 if Val
>= Esize
(Typ
) then
10484 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
10488 Make_Integer_Literal
(Loc
,
10489 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
10497 Make_Op_Shift_Right
(Loc
,
10498 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
10499 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
10502 -- Now do the rewrite
10507 Make_Op_Shift_Right
(Loc
,
10509 Right_Opnd
=> Right
),
10511 Make_If_Expression
(Loc
,
10512 Expressions
=> New_List
(
10514 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
10515 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
10517 Make_Integer_Literal
(Loc
, 0)))));
10518 Analyze_And_Resolve
(N
, Typ
);
10521 end Expand_N_Op_Shift_Right_Arithmetic
;
10523 --------------------------
10524 -- Expand_N_Op_Subtract --
10525 --------------------------
10527 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
10528 Typ
: constant Entity_Id
:= Etype
(N
);
10531 Binary_Op_Validity_Checks
(N
);
10533 -- Check for MINIMIZED/ELIMINATED overflow mode
10535 if Minimized_Eliminated_Overflow_Check
(N
) then
10536 Apply_Arithmetic_Overflow_Check
(N
);
10540 -- Try to narrow the operation
10542 if Typ
= Universal_Integer
then
10543 Narrow_Large_Operation
(N
);
10545 if Nkind
(N
) /= N_Op_Subtract
then
10550 -- N - 0 = N for integer types
10552 if Is_Integer_Type
(Typ
)
10553 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
10554 and then Expr_Value
(Right_Opnd
(N
)) = 0
10556 Rewrite
(N
, Left_Opnd
(N
));
10560 -- Arithmetic overflow checks for signed integer/fixed point types
10562 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
10563 Apply_Arithmetic_Overflow_Check
(N
);
10566 -- Overflow checks for floating-point if -gnateF mode active
10568 Check_Float_Op_Overflow
(N
);
10570 Expand_Nonbinary_Modular_Op
(N
);
10571 end Expand_N_Op_Subtract
;
10573 ---------------------
10574 -- Expand_N_Op_Xor --
10575 ---------------------
10577 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
10578 Typ
: constant Entity_Id
:= Etype
(N
);
10581 Binary_Op_Validity_Checks
(N
);
10583 if Is_Array_Type
(Etype
(N
)) then
10584 Expand_Boolean_Operator
(N
);
10586 elsif Is_Boolean_Type
(Etype
(N
)) then
10587 Adjust_Condition
(Left_Opnd
(N
));
10588 Adjust_Condition
(Right_Opnd
(N
));
10589 Set_Etype
(N
, Standard_Boolean
);
10590 Adjust_Result_Type
(N
, Typ
);
10592 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10593 Expand_Intrinsic_Call
(N
, Entity
(N
));
10596 Expand_Nonbinary_Modular_Op
(N
);
10597 end Expand_N_Op_Xor
;
10599 ----------------------
10600 -- Expand_N_Or_Else --
10601 ----------------------
10603 procedure Expand_N_Or_Else
(N
: Node_Id
)
10604 renames Expand_Short_Circuit_Operator
;
10606 -----------------------------------
10607 -- Expand_N_Qualified_Expression --
10608 -----------------------------------
10610 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
10611 Operand
: constant Node_Id
:= Expression
(N
);
10612 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
10615 -- Do validity check if validity checking operands
10617 if Validity_Checks_On
and Validity_Check_Operands
then
10618 Ensure_Valid
(Operand
);
10621 Freeze_Before
(Operand
, Target_Type
);
10623 -- Apply possible constraint check
10625 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
10627 -- Apply possible predicate check
10629 Apply_Predicate_Check
(Operand
, Target_Type
);
10631 if Do_Range_Check
(Operand
) then
10632 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
10634 end Expand_N_Qualified_Expression
;
10636 ------------------------------------
10637 -- Expand_N_Quantified_Expression --
10638 ------------------------------------
10642 -- for all X in range => Cond
10647 -- for X in range loop
10648 -- if not Cond then
10654 -- Similarly, an existentially quantified expression:
10656 -- for some X in range => Cond
10661 -- for X in range loop
10668 -- In both cases, the iteration may be over a container in which case it is
10669 -- given by an iterator specification, not a loop parameter specification.
10671 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
10672 Actions
: constant List_Id
:= New_List
;
10673 For_All
: constant Boolean := All_Present
(N
);
10674 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
10675 Loc
: constant Source_Ptr
:= Sloc
(N
);
10676 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
10684 -- Ensure that the bound variable as well as the type of Name of the
10685 -- Iter_Spec if present are properly frozen. We must do this before
10686 -- expansion because the expression is about to be converted into a
10687 -- loop, and resulting freeze nodes may end up in the wrong place in the
10690 if Present
(Iter_Spec
) then
10691 Var
:= Defining_Identifier
(Iter_Spec
);
10693 Var
:= Defining_Identifier
(Loop_Spec
);
10697 P
: Node_Id
:= Parent
(N
);
10699 while Nkind
(P
) in N_Subexpr
loop
10703 if Present
(Iter_Spec
) then
10704 Freeze_Before
(P
, Etype
(Name
(Iter_Spec
)));
10707 Freeze_Before
(P
, Etype
(Var
));
10710 -- Create the declaration of the flag which tracks the status of the
10711 -- quantified expression. Generate:
10713 -- Flag : Boolean := (True | False);
10715 Flag
:= Make_Temporary
(Loc
, 'T', N
);
10717 Append_To
(Actions
,
10718 Make_Object_Declaration
(Loc
,
10719 Defining_Identifier
=> Flag
,
10720 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
10722 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
10724 -- Construct the circuitry which tracks the status of the quantified
10725 -- expression. Generate:
10727 -- if [not] Cond then
10728 -- Flag := (False | True);
10732 Cond
:= Relocate_Node
(Condition
(N
));
10735 Cond
:= Make_Op_Not
(Loc
, Cond
);
10738 Stmts
:= New_List
(
10739 Make_Implicit_If_Statement
(N
,
10741 Then_Statements
=> New_List
(
10742 Make_Assignment_Statement
(Loc
,
10743 Name
=> New_Occurrence_Of
(Flag
, Loc
),
10745 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
10746 Make_Exit_Statement
(Loc
))));
10748 -- Build the loop equivalent of the quantified expression
10750 if Present
(Iter_Spec
) then
10752 Make_Iteration_Scheme
(Loc
,
10753 Iterator_Specification
=> Iter_Spec
);
10756 Make_Iteration_Scheme
(Loc
,
10757 Loop_Parameter_Specification
=> Loop_Spec
);
10760 Append_To
(Actions
,
10761 Make_Loop_Statement
(Loc
,
10762 Iteration_Scheme
=> Scheme
,
10763 Statements
=> Stmts
,
10764 End_Label
=> Empty
));
10766 -- Transform the quantified expression
10769 Make_Expression_With_Actions
(Loc
,
10770 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
10771 Actions
=> Actions
));
10772 Analyze_And_Resolve
(N
, Standard_Boolean
);
10773 end Expand_N_Quantified_Expression
;
10775 ---------------------------------
10776 -- Expand_N_Selected_Component --
10777 ---------------------------------
10779 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
10780 Loc
: constant Source_Ptr
:= Sloc
(N
);
10781 Par
: constant Node_Id
:= Parent
(N
);
10782 P
: constant Node_Id
:= Prefix
(N
);
10783 S
: constant Node_Id
:= Selector_Name
(N
);
10784 Ptyp
: constant Entity_Id
:= Underlying_Type
(Etype
(P
));
10790 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
10791 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10792 -- unless the context of an assignment can provide size information.
10793 -- Don't we have a general routine that does this???
10795 function Is_Subtype_Declaration
return Boolean;
10796 -- The replacement of a discriminant reference by its value is required
10797 -- if this is part of the initialization of an temporary generated by a
10798 -- change of representation. This shows up as the construction of a
10799 -- discriminant constraint for a subtype declared at the same point as
10800 -- the entity in the prefix of the selected component. We recognize this
10801 -- case when the context of the reference is:
10802 -- subtype ST is T(Obj.D);
10803 -- where the entity for Obj comes from source, and ST has the same sloc.
10805 -----------------------
10806 -- In_Left_Hand_Side --
10807 -----------------------
10809 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
10811 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
10812 and then Comp
= Name
(Parent
(Comp
)))
10813 or else (Present
(Parent
(Comp
))
10814 and then Nkind
(Parent
(Comp
)) in N_Subexpr
10815 and then In_Left_Hand_Side
(Parent
(Comp
)));
10816 end In_Left_Hand_Side
;
10818 -----------------------------
10819 -- Is_Subtype_Declaration --
10820 -----------------------------
10822 function Is_Subtype_Declaration
return Boolean is
10823 Par
: constant Node_Id
:= Parent
(N
);
10826 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
10827 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
10828 and then Comes_From_Source
(Entity
(Prefix
(N
)))
10829 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
10830 end Is_Subtype_Declaration
;
10832 -- Start of processing for Expand_N_Selected_Component
10835 -- Deal with discriminant check required
10837 if Do_Discriminant_Check
(N
) then
10838 if Present
(Discriminant_Checking_Func
10839 (Original_Record_Component
(Entity
(S
))))
10841 -- Present the discriminant checking function to the backend, so
10842 -- that it can inline the call to the function.
10845 (Discriminant_Checking_Func
10846 (Original_Record_Component
(Entity
(S
))),
10849 -- Now reset the flag and generate the call
10851 Set_Do_Discriminant_Check
(N
, False);
10852 Generate_Discriminant_Check
(N
);
10854 -- In the case of Unchecked_Union, no discriminant checking is
10855 -- actually performed.
10858 if not Is_Unchecked_Union
10859 (Implementation_Base_Type
(Etype
(Prefix
(N
))))
10860 and then not Is_Predefined_Unit
(Get_Source_Unit
(N
))
10863 ("sorry - unable to generate discriminant check for" &
10864 " reference to variant component &",
10865 Selector_Name
(N
));
10868 Set_Do_Discriminant_Check
(N
, False);
10872 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10873 -- function, then additional actuals must be passed.
10875 if Is_Build_In_Place_Function_Call
(P
) then
10876 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
10878 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10879 -- containing build-in-place function calls whose returned object covers
10880 -- interface types.
10882 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
10883 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
10886 -- Gigi cannot handle unchecked conversions that are the prefix of a
10887 -- selected component with discriminants. This must be checked during
10888 -- expansion, because during analysis the type of the selector is not
10889 -- known at the point the prefix is analyzed. If the conversion is the
10890 -- target of an assignment, then we cannot force the evaluation.
10892 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
10893 and then Has_Discriminants
(Etype
(N
))
10894 and then not In_Left_Hand_Side
(N
)
10896 Force_Evaluation
(Prefix
(N
));
10899 -- Remaining processing applies only if selector is a discriminant
10901 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
10903 -- If the selector is a discriminant of a constrained record type,
10904 -- we may be able to rewrite the expression with the actual value
10905 -- of the discriminant, a useful optimization in some cases.
10907 if Is_Record_Type
(Ptyp
)
10908 and then Has_Discriminants
(Ptyp
)
10909 and then Is_Constrained
(Ptyp
)
10911 -- Do this optimization for discrete types only, and not for
10912 -- access types (access discriminants get us into trouble).
10914 if not Is_Discrete_Type
(Etype
(N
)) then
10917 -- Don't do this on the left-hand side of an assignment statement.
10918 -- Normally one would think that references like this would not
10919 -- occur, but they do in generated code, and mean that we really
10920 -- do want to assign the discriminant.
10922 elsif Nkind
(Par
) = N_Assignment_Statement
10923 and then Name
(Par
) = N
10927 -- Don't do this optimization for the prefix of an attribute or
10928 -- the name of an object renaming declaration since these are
10929 -- contexts where we do not want the value anyway.
10931 elsif (Nkind
(Par
) = N_Attribute_Reference
10932 and then Prefix
(Par
) = N
)
10933 or else Is_Renamed_Object
(N
)
10937 -- Don't do this optimization if we are within the code for a
10938 -- discriminant check, since the whole point of such a check may
10939 -- be to verify the condition on which the code below depends.
10941 elsif Is_In_Discriminant_Check
(N
) then
10944 -- Green light to see if we can do the optimization. There is
10945 -- still one condition that inhibits the optimization below but
10946 -- now is the time to check the particular discriminant.
10949 -- Loop through discriminants to find the matching discriminant
10950 -- constraint to see if we can copy it.
10952 Disc
:= First_Discriminant
(Ptyp
);
10953 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
10954 Discr_Loop
: while Present
(Dcon
) loop
10955 Dval
:= Node
(Dcon
);
10957 -- Check if this is the matching discriminant and if the
10958 -- discriminant value is simple enough to make sense to
10959 -- copy. We don't want to copy complex expressions, and
10960 -- indeed to do so can cause trouble (before we put in
10961 -- this guard, a discriminant expression containing an
10962 -- AND THEN was copied, causing problems for coverage
10963 -- analysis tools).
10965 -- However, if the reference is part of the initialization
10966 -- code generated for an object declaration, we must use
10967 -- the discriminant value from the subtype constraint,
10968 -- because the selected component may be a reference to the
10969 -- object being initialized, whose discriminant is not yet
10970 -- set. This only happens in complex cases involving changes
10971 -- of representation.
10973 if Disc
= Entity
(Selector_Name
(N
))
10974 and then (Is_Entity_Name
(Dval
)
10975 or else Compile_Time_Known_Value
(Dval
)
10976 or else Is_Subtype_Declaration
)
10978 -- Here we have the matching discriminant. Check for
10979 -- the case of a discriminant of a component that is
10980 -- constrained by an outer discriminant, which cannot
10981 -- be optimized away.
10983 if Denotes_Discriminant
(Dval
, Check_Concurrent
=> True)
10987 -- Do not retrieve value if constraint is not static. It
10988 -- is generally not useful, and the constraint may be a
10989 -- rewritten outer discriminant in which case it is in
10992 elsif Is_Entity_Name
(Dval
)
10994 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
10995 and then Present
(Expression
(Parent
(Entity
(Dval
))))
10997 Is_OK_Static_Expression
10998 (Expression
(Parent
(Entity
(Dval
))))
11002 -- In the context of a case statement, the expression may
11003 -- have the base type of the discriminant, and we need to
11004 -- preserve the constraint to avoid spurious errors on
11007 elsif Nkind
(Parent
(N
)) = N_Case_Statement
11008 and then Etype
(Dval
) /= Etype
(Disc
)
11011 Make_Qualified_Expression
(Loc
,
11013 New_Occurrence_Of
(Etype
(Disc
), Loc
),
11015 New_Copy_Tree
(Dval
)));
11016 Analyze_And_Resolve
(N
, Etype
(Disc
));
11018 -- In case that comes out as a static expression,
11019 -- reset it (a selected component is never static).
11021 Set_Is_Static_Expression
(N
, False);
11024 -- Otherwise we can just copy the constraint, but the
11025 -- result is certainly not static. In some cases the
11026 -- discriminant constraint has been analyzed in the
11027 -- context of the original subtype indication, but for
11028 -- itypes the constraint might not have been analyzed
11029 -- yet, and this must be done now.
11032 Rewrite
(N
, New_Copy_Tree
(Dval
));
11033 Analyze_And_Resolve
(N
);
11034 Set_Is_Static_Expression
(N
, False);
11040 Next_Discriminant
(Disc
);
11041 end loop Discr_Loop
;
11043 -- Note: the above loop should always find a matching
11044 -- discriminant, but if it does not, we just missed an
11045 -- optimization due to some glitch (perhaps a previous
11046 -- error), so ignore.
11051 -- The only remaining processing is in the case of a discriminant of
11052 -- a concurrent object, where we rewrite the prefix to denote the
11053 -- corresponding record type. If the type is derived and has renamed
11054 -- discriminants, use corresponding discriminant, which is the one
11055 -- that appears in the corresponding record.
11057 if not Is_Concurrent_Type
(Ptyp
) then
11061 Disc
:= Entity
(Selector_Name
(N
));
11063 if Is_Derived_Type
(Ptyp
)
11064 and then Present
(Corresponding_Discriminant
(Disc
))
11066 Disc
:= Corresponding_Discriminant
(Disc
);
11070 Make_Selected_Component
(Loc
,
11072 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
11073 New_Copy_Tree
(P
)),
11074 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
11076 Rewrite
(N
, New_N
);
11080 -- Set Atomic_Sync_Required if necessary for atomic component
11082 if Nkind
(N
) = N_Selected_Component
then
11084 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
11088 -- If component is atomic, but type is not, setting depends on
11089 -- disable/enable state for the component.
11091 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
11092 Set
:= not Atomic_Synchronization_Disabled
(E
);
11094 -- If component is not atomic, but its type is atomic, setting
11095 -- depends on disable/enable state for the type.
11097 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
11098 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
11100 -- If both component and type are atomic, we disable if either
11101 -- component or its type have sync disabled.
11103 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
11104 Set
:= not Atomic_Synchronization_Disabled
(E
)
11106 not Atomic_Synchronization_Disabled
(Etype
(E
));
11112 -- Set flag if required
11115 Activate_Atomic_Synchronization
(N
);
11119 end Expand_N_Selected_Component
;
11121 --------------------
11122 -- Expand_N_Slice --
11123 --------------------
11125 procedure Expand_N_Slice
(N
: Node_Id
) is
11126 Loc
: constant Source_Ptr
:= Sloc
(N
);
11127 Typ
: constant Entity_Id
:= Etype
(N
);
11129 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
11130 -- Check whether the argument is an actual for a procedure call, in
11131 -- which case the expansion of a bit-packed slice is deferred until the
11132 -- call itself is expanded. The reason this is required is that we might
11133 -- have an IN OUT or OUT parameter, and the copy out is essential, and
11134 -- that copy out would be missed if we created a temporary here in
11135 -- Expand_N_Slice. Note that we don't bother to test specifically for an
11136 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
11137 -- is harmless to defer expansion in the IN case, since the call
11138 -- processing will still generate the appropriate copy in operation,
11139 -- which will take care of the slice.
11141 procedure Make_Temporary_For_Slice
;
11142 -- Create a named variable for the value of the slice, in cases where
11143 -- the back end cannot handle it properly, e.g. when packed types or
11144 -- unaligned slices are involved.
11146 -------------------------
11147 -- Is_Procedure_Actual --
11148 -------------------------
11150 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
11151 Par
: Node_Id
:= Parent
(N
);
11155 -- If our parent is a procedure call we can return
11157 if Nkind
(Par
) = N_Procedure_Call_Statement
then
11160 -- If our parent is a type conversion, keep climbing the tree,
11161 -- since a type conversion can be a procedure actual. Also keep
11162 -- climbing if parameter association or a qualified expression,
11163 -- since these are additional cases that do can appear on
11164 -- procedure actuals.
11166 elsif Nkind
(Par
) in N_Type_Conversion
11167 | N_Parameter_Association
11168 | N_Qualified_Expression
11170 Par
:= Parent
(Par
);
11172 -- Any other case is not what we are looking for
11178 end Is_Procedure_Actual
;
11180 ------------------------------
11181 -- Make_Temporary_For_Slice --
11182 ------------------------------
11184 procedure Make_Temporary_For_Slice
is
11185 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
11190 Make_Object_Declaration
(Loc
,
11191 Defining_Identifier
=> Ent
,
11192 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
11194 Set_No_Initialization
(Decl
);
11196 Insert_Actions
(N
, New_List
(
11198 Make_Assignment_Statement
(Loc
,
11199 Name
=> New_Occurrence_Of
(Ent
, Loc
),
11200 Expression
=> Relocate_Node
(N
))));
11202 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
11203 Analyze_And_Resolve
(N
, Typ
);
11204 end Make_Temporary_For_Slice
;
11208 Pref
: constant Node_Id
:= Prefix
(N
);
11210 -- Start of processing for Expand_N_Slice
11213 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11214 -- function, then additional actuals must be passed.
11216 if Is_Build_In_Place_Function_Call
(Pref
) then
11217 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
11219 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11220 -- containing build-in-place function calls whose returned object covers
11221 -- interface types.
11223 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
11224 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
11227 -- The remaining case to be handled is packed slices. We can leave
11228 -- packed slices as they are in the following situations:
11230 -- 1. Right or left side of an assignment (we can handle this
11231 -- situation correctly in the assignment statement expansion).
11233 -- 2. Prefix of indexed component (the slide is optimized away in this
11234 -- case, see the start of Expand_N_Indexed_Component.)
11236 -- 3. Object renaming declaration, since we want the name of the
11237 -- slice, not the value.
11239 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11240 -- be required, and this is handled in the expansion of call
11243 -- 5. Prefix of an address attribute (this is an error which is caught
11244 -- elsewhere, and the expansion would interfere with generating the
11245 -- error message) or of a size attribute (because 'Size may change
11246 -- when applied to the temporary instead of the slice directly).
11248 if not Is_Packed
(Typ
) then
11250 -- Apply transformation for actuals of a function call, where
11251 -- Expand_Actuals is not used.
11253 if Nkind
(Parent
(N
)) = N_Function_Call
11254 and then Is_Possibly_Unaligned_Slice
(N
)
11256 Make_Temporary_For_Slice
;
11259 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
11260 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
11261 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
11265 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
11266 or else Is_Renamed_Object
(N
)
11267 or else Is_Procedure_Actual
(N
)
11271 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
11272 and then (Attribute_Name
(Parent
(N
)) = Name_Address
11273 or else Attribute_Name
(Parent
(N
)) = Name_Size
)
11278 Make_Temporary_For_Slice
;
11280 end Expand_N_Slice
;
11282 ------------------------------
11283 -- Expand_N_Type_Conversion --
11284 ------------------------------
11286 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
11287 Loc
: constant Source_Ptr
:= Sloc
(N
);
11288 Operand
: constant Node_Id
:= Expression
(N
);
11289 Operand_Acc
: Node_Id
:= Operand
;
11290 Target_Type
: Entity_Id
:= Etype
(N
);
11291 Operand_Type
: Entity_Id
:= Etype
(Operand
);
11293 procedure Discrete_Range_Check
;
11294 -- Handles generation of range check for discrete target value
11296 procedure Handle_Changed_Representation
;
11297 -- This is called in the case of record and array type conversions to
11298 -- see if there is a change of representation to be handled. Change of
11299 -- representation is actually handled at the assignment statement level,
11300 -- and what this procedure does is rewrite node N conversion as an
11301 -- assignment to temporary. If there is no change of representation,
11302 -- then the conversion node is unchanged.
11304 procedure Raise_Accessibility_Error
;
11305 -- Called when we know that an accessibility check will fail. Rewrites
11306 -- node N to an appropriate raise statement and outputs warning msgs.
11307 -- The Etype of the raise node is set to Target_Type. Note that in this
11308 -- case the rest of the processing should be skipped (i.e. the call to
11309 -- this procedure will be followed by "goto Done").
11311 procedure Real_Range_Check
;
11312 -- Handles generation of range check for real target value
11314 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
11315 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11316 -- evaluates to True.
11318 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
11320 -- Given a target type for a conversion, determine whether the
11321 -- statically deeper accessibility rules apply to it.
11323 --------------------------
11324 -- Discrete_Range_Check --
11325 --------------------------
11327 -- Case of conversions to a discrete type. We let Generate_Range_Check
11328 -- do the heavy lifting, after converting a fixed-point operand to an
11329 -- appropriate integer type.
11331 procedure Discrete_Range_Check
is
11335 procedure Generate_Temporary
;
11336 -- Generate a temporary to facilitate in the C backend the code
11337 -- generation of the unchecked conversion since the size of the
11338 -- source type may differ from the size of the target type.
11340 ------------------------
11341 -- Generate_Temporary --
11342 ------------------------
11344 procedure Generate_Temporary
is
11346 if Esize
(Etype
(Expr
)) < Esize
(Etype
(Ityp
)) then
11348 Exp_Type
: constant Entity_Id
:= Ityp
;
11349 Def_Id
: constant Entity_Id
:=
11350 Make_Temporary
(Loc
, 'R', Expr
);
11355 Set_Is_Internal
(Def_Id
);
11356 Set_Etype
(Def_Id
, Exp_Type
);
11357 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
11360 Make_Object_Declaration
(Loc
,
11361 Defining_Identifier
=> Def_Id
,
11362 Object_Definition
=> New_Occurrence_Of
11364 Constant_Present
=> True,
11365 Expression
=> Relocate_Node
(Expr
));
11367 Set_Assignment_OK
(E
);
11368 Insert_Action
(Expr
, E
);
11370 Set_Assignment_OK
(Res
, Assignment_OK
(Expr
));
11372 Rewrite
(Expr
, Res
);
11373 Analyze_And_Resolve
(Expr
, Exp_Type
);
11376 end Generate_Temporary
;
11378 -- Start of processing for Discrete_Range_Check
11381 -- Nothing more to do if conversion was rewritten
11383 if Nkind
(N
) /= N_Type_Conversion
then
11387 Expr
:= Expression
(N
);
11389 -- Clear the Do_Range_Check flag on Expr
11391 Set_Do_Range_Check
(Expr
, False);
11393 -- Nothing to do if range checks suppressed
11395 if Range_Checks_Suppressed
(Target_Type
) then
11399 -- Nothing to do if expression is an entity on which checks have been
11402 if Is_Entity_Name
(Expr
)
11403 and then Range_Checks_Suppressed
(Entity
(Expr
))
11408 -- Before we do a range check, we have to deal with treating
11409 -- a fixed-point operand as an integer. The way we do this
11410 -- is simply to do an unchecked conversion to an appropriate
11411 -- integer type with the smallest size, so that we can suppress
11414 if Is_Fixed_Point_Type
(Etype
(Expr
)) then
11415 Ityp
:= Small_Integer_Type_For
11416 (Esize
(Base_Type
(Etype
(Expr
))), Uns
=> False);
11418 -- Generate a temporary with the integer type to facilitate in the
11419 -- C backend the code generation for the unchecked conversion.
11421 if Modify_Tree_For_C
then
11422 Generate_Temporary
;
11425 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11428 -- Reset overflow flag, since the range check will include
11429 -- dealing with possible overflow, and generate the check.
11431 Set_Do_Overflow_Check
(N
, False);
11433 Generate_Range_Check
(Expr
, Target_Type
, CE_Range_Check_Failed
);
11434 end Discrete_Range_Check
;
11436 -----------------------------------
11437 -- Handle_Changed_Representation --
11438 -----------------------------------
11440 procedure Handle_Changed_Representation
is
11448 -- Nothing else to do if no change of representation
11450 if Has_Compatible_Representation
(Target_Type
, Operand_Type
) then
11453 -- The real change of representation work is done by the assignment
11454 -- statement processing. So if this type conversion is appearing as
11455 -- the expression of an assignment statement, nothing needs to be
11456 -- done to the conversion.
11458 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
11461 -- Otherwise we need to generate a temporary variable, and do the
11462 -- change of representation assignment into that temporary variable.
11463 -- The conversion is then replaced by a reference to this variable.
11468 -- If type is unconstrained we have to add a constraint, copied
11469 -- from the actual value of the left-hand side.
11471 if not Is_Constrained
(Target_Type
) then
11472 if Has_Discriminants
(Operand_Type
) then
11474 -- A change of representation can only apply to untagged
11475 -- types. We need to build the constraint that applies to
11476 -- the target type, using the constraints of the operand.
11477 -- The analysis is complicated if there are both inherited
11478 -- discriminants and constrained discriminants.
11479 -- We iterate over the discriminants of the target, and
11480 -- find the discriminant of the same name:
11482 -- a) If there is a corresponding discriminant in the object
11483 -- then the value is a selected component of the operand.
11485 -- b) Otherwise the value of a constrained discriminant is
11486 -- found in the stored constraint of the operand.
11489 Stored
: constant Elist_Id
:=
11490 Stored_Constraint
(Operand_Type
);
11491 -- Stored constraints of the operand. If present, they
11492 -- correspond to the discriminants of the parent type.
11494 Disc_O
: Entity_Id
;
11495 -- Discriminant of the operand type. Its value in the
11496 -- object is captured in a selected component.
11498 Disc_T
: Entity_Id
;
11499 -- Discriminant of the target type
11504 Disc_O
:= First_Discriminant
(Operand_Type
);
11505 Disc_T
:= First_Discriminant
(Target_Type
);
11506 Elmt
:= (if Present
(Stored
)
11507 then First_Elmt
(Stored
)
11511 while Present
(Disc_T
) loop
11512 if Present
(Disc_O
)
11513 and then Chars
(Disc_T
) = Chars
(Disc_O
)
11516 Make_Selected_Component
(Loc
,
11518 Duplicate_Subexpr_Move_Checks
(Operand
),
11520 Make_Identifier
(Loc
, Chars
(Disc_O
))));
11521 Next_Discriminant
(Disc_O
);
11523 elsif Present
(Elmt
) then
11524 Append_To
(Cons
, New_Copy_Tree
(Node
(Elmt
)));
11527 if Present
(Elmt
) then
11531 Next_Discriminant
(Disc_T
);
11535 elsif Is_Array_Type
(Operand_Type
) then
11536 N_Ix
:= First_Index
(Target_Type
);
11539 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
11541 -- We convert the bounds explicitly. We use an unchecked
11542 -- conversion because bounds checks are done elsewhere.
11547 Unchecked_Convert_To
(Etype
(N_Ix
),
11548 Make_Attribute_Reference
(Loc
,
11550 Duplicate_Subexpr_No_Checks
11551 (Operand
, Name_Req
=> True),
11552 Attribute_Name
=> Name_First
,
11553 Expressions
=> New_List
(
11554 Make_Integer_Literal
(Loc
, J
)))),
11557 Unchecked_Convert_To
(Etype
(N_Ix
),
11558 Make_Attribute_Reference
(Loc
,
11560 Duplicate_Subexpr_No_Checks
11561 (Operand
, Name_Req
=> True),
11562 Attribute_Name
=> Name_Last
,
11563 Expressions
=> New_List
(
11564 Make_Integer_Literal
(Loc
, J
))))));
11571 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
11573 if Present
(Cons
) then
11575 Make_Subtype_Indication
(Loc
,
11576 Subtype_Mark
=> Odef
,
11578 Make_Index_Or_Discriminant_Constraint
(Loc
,
11579 Constraints
=> Cons
));
11582 Temp
:= Make_Temporary
(Loc
, 'C');
11584 Make_Object_Declaration
(Loc
,
11585 Defining_Identifier
=> Temp
,
11586 Object_Definition
=> Odef
);
11588 Set_No_Initialization
(Decl
, True);
11590 -- Insert required actions. It is essential to suppress checks
11591 -- since we have suppressed default initialization, which means
11592 -- that the variable we create may have no discriminants.
11597 Make_Assignment_Statement
(Loc
,
11598 Name
=> New_Occurrence_Of
(Temp
, Loc
),
11599 Expression
=> Relocate_Node
(N
))),
11600 Suppress
=> All_Checks
);
11602 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
11605 end Handle_Changed_Representation
;
11607 -------------------------------
11608 -- Raise_Accessibility_Error --
11609 -------------------------------
11611 procedure Raise_Accessibility_Error
is
11613 Error_Msg_Warn
:= SPARK_Mode
/= On
;
11615 Make_Raise_Program_Error
(Sloc
(N
),
11616 Reason
=> PE_Accessibility_Check_Failed
));
11617 Set_Etype
(N
, Target_Type
);
11619 Error_Msg_N
("accessibility check failure<<", N
);
11620 Error_Msg_N
("\Program_Error [<<", N
);
11621 end Raise_Accessibility_Error
;
11623 ----------------------
11624 -- Real_Range_Check --
11625 ----------------------
11627 -- Case of conversions to floating-point or fixed-point. If range checks
11628 -- are enabled and the target type has a range constraint, we convert:
11634 -- Tnn : typ'Base := typ'Base (x);
11635 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11638 -- This is necessary when there is a conversion of integer to float or
11639 -- to fixed-point to ensure that the correct checks are made. It is not
11640 -- necessary for the float-to-float case where it is enough to just set
11641 -- the Do_Range_Check flag on the expression.
11643 procedure Real_Range_Check
is
11644 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
11645 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
11646 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
11657 -- Nothing more to do if conversion was rewritten
11659 if Nkind
(N
) /= N_Type_Conversion
then
11663 Expr
:= Expression
(N
);
11665 -- Clear the Do_Range_Check flag on Expr
11667 Set_Do_Range_Check
(Expr
, False);
11669 -- Nothing to do if range checks suppressed, or target has the same
11670 -- range as the base type (or is the base type).
11672 if Range_Checks_Suppressed
(Target_Type
)
11673 or else (Lo
= Type_Low_Bound
(Btyp
)
11675 Hi
= Type_High_Bound
(Btyp
))
11680 -- Nothing to do if expression is an entity on which checks have been
11683 if Is_Entity_Name
(Expr
)
11684 and then Range_Checks_Suppressed
(Entity
(Expr
))
11689 -- Nothing to do if expression was rewritten into a float-to-float
11690 -- conversion, since this kind of conversion is handled elsewhere.
11692 if Is_Floating_Point_Type
(Etype
(Expr
))
11693 and then Is_Floating_Point_Type
(Target_Type
)
11698 -- Nothing to do if bounds are all static and we can tell that the
11699 -- expression is within the bounds of the target. Note that if the
11700 -- operand is of an unconstrained floating-point type, then we do
11701 -- not trust it to be in range (might be infinite)
11704 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Expr
));
11705 S_Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Expr
));
11708 if (not Is_Floating_Point_Type
(Etype
(Expr
))
11709 or else Is_Constrained
(Etype
(Expr
)))
11710 and then Compile_Time_Known_Value
(S_Lo
)
11711 and then Compile_Time_Known_Value
(S_Hi
)
11712 and then Compile_Time_Known_Value
(Hi
)
11713 and then Compile_Time_Known_Value
(Lo
)
11716 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
11717 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
11722 if Is_Real_Type
(Etype
(Expr
)) then
11723 S_Lov
:= Expr_Value_R
(S_Lo
);
11724 S_Hiv
:= Expr_Value_R
(S_Hi
);
11726 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
11727 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
11731 and then S_Lov
>= D_Lov
11732 and then S_Hiv
<= D_Hiv
11740 -- Otherwise rewrite the conversion as described above
11742 Conv
:= Convert_To
(Btyp
, Expr
);
11744 -- If a conversion is necessary, then copy the specific flags from
11745 -- the original one and also move the Do_Overflow_Check flag since
11746 -- this new conversion is to the base type.
11748 if Nkind
(Conv
) = N_Type_Conversion
then
11749 Set_Conversion_OK
(Conv
, Conversion_OK
(N
));
11750 Set_Float_Truncate
(Conv
, Float_Truncate
(N
));
11751 Set_Rounded_Result
(Conv
, Rounded_Result
(N
));
11753 if Do_Overflow_Check
(N
) then
11754 Set_Do_Overflow_Check
(Conv
);
11755 Set_Do_Overflow_Check
(N
, False);
11759 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
11761 -- For a conversion from Float to Fixed where the bounds of the
11762 -- fixed-point type are static, we can obtain a more accurate
11763 -- fixed-point value by converting the result of the floating-
11764 -- point expression to an appropriate integer type, and then
11765 -- performing an unchecked conversion to the target fixed-point
11766 -- type. The range check can then use the corresponding integer
11767 -- value of the bounds instead of requiring further conversions.
11768 -- This preserves the identity:
11770 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11772 -- which used to fail when Fix_Val was a bound of the type and
11773 -- the 'Small was not a representable number.
11774 -- This transformation requires an integer type large enough to
11775 -- accommodate a fixed-point value.
11777 if Is_Ordinary_Fixed_Point_Type
(Target_Type
)
11778 and then Is_Floating_Point_Type
(Etype
(Expr
))
11779 and then RM_Size
(Btyp
) <= System_Max_Integer_Size
11780 and then Nkind
(Lo
) = N_Real_Literal
11781 and then Nkind
(Hi
) = N_Real_Literal
11784 Expr_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Conv
);
11785 Int_Typ
: constant Entity_Id
:=
11786 Small_Integer_Type_For
(RM_Size
(Btyp
), Uns
=> False);
11787 Trunc
: constant Boolean := Float_Truncate
(Conv
);
11790 Conv
:= Convert_To
(Int_Typ
, Expression
(Conv
));
11791 Set_Float_Truncate
(Conv
, Trunc
);
11793 -- Generate a temporary with the integer value. Required in the
11794 -- CCG compiler to ensure that run-time checks reference this
11795 -- integer expression (instead of the resulting fixed-point
11796 -- value because fixed-point values are handled by means of
11797 -- unsigned integer types).
11800 Make_Object_Declaration
(Loc
,
11801 Defining_Identifier
=> Expr_Id
,
11802 Object_Definition
=> New_Occurrence_Of
(Int_Typ
, Loc
),
11803 Constant_Present
=> True,
11804 Expression
=> Conv
));
11806 -- Create integer objects for range checking of result.
11809 Unchecked_Convert_To
11810 (Int_Typ
, New_Occurrence_Of
(Expr_Id
, Loc
));
11813 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Lo
));
11816 Unchecked_Convert_To
11817 (Int_Typ
, New_Occurrence_Of
(Expr_Id
, Loc
));
11820 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Hi
));
11822 -- Rewrite conversion as an integer conversion of the
11823 -- original floating-point expression, followed by an
11824 -- unchecked conversion to the target fixed-point type.
11827 Unchecked_Convert_To
11828 (Target_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11831 -- All other conversions
11834 Lo_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11836 Make_Attribute_Reference
(Loc
,
11837 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11838 Attribute_Name
=> Name_First
);
11840 Hi_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11842 Make_Attribute_Reference
(Loc
,
11843 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11844 Attribute_Name
=> Name_Last
);
11847 -- Build code for range checking. Note that checks are suppressed
11848 -- here since we don't want a recursive range check popping up.
11850 Insert_Actions
(N
, New_List
(
11851 Make_Object_Declaration
(Loc
,
11852 Defining_Identifier
=> Tnn
,
11853 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
11854 Constant_Present
=> True,
11855 Expression
=> Conv
),
11857 Make_Raise_Constraint_Error
(Loc
,
11862 Left_Opnd
=> Lo_Arg
,
11863 Right_Opnd
=> Lo_Val
),
11867 Left_Opnd
=> Hi_Arg
,
11868 Right_Opnd
=> Hi_Val
)),
11869 Reason
=> CE_Range_Check_Failed
)),
11870 Suppress
=> All_Checks
);
11872 Rewrite
(Expr
, New_Occurrence_Of
(Tnn
, Loc
));
11873 end Real_Range_Check
;
11875 -----------------------------
11876 -- Has_Extra_Accessibility --
11877 -----------------------------
11879 -- Returns true for a formal of an anonymous access type or for an Ada
11880 -- 2012-style stand-alone object of an anonymous access type.
11882 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
11884 if Is_Formal
(Id
) or else Ekind
(Id
) in E_Constant | E_Variable
then
11885 return Present
(Effective_Extra_Accessibility
(Id
));
11889 end Has_Extra_Accessibility
;
11891 ----------------------------------------
11892 -- Statically_Deeper_Relation_Applies --
11893 ----------------------------------------
11895 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
11899 -- The case where the target type is an anonymous access type is
11900 -- ignored since they have different semantics and get covered by
11901 -- various runtime checks depending on context.
11903 -- Note, the current implementation of this predicate is incomplete
11904 -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
11907 return Ekind
(Targ_Typ
) /= E_Anonymous_Access_Type
;
11908 end Statically_Deeper_Relation_Applies
;
11910 -- Start of processing for Expand_N_Type_Conversion
11913 -- First remove check marks put by the semantic analysis on the type
11914 -- conversion between array types. We need these checks, and they will
11915 -- be generated by this expansion routine, but we do not depend on these
11916 -- flags being set, and since we do intend to expand the checks in the
11917 -- front end, we don't want them on the tree passed to the back end.
11919 if Is_Array_Type
(Target_Type
) then
11920 if Is_Constrained
(Target_Type
) then
11921 Set_Do_Length_Check
(N
, False);
11923 Set_Do_Range_Check
(Operand
, False);
11927 -- Nothing at all to do if conversion is to the identical type so remove
11928 -- the conversion completely, it is useless, except that it may carry
11929 -- an Assignment_OK attribute, which must be propagated to the operand
11930 -- and the Do_Range_Check flag on the operand must be cleared, if any.
11932 if Operand_Type
= Target_Type
then
11933 if Assignment_OK
(N
) then
11934 Set_Assignment_OK
(Operand
);
11937 Set_Do_Range_Check
(Operand
, False);
11939 Rewrite
(N
, Relocate_Node
(Operand
));
11944 -- Nothing to do if this is the second argument of read. This is a
11945 -- "backwards" conversion that will be handled by the specialized code
11946 -- in attribute processing.
11948 if Nkind
(Parent
(N
)) = N_Attribute_Reference
11949 and then Attribute_Name
(Parent
(N
)) = Name_Read
11950 and then Next
(First
(Expressions
(Parent
(N
)))) = N
11955 -- Check for case of converting to a type that has an invariant
11956 -- associated with it. This requires an invariant check. We insert
11959 -- invariant_check (typ (expr))
11961 -- in the code, after removing side effects from the expression.
11962 -- This is clearer than replacing the conversion into an expression
11963 -- with actions, because the context may impose additional actions
11964 -- (tag checks, membership tests, etc.) that conflict with this
11965 -- rewriting (used previously).
11967 -- Note: the Comes_From_Source check, and then the resetting of this
11968 -- flag prevents what would otherwise be an infinite recursion.
11970 if Has_Invariants
(Target_Type
)
11971 and then Present
(Invariant_Procedure
(Target_Type
))
11972 and then Comes_From_Source
(N
)
11974 Set_Comes_From_Source
(N
, False);
11975 Remove_Side_Effects
(N
);
11976 Insert_Action
(N
, Make_Invariant_Call
(Duplicate_Subexpr
(N
)));
11979 -- AI12-0042: For a view conversion to a class-wide type occurring
11980 -- within the immediate scope of T, from a specific type that is
11981 -- a descendant of T (including T itself), an invariant check is
11982 -- performed on the part of the object that is of type T. (We don't
11983 -- need to explicitly check for the operand type being a descendant,
11984 -- just that it's a specific type, because the conversion would be
11985 -- illegal if it's specific and not a descendant -- downward conversion
11986 -- is not allowed).
11988 elsif Is_Class_Wide_Type
(Target_Type
)
11989 and then not Is_Class_Wide_Type
(Etype
(Expression
(N
)))
11990 and then Present
(Invariant_Procedure
(Root_Type
(Target_Type
)))
11991 and then Comes_From_Source
(N
)
11992 and then Within_Scope
(Find_Enclosing_Scope
(N
), Scope
(Target_Type
))
11994 Remove_Side_Effects
(N
);
11996 -- Perform the invariant check on a conversion to the class-wide
11997 -- type's root type.
12000 Root_Conv
: constant Node_Id
:=
12001 Make_Type_Conversion
(Loc
,
12003 New_Occurrence_Of
(Root_Type
(Target_Type
), Loc
),
12004 Expression
=> Duplicate_Subexpr
(Expression
(N
)));
12006 Set_Etype
(Root_Conv
, Root_Type
(Target_Type
));
12008 Insert_Action
(N
, Make_Invariant_Call
(Root_Conv
));
12013 -- Here if we may need to expand conversion
12015 -- If the operand of the type conversion is an arithmetic operation on
12016 -- signed integers, and the based type of the signed integer type in
12017 -- question is smaller than Standard.Integer, we promote both of the
12018 -- operands to type Integer.
12020 -- For example, if we have
12022 -- target-type (opnd1 + opnd2)
12024 -- and opnd1 and opnd2 are of type short integer, then we rewrite
12027 -- target-type (integer(opnd1) + integer(opnd2))
12029 -- We do this because we are always allowed to compute in a larger type
12030 -- if we do the right thing with the result, and in this case we are
12031 -- going to do a conversion which will do an appropriate check to make
12032 -- sure that things are in range of the target type in any case. This
12033 -- avoids some unnecessary intermediate overflows.
12035 -- We might consider a similar transformation in the case where the
12036 -- target is a real type or a 64-bit integer type, and the operand
12037 -- is an arithmetic operation using a 32-bit integer type. However,
12038 -- we do not bother with this case, because it could cause significant
12039 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
12040 -- much cheaper, but we don't want different behavior on 32-bit and
12041 -- 64-bit machines. Note that the exclusion of the 64-bit case also
12042 -- handles the configurable run-time cases where 64-bit arithmetic
12043 -- may simply be unavailable.
12045 -- Note: this circuit is partially redundant with respect to the circuit
12046 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
12047 -- the processing here. Also we still need the Checks circuit, since we
12048 -- have to be sure not to generate junk overflow checks in the first
12049 -- place, since it would be tricky to remove them here.
12051 if Integer_Promotion_Possible
(N
) then
12053 -- All conditions met, go ahead with transformation
12060 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
12062 R
:= Convert_To
(Standard_Integer
, Right_Opnd
(Operand
));
12063 Set_Right_Opnd
(Opnd
, R
);
12065 if Nkind
(Operand
) in N_Binary_Op
then
12066 L
:= Convert_To
(Standard_Integer
, Left_Opnd
(Operand
));
12067 Set_Left_Opnd
(Opnd
, L
);
12071 Make_Type_Conversion
(Loc
,
12072 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
12073 Expression
=> Opnd
));
12075 Analyze_And_Resolve
(N
, Target_Type
);
12080 -- If the conversion is from Universal_Integer and requires an overflow
12081 -- check, try to do an intermediate conversion to a narrower type first
12082 -- without overflow check, in order to avoid doing the overflow check
12083 -- in Universal_Integer, which can be a very large type.
12085 if Operand_Type
= Universal_Integer
and then Do_Overflow_Check
(N
) then
12087 Lo
, Hi
, Siz
: Uint
;
12092 Determine_Range
(Operand
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12095 Siz
:= Get_Size_For_Range
(Lo
, Hi
);
12097 -- We use the base type instead of the first subtype because
12098 -- overflow checks are done in the base type, so this avoids
12099 -- the need for useless conversions.
12101 if Siz
< System_Max_Integer_Size
then
12102 Typ
:= Etype
(Integer_Type_For
(Siz
, Uns
=> False));
12104 Convert_To_And_Rewrite
(Typ
, Operand
);
12105 Analyze_And_Resolve
12106 (Operand
, Typ
, Suppress
=> Overflow_Check
);
12108 Analyze_And_Resolve
(N
, Target_Type
);
12115 -- Do validity check if validity checking operands
12117 if Validity_Checks_On
and Validity_Check_Operands
then
12118 Ensure_Valid
(Operand
);
12121 -- Special case of converting from non-standard boolean type
12123 if Is_Boolean_Type
(Operand_Type
)
12124 and then Nonzero_Is_True
(Operand_Type
)
12126 Adjust_Condition
(Operand
);
12127 Set_Etype
(Operand
, Standard_Boolean
);
12128 Operand_Type
:= Standard_Boolean
;
12131 -- Case of converting to an access type
12133 if Is_Access_Type
(Target_Type
) then
12134 -- In terms of accessibility rules, an anonymous access discriminant
12135 -- is not considered separate from its parent object.
12137 if Nkind
(Operand
) = N_Selected_Component
12138 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
12139 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
12141 Operand_Acc
:= Original_Node
(Prefix
(Operand
));
12144 -- If this type conversion was internally generated by the front end
12145 -- to displace the pointer to the object to reference an interface
12146 -- type and the original node was an Unrestricted_Access attribute,
12147 -- then skip applying accessibility checks (because, according to the
12148 -- GNAT Reference Manual, this attribute is similar to 'Access except
12149 -- that all accessibility and aliased view checks are omitted).
12151 if not Comes_From_Source
(N
)
12152 and then Is_Interface
(Designated_Type
(Target_Type
))
12153 and then Nkind
(Original_Node
(N
)) = N_Attribute_Reference
12154 and then Attribute_Name
(Original_Node
(N
)) =
12155 Name_Unrestricted_Access
12159 -- Apply an accessibility check when the conversion operand is an
12160 -- access parameter (or a renaming thereof), unless conversion was
12161 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
12162 -- or for the actual of a class-wide interface parameter. Note that
12163 -- other checks may still need to be applied below (such as tagged
12166 elsif Is_Entity_Name
(Operand_Acc
)
12167 and then Has_Extra_Accessibility
(Entity
(Operand_Acc
))
12168 and then Ekind
(Etype
(Operand_Acc
)) = E_Anonymous_Access_Type
12169 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
12170 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
12171 and then not No_Dynamic_Accessibility_Checks_Enabled
(N
)
12173 if not Comes_From_Source
(N
)
12174 and then Nkind
(Parent
(N
)) in N_Function_Call
12175 | N_Parameter_Association
12176 | N_Procedure_Call_Statement
12177 and then Is_Interface
(Designated_Type
(Target_Type
))
12178 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
12183 Apply_Accessibility_Check
12184 (Operand
, Target_Type
, Insert_Node
=> Operand
);
12187 -- If the level of the operand type is statically deeper than the
12188 -- level of the target type, then force Program_Error. Note that this
12189 -- can only occur for cases where the attribute is within the body of
12190 -- an instantiation, otherwise the conversion will already have been
12191 -- rejected as illegal.
12193 -- Note: warnings are issued by the analyzer for the instance cases,
12194 -- and, since we are late in expansion, a check is performed to
12195 -- verify that neither the target type nor the operand type are
12196 -- internally generated - as this can lead to spurious errors when,
12197 -- for example, the operand type is a result of BIP expansion.
12199 elsif In_Instance_Body
12200 and then Statically_Deeper_Relation_Applies
(Target_Type
)
12201 and then not Is_Internal
(Target_Type
)
12202 and then not Is_Internal
(Operand_Type
)
12204 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
12206 Raise_Accessibility_Error
;
12209 -- When the operand is a selected access discriminant the check needs
12210 -- to be made against the level of the object denoted by the prefix
12211 -- of the selected name. Force Program_Error for this case as well
12212 -- (this accessibility violation can only happen if within the body
12213 -- of an instantiation).
12215 elsif In_Instance_Body
12216 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
12217 and then Nkind
(Operand
) = N_Selected_Component
12218 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
12219 and then Static_Accessibility_Level
(Operand
, Zero_On_Dynamic_Level
)
12220 > Type_Access_Level
(Target_Type
)
12222 Raise_Accessibility_Error
;
12227 -- Case of conversions of tagged types and access to tagged types
12229 -- When needed, that is to say when the expression is class-wide, Add
12230 -- runtime a tag check for (strict) downward conversion by using the
12231 -- membership test, generating:
12233 -- [constraint_error when Operand not in Target_Type'Class]
12235 -- or in the access type case
12237 -- [constraint_error
12238 -- when Operand /= null
12239 -- and then Operand.all not in
12240 -- Designated_Type (Target_Type)'Class]
12242 if (Is_Access_Type
(Target_Type
)
12243 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
12244 or else Is_Tagged_Type
(Target_Type
)
12246 -- Do not do any expansion in the access type case if the parent is a
12247 -- renaming, since this is an error situation which will be caught by
12248 -- Sem_Ch8, and the expansion can interfere with this error check.
12250 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
12254 -- Otherwise, proceed with processing tagged conversion
12256 Tagged_Conversion
: declare
12257 Actual_Op_Typ
: Entity_Id
;
12258 Actual_Targ_Typ
: Entity_Id
;
12259 Root_Op_Typ
: Entity_Id
;
12261 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
12262 -- Create a membership check to test whether Operand is a member
12263 -- of Targ_Typ. If the original Target_Type is an access, include
12264 -- a test for null value. The check is inserted at N.
12266 --------------------
12267 -- Make_Tag_Check --
12268 --------------------
12270 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
12275 -- [Constraint_Error
12276 -- when Operand /= null
12277 -- and then Operand.all not in Targ_Typ]
12279 if Is_Access_Type
(Target_Type
) then
12281 Make_And_Then
(Loc
,
12284 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12285 Right_Opnd
=> Make_Null
(Loc
)),
12290 Make_Explicit_Dereference
(Loc
,
12291 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
12292 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
12295 -- [Constraint_Error when Operand not in Targ_Typ]
12300 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12301 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
12305 Make_Raise_Constraint_Error
(Loc
,
12307 Reason
=> CE_Tag_Check_Failed
),
12308 Suppress
=> All_Checks
);
12309 end Make_Tag_Check
;
12311 -- Start of processing for Tagged_Conversion
12314 -- Handle entities from the limited view
12316 if Is_Access_Type
(Operand_Type
) then
12318 Available_View
(Designated_Type
(Operand_Type
));
12320 Actual_Op_Typ
:= Operand_Type
;
12323 if Is_Access_Type
(Target_Type
) then
12325 Available_View
(Designated_Type
(Target_Type
));
12327 Actual_Targ_Typ
:= Target_Type
;
12330 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
12332 -- Ada 2005 (AI-251): Handle interface type conversion
12334 if Is_Interface
(Actual_Op_Typ
)
12336 Is_Interface
(Actual_Targ_Typ
)
12338 Expand_Interface_Conversion
(N
);
12342 -- Create a runtime tag check for a downward CW type conversion
12344 if Is_Class_Wide_Type
(Actual_Op_Typ
)
12345 and then Actual_Op_Typ
/= Actual_Targ_Typ
12346 and then Root_Op_Typ
/= Actual_Targ_Typ
12347 and then Is_Ancestor
12348 (Root_Op_Typ
, Actual_Targ_Typ
, Use_Full_View
=> True)
12349 and then not Tag_Checks_Suppressed
(Actual_Targ_Typ
)
12354 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
12355 Conv
:= Unchecked_Convert_To
(Target_Type
, Expression
(N
));
12357 Analyze_And_Resolve
(N
, Target_Type
);
12360 end Tagged_Conversion
;
12362 -- Case of other access type conversions
12364 elsif Is_Access_Type
(Target_Type
) then
12365 Apply_Constraint_Check
(Operand
, Target_Type
);
12367 -- Case of conversions from a fixed-point type
12369 -- These conversions require special expansion and processing, found in
12370 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12371 -- since from a semantic point of view, these are simple integer
12372 -- conversions, which do not need further processing except for the
12373 -- generation of range checks, which is performed at the end of this
12376 elsif Is_Fixed_Point_Type
(Operand_Type
)
12377 and then not Conversion_OK
(N
)
12379 -- We should never see universal fixed at this case, since the
12380 -- expansion of the constituent divide or multiply should have
12381 -- eliminated the explicit mention of universal fixed.
12383 pragma Assert
(Operand_Type
/= Universal_Fixed
);
12385 -- Check for special case of the conversion to universal real that
12386 -- occurs as a result of the use of a round attribute. In this case,
12387 -- the real type for the conversion is taken from the target type of
12388 -- the Round attribute and the result must be marked as rounded.
12390 if Target_Type
= Universal_Real
12391 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
12392 and then Attribute_Name
(Parent
(N
)) = Name_Round
12394 Set_Etype
(N
, Etype
(Parent
(N
)));
12395 Target_Type
:= Etype
(N
);
12396 Set_Rounded_Result
(N
);
12399 if Is_Fixed_Point_Type
(Target_Type
) then
12400 Expand_Convert_Fixed_To_Fixed
(N
);
12401 elsif Is_Integer_Type
(Target_Type
) then
12402 Expand_Convert_Fixed_To_Integer
(N
);
12404 pragma Assert
(Is_Floating_Point_Type
(Target_Type
));
12405 Expand_Convert_Fixed_To_Float
(N
);
12408 -- Case of conversions to a fixed-point type
12410 -- These conversions require special expansion and processing, found in
12411 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12412 -- since from a semantic point of view, these are simple integer
12413 -- conversions, which do not need further processing.
12415 elsif Is_Fixed_Point_Type
(Target_Type
)
12416 and then not Conversion_OK
(N
)
12418 if Is_Integer_Type
(Operand_Type
) then
12419 Expand_Convert_Integer_To_Fixed
(N
);
12421 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
12422 Expand_Convert_Float_To_Fixed
(N
);
12425 -- Case of array conversions
12427 -- Expansion of array conversions, add required length/range checks but
12428 -- only do this if there is no change of representation. For handling of
12429 -- this case, see Handle_Changed_Representation.
12431 elsif Is_Array_Type
(Target_Type
) then
12432 if Is_Constrained
(Target_Type
) then
12433 Apply_Length_Check
(Operand
, Target_Type
);
12435 -- If the object has an unconstrained array subtype with fixed
12436 -- lower bound, then sliding to that bound may be needed.
12438 if Is_Fixed_Lower_Bound_Array_Subtype
(Target_Type
) then
12439 Expand_Sliding_Conversion
(Operand
, Target_Type
);
12442 Apply_Range_Check
(Operand
, Target_Type
);
12445 Handle_Changed_Representation
;
12447 -- Case of conversions of discriminated types
12449 -- Add required discriminant checks if target is constrained. Again this
12450 -- change is skipped if we have a change of representation.
12452 elsif Has_Discriminants
(Target_Type
)
12453 and then Is_Constrained
(Target_Type
)
12455 Apply_Discriminant_Check
(Operand
, Target_Type
);
12456 Handle_Changed_Representation
;
12458 -- Case of all other record conversions. The only processing required
12459 -- is to check for a change of representation requiring the special
12460 -- assignment processing.
12462 elsif Is_Record_Type
(Target_Type
) then
12464 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12465 -- a derived Unchecked_Union type to an unconstrained type that is
12466 -- not Unchecked_Union if the operand lacks inferable discriminants.
12468 if Is_Derived_Type
(Operand_Type
)
12469 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
12470 and then not Is_Constrained
(Target_Type
)
12471 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
12472 and then not Has_Inferable_Discriminants
(Operand
)
12474 -- To prevent Gigi from generating illegal code, we generate a
12475 -- Program_Error node, but we give it the target type of the
12476 -- conversion (is this requirement documented somewhere ???)
12479 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
12480 Reason
=> PE_Unchecked_Union_Restriction
);
12483 Set_Etype
(PE
, Target_Type
);
12488 Handle_Changed_Representation
;
12491 -- Case of conversions of enumeration types
12493 elsif Is_Enumeration_Type
(Target_Type
) then
12495 -- Special processing is required if there is a change of
12496 -- representation (from enumeration representation clauses).
12498 if not Has_Compatible_Representation
(Target_Type
, Operand_Type
)
12499 and then not Conversion_OK
(N
)
12501 if Optimization_Level
> 0
12502 and then Is_Boolean_Type
(Target_Type
)
12504 -- Convert x(y) to (if y then x'(True) else x'(False)).
12505 -- Use literals, instead of indexing x'val, to enable
12506 -- further optimizations in the middle-end.
12509 Make_If_Expression
(Loc
,
12510 Expressions
=> New_List
(
12512 Convert_To
(Target_Type
,
12513 New_Occurrence_Of
(Standard_True
, Loc
)),
12514 Convert_To
(Target_Type
,
12515 New_Occurrence_Of
(Standard_False
, Loc
)))));
12518 -- Convert: x(y) to x'val (ytyp'pos (y))
12521 Make_Attribute_Reference
(Loc
,
12522 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
12523 Attribute_Name
=> Name_Val
,
12524 Expressions
=> New_List
(
12525 Make_Attribute_Reference
(Loc
,
12526 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
12527 Attribute_Name
=> Name_Pos
,
12528 Expressions
=> New_List
(Operand
)))));
12531 Analyze_And_Resolve
(N
, Target_Type
);
12535 -- At this stage, either the conversion node has been transformed into
12536 -- some other equivalent expression, or left as a conversion that can be
12537 -- handled by Gigi.
12539 -- The only remaining step is to generate a range check if we still have
12540 -- a type conversion at this stage and Do_Range_Check is set. Note that
12541 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12542 -- conversions here, because the float-to-integer case is entirely dealt
12543 -- with by Apply_Float_Conversion_Check.
12545 if Nkind
(N
) = N_Type_Conversion
12546 and then Do_Range_Check
(Expression
(N
))
12548 -- Float-to-float conversions
12550 if Is_Floating_Point_Type
(Target_Type
)
12551 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
12553 -- Reset overflow flag, since the range check will include
12554 -- dealing with possible overflow, and generate the check.
12556 Set_Do_Overflow_Check
(N
, False);
12558 Generate_Range_Check
12559 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
12561 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12562 -- conversions when Conversion_OK is set.
12564 elsif Is_Discrete_Type
(Target_Type
)
12565 and then (Is_Discrete_Type
(Etype
(Expression
(N
)))
12566 or else (Is_Fixed_Point_Type
(Etype
(Expression
(N
)))
12567 and then Conversion_OK
(N
)))
12569 -- If Address is either a source type or target type,
12570 -- suppress range check to avoid typing anomalies when
12571 -- it is a visible integer type.
12573 if Is_Descendant_Of_Address
(Etype
(Expression
(N
)))
12574 or else Is_Descendant_Of_Address
(Target_Type
)
12576 Set_Do_Range_Check
(Expression
(N
), False);
12578 Discrete_Range_Check
;
12581 -- Conversions to floating- or fixed-point when Conversion_OK is set
12583 elsif Is_Floating_Point_Type
(Target_Type
)
12584 or else (Is_Fixed_Point_Type
(Target_Type
)
12585 and then Conversion_OK
(N
))
12590 pragma Assert
(not Do_Range_Check
(Expression
(N
)));
12593 -- Here at end of processing
12596 -- Apply predicate check if required. Note that we can't just call
12597 -- Apply_Predicate_Check here, because the type looks right after
12598 -- the conversion and it would omit the check. The Comes_From_Source
12599 -- guard is necessary to prevent infinite recursions when we generate
12600 -- internal conversions for the purpose of checking predicates.
12602 -- A view conversion of a tagged object is an object and can appear
12603 -- in an assignment context, in which case no predicate check applies
12604 -- to the now-dead value.
12606 if Nkind
(Parent
(N
)) = N_Assignment_Statement
12607 and then N
= Name
(Parent
(N
))
12611 elsif Predicate_Enabled
(Target_Type
)
12612 and then Target_Type
/= Operand_Type
12613 and then Comes_From_Source
(N
)
12616 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
12619 -- Avoid infinite recursion on the subsequent expansion of the
12620 -- copy of the original type conversion. When needed, a range
12621 -- check has already been applied to the expression.
12623 Set_Comes_From_Source
(New_Expr
, False);
12625 Make_Predicate_Check
(Target_Type
, New_Expr
),
12626 Suppress
=> Range_Check
);
12629 end Expand_N_Type_Conversion
;
12631 -----------------------------------
12632 -- Expand_N_Unchecked_Expression --
12633 -----------------------------------
12635 -- Remove the unchecked expression node from the tree. Its job was simply
12636 -- to make sure that its constituent expression was handled with checks
12637 -- off, and now that is done, we can remove it from the tree, and indeed
12638 -- must, since Gigi does not expect to see these nodes.
12640 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
12641 Exp
: constant Node_Id
:= Expression
(N
);
12643 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
12645 end Expand_N_Unchecked_Expression
;
12647 ----------------------------------------
12648 -- Expand_N_Unchecked_Type_Conversion --
12649 ----------------------------------------
12651 -- If this cannot be handled by Gigi and we haven't already made a
12652 -- temporary for it, do it now.
12654 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
12655 Target_Type
: constant Entity_Id
:= Etype
(N
);
12656 Operand
: constant Node_Id
:= Expression
(N
);
12657 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12660 -- Nothing at all to do if conversion is to the identical type so remove
12661 -- the conversion completely, it is useless, except that it may carry
12662 -- an Assignment_OK indication which must be propagated to the operand.
12664 if Operand_Type
= Target_Type
then
12665 Expand_N_Unchecked_Expression
(N
);
12669 -- Generate an extra temporary for cases unsupported by the C backend
12671 if Modify_Tree_For_C
then
12673 Source
: constant Node_Id
:= Unqual_Conv
(Expression
(N
));
12674 Source_Typ
: Entity_Id
:= Get_Full_View
(Etype
(Source
));
12677 if Is_Packed_Array
(Source_Typ
) then
12678 Source_Typ
:= Packed_Array_Impl_Type
(Source_Typ
);
12681 if Nkind
(Source
) = N_Function_Call
12682 and then (Is_Composite_Type
(Etype
(Source
))
12683 or else Is_Composite_Type
(Target_Type
))
12685 Force_Evaluation
(Source
);
12690 -- Nothing to do if conversion is safe
12692 if Safe_Unchecked_Type_Conversion
(N
) then
12696 if Assignment_OK
(N
) then
12699 Force_Evaluation
(N
);
12701 end Expand_N_Unchecked_Type_Conversion
;
12703 ----------------------------
12704 -- Expand_Record_Equality --
12705 ----------------------------
12707 -- For non-variant records, Equality is expanded when needed into:
12709 -- and then Lhs.Discr1 = Rhs.Discr1
12711 -- and then Lhs.Discrn = Rhs.Discrn
12712 -- and then Lhs.Cmp1 = Rhs.Cmp1
12714 -- and then Lhs.Cmpn = Rhs.Cmpn
12716 -- The expression is folded by the back end for adjacent fields. This
12717 -- function is called for tagged record in only one occasion: for imple-
12718 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12719 -- otherwise the primitive "=" is used directly.
12721 function Expand_Record_Equality
12725 Rhs
: Node_Id
) return Node_Id
12727 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12732 First_Time
: Boolean := True;
12734 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
12735 -- Return the next discriminant or component to compare, starting with
12736 -- C, skipping inherited components.
12738 ------------------------
12739 -- Element_To_Compare --
12740 ------------------------
12742 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
12743 Comp
: Entity_Id
:= C
;
12746 while Present
(Comp
) loop
12747 -- Skip inherited components
12749 -- Note: for a tagged type, we always generate the "=" primitive
12750 -- for the base type (not on the first subtype), so the test for
12751 -- Comp /= Original_Record_Component (Comp) is True for inherited
12752 -- components only.
12754 if (Is_Tagged_Type
(Typ
)
12755 and then Comp
/= Original_Record_Component
(Comp
))
12759 or else Chars
(Comp
) = Name_uTag
12761 -- Skip interface elements (secondary tags???)
12763 or else Is_Interface
(Etype
(Comp
))
12765 Next_Component_Or_Discriminant
(Comp
);
12772 end Element_To_Compare
;
12774 -- Start of processing for Expand_Record_Equality
12777 -- Generates the following code: (assuming that Typ has one Discr and
12778 -- component C2 is also a record)
12780 -- Lhs.Discr1 = Rhs.Discr1
12781 -- and then Lhs.C1 = Rhs.C1
12782 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12784 -- and then Lhs.Cmpn = Rhs.Cmpn
12786 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
12787 C
:= Element_To_Compare
(First_Component_Or_Discriminant
(Typ
));
12788 while Present
(C
) loop
12799 New_Lhs
:= New_Copy_Tree
(Lhs
);
12800 New_Rhs
:= New_Copy_Tree
(Rhs
);
12804 Expand_Composite_Equality
12805 (Outer_Type
=> Typ
, Nod
=> Nod
, Comp_Type
=> Etype
(C
),
12807 Make_Selected_Component
(Loc
,
12809 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12811 Make_Selected_Component
(Loc
,
12813 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)));
12815 -- If some (sub)component is an unchecked_union, the whole
12816 -- operation will raise program error.
12818 if Nkind
(Check
) = N_Raise_Program_Error
then
12820 Set_Etype
(Result
, Standard_Boolean
);
12826 -- Generate logical "and" for CodePeer to simplify the
12827 -- generated code and analysis.
12829 elsif CodePeer_Mode
then
12832 Left_Opnd
=> Result
,
12833 Right_Opnd
=> Check
);
12837 Make_And_Then
(Loc
,
12838 Left_Opnd
=> Result
,
12839 Right_Opnd
=> Check
);
12844 First_Time
:= False;
12845 C
:= Element_To_Compare
(Next_Component_Or_Discriminant
(C
));
12849 end Expand_Record_Equality
;
12851 ---------------------------
12852 -- Expand_Set_Membership --
12853 ---------------------------
12855 procedure Expand_Set_Membership
(N
: Node_Id
) is
12856 Lop
: constant Node_Id
:= Left_Opnd
(N
);
12858 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
12859 -- If the alternative is a subtype mark, create a simple membership
12860 -- test. Otherwise create an equality test for it.
12866 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
12868 L
: constant Node_Id
:= New_Copy_Tree
(Lop
);
12869 R
: constant Node_Id
:= Relocate_Node
(Alt
);
12872 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
12873 or else Nkind
(Alt
) = N_Range
12875 Cond
:= Make_In
(Sloc
(Alt
), Left_Opnd
=> L
, Right_Opnd
=> R
);
12878 Cond
:= Make_Op_Eq
(Sloc
(Alt
), Left_Opnd
=> L
, Right_Opnd
=> R
);
12879 Resolve_Membership_Equality
(Cond
, Etype
(Alt
));
12888 Res
: Node_Id
:= Empty
;
12890 -- Start of processing for Expand_Set_Membership
12893 Remove_Side_Effects
(Lop
);
12895 -- We use left associativity as in the equivalent boolean case. This
12896 -- kind of canonicalization helps the optimizer of the code generator.
12898 Alt
:= First
(Alternatives
(N
));
12899 while Present
(Alt
) loop
12900 Evolve_Or_Else
(Res
, Make_Cond
(Alt
));
12905 Analyze_And_Resolve
(N
, Standard_Boolean
);
12906 end Expand_Set_Membership
;
12908 -----------------------------------
12909 -- Expand_Short_Circuit_Operator --
12910 -----------------------------------
12912 -- Deal with special expansion if actions are present for the right operand
12913 -- and deal with optimizing case of arguments being True or False. We also
12914 -- deal with the special case of non-standard boolean values.
12916 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
12917 Loc
: constant Source_Ptr
:= Sloc
(N
);
12918 Typ
: constant Entity_Id
:= Etype
(N
);
12919 Left
: constant Node_Id
:= Left_Opnd
(N
);
12920 Right
: constant Node_Id
:= Right_Opnd
(N
);
12921 LocR
: constant Source_Ptr
:= Sloc
(Right
);
12924 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
12925 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
12926 -- If Left = Shortcut_Value then Right need not be evaluated
12928 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
12929 -- For Opnd a boolean expression, return a Boolean expression equivalent
12930 -- to Opnd /= Shortcut_Value.
12932 function Useful
(Actions
: List_Id
) return Boolean;
12933 -- Return True if Actions is not empty and contains useful nodes to
12936 --------------------
12937 -- Make_Test_Expr --
12938 --------------------
12940 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
12942 if Shortcut_Value
then
12943 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
12947 end Make_Test_Expr
;
12953 function Useful
(Actions
: List_Id
) return Boolean is
12956 if Present
(Actions
) then
12957 L
:= First
(Actions
);
12959 -- For now "useful" means not N_Variable_Reference_Marker.
12960 -- Consider stripping other nodes in the future.
12962 while Present
(L
) loop
12963 if Nkind
(L
) /= N_Variable_Reference_Marker
then
12976 Op_Var
: Entity_Id
;
12977 -- Entity for a temporary variable holding the value of the operator,
12978 -- used for expansion in the case where actions are present.
12980 -- Start of processing for Expand_Short_Circuit_Operator
12983 -- Deal with non-standard booleans
12985 if Is_Boolean_Type
(Typ
) then
12986 Adjust_Condition
(Left
);
12987 Adjust_Condition
(Right
);
12988 Set_Etype
(N
, Standard_Boolean
);
12991 -- Check for cases where left argument is known to be True or False
12993 if Compile_Time_Known_Value
(Left
) then
12995 -- Mark SCO for left condition as compile time known
12997 if Generate_SCO
and then Comes_From_Source
(Left
) then
12998 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
13001 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
13002 -- Any actions associated with Right will be executed unconditionally
13003 -- and can thus be inserted into the tree unconditionally.
13005 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
13006 if Present
(Actions
(N
)) then
13007 Insert_Actions
(N
, Actions
(N
));
13010 Rewrite
(N
, Right
);
13012 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
13013 -- In this case we can forget the actions associated with Right,
13014 -- since they will never be executed.
13017 Kill_Dead_Code
(Right
);
13018 Kill_Dead_Code
(Actions
(N
));
13019 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
13022 Adjust_Result_Type
(N
, Typ
);
13026 -- If Actions are present for the right operand, we have to do some
13027 -- special processing. We can't just let these actions filter back into
13028 -- code preceding the short circuit (which is what would have happened
13029 -- if we had not trapped them in the short-circuit form), since they
13030 -- must only be executed if the right operand of the short circuit is
13031 -- executed and not otherwise.
13033 if Useful
(Actions
(N
)) then
13034 Actlist
:= Actions
(N
);
13036 -- The old approach is to expand:
13038 -- left AND THEN right
13042 -- C : Boolean := False;
13050 -- and finally rewrite the operator into a reference to C. Similarly
13051 -- for left OR ELSE right, with negated values. Note that this
13052 -- rewrite causes some difficulties for coverage analysis because
13053 -- of the introduction of the new variable C, which obscures the
13054 -- structure of the test.
13056 -- We use this "old approach" if Minimize_Expression_With_Actions
13059 if Minimize_Expression_With_Actions
then
13060 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
13063 Make_Object_Declaration
(Loc
,
13064 Defining_Identifier
=> Op_Var
,
13065 Object_Definition
=>
13066 New_Occurrence_Of
(Standard_Boolean
, Loc
),
13068 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
13070 Append_To
(Actlist
,
13071 Make_Implicit_If_Statement
(Right
,
13072 Condition
=> Make_Test_Expr
(Right
),
13073 Then_Statements
=> New_List
(
13074 Make_Assignment_Statement
(LocR
,
13075 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
13078 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
13081 Make_Implicit_If_Statement
(Left
,
13082 Condition
=> Make_Test_Expr
(Left
),
13083 Then_Statements
=> Actlist
));
13085 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
13086 Analyze_And_Resolve
(N
, Standard_Boolean
);
13088 -- The new approach (the default) is to use an
13089 -- Expression_With_Actions node for the right operand of the
13090 -- short-circuit form. Note that this solves the traceability
13091 -- problems for coverage analysis.
13095 Make_Expression_With_Actions
(LocR
,
13096 Expression
=> Relocate_Node
(Right
),
13097 Actions
=> Actlist
));
13099 Set_Actions
(N
, No_List
);
13100 Analyze_And_Resolve
(Right
, Standard_Boolean
);
13103 Adjust_Result_Type
(N
, Typ
);
13107 -- No actions present, check for cases of right argument True/False
13109 if Compile_Time_Known_Value
(Right
) then
13111 -- Mark SCO for left condition as compile time known
13113 if Generate_SCO
and then Comes_From_Source
(Right
) then
13114 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
13117 -- Change (Left and then True), (Left or else False) to Left. Note
13118 -- that we know there are no actions associated with the right
13119 -- operand, since we just checked for this case above.
13121 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
13124 -- Change (Left and then False), (Left or else True) to Right,
13125 -- making sure to preserve any side effects associated with the Left
13129 Remove_Side_Effects
(Left
);
13130 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
13134 Adjust_Result_Type
(N
, Typ
);
13135 end Expand_Short_Circuit_Operator
;
13137 -------------------------------------
13138 -- Expand_Unchecked_Union_Equality --
13139 -------------------------------------
13141 procedure Expand_Unchecked_Union_Equality
(N
: Node_Id
) is
13142 Loc
: constant Source_Ptr
:= Sloc
(N
);
13143 Eq
: constant Entity_Id
:= Entity
(Name
(N
));
13144 Lhs
: constant Node_Id
:= First_Actual
(N
);
13145 Rhs
: constant Node_Id
:= Next_Actual
(Lhs
);
13147 function Get_Discr_Values
(Op
: Node_Id
; Lhs
: Boolean) return Elist_Id
;
13148 -- Return the list of inferred discriminant values for Op
13150 ----------------------
13151 -- Get_Discr_Values --
13152 ----------------------
13154 function Get_Discr_Values
(Op
: Node_Id
; Lhs
: Boolean) return Elist_Id
13156 Typ
: constant Entity_Id
:= Etype
(Op
);
13157 Values
: constant Elist_Id
:= New_Elmt_List
;
13159 function Get_Extra_Formal
(Nam
: Name_Id
) return Entity_Id
;
13160 -- Return the extra formal Nam from the current scope, which must be
13161 -- an equality function for an unchecked union type.
13163 ----------------------
13164 -- Get_Extra_Formal --
13165 ----------------------
13167 function Get_Extra_Formal
(Nam
: Name_Id
) return Entity_Id
is
13168 Func
: constant Entity_Id
:= Current_Scope
;
13170 Formal
: Entity_Id
;
13173 pragma Assert
(Ekind
(Func
) = E_Function
);
13175 Formal
:= Extra_Formals
(Func
);
13176 while Present
(Formal
) loop
13177 if Chars
(Formal
) = Nam
then
13181 Formal
:= Extra_Formal
(Formal
);
13184 -- An extra formal of the proper name must be found
13186 raise Program_Error
;
13187 end Get_Extra_Formal
;
13193 -- Start of processing for Get_Discr_Values
13196 -- Per-object constrained selected components require special
13197 -- attention. If the enclosing scope of the component is an
13198 -- Unchecked_Union, we cannot reference its discriminants
13199 -- directly. This is why we use the extra parameters of the
13200 -- equality function of the enclosing Unchecked_Union.
13202 -- type UU_Type (Discr : Integer := 0) is
13205 -- pragma Unchecked_Union (UU_Type);
13207 -- 1. Unchecked_Union enclosing record:
13209 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
13211 -- Comp : UU_Type (Discr);
13213 -- end Enclosing_UU_Type;
13214 -- pragma Unchecked_Union (Enclosing_UU_Type);
13216 -- Obj1 : Enclosing_UU_Type;
13217 -- Obj2 : Enclosing_UU_Type (1);
13219 -- [. . .] Obj1 = Obj2 [. . .]
13223 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
13225 -- A and B are the formal parameters of the equality function
13226 -- of Enclosing_UU_Type. The function always has two extra
13227 -- formals to capture the inferred discriminant values for
13228 -- each discriminant of the type.
13230 -- 2. Non-Unchecked_Union enclosing record:
13233 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
13236 -- Comp : UU_Type (Discr);
13238 -- end Enclosing_Non_UU_Type;
13240 -- Obj1 : Enclosing_Non_UU_Type;
13241 -- Obj2 : Enclosing_Non_UU_Type (1);
13243 -- ... Obj1 = Obj2 ...
13247 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
13248 -- obj1.discr, obj2.discr)) then
13250 -- In this case we can directly reference the discriminants of
13251 -- the enclosing record.
13253 if Nkind
(Op
) = N_Selected_Component
13254 and then Has_Per_Object_Constraint
(Entity
(Selector_Name
(Op
)))
13256 -- If enclosing record is an Unchecked_Union, use formals
13257 -- corresponding to each discriminant. The name of the
13258 -- formal is that of the discriminant, with added suffix,
13259 -- see Exp_Ch3.Build_Variant_Record_Equality for details.
13261 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Op
)))) then
13264 (Scope
(Entity
(Selector_Name
(Op
))));
13265 while Present
(Discr
) loop
13270 (Chars
(Discr
), (if Lhs
then 'A' else 'B'))), Loc
),
13272 Next_Discriminant
(Discr
);
13275 -- If enclosing record is of a non-Unchecked_Union type, it
13276 -- is possible to reference its discriminants directly.
13279 Discr
:= First_Discriminant
(Typ
);
13280 while Present
(Discr
) loop
13282 (Make_Selected_Component
(Loc
,
13283 Prefix
=> Prefix
(Op
),
13286 (Get_Discriminant_Value
(Discr
,
13288 Stored_Constraint
(Typ
)))),
13290 Next_Discriminant
(Discr
);
13294 -- Otherwise operand is on object with a constrained type.
13295 -- Infer the discriminant values from the constraint.
13298 Discr
:= First_Discriminant
(Typ
);
13299 while Present
(Discr
) loop
13302 (Get_Discriminant_Value
(Discr
,
13304 Stored_Constraint
(Typ
))),
13306 Next_Discriminant
(Discr
);
13311 end Get_Discr_Values
;
13313 -- Start of processing for Expand_Unchecked_Union_Equality
13316 -- Guard against repeated invocation on the same node
13318 if Present
(Next_Actual
(Rhs
)) then
13322 -- If we can infer the discriminants of the operands, make a call to Eq
13324 if Has_Inferable_Discriminants
(Lhs
)
13326 Has_Inferable_Discriminants
(Rhs
)
13329 Lhs_Values
: constant Elist_Id
:= Get_Discr_Values
(Lhs
, True);
13330 Rhs_Values
: constant Elist_Id
:= Get_Discr_Values
(Rhs
, False);
13332 Formal
: Entity_Id
;
13337 -- Add the inferred discriminant values as extra actuals
13339 Formal
:= Extra_Formals
(Eq
);
13340 L_Elmt
:= First_Elmt
(Lhs_Values
);
13341 R_Elmt
:= First_Elmt
(Rhs_Values
);
13343 while Present
(L_Elmt
) loop
13344 Analyze_And_Resolve
(Node
(L_Elmt
), Etype
(Formal
));
13345 Add_Extra_Actual_To_Call
(N
, Formal
, Node
(L_Elmt
));
13347 Formal
:= Extra_Formal
(Formal
);
13349 Analyze_And_Resolve
(Node
(R_Elmt
), Etype
(Formal
));
13350 Add_Extra_Actual_To_Call
(N
, Formal
, Node
(R_Elmt
));
13352 Formal
:= Extra_Formal
(Formal
);
13353 Next_Elmt
(L_Elmt
);
13354 Next_Elmt
(R_Elmt
);
13358 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
13359 -- the predefined equality operator for an Unchecked_Union type
13360 -- if either of the operands lack inferable discriminants.
13364 Make_Raise_Program_Error
(Loc
,
13365 Reason
=> PE_Unchecked_Union_Restriction
));
13367 -- Give a warning on source equalities only, otherwise the message
13368 -- may appear out of place due to internal use. It is unconditional
13369 -- because it is required by the language.
13371 if Comes_From_Source
(Original_Node
(N
)) then
13373 ("Unchecked_Union discriminants cannot be determined??", N
);
13375 ("\Program_Error will be raised for equality operation??", N
);
13378 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
13380 end Expand_Unchecked_Union_Equality
;
13382 ------------------------------------
13383 -- Fixup_Universal_Fixed_Operation --
13384 -------------------------------------
13386 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
13387 Conv
: constant Node_Id
:= Parent
(N
);
13390 -- We must have a type conversion immediately above us
13392 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
13394 -- Normally the type conversion gives our target type. The exception
13395 -- occurs in the case of the Round attribute, where the conversion
13396 -- will be to universal real, and our real type comes from the Round
13397 -- attribute (as well as an indication that we must round the result)
13399 if Etype
(Conv
) = Universal_Real
13400 and then Nkind
(Parent
(Conv
)) = N_Attribute_Reference
13401 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
13403 Set_Etype
(N
, Base_Type
(Etype
(Parent
(Conv
))));
13404 Set_Rounded_Result
(N
);
13406 -- Normal case where type comes from conversion above us
13409 Set_Etype
(N
, Base_Type
(Etype
(Conv
)));
13411 end Fixup_Universal_Fixed_Operation
;
13413 ----------------------------
13414 -- Get_First_Index_Bounds --
13415 ----------------------------
13417 procedure Get_First_Index_Bounds
(T
: Entity_Id
; Lo
, Hi
: out Uint
) is
13421 pragma Assert
(Is_Array_Type
(T
));
13423 -- This follows Sem_Eval.Compile_Time_Known_Bounds
13425 if Ekind
(T
) = E_String_Literal_Subtype
then
13426 Lo
:= Expr_Value
(String_Literal_Low_Bound
(T
));
13427 Hi
:= Lo
+ String_Literal_Length
(T
) - 1;
13430 Typ
:= Underlying_Type
(Etype
(First_Index
(T
)));
13432 Lo
:= Expr_Value
(Type_Low_Bound
(Typ
));
13433 Hi
:= Expr_Value
(Type_High_Bound
(Typ
));
13435 end Get_First_Index_Bounds
;
13437 ------------------------
13438 -- Get_Size_For_Range --
13439 ------------------------
13441 function Get_Size_For_Range
(Lo
, Hi
: Uint
) return Uint
is
13443 function Is_OK_For_Range
(Siz
: Uint
) return Boolean;
13444 -- Return True if a signed integer with given size can cover Lo .. Hi
13446 --------------------------
13447 -- Is_OK_For_Range --
13448 --------------------------
13450 function Is_OK_For_Range
(Siz
: Uint
) return Boolean is
13451 B
: constant Uint
:= Uint_2
** (Siz
- 1);
13454 -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
13456 return Lo
>= -B
and then Hi
>= -B
and then Lo
< B
and then Hi
< B
;
13457 end Is_OK_For_Range
;
13460 -- This is (almost always) the size of Integer
13462 if Is_OK_For_Range
(Uint_32
) then
13467 elsif Is_OK_For_Range
(Uint_63
) then
13470 -- This is (almost always) the size of Long_Long_Integer
13472 elsif Is_OK_For_Range
(Uint_64
) then
13477 elsif Is_OK_For_Range
(Uint_127
) then
13483 end Get_Size_For_Range
;
13485 -------------------------------
13486 -- Insert_Dereference_Action --
13487 -------------------------------
13489 procedure Insert_Dereference_Action
(N
: Node_Id
) is
13490 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
13491 -- Return true if type of P is derived from Checked_Pool;
13493 -----------------------------
13494 -- Is_Checked_Storage_Pool --
13495 -----------------------------
13497 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
13506 while T
/= Etype
(T
) loop
13507 if Is_RTE
(T
, RE_Checked_Pool
) then
13515 end Is_Checked_Storage_Pool
;
13519 Context
: constant Node_Id
:= Parent
(N
);
13520 Ptr_Typ
: constant Entity_Id
:= Etype
(N
);
13521 Desig_Typ
: constant Entity_Id
:=
13522 Available_View
(Designated_Type
(Ptr_Typ
));
13523 Loc
: constant Source_Ptr
:= Sloc
(N
);
13524 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
13530 Size_Bits
: Node_Id
;
13533 -- Start of processing for Insert_Dereference_Action
13536 pragma Assert
(Nkind
(Context
) = N_Explicit_Dereference
);
13538 -- Do not re-expand a dereference which has already been processed by
13541 if Has_Dereference_Action
(Context
) then
13544 -- Do not perform this type of expansion for internally-generated
13547 elsif not Comes_From_Source
(Original_Node
(Context
)) then
13550 -- A dereference action is only applicable to objects which have been
13551 -- allocated on a checked pool.
13553 elsif not Is_Checked_Storage_Pool
(Pool
) then
13557 -- Extract the address of the dereferenced object. Generate:
13559 -- Addr : System.Address := <N>'Pool_Address;
13561 Addr
:= Make_Temporary
(Loc
, 'P');
13564 Make_Object_Declaration
(Loc
,
13565 Defining_Identifier
=> Addr
,
13566 Object_Definition
=>
13567 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
13569 Make_Attribute_Reference
(Loc
,
13570 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
13571 Attribute_Name
=> Name_Pool_Address
)));
13573 -- Calculate the size of the dereferenced object. Generate:
13575 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13578 Make_Explicit_Dereference
(Loc
,
13579 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13580 Set_Has_Dereference_Action
(Deref
);
13583 Make_Attribute_Reference
(Loc
,
13585 Attribute_Name
=> Name_Size
);
13587 -- Special case of an unconstrained array: need to add descriptor size
13589 if Is_Array_Type
(Desig_Typ
)
13590 and then not Is_Constrained
(First_Subtype
(Desig_Typ
))
13595 Make_Attribute_Reference
(Loc
,
13597 New_Occurrence_Of
(First_Subtype
(Desig_Typ
), Loc
),
13598 Attribute_Name
=> Name_Descriptor_Size
),
13599 Right_Opnd
=> Size_Bits
);
13602 Size
:= Make_Temporary
(Loc
, 'S');
13604 Make_Object_Declaration
(Loc
,
13605 Defining_Identifier
=> Size
,
13606 Object_Definition
=>
13607 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13609 Make_Op_Divide
(Loc
,
13610 Left_Opnd
=> Size_Bits
,
13611 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
13613 -- Calculate the alignment of the dereferenced object. Generate:
13614 -- Alig : constant Storage_Count := <N>.all'Alignment;
13617 Make_Explicit_Dereference
(Loc
,
13618 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13619 Set_Has_Dereference_Action
(Deref
);
13621 Alig
:= Make_Temporary
(Loc
, 'A');
13623 Make_Object_Declaration
(Loc
,
13624 Defining_Identifier
=> Alig
,
13625 Object_Definition
=>
13626 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13628 Make_Attribute_Reference
(Loc
,
13630 Attribute_Name
=> Name_Alignment
)));
13632 -- A dereference of a controlled object requires special processing. The
13633 -- finalization machinery requests additional space from the underlying
13634 -- pool to allocate and hide two pointers. As a result, a checked pool
13635 -- may mark the wrong memory as valid. Since checked pools do not have
13636 -- knowledge of hidden pointers, we have to bring the two pointers back
13637 -- in view in order to restore the original state of the object.
13639 -- The address manipulation is not performed for access types that are
13640 -- subject to pragma No_Heap_Finalization because the two pointers do
13641 -- not exist in the first place.
13643 if No_Heap_Finalization
(Ptr_Typ
) then
13646 elsif Needs_Finalization
(Desig_Typ
) then
13648 -- Adjust the address and size of the dereferenced object. Generate:
13649 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13652 Make_Procedure_Call_Statement
(Loc
,
13654 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
13655 Parameter_Associations
=> New_List
(
13656 New_Occurrence_Of
(Addr
, Loc
),
13657 New_Occurrence_Of
(Size
, Loc
),
13658 New_Occurrence_Of
(Alig
, Loc
)));
13660 -- Class-wide types complicate things because we cannot determine
13661 -- statically whether the actual object is truly controlled. We must
13662 -- generate a runtime check to detect this property. Generate:
13664 -- if Needs_Finalization (<N>.all'Tag) then
13668 if Is_Class_Wide_Type
(Desig_Typ
) then
13670 Make_Explicit_Dereference
(Loc
,
13671 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13672 Set_Has_Dereference_Action
(Deref
);
13675 Make_Implicit_If_Statement
(N
,
13677 Make_Function_Call
(Loc
,
13679 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
13680 Parameter_Associations
=> New_List
(
13681 Make_Attribute_Reference
(Loc
,
13683 Attribute_Name
=> Name_Tag
))),
13684 Then_Statements
=> New_List
(Stmt
));
13687 Insert_Action
(N
, Stmt
);
13691 -- Dereference (Pool, Addr, Size, Alig);
13694 Make_Procedure_Call_Statement
(Loc
,
13697 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
13698 Parameter_Associations
=> New_List
(
13699 New_Occurrence_Of
(Pool
, Loc
),
13700 New_Occurrence_Of
(Addr
, Loc
),
13701 New_Occurrence_Of
(Size
, Loc
),
13702 New_Occurrence_Of
(Alig
, Loc
))));
13704 -- Mark the explicit dereference as processed to avoid potential
13705 -- infinite expansion.
13707 Set_Has_Dereference_Action
(Context
);
13710 when RE_Not_Available
=>
13712 end Insert_Dereference_Action
;
13714 --------------------------------
13715 -- Integer_Promotion_Possible --
13716 --------------------------------
13718 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
13719 Operand
: constant Node_Id
:= Expression
(N
);
13720 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
13721 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
13724 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
13728 -- We only do the transformation for source constructs. We assume
13729 -- that the expander knows what it is doing when it generates code.
13731 Comes_From_Source
(N
)
13733 -- If the operand type is Short_Integer or Short_Short_Integer,
13734 -- then we will promote to Integer, which is available on all
13735 -- targets, and is sufficient to ensure no intermediate overflow.
13736 -- Furthermore it is likely to be as efficient or more efficient
13737 -- than using the smaller type for the computation so we do this
13738 -- unconditionally.
13741 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
13743 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
13745 -- Test for interesting operation, which includes addition,
13746 -- division, exponentiation, multiplication, subtraction, absolute
13747 -- value and unary negation. Unary "+" is omitted since it is a
13748 -- no-op and thus can't overflow.
13750 and then Nkind
(Operand
) in
13751 N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
13752 N_Op_Minus | N_Op_Multiply | N_Op_Subtract
;
13753 end Integer_Promotion_Possible
;
13755 ------------------------------
13756 -- Make_Array_Comparison_Op --
13757 ------------------------------
13759 -- This is a hand-coded expansion of the following generic function:
13762 -- type elem is (<>);
13763 -- type index is (<>);
13764 -- type a is array (index range <>) of elem;
13766 -- function Gnnn (X : a; Y: a) return boolean is
13767 -- J : index := Y'first;
13770 -- if X'length = 0 then
13773 -- elsif Y'length = 0 then
13777 -- for I in X'range loop
13778 -- if X (I) = Y (J) then
13779 -- if J = Y'last then
13782 -- J := index'succ (J);
13786 -- return X (I) > Y (J);
13790 -- return X'length > Y'length;
13794 -- Note that since we are essentially doing this expansion by hand, we
13795 -- do not need to generate an actual or formal generic part, just the
13796 -- instantiated function itself.
13798 function Make_Array_Comparison_Op
13800 Nod
: Node_Id
) return Node_Id
13802 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
13804 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
13805 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
13806 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
13807 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13809 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
13811 Loop_Statement
: Node_Id
;
13812 Loop_Body
: Node_Id
;
13814 Inner_If
: Node_Id
;
13815 Final_Expr
: Node_Id
;
13816 Func_Body
: Node_Id
;
13817 Func_Name
: Entity_Id
;
13823 -- if J = Y'last then
13826 -- J := index'succ (J);
13830 Make_Implicit_If_Statement
(Nod
,
13833 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
13835 Make_Attribute_Reference
(Loc
,
13836 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13837 Attribute_Name
=> Name_Last
)),
13839 Then_Statements
=> New_List
(
13840 Make_Exit_Statement
(Loc
)),
13844 Make_Assignment_Statement
(Loc
,
13845 Name
=> New_Occurrence_Of
(J
, Loc
),
13847 Make_Attribute_Reference
(Loc
,
13848 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
13849 Attribute_Name
=> Name_Succ
,
13850 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
13852 -- if X (I) = Y (J) then
13855 -- return X (I) > Y (J);
13859 Make_Implicit_If_Statement
(Nod
,
13863 Make_Indexed_Component
(Loc
,
13864 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13865 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13868 Make_Indexed_Component
(Loc
,
13869 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13870 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
13872 Then_Statements
=> New_List
(Inner_If
),
13874 Else_Statements
=> New_List
(
13875 Make_Simple_Return_Statement
(Loc
,
13879 Make_Indexed_Component
(Loc
,
13880 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13881 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13884 Make_Indexed_Component
(Loc
,
13885 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13886 Expressions
=> New_List
(
13887 New_Occurrence_Of
(J
, Loc
)))))));
13889 -- for I in X'range loop
13894 Make_Implicit_Loop_Statement
(Nod
,
13895 Identifier
=> Empty
,
13897 Iteration_Scheme
=>
13898 Make_Iteration_Scheme
(Loc
,
13899 Loop_Parameter_Specification
=>
13900 Make_Loop_Parameter_Specification
(Loc
,
13901 Defining_Identifier
=> I
,
13902 Discrete_Subtype_Definition
=>
13903 Make_Attribute_Reference
(Loc
,
13904 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13905 Attribute_Name
=> Name_Range
))),
13907 Statements
=> New_List
(Loop_Body
));
13909 -- if X'length = 0 then
13911 -- elsif Y'length = 0 then
13914 -- for ... loop ... end loop;
13915 -- return X'length > Y'length;
13919 Make_Attribute_Reference
(Loc
,
13920 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13921 Attribute_Name
=> Name_Length
);
13924 Make_Attribute_Reference
(Loc
,
13925 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13926 Attribute_Name
=> Name_Length
);
13930 Left_Opnd
=> Length1
,
13931 Right_Opnd
=> Length2
);
13934 Make_Implicit_If_Statement
(Nod
,
13938 Make_Attribute_Reference
(Loc
,
13939 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13940 Attribute_Name
=> Name_Length
),
13942 Make_Integer_Literal
(Loc
, 0)),
13946 Make_Simple_Return_Statement
(Loc
,
13947 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
13949 Elsif_Parts
=> New_List
(
13950 Make_Elsif_Part
(Loc
,
13954 Make_Attribute_Reference
(Loc
,
13955 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13956 Attribute_Name
=> Name_Length
),
13958 Make_Integer_Literal
(Loc
, 0)),
13962 Make_Simple_Return_Statement
(Loc
,
13963 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
13965 Else_Statements
=> New_List
(
13967 Make_Simple_Return_Statement
(Loc
,
13968 Expression
=> Final_Expr
)));
13972 Formals
:= New_List
(
13973 Make_Parameter_Specification
(Loc
,
13974 Defining_Identifier
=> X
,
13975 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13977 Make_Parameter_Specification
(Loc
,
13978 Defining_Identifier
=> Y
,
13979 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13981 -- function Gnnn (...) return boolean is
13982 -- J : index := Y'first;
13987 Func_Name
:= Make_Temporary
(Loc
, 'G');
13990 Make_Subprogram_Body
(Loc
,
13992 Make_Function_Specification
(Loc
,
13993 Defining_Unit_Name
=> Func_Name
,
13994 Parameter_Specifications
=> Formals
,
13995 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
13997 Declarations
=> New_List
(
13998 Make_Object_Declaration
(Loc
,
13999 Defining_Identifier
=> J
,
14000 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
14002 Make_Attribute_Reference
(Loc
,
14003 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
14004 Attribute_Name
=> Name_First
))),
14006 Handled_Statement_Sequence
=>
14007 Make_Handled_Sequence_Of_Statements
(Loc
,
14008 Statements
=> New_List
(If_Stat
)));
14011 end Make_Array_Comparison_Op
;
14013 ---------------------------
14014 -- Make_Boolean_Array_Op --
14015 ---------------------------
14017 -- For logical operations on boolean arrays, expand in line the following,
14018 -- replacing 'and' with 'or' or 'xor' where needed:
14020 -- function Annn (A : typ; B: typ) return typ is
14023 -- for J in A'range loop
14024 -- C (J) := A (J) op B (J);
14029 -- or in the case of Transform_Function_Array:
14031 -- procedure Annn (A : typ; B: typ; RESULT: out typ) is
14033 -- for J in A'range loop
14034 -- RESULT (J) := A (J) op B (J);
14038 -- Here typ is the boolean array type
14040 function Make_Boolean_Array_Op
14042 N
: Node_Id
) return Node_Id
14044 Loc
: constant Source_Ptr
:= Sloc
(N
);
14046 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
14047 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
14048 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
14058 Func_Name
: Entity_Id
;
14059 Func_Body
: Node_Id
;
14060 Loop_Statement
: Node_Id
;
14063 if Transform_Function_Array
then
14064 C
:= Make_Defining_Identifier
(Loc
, Name_UP_RESULT
);
14066 C
:= Make_Defining_Identifier
(Loc
, Name_uC
);
14070 Make_Indexed_Component
(Loc
,
14071 Prefix
=> New_Occurrence_Of
(A
, Loc
),
14072 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14075 Make_Indexed_Component
(Loc
,
14076 Prefix
=> New_Occurrence_Of
(B
, Loc
),
14077 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14080 Make_Indexed_Component
(Loc
,
14081 Prefix
=> New_Occurrence_Of
(C
, Loc
),
14082 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14084 if Nkind
(N
) = N_Op_And
then
14088 Right_Opnd
=> B_J
);
14090 elsif Nkind
(N
) = N_Op_Or
then
14094 Right_Opnd
=> B_J
);
14100 Right_Opnd
=> B_J
);
14104 Make_Implicit_Loop_Statement
(N
,
14105 Identifier
=> Empty
,
14107 Iteration_Scheme
=>
14108 Make_Iteration_Scheme
(Loc
,
14109 Loop_Parameter_Specification
=>
14110 Make_Loop_Parameter_Specification
(Loc
,
14111 Defining_Identifier
=> J
,
14112 Discrete_Subtype_Definition
=>
14113 Make_Attribute_Reference
(Loc
,
14114 Prefix
=> New_Occurrence_Of
(A
, Loc
),
14115 Attribute_Name
=> Name_Range
))),
14117 Statements
=> New_List
(
14118 Make_Assignment_Statement
(Loc
,
14120 Expression
=> Op
)));
14122 Formals
:= New_List
(
14123 Make_Parameter_Specification
(Loc
,
14124 Defining_Identifier
=> A
,
14125 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
14127 Make_Parameter_Specification
(Loc
,
14128 Defining_Identifier
=> B
,
14129 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
14131 if Transform_Function_Array
then
14132 Append_To
(Formals
,
14133 Make_Parameter_Specification
(Loc
,
14134 Defining_Identifier
=> C
,
14135 Out_Present
=> True,
14136 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
14139 Func_Name
:= Make_Temporary
(Loc
, 'A');
14140 Set_Is_Inlined
(Func_Name
);
14142 if Transform_Function_Array
then
14144 Make_Subprogram_Body
(Loc
,
14146 Make_Procedure_Specification
(Loc
,
14147 Defining_Unit_Name
=> Func_Name
,
14148 Parameter_Specifications
=> Formals
),
14150 Declarations
=> New_List
,
14152 Handled_Statement_Sequence
=>
14153 Make_Handled_Sequence_Of_Statements
(Loc
,
14154 Statements
=> New_List
(Loop_Statement
)));
14158 Make_Subprogram_Body
(Loc
,
14160 Make_Function_Specification
(Loc
,
14161 Defining_Unit_Name
=> Func_Name
,
14162 Parameter_Specifications
=> Formals
,
14163 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
14165 Declarations
=> New_List
(
14166 Make_Object_Declaration
(Loc
,
14167 Defining_Identifier
=> C
,
14168 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
14170 Handled_Statement_Sequence
=>
14171 Make_Handled_Sequence_Of_Statements
(Loc
,
14172 Statements
=> New_List
(
14174 Make_Simple_Return_Statement
(Loc
,
14175 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
14179 end Make_Boolean_Array_Op
;
14181 -----------------------------------------
14182 -- Minimized_Eliminated_Overflow_Check --
14183 -----------------------------------------
14185 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
14187 -- The MINIMIZED mode operates in Long_Long_Integer so we cannot use it
14188 -- if the type of the expression is already larger.
14191 Is_Signed_Integer_Type
(Etype
(N
))
14192 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
14193 and then not (Overflow_Check_Mode
= Minimized
14195 Esize
(Etype
(N
)) > Standard_Long_Long_Integer_Size
);
14196 end Minimized_Eliminated_Overflow_Check
;
14198 ----------------------------
14199 -- Narrow_Large_Operation --
14200 ----------------------------
14202 procedure Narrow_Large_Operation
(N
: Node_Id
) is
14203 Kind
: constant Node_Kind
:= Nkind
(N
);
14204 Otyp
: constant Entity_Id
:= Etype
(N
);
14205 In_Rng
: constant Boolean := Kind
= N_In
;
14206 Binary
: constant Boolean := Kind
in N_Binary_Op
or else In_Rng
;
14207 Compar
: constant Boolean := Kind
in N_Op_Compare
or else In_Rng
;
14208 R
: constant Node_Id
:= Right_Opnd
(N
);
14209 Typ
: constant Entity_Id
:= Etype
(R
);
14210 Tsiz
: constant Uint
:= RM_Size
(Typ
);
14224 -- Start of processing for Narrow_Large_Operation
14227 -- First, determine the range of the left operand, if any
14230 L
:= Left_Opnd
(N
);
14231 Determine_Range
(L
, OK
, Llo
, Lhi
, Assume_Valid
=> True);
14242 -- Second, determine the range of the right operand, which can itself
14243 -- be a range, in which case we take the lower bound of the low bound
14244 -- and the upper bound of the high bound.
14252 (Low_Bound
(R
), OK
, Rlo
, Zhi
, Assume_Valid
=> True);
14258 (High_Bound
(R
), OK
, Zlo
, Rhi
, Assume_Valid
=> True);
14265 Determine_Range
(R
, OK
, Rlo
, Rhi
, Assume_Valid
=> True);
14271 -- Then compute a size suitable for each range
14274 Lsiz
:= Get_Size_For_Range
(Llo
, Lhi
);
14279 Rsiz
:= Get_Size_For_Range
(Rlo
, Rhi
);
14281 -- Now compute the size of the narrower type
14284 -- The type must be able to accommodate the operands
14286 Nsiz
:= UI_Max
(Lsiz
, Rsiz
);
14289 -- The type must be able to accommodate the operand(s) and result.
14291 -- Note that Determine_Range typically does not report the bounds of
14292 -- the value as being larger than those of the base type, which means
14293 -- that it does not report overflow (see also Enable_Overflow_Check).
14295 Determine_Range
(N
, OK
, Nlo
, Nhi
, Assume_Valid
=> True);
14300 -- Therefore, if Nsiz is not lower than the size of the original type
14301 -- here, we cannot be sure that the operation does not overflow.
14303 Nsiz
:= Get_Size_For_Range
(Nlo
, Nhi
);
14304 Nsiz
:= UI_Max
(Nsiz
, Lsiz
);
14305 Nsiz
:= UI_Max
(Nsiz
, Rsiz
);
14308 -- If the size is not lower than the size of the original type, then
14309 -- there is no point in changing the type, except in the case where
14310 -- we can remove a conversion to the original type from an operand.
14313 and then not (Binary
14314 and then Nkind
(L
) = N_Type_Conversion
14315 and then Entity
(Subtype_Mark
(L
)) = Typ
)
14316 and then not (Nkind
(R
) = N_Type_Conversion
14317 and then Entity
(Subtype_Mark
(R
)) = Typ
)
14322 -- Now pick the narrower type according to the size. We use the base
14323 -- type instead of the first subtype because operations are done in
14324 -- the base type, so this avoids the need for useless conversions.
14326 if Nsiz
<= System_Max_Integer_Size
then
14327 Ntyp
:= Etype
(Integer_Type_For
(Nsiz
, Uns
=> False));
14332 -- Finally, rewrite the operation in the narrower type, but make sure
14333 -- not to perform name resolution for the operator again.
14335 Nop
:= New_Op_Node
(Kind
, Sloc
(N
));
14336 if Nkind
(N
) in N_Has_Entity
then
14337 Set_Entity
(Nop
, Entity
(N
));
14341 Set_Left_Opnd
(Nop
, Convert_To
(Ntyp
, L
));
14345 Set_Right_Opnd
(Nop
,
14346 Make_Range
(Sloc
(N
),
14347 Convert_To
(Ntyp
, Low_Bound
(R
)),
14348 Convert_To
(Ntyp
, High_Bound
(R
))));
14350 Set_Right_Opnd
(Nop
, Convert_To
(Ntyp
, R
));
14356 -- Analyze it with the comparison type and checks suppressed since
14357 -- the conversions of the operands cannot overflow.
14359 Analyze_And_Resolve
(N
, Otyp
, Suppress
=> Overflow_Check
);
14362 -- Analyze it with the narrower type and checks suppressed, but only
14363 -- when we are sure that the operation does not overflow, see above.
14365 if Nsiz
< Tsiz
then
14366 Analyze_And_Resolve
(N
, Ntyp
, Suppress
=> Overflow_Check
);
14368 Analyze_And_Resolve
(N
, Ntyp
);
14371 -- Put back a conversion to the original type
14373 Convert_To_And_Rewrite
(Typ
, N
);
14375 end Narrow_Large_Operation
;
14377 --------------------------------
14378 -- Optimize_Length_Comparison --
14379 --------------------------------
14381 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
14382 Loc
: constant Source_Ptr
:= Sloc
(N
);
14383 Typ
: constant Entity_Id
:= Etype
(N
);
14388 -- First and Last attribute reference nodes, which end up as left and
14389 -- right operands of the optimized result.
14392 -- True for comparison operand of zero
14394 Maybe_Superflat
: Boolean;
14395 -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set
14396 -- to false but the comparison operand can be zero at run time. In this
14397 -- case, we normally cannot do anything because the canonical formula of
14398 -- the length is not valid, but there is one exception: when the operand
14399 -- is itself the length of an array with the same bounds as the array on
14400 -- the LHS, we can entirely optimize away the comparison.
14403 -- Comparison operand, set only if Is_Zero is false
14405 Ent
: array (Pos
range 1 .. 2) of Entity_Id
:= (Empty
, Empty
);
14406 -- Entities whose length is being compared
14408 Index
: array (Pos
range 1 .. 2) of Node_Id
:= (Empty
, Empty
);
14409 -- Integer_Literal nodes for length attribute expressions, or Empty
14410 -- if there is no such expression present.
14412 Op
: Node_Kind
:= Nkind
(N
);
14413 -- Kind of comparison operator, gets flipped if operands backwards
14415 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
;
14416 -- Given a discrete expression, returns a Long_Long_Integer typed
14417 -- expression representing the underlying value of the expression.
14418 -- This is done with an unchecked conversion to Long_Long_Integer.
14419 -- We use unchecked conversion to handle the enumeration type case.
14421 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean;
14422 -- Tests if N is a length attribute applied to a simple entity. If so,
14423 -- returns True, and sets Ent to the entity, and Index to the integer
14424 -- literal provided as an attribute expression, or to Empty if none.
14425 -- Num is the index designating the relevant slot in Ent and Index.
14426 -- Also returns True if the expression is a generated type conversion
14427 -- whose expression is of the desired form. This latter case arises
14428 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
14429 -- to check for being in range, which is not needed in this context.
14430 -- Returns False if neither condition holds.
14432 function Is_Optimizable
(N
: Node_Id
) return Boolean;
14433 -- Tests N to see if it is an optimizable comparison value (defined as
14434 -- constant zero or one, or something else where the value is known to
14435 -- be nonnegative and in the 32-bit range and where the corresponding
14436 -- Length value is also known to be 32 bits). If result is true, sets
14437 -- Is_Zero, Maybe_Superflat and Comp accordingly.
14439 procedure Rewrite_For_Equal_Lengths
;
14440 -- Rewrite the comparison of two equal lengths into either True or False
14442 ----------------------------------
14443 -- Convert_To_Long_Long_Integer --
14444 ----------------------------------
14446 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
is
14448 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
14449 end Convert_To_Long_Long_Integer
;
14451 ----------------------
14452 -- Is_Entity_Length --
14453 ----------------------
14455 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean is
14457 if Nkind
(N
) = N_Attribute_Reference
14458 and then Attribute_Name
(N
) = Name_Length
14459 and then Is_Entity_Name
(Prefix
(N
))
14461 Ent
(Num
) := Entity
(Prefix
(N
));
14463 if Present
(Expressions
(N
)) then
14464 Index
(Num
) := First
(Expressions
(N
));
14466 Index
(Num
) := Empty
;
14471 elsif Nkind
(N
) = N_Type_Conversion
14472 and then not Comes_From_Source
(N
)
14474 return Is_Entity_Length
(Expression
(N
), Num
);
14479 end Is_Entity_Length
;
14481 --------------------
14482 -- Is_Optimizable --
14483 --------------------
14485 function Is_Optimizable
(N
: Node_Id
) return Boolean is
14495 if Compile_Time_Known_Value
(N
) then
14496 Val
:= Expr_Value
(N
);
14498 if Val
= Uint_0
then
14500 Maybe_Superflat
:= False;
14504 elsif Val
= Uint_1
then
14506 Maybe_Superflat
:= False;
14512 -- Here we have to make sure of being within a 32-bit range (take the
14513 -- full unsigned range so the length of 32-bit arrays is accepted).
14515 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
14518 or else Lo
< Uint_0
14519 or else Hi
> Uint_2
** 32
14524 Maybe_Superflat
:= (Lo
= Uint_0
);
14526 -- Tests if N is also a length attribute applied to a simple entity
14528 Dbl
:= Is_Entity_Length
(N
, 2);
14530 -- We can deal with the superflat case only if N is also a length
14532 if Maybe_Superflat
and then not Dbl
then
14536 -- Comparison value was within range, so now we must check the index
14537 -- value to make sure it is also within 32 bits.
14539 for K
in Pos
range 1 .. 2 loop
14540 Indx
:= First_Index
(Etype
(Ent
(K
)));
14542 if Present
(Index
(K
)) then
14543 for J
in 2 .. UI_To_Int
(Intval
(Index
(K
))) loop
14548 Ityp
:= Etype
(Indx
);
14550 if Esize
(Ityp
) > 32 then
14560 end Is_Optimizable
;
14562 -------------------------------
14563 -- Rewrite_For_Equal_Lengths --
14564 -------------------------------
14566 procedure Rewrite_For_Equal_Lengths
is
14575 New_Occurrence_Of
(Standard_True
, Sloc
(N
))));
14583 New_Occurrence_Of
(Standard_False
, Sloc
(N
))));
14586 raise Program_Error
;
14589 Analyze_And_Resolve
(N
, Typ
);
14590 end Rewrite_For_Equal_Lengths
;
14592 -- Start of processing for Optimize_Length_Comparison
14595 -- Nothing to do if not a comparison
14597 if Op
not in N_Op_Compare
then
14601 -- Nothing to do if special -gnatd.P debug flag set.
14603 if Debug_Flag_Dot_PP
then
14607 -- Ent'Length op 0/1
14609 if Is_Entity_Length
(Left_Opnd
(N
), 1)
14610 and then Is_Optimizable
(Right_Opnd
(N
))
14614 -- 0/1 op Ent'Length
14616 elsif Is_Entity_Length
(Right_Opnd
(N
), 1)
14617 and then Is_Optimizable
(Left_Opnd
(N
))
14619 -- Flip comparison to opposite sense
14622 when N_Op_Lt
=> Op
:= N_Op_Gt
;
14623 when N_Op_Le
=> Op
:= N_Op_Ge
;
14624 when N_Op_Gt
=> Op
:= N_Op_Lt
;
14625 when N_Op_Ge
=> Op
:= N_Op_Le
;
14626 when others => null;
14629 -- Else optimization not possible
14635 -- Fall through if we will do the optimization
14637 -- Cases to handle:
14639 -- X'Length = 0 => X'First > X'Last
14640 -- X'Length = 1 => X'First = X'Last
14641 -- X'Length = n => X'First + (n - 1) = X'Last
14643 -- X'Length /= 0 => X'First <= X'Last
14644 -- X'Length /= 1 => X'First /= X'Last
14645 -- X'Length /= n => X'First + (n - 1) /= X'Last
14647 -- X'Length >= 0 => always true, warn
14648 -- X'Length >= 1 => X'First <= X'Last
14649 -- X'Length >= n => X'First + (n - 1) <= X'Last
14651 -- X'Length > 0 => X'First <= X'Last
14652 -- X'Length > 1 => X'First < X'Last
14653 -- X'Length > n => X'First + (n - 1) < X'Last
14655 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
14656 -- X'Length <= 1 => X'First >= X'Last
14657 -- X'Length <= n => X'First + (n - 1) >= X'Last
14659 -- X'Length < 0 => always false (warn)
14660 -- X'Length < 1 => X'First > X'Last
14661 -- X'Length < n => X'First + (n - 1) > X'Last
14663 -- Note: for the cases of n (not constant 0,1), we require that the
14664 -- corresponding index type be integer or shorter (i.e. not 64-bit),
14665 -- and the same for the comparison value. Then we do the comparison
14666 -- using 64-bit arithmetic (actually long long integer), so that we
14667 -- cannot have overflow intefering with the result.
14669 -- First deal with warning cases
14678 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
14679 Analyze_And_Resolve
(N
, Typ
);
14680 Warn_On_Known_Condition
(N
);
14687 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
14688 Analyze_And_Resolve
(N
, Typ
);
14689 Warn_On_Known_Condition
(N
);
14693 if Constant_Condition_Warnings
14694 and then Comes_From_Source
(Original_Node
(N
))
14696 Error_Msg_N
("could replace by ""'=""?c?", N
);
14706 -- Build the First reference we will use
14709 Make_Attribute_Reference
(Loc
,
14710 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14711 Attribute_Name
=> Name_First
);
14713 if Present
(Index
(1)) then
14714 Set_Expressions
(Left
, New_List
(New_Copy
(Index
(1))));
14717 -- Build the Last reference we will use
14720 Make_Attribute_Reference
(Loc
,
14721 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14722 Attribute_Name
=> Name_Last
);
14724 if Present
(Index
(1)) then
14725 Set_Expressions
(Right
, New_List
(New_Copy
(Index
(1))));
14728 -- If general value case, then do the addition of (n - 1), and
14729 -- also add the needed conversions to type Long_Long_Integer.
14731 -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into:
14733 -- Y'Last + (X'First - Y'First) op X'Last
14735 -- in the hope that X'First - Y'First can be computed statically.
14737 if Present
(Comp
) then
14738 if Present
(Ent
(2)) then
14740 Y_First
: constant Node_Id
:=
14741 Make_Attribute_Reference
(Loc
,
14742 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14743 Attribute_Name
=> Name_First
);
14744 Y_Last
: constant Node_Id
:=
14745 Make_Attribute_Reference
(Loc
,
14746 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14747 Attribute_Name
=> Name_Last
);
14748 R
: Compare_Result
;
14751 if Present
(Index
(2)) then
14752 Set_Expressions
(Y_First
, New_List
(New_Copy
(Index
(2))));
14753 Set_Expressions
(Y_Last
, New_List
(New_Copy
(Index
(2))));
14759 -- If X'First = Y'First, simplify the above formula into a
14760 -- direct comparison of Y'Last and X'Last.
14762 R
:= Compile_Time_Compare
(Left
, Y_First
, Assume_Valid
=> True);
14768 R
:= Compile_Time_Compare
14769 (Right
, Y_Last
, Assume_Valid
=> True);
14771 -- If the pairs of attributes are equal, we are done
14774 Rewrite_For_Equal_Lengths
;
14778 -- If the base types are different, convert both operands to
14779 -- Long_Long_Integer, else compare them directly.
14781 if Base_Type
(Etype
(Right
)) /= Base_Type
(Etype
(Y_Last
))
14783 Left
:= Convert_To_Long_Long_Integer
(Y_Last
);
14789 -- Otherwise, use the above formula as-is
14795 Convert_To_Long_Long_Integer
(Y_Last
),
14797 Make_Op_Subtract
(Loc
,
14799 Convert_To_Long_Long_Integer
(Left
),
14801 Convert_To_Long_Long_Integer
(Y_First
)));
14805 -- General value case
14810 Left_Opnd
=> Convert_To_Long_Long_Integer
(Left
),
14812 Make_Op_Subtract
(Loc
,
14813 Left_Opnd
=> Convert_To_Long_Long_Integer
(Comp
),
14814 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
14818 -- We cannot do anything in the superflat case past this point
14820 if Maybe_Superflat
then
14824 -- If general operand, convert Last reference to Long_Long_Integer
14826 if Present
(Comp
) then
14827 Right
:= Convert_To_Long_Long_Integer
(Right
);
14830 -- Check for cases to optimize
14832 -- X'Length = 0 => X'First > X'Last
14833 -- X'Length < 1 => X'First > X'Last
14834 -- X'Length < n => X'First + (n - 1) > X'Last
14836 if (Is_Zero
and then Op
= N_Op_Eq
)
14837 or else (not Is_Zero
and then Op
= N_Op_Lt
)
14842 Right_Opnd
=> Right
);
14844 -- X'Length = 1 => X'First = X'Last
14845 -- X'Length = n => X'First + (n - 1) = X'Last
14847 elsif not Is_Zero
and then Op
= N_Op_Eq
then
14851 Right_Opnd
=> Right
);
14853 -- X'Length /= 0 => X'First <= X'Last
14854 -- X'Length > 0 => X'First <= X'Last
14856 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
14860 Right_Opnd
=> Right
);
14862 -- X'Length /= 1 => X'First /= X'Last
14863 -- X'Length /= n => X'First + (n - 1) /= X'Last
14865 elsif not Is_Zero
and then Op
= N_Op_Ne
then
14869 Right_Opnd
=> Right
);
14871 -- X'Length >= 1 => X'First <= X'Last
14872 -- X'Length >= n => X'First + (n - 1) <= X'Last
14874 elsif not Is_Zero
and then Op
= N_Op_Ge
then
14878 Right_Opnd
=> Right
);
14880 -- X'Length > 1 => X'First < X'Last
14881 -- X'Length > n => X'First + (n = 1) < X'Last
14883 elsif not Is_Zero
and then Op
= N_Op_Gt
then
14887 Right_Opnd
=> Right
);
14889 -- X'Length <= 1 => X'First >= X'Last
14890 -- X'Length <= n => X'First + (n - 1) >= X'Last
14892 elsif not Is_Zero
and then Op
= N_Op_Le
then
14896 Right_Opnd
=> Right
);
14898 -- Should not happen at this stage
14901 raise Program_Error
;
14904 -- Rewrite and finish up (we can suppress overflow checks, see above)
14906 Rewrite
(N
, Result
);
14907 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Overflow_Check
);
14908 end Optimize_Length_Comparison
;
14910 --------------------------------------
14911 -- Process_Transients_In_Expression --
14912 --------------------------------------
14914 procedure Process_Transients_In_Expression
14918 procedure Process_Transient_In_Expression
(Obj_Decl
: Node_Id
);
14919 -- Process the object whose declaration Obj_Decl is present in Stmts
14921 -------------------------------------
14922 -- Process_Transient_In_Expression --
14923 -------------------------------------
14925 procedure Process_Transient_In_Expression
(Obj_Decl
: Node_Id
) is
14926 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
14927 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Obj_Decl
);
14929 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Expr
);
14930 -- The node on which to insert the hook as an action. This is usually
14931 -- the innermost enclosing non-transient construct.
14933 Fin_Call
: Node_Id
;
14934 Hook_Assign
: Node_Id
;
14935 Hook_Clear
: Node_Id
;
14936 Hook_Decl
: Node_Id
;
14937 Hook_Insert
: Node_Id
;
14938 Ptr_Decl
: Node_Id
;
14940 Fin_Context
: Node_Id
;
14941 -- The node after which to insert the finalization actions of the
14942 -- transient object.
14945 pragma Assert
(Nkind
(Expr
) in N_Case_Expression
14946 | N_Expression_With_Actions
14947 | N_If_Expression
);
14949 -- When the context is a Boolean evaluation, all three nodes capture
14950 -- the result of their computation in a local temporary:
14953 -- Trans_Id : Ctrl_Typ := ...;
14954 -- Result : constant Boolean := ... Trans_Id ...;
14955 -- <finalize Trans_Id>
14958 -- As a result, the finalization of any transient objects can take
14959 -- place just after the result is captured, except for the case of
14960 -- conditional expressions in a simple return statement because the
14961 -- return statement will be distributed into dependent expressions
14962 -- (see the special handling of simple return statements below).
14964 -- ??? could this be extended to elementary types?
14966 if Is_Boolean_Type
(Etype
(Expr
))
14968 (Nkind
(Expr
) = N_Expression_With_Actions
14969 or else Nkind
(Parent
(Expr
)) /= N_Simple_Return_Statement
)
14971 Fin_Context
:= Last
(Stmts
);
14973 -- Otherwise the immediate context may not be safe enough to carry
14974 -- out transient object finalization due to aliasing and nesting of
14975 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14976 -- enclosing non-transient construct.
14979 Fin_Context
:= Hook_Context
;
14982 -- Mark the transient object as successfully processed to avoid
14983 -- double finalization.
14985 Set_Is_Finalized_Transient
(Obj_Id
);
14987 -- Construct all the pieces necessary to hook and finalize a
14988 -- transient object.
14990 Build_Transient_Object_Statements
14991 (Obj_Decl
=> Obj_Decl
,
14992 Fin_Call
=> Fin_Call
,
14993 Hook_Assign
=> Hook_Assign
,
14994 Hook_Clear
=> Hook_Clear
,
14995 Hook_Decl
=> Hook_Decl
,
14996 Ptr_Decl
=> Ptr_Decl
,
14997 Finalize_Obj
=> False);
14999 -- Add the access type which provides a reference to the transient
15000 -- object. Generate:
15002 -- type Ptr_Typ is access all Desig_Typ;
15004 Insert_Action
(Hook_Context
, Ptr_Decl
);
15006 -- Add the temporary which acts as a hook to the transient object.
15009 -- Hook : Ptr_Id := null;
15011 Insert_Action
(Hook_Context
, Hook_Decl
);
15013 -- When the transient object is initialized by an aggregate, the hook
15014 -- must capture the object after the last aggregate assignment takes
15015 -- place. Only then is the object considered initialized. Generate:
15017 -- Hook := Ptr_Typ (Obj_Id);
15019 -- Hook := Obj_Id'Unrestricted_Access;
15021 if Ekind
(Obj_Id
) in E_Constant | E_Variable
15022 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
15024 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
15026 -- Otherwise the hook seizes the related object immediately
15029 Hook_Insert
:= Obj_Decl
;
15032 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
15034 -- When the node is part of a return statement, there is no need to
15035 -- insert a finalization call, as the general finalization mechanism
15036 -- (see Build_Finalizer) would take care of the transient object on
15037 -- subprogram exit. Note that it would also be impossible to insert
15038 -- the finalization code after the return statement as this will
15039 -- render it unreachable.
15041 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
15044 -- Finalize the hook after the context has been evaluated. Generate:
15046 -- if Hook /= null then
15047 -- [Deep_]Finalize (Hook.all);
15051 -- But the node returned by Find_Hook_Context may be an operator,
15052 -- which is not a list member. We must locate the proper node
15053 -- in the tree after which to insert the finalization code.
15056 while not Is_List_Member
(Fin_Context
) loop
15057 Fin_Context
:= Parent
(Fin_Context
);
15060 pragma Assert
(Present
(Fin_Context
));
15062 Insert_Action_After
(Fin_Context
,
15063 Make_Implicit_If_Statement
(Obj_Decl
,
15067 New_Occurrence_Of
(Defining_Entity
(Hook_Decl
), Loc
),
15068 Right_Opnd
=> Make_Null
(Loc
)),
15070 Then_Statements
=> New_List
(
15074 end Process_Transient_In_Expression
;
15080 -- Start of processing for Process_Transients_In_Expression
15083 pragma Assert
(Nkind
(Expr
) in N_Case_Expression
15084 | N_Expression_With_Actions
15085 | N_If_Expression
);
15087 Decl
:= First
(Stmts
);
15088 while Present
(Decl
) loop
15089 if Nkind
(Decl
) = N_Object_Declaration
15090 and then Is_Finalizable_Transient
(Decl
, Expr
)
15092 Process_Transient_In_Expression
(Decl
);
15097 end Process_Transients_In_Expression
;
15099 ------------------------
15100 -- Rewrite_Comparison --
15101 ------------------------
15103 procedure Rewrite_Comparison
(N
: Node_Id
) is
15104 Typ
: constant Entity_Id
:= Etype
(N
);
15106 False_Result
: Boolean;
15107 True_Result
: Boolean;
15110 if Nkind
(N
) = N_Type_Conversion
then
15111 Rewrite_Comparison
(Expression
(N
));
15114 elsif Nkind
(N
) not in N_Op_Compare
then
15118 -- If both operands are static, then the comparison has been already
15119 -- folded in evaluation.
15122 (not Is_Static_Expression
(Left_Opnd
(N
))
15124 not Is_Static_Expression
(Right_Opnd
(N
)));
15126 -- Determine the potential outcome of the comparison assuming that the
15127 -- operands are valid and emit a warning when the comparison evaluates
15128 -- to True or False only in the presence of invalid values.
15130 Warn_On_Constant_Valid_Condition
(N
);
15132 -- Determine the potential outcome of the comparison assuming that the
15133 -- operands are not valid.
15137 Assume_Valid
=> False,
15138 True_Result
=> True_Result
,
15139 False_Result
=> False_Result
);
15141 -- The outcome is a decisive False or True, rewrite the operator into a
15142 -- non-static literal.
15144 if False_Result
or True_Result
then
15147 New_Occurrence_Of
(Boolean_Literals
(True_Result
), Sloc
(N
))));
15149 Analyze_And_Resolve
(N
, Typ
);
15150 Set_Is_Static_Expression
(N
, False);
15151 Warn_On_Known_Condition
(N
);
15153 end Rewrite_Comparison
;
15155 ----------------------------
15156 -- Safe_In_Place_Array_Op --
15157 ----------------------------
15159 function Safe_In_Place_Array_Op
15162 Op2
: Node_Id
) return Boolean
15164 Target
: Entity_Id
;
15166 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
15167 -- Operand is safe if it cannot overlap part of the target of the
15168 -- operation. If the operand and the target are identical, the operand
15169 -- is safe. The operand can be empty in the case of negation.
15171 function Is_Unaliased
(N
: Node_Id
) return Boolean;
15172 -- Check that N is a stand-alone entity
15178 function Is_Unaliased
(N
: Node_Id
) return Boolean is
15182 and then No
(Address_Clause
(Entity
(N
)))
15183 and then No
(Renamed_Object
(Entity
(N
)));
15186 ---------------------
15187 -- Is_Safe_Operand --
15188 ---------------------
15190 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
15195 elsif Is_Entity_Name
(Op
) then
15196 return Is_Unaliased
(Op
);
15198 elsif Nkind
(Op
) in N_Indexed_Component | N_Selected_Component
then
15199 return Is_Unaliased
(Prefix
(Op
));
15201 elsif Nkind
(Op
) = N_Slice
then
15203 Is_Unaliased
(Prefix
(Op
))
15204 and then Entity
(Prefix
(Op
)) /= Target
;
15206 elsif Nkind
(Op
) = N_Op_Not
then
15207 return Is_Safe_Operand
(Right_Opnd
(Op
));
15212 end Is_Safe_Operand
;
15214 -- Start of processing for Safe_In_Place_Array_Op
15217 -- Skip this processing if the component size is different from system
15218 -- storage unit (since at least for NOT this would cause problems).
15220 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
15223 -- Cannot do in place stuff if non-standard Boolean representation
15225 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
15228 elsif not Is_Unaliased
(Lhs
) then
15232 Target
:= Entity
(Lhs
);
15233 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
15235 end Safe_In_Place_Array_Op
;
15237 -----------------------
15238 -- Tagged_Membership --
15239 -----------------------
15241 -- There are two different cases to consider depending on whether the right
15242 -- operand is a class-wide type or not. If not we just compare the actual
15243 -- tag of the left expr to the target type tag:
15245 -- Left_Expr.Tag = Right_Type'Tag;
15247 -- If it is a class-wide type we use the RT function CW_Membership which is
15248 -- usually implemented by looking in the ancestor tables contained in the
15249 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
15251 -- In both cases if Left_Expr is an access type, we first check whether it
15254 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
15255 -- function IW_Membership which is usually implemented by looking in the
15256 -- table of abstract interface types plus the ancestor table contained in
15257 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
15259 procedure Tagged_Membership
15261 SCIL_Node
: out Node_Id
;
15262 Result
: out Node_Id
)
15264 Left
: constant Node_Id
:= Left_Opnd
(N
);
15265 Right
: constant Node_Id
:= Right_Opnd
(N
);
15266 Loc
: constant Source_Ptr
:= Sloc
(N
);
15268 -- Handle entities from the limited view
15270 Orig_Right_Type
: constant Entity_Id
:= Available_View
(Etype
(Right
));
15272 Full_R_Typ
: Entity_Id
;
15273 Left_Type
: Entity_Id
:= Available_View
(Etype
(Left
));
15274 Right_Type
: Entity_Id
:= Orig_Right_Type
;
15278 SCIL_Node
:= Empty
;
15280 -- We have to examine the corresponding record type when dealing with
15281 -- protected types instead of the original, unexpanded, type.
15283 if Ekind
(Right_Type
) = E_Protected_Type
then
15284 Right_Type
:= Corresponding_Record_Type
(Right_Type
);
15287 if Ekind
(Left_Type
) = E_Protected_Type
then
15288 Left_Type
:= Corresponding_Record_Type
(Left_Type
);
15291 -- In the case where the type is an access type, the test is applied
15292 -- using the designated types (needed in Ada 2012 for implicit anonymous
15293 -- access conversions, for AI05-0149).
15295 if Is_Access_Type
(Right_Type
) then
15296 Left_Type
:= Designated_Type
(Left_Type
);
15297 Right_Type
:= Designated_Type
(Right_Type
);
15300 if Is_Class_Wide_Type
(Left_Type
) then
15301 Left_Type
:= Root_Type
(Left_Type
);
15304 if Is_Class_Wide_Type
(Right_Type
) then
15305 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
15307 Full_R_Typ
:= Underlying_Type
(Right_Type
);
15311 Make_Selected_Component
(Loc
,
15312 Prefix
=> Relocate_Node
(Left
),
15314 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
15316 if Is_Class_Wide_Type
(Right_Type
) then
15318 -- No need to issue a run-time check if we statically know that the
15319 -- result of this membership test is always true. For example,
15320 -- considering the following declarations:
15322 -- type Iface is interface;
15323 -- type T is tagged null record;
15324 -- type DT is new T and Iface with null record;
15329 -- These membership tests are always true:
15332 -- Obj2 in T'Class;
15333 -- Obj2 in Iface'Class;
15335 -- We do not need to handle cases where the membership is illegal.
15338 -- Obj1 in DT'Class; -- Compile time error
15339 -- Obj1 in Iface'Class; -- Compile time error
15341 if not Is_Interface
(Left_Type
)
15342 and then not Is_Class_Wide_Type
(Left_Type
)
15343 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
15344 Use_Full_View
=> True)
15345 or else (Is_Interface
(Etype
(Right_Type
))
15346 and then Interface_Present_In_Ancestor
15348 Iface
=> Etype
(Right_Type
))))
15350 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
15354 -- Ada 2005 (AI-251): Class-wide applied to interfaces
15356 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
15358 -- Support to: "Iface_CW_Typ in Typ'Class"
15360 or else Is_Interface
(Left_Type
)
15362 -- Issue error if IW_Membership operation not available in a
15363 -- configurable run-time setting.
15365 if not RTE_Available
(RE_IW_Membership
) then
15367 ("dynamic membership test on interface types", N
);
15373 Make_Function_Call
(Loc
,
15374 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
15375 Parameter_Associations
=> New_List
(
15376 Make_Attribute_Reference
(Loc
,
15378 Attribute_Name
=> Name_Address
),
15379 New_Occurrence_Of
(
15380 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15383 -- Ada 95: Normal case
15386 -- Issue error if CW_Membership operation not available in a
15387 -- configurable run-time setting.
15389 if not RTE_Available
(RE_CW_Membership
) then
15391 ("dynamic membership test on tagged types", N
);
15397 Make_Function_Call
(Loc
,
15398 Name
=> New_Occurrence_Of
(RTE
(RE_CW_Membership
), Loc
),
15399 Parameter_Associations
=> New_List
(
15401 New_Occurrence_Of
(
15402 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15405 -- Generate the SCIL node for this class-wide membership test.
15407 if Generate_SCIL
then
15408 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
15409 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
15410 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
15414 -- Right_Type is not a class-wide type
15417 -- No need to check the tag of the object if Right_Typ is abstract
15419 if Is_Abstract_Type
(Right_Type
) then
15420 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
15425 Left_Opnd
=> Obj_Tag
,
15428 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
15432 -- if Left is an access object then generate test of the form:
15433 -- * if Right_Type excludes null: Left /= null and then ...
15434 -- * if Right_Type includes null: Left = null or else ...
15436 if Is_Access_Type
(Orig_Right_Type
) then
15437 if Can_Never_Be_Null
(Orig_Right_Type
) then
15438 Result
:= Make_And_Then
(Loc
,
15442 Right_Opnd
=> Make_Null
(Loc
)),
15443 Right_Opnd
=> Result
);
15446 Result
:= Make_Or_Else
(Loc
,
15450 Right_Opnd
=> Make_Null
(Loc
)),
15451 Right_Opnd
=> Result
);
15454 end Tagged_Membership
;
15456 ------------------------------
15457 -- Unary_Op_Validity_Checks --
15458 ------------------------------
15460 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
15462 if Validity_Checks_On
and Validity_Check_Operands
then
15463 Ensure_Valid
(Right_Opnd
(N
));
15465 end Unary_Op_Validity_Checks
;