1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Apply_Predicate_Check
(Expression
(N
), Dtyp
);
4662 if Nkind
(Expression
(N
)) = N_Raise_Constraint_Error
then
4663 Rewrite
(N
, New_Copy
(Expression
(N
)));
4664 Set_Etype
(N
, PtrT
);
4669 if No_Initialization
(N
) then
4671 -- Even though this might be a simple allocation, create a custom
4672 -- Allocate if the context requires it.
4674 if Present
(Finalization_Master
(PtrT
)) then
4675 Build_Allocate_Deallocate_Proc
4677 Is_Allocate
=> True);
4680 -- Optimize the default allocation of an array object when pragma
4681 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4682 -- in-place initialization aggregate which may be convert into a fast
4683 -- memset by the backend.
4685 elsif Init_Or_Norm_Scalars
4686 and then Is_Array_Type
(T
)
4688 -- The array must lack atomic components because they are treated
4689 -- as non-static, and as a result the backend will not initialize
4690 -- the memory in one go.
4692 and then not Has_Atomic_Components
(T
)
4694 -- The array must not be packed because the invalid values in
4695 -- System.Scalar_Values are multiples of Storage_Unit.
4697 and then not Is_Packed
(T
)
4699 -- The array must have static non-empty ranges, otherwise the
4700 -- backend cannot initialize the memory in one go.
4702 and then Has_Static_Non_Empty_Array_Bounds
(T
)
4704 -- The optimization is only relevant for arrays of scalar types
4706 and then Is_Scalar_Type
(Component_Type
(T
))
4708 -- Similar to regular array initialization using a type init proc,
4709 -- predicate checks are not performed because the initialization
4710 -- values are intentionally invalid, and may violate the predicate.
4712 and then not Has_Predicates
(Component_Type
(T
))
4714 -- The component type must have a single initialization value
4716 and then Needs_Simple_Initialization
4717 (Typ
=> Component_Type
(T
),
4718 Consider_IS
=> True)
4721 Temp
:= Make_Temporary
(Loc
, 'P');
4724 -- Temp : Ptr_Typ := new ...;
4729 Make_Object_Declaration
(Loc
,
4730 Defining_Identifier
=> Temp
,
4731 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
4732 Expression
=> Relocate_Node
(N
)),
4733 Suppress
=> All_Checks
);
4736 -- Temp.all := (others => ...);
4741 Make_Assignment_Statement
(Loc
,
4743 Make_Explicit_Dereference
(Loc
,
4744 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
4749 Size
=> Esize
(Component_Type
(T
)))),
4750 Suppress
=> All_Checks
);
4752 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4753 Analyze_And_Resolve
(N
, PtrT
);
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 -- When designated type has Default_Initial_Condition aspects,
5123 -- make a call to the type's DIC procedure to perform the
5124 -- checks. Theoretically this might also be needed for cases
5125 -- where the type doesn't have an init proc, but those should
5126 -- be very uncommon, and for now we only support the init proc
5130 and then Present
(DIC_Procedure
(Dtyp
))
5131 and then not Has_Null_Body
(DIC_Procedure
(Dtyp
))
5134 Build_DIC_Call
(Loc
,
5135 Make_Explicit_Dereference
(Loc
,
5136 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
5143 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5144 -- object that has been rewritten as a reference, we displace "this"
5145 -- to reference properly its secondary dispatch table.
5147 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
5148 Displace_Allocator_Pointer
(N
);
5152 when RE_Not_Available
=>
5154 end Expand_N_Allocator
;
5156 -----------------------
5157 -- Expand_N_And_Then --
5158 -----------------------
5160 procedure Expand_N_And_Then
(N
: Node_Id
)
5161 renames Expand_Short_Circuit_Operator
;
5163 ------------------------------
5164 -- Expand_N_Case_Expression --
5165 ------------------------------
5167 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
5168 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean;
5169 -- Return True if we can copy objects of this type when expanding a case
5176 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean is
5178 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5179 -- large objects, as long as they are constrained and not limited.
5182 Is_Elementary_Type
(Underlying_Type
(Typ
))
5184 (Minimize_Expression_With_Actions
5185 and then Is_Constrained
(Underlying_Type
(Typ
))
5186 and then not Is_Limited_Type
(Underlying_Type
(Typ
)));
5191 Loc
: constant Source_Ptr
:= Sloc
(N
);
5192 Par
: constant Node_Id
:= Parent
(N
);
5193 Typ
: constant Entity_Id
:= Etype
(N
);
5197 Case_Stmt
: Node_Id
;
5199 Target
: Entity_Id
:= Empty
;
5200 Target_Typ
: Entity_Id
;
5202 In_Predicate
: Boolean := False;
5203 -- Flag set when the case expression appears within a predicate
5205 Optimize_Return_Stmt
: Boolean := False;
5206 -- Flag set when the case expression can be optimized in the context of
5207 -- a simple return statement.
5209 -- Start of processing for Expand_N_Case_Expression
5212 -- Check for MINIMIZED/ELIMINATED overflow mode
5214 if Minimized_Eliminated_Overflow_Check
(N
) then
5215 Apply_Arithmetic_Overflow_Check
(N
);
5219 -- If the case expression is a predicate specification, and the type
5220 -- to which it applies has a static predicate aspect, do not expand,
5221 -- because it will be converted to the proper predicate form later.
5223 if Ekind
(Current_Scope
) in E_Function | E_Procedure
5224 and then Is_Predicate_Function
(Current_Scope
)
5226 In_Predicate
:= True;
5228 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
5234 -- When the type of the case expression is elementary, expand
5236 -- (case X is when A => AX, when B => BX ...)
5251 -- In all other cases expand into
5253 -- type Ptr_Typ is access all Typ;
5254 -- Target : Ptr_Typ;
5257 -- Target := AX'Unrestricted_Access;
5259 -- Target := BX'Unrestricted_Access;
5263 -- and replace the case expression by a reference to Target.all.
5265 -- This approach avoids extra copies of potentially large objects. It
5266 -- also allows handling of values of limited or unconstrained types.
5267 -- Note that we do the copy also for constrained, nonlimited types
5268 -- when minimizing expressions with actions (e.g. when generating C
5269 -- code) since it allows us to do the optimization below in more cases.
5272 Make_Case_Statement
(Loc
,
5273 Expression
=> Expression
(N
),
5274 Alternatives
=> New_List
);
5276 -- Preserve the original context for which the case statement is being
5277 -- generated. This is needed by the finalization machinery to prevent
5278 -- the premature finalization of controlled objects found within the
5281 Set_From_Conditional_Expression
(Case_Stmt
);
5284 -- Small optimization: when the case expression appears in the context
5285 -- of a simple return statement, expand into
5295 -- This makes the expansion much easier when expressions are calls to
5296 -- a BIP function. But do not perform it when the return statement is
5297 -- within a predicate function, as this causes spurious errors.
5299 Optimize_Return_Stmt
:=
5300 Nkind
(Par
) = N_Simple_Return_Statement
and then not In_Predicate
;
5304 if Is_Copy_Type
(Typ
) then
5307 -- Otherwise create an access type to handle the general case using
5308 -- 'Unrestricted_Access.
5311 -- type Ptr_Typ is access all Typ;
5314 if Generate_C_Code
then
5316 -- We cannot ensure that correct C code will be generated if any
5317 -- temporary is created down the line (to e.g. handle checks or
5318 -- capture values) since we might end up with dangling references
5319 -- to local variables, so better be safe and reject the construct.
5322 ("case expression too complex, use case statement instead", N
);
5325 Target_Typ
:= Make_Temporary
(Loc
, 'P');
5328 Make_Full_Type_Declaration
(Loc
,
5329 Defining_Identifier
=> Target_Typ
,
5331 Make_Access_To_Object_Definition
(Loc
,
5332 All_Present
=> True,
5333 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5336 -- Create the declaration of the target which captures the value of the
5340 -- Target : [Ptr_]Typ;
5342 if not Optimize_Return_Stmt
then
5343 Target
:= Make_Temporary
(Loc
, 'T');
5346 Make_Object_Declaration
(Loc
,
5347 Defining_Identifier
=> Target
,
5348 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
5349 Set_No_Initialization
(Decl
);
5351 Append_To
(Acts
, Decl
);
5354 -- Process the alternatives
5356 Alt
:= First
(Alternatives
(N
));
5357 while Present
(Alt
) loop
5359 Alt_Expr
: Node_Id
:= Expression
(Alt
);
5360 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
5365 -- Take the unrestricted access of the expression value for non-
5366 -- scalar types. This approach avoids big copies and covers the
5367 -- limited and unconstrained cases.
5370 -- return AX['Unrestricted_Access];
5372 if Optimize_Return_Stmt
then
5374 Make_Simple_Return_Statement
(Alt_Loc
,
5375 Expression
=> Alt_Expr
));
5378 -- Target := AX['Unrestricted_Access];
5381 if not Is_Copy_Type
(Typ
) then
5383 Make_Attribute_Reference
(Alt_Loc
,
5384 Prefix
=> Relocate_Node
(Alt_Expr
),
5385 Attribute_Name
=> Name_Unrestricted_Access
);
5388 LHS
:= New_Occurrence_Of
(Target
, Loc
);
5389 Set_Assignment_OK
(LHS
);
5392 Make_Assignment_Statement
(Alt_Loc
,
5394 Expression
=> Alt_Expr
));
5397 -- Propagate declarations inserted in the node by Insert_Actions
5398 -- (for example, temporaries generated to remove side effects).
5399 -- These actions must remain attached to the alternative, given
5400 -- that they are generated by the corresponding expression.
5402 if Present
(Actions
(Alt
)) then
5403 Prepend_List
(Actions
(Alt
), Stmts
);
5407 (Alternatives
(Case_Stmt
),
5408 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5409 Discrete_Choices
=> Discrete_Choices
(Alt
),
5410 Statements
=> Stmts
));
5412 -- Finalize any transient objects on exit from the alternative.
5413 -- Note that this needs to be done only after Stmts is attached
5414 -- to the Alternatives list above (for Safe_To_Capture_Value).
5416 Process_Transients_In_Expression
(N
, Stmts
);
5422 -- Rewrite the parent return statement as a case statement
5424 if Optimize_Return_Stmt
then
5425 Rewrite
(Par
, Case_Stmt
);
5428 -- Otherwise rewrite the case expression itself
5431 Append_To
(Acts
, Case_Stmt
);
5433 if Is_Copy_Type
(Typ
) then
5435 Make_Expression_With_Actions
(Loc
,
5436 Expression
=> New_Occurrence_Of
(Target
, Loc
),
5440 Insert_Actions
(N
, Acts
);
5442 Make_Explicit_Dereference
(Loc
,
5443 Prefix
=> New_Occurrence_Of
(Target
, Loc
)));
5446 Analyze_And_Resolve
(N
, Typ
);
5448 end Expand_N_Case_Expression
;
5450 -----------------------------------
5451 -- Expand_N_Explicit_Dereference --
5452 -----------------------------------
5454 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5456 -- Insert explicit dereference call for the checked storage pool case
5458 Insert_Dereference_Action
(Prefix
(N
));
5460 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5461 -- we set the atomic sync flag.
5463 if Is_Atomic
(Etype
(N
))
5464 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5466 Activate_Atomic_Synchronization
(N
);
5468 end Expand_N_Explicit_Dereference
;
5470 --------------------------------------
5471 -- Expand_N_Expression_With_Actions --
5472 --------------------------------------
5474 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5475 Acts
: constant List_Id
:= Actions
(N
);
5477 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
5478 -- Force the evaluation of Boolean expression Expr
5480 ------------------------------
5481 -- Force_Boolean_Evaluation --
5482 ------------------------------
5484 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
5485 Loc
: constant Source_Ptr
:= Sloc
(N
);
5486 Flag_Decl
: Node_Id
;
5487 Flag_Id
: Entity_Id
;
5490 -- Relocate the expression to the actions list by capturing its value
5491 -- in a Boolean flag. Generate:
5492 -- Flag : constant Boolean := Expr;
5494 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5497 Make_Object_Declaration
(Loc
,
5498 Defining_Identifier
=> Flag_Id
,
5499 Constant_Present
=> True,
5500 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5501 Expression
=> Relocate_Node
(Expr
));
5503 Append
(Flag_Decl
, Acts
);
5504 Analyze
(Flag_Decl
);
5506 -- Replace the expression with a reference to the flag
5508 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
5509 Analyze
(Expression
(N
));
5510 end Force_Boolean_Evaluation
;
5512 -- Start of processing for Expand_N_Expression_With_Actions
5515 -- Do not evaluate the expression when it denotes an entity because the
5516 -- expression_with_actions node will be replaced by the reference.
5518 if Is_Entity_Name
(Expression
(N
)) then
5521 -- Do not evaluate the expression when there are no actions because the
5522 -- expression_with_actions node will be replaced by the expression.
5524 elsif Is_Empty_List
(Acts
) then
5527 -- Force the evaluation of the expression by capturing its value in a
5528 -- temporary. This ensures that aliases of transient objects do not leak
5529 -- to the expression of the expression_with_actions node:
5532 -- Trans_Id : Ctrl_Typ := ...;
5533 -- Alias : ... := Trans_Id;
5534 -- in ... Alias ... end;
5536 -- In the example above, Trans_Id cannot be finalized at the end of the
5537 -- actions list because this may affect the alias and the final value of
5538 -- the expression_with_actions. Forcing the evaluation encapsulates the
5539 -- reference to the Alias within the actions list:
5542 -- Trans_Id : Ctrl_Typ := ...;
5543 -- Alias : ... := Trans_Id;
5544 -- Val : constant Boolean := ... Alias ...;
5545 -- <finalize Trans_Id>
5548 -- Once this transformation is performed, it is safe to finalize the
5549 -- transient object at the end of the actions list.
5551 -- Note that Force_Evaluation does not remove side effects in operators
5552 -- because it assumes that all operands are evaluated and side effect
5553 -- free. This is not the case when an operand depends implicitly on the
5554 -- transient object through the use of access types.
5556 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5557 Force_Boolean_Evaluation
(Expression
(N
));
5559 -- The expression of an expression_with_actions node may not necessarily
5560 -- be Boolean when the node appears in an if expression. In this case do
5561 -- the usual forced evaluation to encapsulate potential aliasing.
5564 -- A check is also needed since the subtype of the EWA node and the
5565 -- subtype of the expression may differ (for example, the EWA node
5566 -- may have a null-excluding access subtype).
5568 Apply_Constraint_Check
(Expression
(N
), Etype
(N
));
5569 Force_Evaluation
(Expression
(N
));
5572 -- Process transient objects found within the actions of the EWA node
5574 Process_Transients_In_Expression
(N
, Acts
);
5576 -- Deal with case where there are no actions. In this case we simply
5577 -- rewrite the node with its expression since we don't need the actions
5578 -- and the specification of this node does not allow a null action list.
5580 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5581 -- the expanded tree and relying on being able to retrieve the original
5582 -- tree in cases like this. This raises a whole lot of issues of whether
5583 -- we have problems elsewhere, which will be addressed in the future???
5585 if Is_Empty_List
(Acts
) then
5586 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5588 end Expand_N_Expression_With_Actions
;
5590 ----------------------------
5591 -- Expand_N_If_Expression --
5592 ----------------------------
5594 -- Deal with limited types and condition actions
5596 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5597 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5598 Loc
: constant Source_Ptr
:= Sloc
(N
);
5599 Thenx
: constant Node_Id
:= Next
(Cond
);
5600 Elsex
: constant Node_Id
:= Next
(Thenx
);
5601 Par
: constant Node_Id
:= Parent
(N
);
5602 Typ
: constant Entity_Id
:= Etype
(N
);
5604 Force_Expand
: constant Boolean := Is_Anonymous_Access_Actual
(N
);
5605 -- Determine if we are dealing with a special case of a conditional
5606 -- expression used as an actual for an anonymous access type which
5607 -- forces us to transform the if expression into an expression with
5608 -- actions in order to create a temporary to capture the level of the
5609 -- expression in each branch.
5611 function OK_For_Single_Subtype
(T1
, T2
: Entity_Id
) return Boolean;
5612 -- Return true if it is acceptable to use a single subtype for two
5613 -- dependent expressions of subtype T1 and T2 respectively, which are
5614 -- unidimensional arrays whose index bounds are known at compile time.
5616 ---------------------------
5617 -- OK_For_Single_Subtype --
5618 ---------------------------
5620 function OK_For_Single_Subtype
(T1
, T2
: Entity_Id
) return Boolean is
5625 Get_First_Index_Bounds
(T1
, Lo1
, Hi1
);
5626 Get_First_Index_Bounds
(T2
, Lo2
, Hi2
);
5628 -- Return true if the length of the covering subtype is not too large
5631 UI_Max
(Hi1
, Hi2
) - UI_Min
(Lo1
, Lo2
) < Too_Large_Length_For_Array
;
5632 end OK_For_Single_Subtype
;
5642 Optimize_Return_Stmt
: Boolean := False;
5643 -- Flag set when the if expression can be optimized in the context of
5644 -- a simple return statement.
5646 -- Start of processing for Expand_N_If_Expression
5649 -- Deal with non-standard booleans
5651 Adjust_Condition
(Cond
);
5653 -- Check for MINIMIZED/ELIMINATED overflow mode.
5654 -- Apply_Arithmetic_Overflow_Check will not deal with Then/Else_Actions
5655 -- so skip this step if any actions are present.
5657 if Minimized_Eliminated_Overflow_Check
(N
)
5658 and then No
(Then_Actions
(N
))
5659 and then No
(Else_Actions
(N
))
5661 Apply_Arithmetic_Overflow_Check
(N
);
5665 -- Fold at compile time if condition known. We have already folded
5666 -- static if expressions, but it is possible to fold any case in which
5667 -- the condition is known at compile time, even though the result is
5670 -- Note that we don't do the fold of such cases in Sem_Elab because
5671 -- it can cause infinite loops with the expander adding a conditional
5672 -- expression, and Sem_Elab circuitry removing it repeatedly.
5674 if Compile_Time_Known_Value
(Cond
) then
5676 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5677 -- Fold at compile time. Assumes condition known. Return True if
5678 -- folding occurred, meaning we're done.
5680 ----------------------
5681 -- Fold_Known_Value --
5682 ----------------------
5684 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5686 if Is_True
(Expr_Value
(Cond
)) then
5688 Actions
:= Then_Actions
(N
);
5691 Actions
:= Else_Actions
(N
);
5696 if Present
(Actions
) then
5698 -- To minimize the use of Expression_With_Actions, just skip
5699 -- the optimization as it is not critical for correctness.
5701 if Minimize_Expression_With_Actions
then
5706 Make_Expression_With_Actions
(Loc
,
5707 Expression
=> Relocate_Node
(Expr
),
5708 Actions
=> Actions
));
5709 Analyze_And_Resolve
(N
, Typ
);
5712 Rewrite
(N
, Relocate_Node
(Expr
));
5715 -- Note that the result is never static (legitimate cases of
5716 -- static if expressions were folded in Sem_Eval).
5718 Set_Is_Static_Expression
(N
, False);
5720 end Fold_Known_Value
;
5723 if Fold_Known_Value
(Cond
) then
5729 -- Small optimization: when the if expression appears in the context of
5730 -- a simple return statement, expand into
5735 -- return else-expr;
5738 -- This makes the expansion much easier when expressions are calls to
5739 -- a BIP function. But do not perform it when the return statement is
5740 -- within a predicate function, as this causes spurious errors.
5742 Optimize_Return_Stmt
:=
5743 Nkind
(Par
) = N_Simple_Return_Statement
5744 and then not (Ekind
(Current_Scope
) in E_Function | E_Procedure
5745 and then Is_Predicate_Function
(Current_Scope
));
5747 if Optimize_Return_Stmt
then
5748 -- When the "then" or "else" expressions involve controlled function
5749 -- calls, generated temporaries are chained on the corresponding list
5750 -- of actions. These temporaries need to be finalized after the if
5751 -- expression is evaluated.
5753 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5754 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5757 Make_Implicit_If_Statement
(N
,
5758 Condition
=> Relocate_Node
(Cond
),
5759 Then_Statements
=> New_List
(
5760 Make_Simple_Return_Statement
(Sloc
(Thenx
),
5761 Expression
=> Relocate_Node
(Thenx
))),
5762 Else_Statements
=> New_List
(
5763 Make_Simple_Return_Statement
(Sloc
(Elsex
),
5764 Expression
=> Relocate_Node
(Elsex
))));
5766 -- Preserve the original context for which the if statement is
5767 -- being generated. This is needed by the finalization machinery
5768 -- to prevent the premature finalization of controlled objects
5769 -- found within the if statement.
5771 Set_From_Conditional_Expression
(New_If
);
5773 -- If the type is by reference, then we expand as follows to avoid the
5774 -- possibility of improper copying.
5776 -- type Ptr is access all Typ;
5780 -- Cnn := then-expr'Unrestricted_Access;
5783 -- Cnn := else-expr'Unrestricted_Access;
5786 -- and replace the if expression by a reference to Cnn.all.
5788 elsif Is_By_Reference_Type
(Typ
) then
5789 -- When the "then" or "else" expressions involve controlled function
5790 -- calls, generated temporaries are chained on the corresponding list
5791 -- of actions. These temporaries need to be finalized after the if
5792 -- expression is evaluated.
5794 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5795 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5798 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C', N
);
5799 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5803 -- type Ann is access all Typ;
5806 Make_Full_Type_Declaration
(Loc
,
5807 Defining_Identifier
=> Ptr_Typ
,
5809 Make_Access_To_Object_Definition
(Loc
,
5810 All_Present
=> True,
5811 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5817 Make_Object_Declaration
(Loc
,
5818 Defining_Identifier
=> Cnn
,
5819 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5823 -- Cnn := <Thenx>'Unrestricted_Access;
5825 -- Cnn := <Elsex>'Unrestricted_Access;
5829 Make_Implicit_If_Statement
(N
,
5830 Condition
=> Relocate_Node
(Cond
),
5831 Then_Statements
=> New_List
(
5832 Make_Assignment_Statement
(Sloc
(Thenx
),
5833 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5835 Make_Attribute_Reference
(Loc
,
5836 Prefix
=> Relocate_Node
(Thenx
),
5837 Attribute_Name
=> Name_Unrestricted_Access
))),
5839 Else_Statements
=> New_List
(
5840 Make_Assignment_Statement
(Sloc
(Elsex
),
5841 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5843 Make_Attribute_Reference
(Loc
,
5844 Prefix
=> Relocate_Node
(Elsex
),
5845 Attribute_Name
=> Name_Unrestricted_Access
))));
5847 -- Preserve the original context for which the if statement is
5848 -- being generated. This is needed by the finalization machinery
5849 -- to prevent the premature finalization of controlled objects
5850 -- found within the if statement.
5852 Set_From_Conditional_Expression
(New_If
);
5855 Make_Explicit_Dereference
(Loc
,
5856 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5859 -- If the result is a unidimensional unconstrained array but the two
5860 -- dependent expressions have constrained subtypes with known bounds,
5861 -- then we expand as follows:
5863 -- subtype Txx is Typ (<static low-bound> .. <static high-bound>);
5867 -- Cnn (<then low-bound .. then high-bound>) := then-expr;
5870 -- Cnn (<else low bound .. else high-bound>) := else-expr;
5873 -- and replace the if expression by a slice of Cnn, provided that Txx
5874 -- is not too large. This will create a static temporary instead of the
5875 -- dynamic one of the next case and thus help the code generator.
5877 -- Note that we need to deal with the case where the else expression is
5878 -- itself such a slice, in order to catch if expressions with more than
5879 -- two dependent expressions in the source code.
5881 -- Also note that this creates variables on branches without an explicit
5882 -- scope, causing troubles with e.g. the LLVM IR, so disable this
5883 -- optimization when Unnest_Subprogram_Mode (enabled for LLVM).
5885 elsif Is_Array_Type
(Typ
)
5886 and then Number_Dimensions
(Typ
) = 1
5887 and then not Is_Constrained
(Typ
)
5888 and then Is_Constrained
(Etype
(Thenx
))
5889 and then Compile_Time_Known_Bounds
(Etype
(Thenx
))
5891 ((Is_Constrained
(Etype
(Elsex
))
5892 and then Compile_Time_Known_Bounds
(Etype
(Elsex
))
5893 and then OK_For_Single_Subtype
(Etype
(Thenx
), Etype
(Elsex
)))
5895 (Nkind
(Elsex
) = N_Slice
5896 and then Is_Constrained
(Etype
(Prefix
(Elsex
)))
5897 and then Compile_Time_Known_Bounds
(Etype
(Prefix
(Elsex
)))
5899 OK_For_Single_Subtype
(Etype
(Thenx
), Etype
(Prefix
(Elsex
)))))
5900 and then not Generate_C_Code
5901 and then not Unnest_Subprogram_Mode
5903 -- When the "then" or "else" expressions involve controlled function
5904 -- calls, generated temporaries are chained on the corresponding list
5905 -- of actions. These temporaries need to be finalized after the if
5906 -- expression is evaluated.
5908 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
5909 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
5912 Ityp
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
5914 function Build_New_Bound
5917 Slice_Bnd
: Node_Id
) return Node_Id
;
5918 -- Build a new bound from the bounds of the if expression
5920 function To_Ityp
(V
: Uint
) return Node_Id
;
5921 -- Convert V to an index value in Ityp
5923 ---------------------
5924 -- Build_New_Bound --
5925 ---------------------
5927 function Build_New_Bound
5930 Slice_Bnd
: Node_Id
) return Node_Id
is
5933 -- We need to use the special processing for slices only if
5934 -- they do not have compile-time known bounds; if they do, they
5935 -- can be treated like any other expressions.
5937 if Nkind
(Elsex
) = N_Slice
5938 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
5940 if Compile_Time_Known_Value
(Slice_Bnd
)
5941 and then Expr_Value
(Slice_Bnd
) = Then_Bnd
5943 return To_Ityp
(Then_Bnd
);
5946 return Make_If_Expression
(Loc
,
5947 Expressions
=> New_List
(
5948 Duplicate_Subexpr
(Cond
),
5950 New_Copy_Tree
(Slice_Bnd
)));
5953 elsif Then_Bnd
= Else_Bnd
then
5954 return To_Ityp
(Then_Bnd
);
5957 return Make_If_Expression
(Loc
,
5958 Expressions
=> New_List
(
5959 Duplicate_Subexpr
(Cond
),
5961 To_Ityp
(Else_Bnd
)));
5963 end Build_New_Bound
;
5969 function To_Ityp
(V
: Uint
) return Node_Id
is
5970 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, V
);
5973 if Is_Enumeration_Type
(Ityp
) then
5975 Make_Attribute_Reference
(Loc
,
5976 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
5977 Attribute_Name
=> Name_Val
,
5978 Expressions
=> New_List
(Result
));
5985 Slice_Lo
, Slice_Hi
: Node_Id
;
5986 Subtyp_Ind
: Node_Id
;
5987 Else_Lo
, Else_Hi
: Uint
;
5988 Min_Lo
, Max_Hi
: Uint
;
5989 Then_Lo
, Then_Hi
: Uint
;
5990 Then_List
, Else_List
: List_Id
;
5993 Get_First_Index_Bounds
(Etype
(Thenx
), Then_Lo
, Then_Hi
);
5995 -- See the rationale in Build_New_Bound
5997 if Nkind
(Elsex
) = N_Slice
5998 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
6000 Slice_Lo
:= Low_Bound
(Discrete_Range
(Elsex
));
6001 Slice_Hi
:= High_Bound
(Discrete_Range
(Elsex
));
6002 Get_First_Index_Bounds
6003 (Etype
(Prefix
(Elsex
)), Else_Lo
, Else_Hi
);
6008 Get_First_Index_Bounds
(Etype
(Elsex
), Else_Lo
, Else_Hi
);
6011 Min_Lo
:= UI_Min
(Then_Lo
, Else_Lo
);
6012 Max_Hi
:= UI_Max
(Then_Hi
, Else_Hi
);
6014 -- Now we construct an array object with appropriate bounds and
6015 -- mark it as internal to prevent useless initialization when
6016 -- Initialize_Scalars is enabled. Also since this is the actual
6017 -- result entity, we make sure we have debug information for it.
6020 Make_Subtype_Indication
(Loc
,
6021 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
6023 Make_Index_Or_Discriminant_Constraint
(Loc
,
6024 Constraints
=> New_List
(
6026 Low_Bound
=> To_Ityp
(Min_Lo
),
6027 High_Bound
=> To_Ityp
(Max_Hi
)))));
6029 Ent
:= Make_Temporary
(Loc
, 'C');
6030 Set_Is_Internal
(Ent
);
6031 Set_Debug_Info_Needed
(Ent
);
6034 Make_Object_Declaration
(Loc
,
6035 Defining_Identifier
=> Ent
,
6036 Object_Definition
=> Subtyp_Ind
);
6038 -- If the result of the expression appears as the initializing
6039 -- expression of an object declaration, we can just rename the
6040 -- result, rather than copying it.
6042 Mutate_Ekind
(Ent
, E_Variable
);
6043 Set_OK_To_Rename
(Ent
);
6045 Then_List
:= New_List
(
6046 Make_Assignment_Statement
(Loc
,
6049 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6052 Low_Bound
=> To_Ityp
(Then_Lo
),
6053 High_Bound
=> To_Ityp
(Then_Hi
))),
6054 Expression
=> Relocate_Node
(Thenx
)));
6056 Set_Suppress_Assignment_Checks
(Last
(Then_List
));
6058 -- See the rationale in Build_New_Bound
6060 if Nkind
(Elsex
) = N_Slice
6061 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
6063 Else_List
:= New_List
(
6064 Make_Assignment_Statement
(Loc
,
6067 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6070 Low_Bound
=> New_Copy_Tree
(Slice_Lo
),
6071 High_Bound
=> New_Copy_Tree
(Slice_Hi
))),
6072 Expression
=> Relocate_Node
(Elsex
)));
6075 Else_List
:= New_List
(
6076 Make_Assignment_Statement
(Loc
,
6079 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6082 Low_Bound
=> To_Ityp
(Else_Lo
),
6083 High_Bound
=> To_Ityp
(Else_Hi
))),
6084 Expression
=> Relocate_Node
(Elsex
)));
6087 Set_Suppress_Assignment_Checks
(Last
(Else_List
));
6090 Make_Implicit_If_Statement
(N
,
6091 Condition
=> Duplicate_Subexpr
(Cond
),
6092 Then_Statements
=> Then_List
,
6093 Else_Statements
=> Else_List
);
6097 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6098 Discrete_Range
=> Make_Range
(Loc
,
6099 Low_Bound
=> Build_New_Bound
(Then_Lo
, Else_Lo
, Slice_Lo
),
6100 High_Bound
=> Build_New_Bound
(Then_Hi
, Else_Hi
, Slice_Hi
)));
6103 -- If the result is an unconstrained array and the if expression is in a
6104 -- context other than the initializing expression of the declaration of
6105 -- an object, then we pull out the if expression as follows:
6107 -- Cnn : constant typ := if-expression
6109 -- and then replace the if expression with an occurrence of Cnn. This
6110 -- avoids the need in the back end to create on-the-fly variable length
6111 -- temporaries (which it cannot do!)
6113 -- Note that the test for being in an object declaration avoids doing an
6114 -- unnecessary expansion, and also avoids infinite recursion.
6116 elsif Is_Array_Type
(Typ
)
6117 and then not Is_Constrained
(Typ
)
6118 and then not (Nkind
(Par
) = N_Object_Declaration
6119 and then Expression
(Par
) = N
)
6122 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6126 Make_Object_Declaration
(Loc
,
6127 Defining_Identifier
=> Cnn
,
6128 Constant_Present
=> True,
6129 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6130 Expression
=> Relocate_Node
(N
),
6131 Has_Init_Expression
=> True));
6133 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
6137 -- For other types, we only need to expand if there are other actions
6138 -- associated with either branch or we need to force expansion to deal
6139 -- with if expressions used as an actual of an anonymous access type.
6141 elsif Present
(Then_Actions
(N
))
6142 or else Present
(Else_Actions
(N
))
6143 or else Force_Expand
6145 -- We now wrap the actions into the appropriate expression
6147 if Minimize_Expression_With_Actions
6148 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
6149 or else Is_Constrained
(Underlying_Type
(Typ
)))
6151 -- When the "then" or "else" expressions involve controlled
6152 -- function calls, generated temporaries are chained on the
6153 -- corresponding list of actions. These temporaries need to
6154 -- be finalized after the if expression is evaluated.
6156 Process_Transients_In_Expression
(N
, Then_Actions
(N
));
6157 Process_Transients_In_Expression
(N
, Else_Actions
(N
));
6159 -- If we can't use N_Expression_With_Actions nodes, then we insert
6160 -- the following sequence of actions (using Insert_Actions):
6165 -- Cnn := then-expr;
6171 -- and replace the if expression by a reference to Cnn
6174 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6178 Make_Object_Declaration
(Loc
,
6179 Defining_Identifier
=> Cnn
,
6180 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6183 Make_Implicit_If_Statement
(N
,
6184 Condition
=> Relocate_Node
(Cond
),
6186 Then_Statements
=> New_List
(
6187 Make_Assignment_Statement
(Sloc
(Thenx
),
6188 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6189 Expression
=> Relocate_Node
(Thenx
))),
6191 Else_Statements
=> New_List
(
6192 Make_Assignment_Statement
(Sloc
(Elsex
),
6193 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6194 Expression
=> Relocate_Node
(Elsex
))));
6196 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
6197 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
6199 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
6202 -- Regular path using Expression_With_Actions
6205 -- We do not need to call Process_Transients_In_Expression on
6206 -- the list of actions in this case, because the expansion of
6207 -- Expression_With_Actions will do it.
6209 if Present
(Then_Actions
(N
)) then
6211 Make_Expression_With_Actions
(Sloc
(Thenx
),
6212 Actions
=> Then_Actions
(N
),
6213 Expression
=> Relocate_Node
(Thenx
)));
6215 Set_Then_Actions
(N
, No_List
);
6216 Analyze_And_Resolve
(Thenx
, Typ
);
6219 if Present
(Else_Actions
(N
)) then
6221 Make_Expression_With_Actions
(Sloc
(Elsex
),
6222 Actions
=> Else_Actions
(N
),
6223 Expression
=> Relocate_Node
(Elsex
)));
6225 Set_Else_Actions
(N
, No_List
);
6226 Analyze_And_Resolve
(Elsex
, Typ
);
6229 -- We must force expansion into an expression with actions when
6230 -- an if expression gets used directly as an actual for an
6231 -- anonymous access type.
6233 if Force_Expand
then
6235 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
6244 Make_Object_Declaration
(Loc
,
6245 Defining_Identifier
=> Cnn
,
6246 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6247 Append_To
(Acts
, Decl
);
6249 Set_No_Initialization
(Decl
);
6259 Make_Implicit_If_Statement
(N
,
6260 Condition
=> Relocate_Node
(Cond
),
6261 Then_Statements
=> New_List
(
6262 Make_Assignment_Statement
(Sloc
(Thenx
),
6263 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6264 Expression
=> Relocate_Node
(Thenx
))),
6266 Else_Statements
=> New_List
(
6267 Make_Assignment_Statement
(Sloc
(Elsex
),
6268 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6269 Expression
=> Relocate_Node
(Elsex
))));
6270 Append_To
(Acts
, New_If
);
6278 Make_Expression_With_Actions
(Loc
,
6279 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6281 Analyze_And_Resolve
(N
, Typ
);
6288 -- For the sake of GNATcoverage, generate an intermediate temporary in
6289 -- the case where the if expression is a condition in an outer decision,
6290 -- in order to make sure that no branch is shared between the decisions.
6292 elsif Opt
.Suppress_Control_Flow_Optimizations
6293 and then Nkind
(Original_Node
(Par
)) in N_Case_Expression
6297 | N_Goto_When_Statement
6299 | N_Return_When_Statement
6303 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
6309 -- Cnn : constant Typ := N;
6313 Make_Object_Declaration
(Loc
,
6314 Defining_Identifier
=> Cnn
,
6315 Constant_Present
=> True,
6316 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6317 Expression
=> Relocate_Node
(N
)));
6320 Make_Expression_With_Actions
(Loc
,
6321 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6324 Analyze_And_Resolve
(N
, Typ
);
6328 -- If no actions then no expansion needed, gigi will handle it using the
6329 -- same approach as a C conditional expression.
6335 -- Fall through here for either the limited expansion, or the case of
6336 -- inserting actions for nonlimited types. In both these cases, we must
6337 -- move the SLOC of the parent If statement to the newly created one and
6338 -- change it to the SLOC of the expression which, after expansion, will
6339 -- correspond to what is being evaluated.
6341 if Present
(Par
) and then Nkind
(Par
) = N_If_Statement
then
6342 Set_Sloc
(New_If
, Sloc
(Par
));
6343 Set_Sloc
(Par
, Loc
);
6346 -- Move Then_Actions and Else_Actions, if any, to the new if statement
6348 if Present
(Then_Actions
(N
)) then
6349 Prepend_List
(Then_Actions
(N
), Then_Statements
(New_If
));
6352 if Present
(Else_Actions
(N
)) then
6353 Prepend_List
(Else_Actions
(N
), Else_Statements
(New_If
));
6356 -- Rewrite the parent return statement as an if statement
6358 if Optimize_Return_Stmt
then
6359 Rewrite
(Par
, New_If
);
6362 -- Otherwise rewrite the if expression itself
6365 Insert_Action
(N
, Decl
);
6366 Insert_Action
(N
, New_If
);
6368 Analyze_And_Resolve
(N
, Typ
);
6370 end Expand_N_If_Expression
;
6376 procedure Expand_N_In
(N
: Node_Id
) is
6377 Loc
: constant Source_Ptr
:= Sloc
(N
);
6378 Restyp
: constant Entity_Id
:= Etype
(N
);
6379 Lop
: constant Node_Id
:= Left_Opnd
(N
);
6380 Rop
: constant Node_Id
:= Right_Opnd
(N
);
6381 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
6383 procedure Substitute_Valid_Test
;
6384 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6385 -- test for the left operand being in range of its subtype.
6387 ---------------------------
6388 -- Substitute_Valid_Test --
6389 ---------------------------
6391 procedure Substitute_Valid_Test
is
6392 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
6393 -- Determine whether arbitrary node Nod denotes a source object that
6394 -- may safely act as prefix of attribute 'Valid.
6396 ----------------------------
6397 -- Is_OK_Object_Reference --
6398 ----------------------------
6400 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
6401 Obj_Ref
: constant Node_Id
:= Original_Node
(Nod
);
6402 -- The original operand
6405 -- The object reference must be a source construct, otherwise the
6406 -- codefix suggestion may refer to nonexistent code from a user
6409 return Comes_From_Source
(Obj_Ref
)
6410 and then Is_Object_Reference
(Unqual_Conv
(Obj_Ref
));
6411 end Is_OK_Object_Reference
;
6413 -- Start of processing for Substitute_Valid_Test
6417 Make_Attribute_Reference
(Loc
,
6418 Prefix
=> Relocate_Node
(Lop
),
6419 Attribute_Name
=> Name_Valid
));
6421 Analyze_And_Resolve
(N
, Restyp
);
6423 -- Emit a warning when the left-hand operand of the membership test
6424 -- is a source object, otherwise the use of attribute 'Valid would be
6425 -- illegal. The warning is not given when overflow checking is either
6426 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6427 -- eliminated above.
6429 if Is_OK_Object_Reference
(Lop
)
6430 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
6433 ("??explicit membership test may be optimized away", N
);
6434 Error_Msg_N
-- CODEFIX
6435 ("\??use ''Valid attribute instead", N
);
6437 end Substitute_Valid_Test
;
6444 -- Start of processing for Expand_N_In
6447 -- If set membership case, expand with separate procedure
6449 if Present
(Alternatives
(N
)) then
6450 Expand_Set_Membership
(N
);
6454 -- Not set membership, proceed with expansion
6456 Ltyp
:= Etype
(Left_Opnd
(N
));
6457 Rtyp
:= Etype
(Right_Opnd
(N
));
6459 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6460 -- type, then expand with a separate procedure. Note the use of the
6461 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6463 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
))
6464 and then not No_Minimize_Eliminate
(N
)
6466 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
6470 -- Check case of explicit test for an expression in range of its
6471 -- subtype. This is suspicious usage and we replace it with a 'Valid
6472 -- test and give a warning for scalar types.
6474 if Is_Scalar_Type
(Ltyp
)
6476 -- Only relevant for source comparisons
6478 and then Comes_From_Source
(N
)
6480 -- In floating-point this is a standard way to check for finite values
6481 -- and using 'Valid would typically be a pessimization.
6483 and then not Is_Floating_Point_Type
(Ltyp
)
6485 -- Don't give the message unless right operand is a type entity and
6486 -- the type of the left operand matches this type. Note that this
6487 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6488 -- checks have changed the type of the left operand.
6490 and then Is_Entity_Name
(Rop
)
6491 and then Ltyp
= Entity
(Rop
)
6493 -- Skip this for predicated types, where such expressions are a
6494 -- reasonable way of testing if something meets the predicate.
6496 and then No
(Predicate_Function
(Ltyp
))
6498 Substitute_Valid_Test
;
6502 -- Do validity check on operands
6504 if Validity_Checks_On
and Validity_Check_Operands
then
6505 Ensure_Valid
(Left_Opnd
(N
));
6506 Validity_Check_Range
(Right_Opnd
(N
));
6509 -- Case of explicit range
6511 if Nkind
(Rop
) = N_Range
then
6513 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
6514 Hi
: constant Node_Id
:= High_Bound
(Rop
);
6516 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
6517 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
6518 Rop_Orig
: constant Node_Id
:= Original_Node
(Rop
);
6520 Comes_From_Simple_Range_In_Source
: constant Boolean :=
6521 Comes_From_Source
(N
)
6523 (Is_Entity_Name
(Rop_Orig
)
6524 and then Is_Type
(Entity
(Rop_Orig
))
6525 and then Present
(Predicate_Function
(Entity
(Rop_Orig
))));
6526 -- This is true for a membership test present in the source with a
6527 -- range or mark for a subtype that is not predicated. As already
6528 -- explained a few lines above, we do not want to give warnings on
6529 -- a test with a mark for a subtype that is predicated.
6531 Warn
: constant Boolean :=
6532 Constant_Condition_Warnings
6533 and then Comes_From_Simple_Range_In_Source
6534 and then not In_Instance
;
6535 -- This must be true for any of the optimization warnings, we
6536 -- clearly want to give them only for source with the flag on. We
6537 -- also skip these warnings in an instance since it may be the
6538 -- case that different instantiations have different ranges.
6540 Lcheck
: Compare_Result
;
6541 Ucheck
: Compare_Result
;
6544 -- If test is explicit x'First .. x'Last, replace by 'Valid test
6546 if Is_Scalar_Type
(Ltyp
)
6548 -- Only relevant for source comparisons
6550 and then Comes_From_Simple_Range_In_Source
6552 -- And left operand is X'First where X matches left operand
6553 -- type (this eliminates cases of type mismatch, including
6554 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6555 -- type of the left operand.
6557 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
6558 and then Attribute_Name
(Lo_Orig
) = Name_First
6559 and then Is_Entity_Name
(Prefix
(Lo_Orig
))
6560 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
6562 -- Same tests for right operand
6564 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
6565 and then Attribute_Name
(Hi_Orig
) = Name_Last
6566 and then Is_Entity_Name
(Prefix
(Hi_Orig
))
6567 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
6569 Substitute_Valid_Test
;
6573 -- If bounds of type are known at compile time, and the end points
6574 -- are known at compile time and identical, this is another case
6575 -- for substituting a valid test. We only do this for discrete
6576 -- types, since it won't arise in practice for float types.
6578 if Comes_From_Simple_Range_In_Source
6579 and then Is_Discrete_Type
(Ltyp
)
6580 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
6581 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
6582 and then Compile_Time_Known_Value
(Lo
)
6583 and then Compile_Time_Known_Value
(Hi
)
6584 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
6585 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
6587 -- Kill warnings in instances, since they may be cases where we
6588 -- have a test in the generic that makes sense with some types
6589 -- and not with other types.
6591 -- Similarly, do not rewrite membership as a 'Valid test if
6592 -- within the predicate function for the type.
6594 -- Finally, if the original bounds are type conversions, even
6595 -- if they have been folded into constants, there are different
6596 -- types involved and 'Valid is not appropriate.
6600 or else (Ekind
(Current_Scope
) = E_Function
6601 and then Is_Predicate_Function
(Current_Scope
))
6605 elsif Nkind
(Lo_Orig
) = N_Type_Conversion
6606 or else Nkind
(Hi_Orig
) = N_Type_Conversion
6611 Substitute_Valid_Test
;
6616 -- If we have an explicit range, do a bit of optimization based on
6617 -- range analysis (we may be able to kill one or both checks).
6619 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
6620 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
6622 -- If either check is known to fail, replace result by False since
6623 -- the other check does not matter. Preserve the static flag for
6624 -- legality checks, because we are constant-folding beyond RM 4.9.
6626 if Lcheck
= LT
or else Ucheck
= GT
then
6628 Error_Msg_N
("?c?range test optimized away", N
);
6629 Error_Msg_N
("\?c?value is known to be out of range", N
);
6632 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6633 Analyze_And_Resolve
(N
, Restyp
);
6634 Set_Is_Static_Expression
(N
, Static
);
6637 -- If both checks are known to succeed, replace result by True,
6638 -- since we know we are in range.
6640 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6642 Error_Msg_N
("?c?range test optimized away", N
);
6643 Error_Msg_N
("\?c?value is known to be in range", N
);
6646 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6647 Analyze_And_Resolve
(N
, Restyp
);
6648 Set_Is_Static_Expression
(N
, Static
);
6651 -- If lower bound check succeeds and upper bound check is not
6652 -- known to succeed or fail, then replace the range check with
6653 -- a comparison against the upper bound.
6655 elsif Lcheck
in Compare_GE
then
6659 Right_Opnd
=> High_Bound
(Rop
)));
6660 Analyze_And_Resolve
(N
, Restyp
);
6663 -- Inverse of previous case.
6665 elsif Ucheck
in Compare_LE
then
6669 Right_Opnd
=> Low_Bound
(Rop
)));
6670 Analyze_And_Resolve
(N
, Restyp
);
6674 -- We couldn't optimize away the range check, but there is one
6675 -- more issue. If we are checking constant conditionals, then we
6676 -- see if we can determine the outcome assuming everything is
6677 -- valid, and if so give an appropriate warning.
6679 if Warn
and then not Assume_No_Invalid_Values
then
6680 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
6681 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
6683 -- Result is out of range for valid value
6685 if Lcheck
= LT
or else Ucheck
= GT
then
6687 ("?c?value can only be in range if it is invalid", N
);
6689 -- Result is in range for valid value
6691 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6693 ("?c?value can only be out of range if it is invalid", N
);
6698 -- Try to narrow the operation
6700 if Ltyp
= Universal_Integer
and then Nkind
(N
) = N_In
then
6701 Narrow_Large_Operation
(N
);
6704 -- For all other cases of an explicit range, nothing to be done
6708 -- Here right operand is a subtype mark
6712 Typ
: Entity_Id
:= Etype
(Rop
);
6713 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
6714 Check_Null_Exclusion
: Boolean;
6715 Cond
: Node_Id
:= Empty
;
6717 Obj
: Node_Id
:= Lop
;
6718 SCIL_Node
: Node_Id
;
6721 Remove_Side_Effects
(Obj
);
6723 -- For tagged type, do tagged membership operation
6725 if Is_Tagged_Type
(Typ
) then
6727 -- No expansion will be performed for VM targets, as the VM
6728 -- back ends will handle the membership tests directly.
6730 if Tagged_Type_Expansion
then
6731 Tagged_Membership
(N
, SCIL_Node
, New_N
);
6733 Analyze_And_Resolve
(N
, Restyp
, Suppress
=> All_Checks
);
6735 -- Update decoration of relocated node referenced by the
6738 if Generate_SCIL
and then Present
(SCIL_Node
) then
6739 Set_SCIL_Node
(N
, SCIL_Node
);
6745 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6746 -- The reason we do this is that the bounds may have the wrong
6747 -- type if they come from the original type definition. Also this
6748 -- way we get all the processing above for an explicit range.
6750 -- Don't do this for predicated types, since in this case we want
6751 -- to generate the predicate check at the end of the function.
6753 elsif Is_Scalar_Type
(Typ
) then
6754 if No
(Predicate_Function
(Typ
)) then
6758 Make_Attribute_Reference
(Loc
,
6759 Attribute_Name
=> Name_First
,
6760 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
6763 Make_Attribute_Reference
(Loc
,
6764 Attribute_Name
=> Name_Last
,
6765 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
6767 Analyze_And_Resolve
(N
, Restyp
);
6772 -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is
6773 -- raised when evaluating an individual membership test if the
6774 -- subtype mark denotes a constrained Unchecked_Union subtype
6775 -- and the expression lacks inferable discriminants.
6777 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
6778 and then Is_Constrained
(Typ
)
6779 and then not Has_Inferable_Discriminants
(Lop
)
6782 Make_Expression_With_Actions
(Loc
,
6784 New_List
(Make_Raise_Program_Error
(Loc
,
6785 Reason
=> PE_Unchecked_Union_Restriction
)),
6787 New_Occurrence_Of
(Standard_False
, Loc
)));
6788 Analyze_And_Resolve
(N
, Restyp
);
6793 -- Here we have a non-scalar type
6797 -- If the null exclusion checks are not compatible, need to
6798 -- perform further checks. In other words, we cannot have
6799 -- Ltyp including null or Lop being null, and Typ excluding
6800 -- null. All other cases are OK.
6802 Check_Null_Exclusion
:=
6803 Can_Never_Be_Null
(Typ
)
6804 and then (not Can_Never_Be_Null
(Ltyp
)
6805 or else Nkind
(Lop
) = N_Null
);
6806 Typ
:= Designated_Type
(Typ
);
6809 if not Is_Constrained
(Typ
) then
6810 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6812 -- For the constrained array case, we have to check the subscripts
6813 -- for an exact match if the lengths are non-zero (the lengths
6814 -- must match in any case).
6816 elsif Is_Array_Type
(Typ
) then
6817 Check_Subscripts
: declare
6818 function Build_Attribute_Reference
6821 Dim
: Nat
) return Node_Id
;
6822 -- Build attribute reference E'Nam (Dim)
6824 -------------------------------
6825 -- Build_Attribute_Reference --
6826 -------------------------------
6828 function Build_Attribute_Reference
6831 Dim
: Nat
) return Node_Id
6835 Make_Attribute_Reference
(Loc
,
6837 Attribute_Name
=> Nam
,
6838 Expressions
=> New_List
(
6839 Make_Integer_Literal
(Loc
, Dim
)));
6840 end Build_Attribute_Reference
;
6842 -- Start of processing for Check_Subscripts
6845 for J
in 1 .. Number_Dimensions
(Typ
) loop
6846 Evolve_And_Then
(Cond
,
6849 Build_Attribute_Reference
6850 (Duplicate_Subexpr_No_Checks
(Obj
),
6853 Build_Attribute_Reference
6854 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
6856 Evolve_And_Then
(Cond
,
6859 Build_Attribute_Reference
6860 (Duplicate_Subexpr_No_Checks
(Obj
),
6863 Build_Attribute_Reference
6864 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
6866 end Check_Subscripts
;
6868 -- These are the cases where constraint checks may be required,
6869 -- e.g. records with possible discriminants
6872 -- Expand the test into a series of discriminant comparisons.
6873 -- The expression that is built is the negation of the one that
6874 -- is used for checking discriminant constraints.
6876 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6878 if Has_Discriminants
(Typ
) then
6879 Cond
:= Make_Op_Not
(Loc
,
6880 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6882 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6887 if Check_Null_Exclusion
then
6888 Cond
:= Make_And_Then
(Loc
,
6892 Right_Opnd
=> Make_Null
(Loc
)),
6893 Right_Opnd
=> Cond
);
6895 Cond
:= Make_Or_Else
(Loc
,
6899 Right_Opnd
=> Make_Null
(Loc
)),
6900 Right_Opnd
=> Cond
);
6905 Analyze_And_Resolve
(N
, Restyp
);
6907 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6908 -- expression of an anonymous access type. This can involve an
6909 -- accessibility test and a tagged type membership test in the
6910 -- case of tagged designated types.
6912 if Ada_Version
>= Ada_2012
6914 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
6917 Expr_Entity
: Entity_Id
:= Empty
;
6919 Param_Level
: Node_Id
;
6920 Type_Level
: Node_Id
;
6923 if Is_Entity_Name
(Lop
) then
6924 Expr_Entity
:= Param_Entity
(Lop
);
6926 if No
(Expr_Entity
) then
6927 Expr_Entity
:= Entity
(Lop
);
6931 -- When restriction No_Dynamic_Accessibility_Checks is in
6932 -- effect, expand the membership test to a static value
6933 -- since we cannot rely on dynamic levels.
6935 if No_Dynamic_Accessibility_Checks_Enabled
(Lop
) then
6936 if Static_Accessibility_Level
6937 (Lop
, Object_Decl_Level
)
6938 > Type_Access_Level
(Rtyp
)
6940 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6942 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6944 Analyze_And_Resolve
(N
, Restyp
);
6946 -- If a conversion of the anonymous access value to the
6947 -- tested type would be illegal, then the result is False.
6949 elsif not Valid_Conversion
6950 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6952 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6953 Analyze_And_Resolve
(N
, Restyp
);
6955 -- Apply an accessibility check if the access object has an
6956 -- associated access level and when the level of the type is
6957 -- less deep than the level of the access parameter. This
6958 -- can only occur for access parameters and stand-alone
6959 -- objects of an anonymous access type.
6962 Param_Level
:= Accessibility_Level
6963 (Expr_Entity
, Dynamic_Level
);
6966 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6968 -- Return True only if the accessibility level of the
6969 -- expression entity is not deeper than the level of
6970 -- the tested access type.
6974 Left_Opnd
=> Relocate_Node
(N
),
6975 Right_Opnd
=> Make_Op_Le
(Loc
,
6976 Left_Opnd
=> Param_Level
,
6977 Right_Opnd
=> Type_Level
)));
6979 Analyze_And_Resolve
(N
);
6981 -- If the designated type is tagged, do tagged membership
6984 if Is_Tagged_Type
(Typ
) then
6986 -- No expansion will be performed for VM targets, as
6987 -- the VM back ends will handle the membership tests
6990 if Tagged_Type_Expansion
then
6992 -- Note that we have to pass Original_Node, because
6993 -- the membership test might already have been
6994 -- rewritten by earlier parts of membership test.
6997 (Original_Node
(N
), SCIL_Node
, New_N
);
6999 -- Update decoration of relocated node referenced
7000 -- by the SCIL node.
7002 if Generate_SCIL
and then Present
(SCIL_Node
) then
7003 Set_SCIL_Node
(New_N
, SCIL_Node
);
7008 Left_Opnd
=> Relocate_Node
(N
),
7009 Right_Opnd
=> New_N
));
7011 Analyze_And_Resolve
(N
, Restyp
);
7020 -- At this point, we have done the processing required for the basic
7021 -- membership test, but not yet dealt with the predicate.
7025 -- If a predicate is present, then we do the predicate test, but we
7026 -- most certainly want to omit this if we are within the predicate
7027 -- function itself, since otherwise we have an infinite recursion.
7028 -- The check should also not be emitted when testing against a range
7029 -- (the check is only done when the right operand is a subtype; see
7030 -- RM12-4.5.2 (28.1/3-30/3)).
7032 Predicate_Check
: declare
7033 function In_Range_Check
return Boolean;
7034 -- Within an expanded range check that may raise Constraint_Error do
7035 -- not generate a predicate check as well. It is redundant because
7036 -- the context will add an explicit predicate check, and it will
7037 -- raise the wrong exception if it fails.
7039 --------------------
7040 -- In_Range_Check --
7041 --------------------
7043 function In_Range_Check
return Boolean is
7047 while Present
(P
) loop
7048 if Nkind
(P
) = N_Raise_Constraint_Error
then
7051 elsif Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
7052 or else Nkind
(P
) = N_Procedure_Call_Statement
7053 or else Nkind
(P
) in N_Declaration
7066 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
7069 -- Start of processing for Predicate_Check
7073 and then Current_Scope
/= PFunc
7074 and then Nkind
(Rop
) /= N_Range
7076 -- First apply the transformation that was skipped above
7078 if Is_Scalar_Type
(Rtyp
) then
7082 Make_Attribute_Reference
(Loc
,
7083 Attribute_Name
=> Name_First
,
7084 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
7087 Make_Attribute_Reference
(Loc
,
7088 Attribute_Name
=> Name_Last
,
7089 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
7091 Analyze_And_Resolve
(N
, Restyp
);
7094 if not In_Range_Check
then
7095 -- Indicate via Static_Mem parameter that this predicate
7096 -- evaluation is for a membership test.
7097 R_Op
:= Make_Predicate_Call
(Rtyp
, Lop
, Static_Mem
=> True);
7099 R_Op
:= New_Occurrence_Of
(Standard_True
, Loc
);
7104 Left_Opnd
=> Relocate_Node
(N
),
7105 Right_Opnd
=> R_Op
));
7107 -- Analyze new expression, mark left operand as analyzed to
7108 -- avoid infinite recursion adding predicate calls. Similarly,
7109 -- suppress further range checks on the call.
7111 Set_Analyzed
(Left_Opnd
(N
));
7112 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7114 end Predicate_Check
;
7117 --------------------------------
7118 -- Expand_N_Indexed_Component --
7119 --------------------------------
7121 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
7123 Wild_Reads_May_Have_Bad_Side_Effects
: Boolean
7124 renames Validity_Check_Subscripts
;
7125 -- This Boolean needs to be True if reading from a bad address can
7126 -- have a bad side effect (e.g., a segmentation fault that is not
7127 -- transformed into a Storage_Error exception, or interactions with
7128 -- memory-mapped I/O) that needs to be prevented. This refers to the
7129 -- act of reading itself, not to any damage that might be caused later
7130 -- by making use of whatever value was read. We assume here that
7131 -- Validity_Check_Subscripts meets this requirement, but introduce
7132 -- this declaration in order to document this assumption.
7134 function Is_Renamed_Variable_Name
(N
: Node_Id
) return Boolean;
7135 -- Returns True if the given name occurs as part of the renaming
7136 -- of a variable. In this case, the indexing operation should be
7137 -- treated as a write, rather than a read, with respect to validity
7138 -- checking. This is because the renamed variable can later be
7141 function Type_Requires_Subscript_Validity_Checks_For_Reads
7142 (Typ
: Entity_Id
) return Boolean;
7143 -- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing
7144 -- into an array of characters in order to read an element, it is ok
7145 -- if an invalid index value goes undetected. But if it is an array of
7146 -- pointers or an array of tasks, the consequences of such a read are
7147 -- potentially more severe and so we want to detect an invalid index
7148 -- value. This function captures that distinction; this is intended to
7149 -- be consistent with the "but does not by itself lead to erroneous
7150 -- ... execution" rule of RM 13.9.1(11).
7152 ------------------------------
7153 -- Is_Renamed_Variable_Name --
7154 ------------------------------
7156 function Is_Renamed_Variable_Name
(N
: Node_Id
) return Boolean is
7157 Rover
: Node_Id
:= N
;
7159 if Is_Variable
(N
) then
7162 Rover_Parent
: constant Node_Id
:= Parent
(Rover
);
7164 case Nkind
(Rover_Parent
) is
7165 when N_Object_Renaming_Declaration
=>
7166 return Rover
= Name
(Rover_Parent
);
7168 when N_Indexed_Component
7170 | N_Selected_Component
7172 exit when Rover
/= Prefix
(Rover_Parent
);
7173 Rover
:= Rover_Parent
;
7175 -- No need to check for qualified expressions or type
7176 -- conversions here, mostly because of the Is_Variable
7177 -- test. It is possible to have a view conversion for
7178 -- which Is_Variable yields True and which occurs as
7179 -- part of an object renaming, but only if the type is
7180 -- tagged; in that case this function will not be called.
7189 end Is_Renamed_Variable_Name
;
7191 -------------------------------------------------------
7192 -- Type_Requires_Subscript_Validity_Checks_For_Reads --
7193 -------------------------------------------------------
7195 function Type_Requires_Subscript_Validity_Checks_For_Reads
7196 (Typ
: Entity_Id
) return Boolean
7198 -- a shorter name for recursive calls
7199 function Needs_Check
(Typ
: Entity_Id
) return Boolean renames
7200 Type_Requires_Subscript_Validity_Checks_For_Reads
;
7202 if Is_Access_Type
(Typ
)
7203 or else Is_Tagged_Type
(Typ
)
7204 or else Is_Concurrent_Type
(Typ
)
7205 or else (Is_Array_Type
(Typ
)
7206 and then Needs_Check
(Component_Type
(Typ
)))
7207 or else (Is_Scalar_Type
(Typ
)
7208 and then Has_Aspect
(Typ
, Aspect_Default_Value
))
7213 if Is_Record_Type
(Typ
) then
7215 Comp
: Entity_Id
:= First_Component_Or_Discriminant
(Typ
);
7217 while Present
(Comp
) loop
7218 if Needs_Check
(Etype
(Comp
)) then
7222 Next_Component_Or_Discriminant
(Comp
);
7228 end Type_Requires_Subscript_Validity_Checks_For_Reads
;
7232 Loc
: constant Source_Ptr
:= Sloc
(N
);
7233 Typ
: constant Entity_Id
:= Etype
(N
);
7234 P
: constant Node_Id
:= Prefix
(N
);
7235 T
: constant Entity_Id
:= Etype
(P
);
7237 -- Start of processing for Expand_N_Indexed_Component
7240 -- A special optimization, if we have an indexed component that is
7241 -- selecting from a slice, then we can eliminate the slice, since, for
7242 -- example, x (i .. j)(k) is identical to x(k). The only difference is
7243 -- the range check required by the slice. The range check for the slice
7244 -- itself has already been generated. The range check for the
7245 -- subscripting operation is ensured by converting the subject to
7246 -- the subtype of the slice.
7248 -- This optimization not only generates better code, avoiding slice
7249 -- messing especially in the packed case, but more importantly bypasses
7250 -- some problems in handling this peculiar case, for example, the issue
7251 -- of dealing specially with object renamings.
7253 if Nkind
(P
) = N_Slice
7255 -- This optimization is disabled for CodePeer because it can transform
7256 -- an index-check constraint_error into a range-check constraint_error
7257 -- and CodePeer cares about that distinction.
7259 and then not CodePeer_Mode
7262 Make_Indexed_Component
(Loc
,
7263 Prefix
=> Prefix
(P
),
7264 Expressions
=> New_List
(
7266 (Etype
(First_Index
(Etype
(P
))),
7267 First
(Expressions
(N
))))));
7268 Analyze_And_Resolve
(N
, Typ
);
7272 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7273 -- function, then additional actuals must be passed.
7275 if Is_Build_In_Place_Function_Call
(P
) then
7276 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
7278 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
7279 -- containing build-in-place function calls whose returned object covers
7282 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
7283 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
7286 -- Generate index and validity checks
7289 Dims_Checked
: Dimension_Set
(Dimensions
=>
7290 (if Is_Array_Type
(T
)
7291 then Number_Dimensions
(T
)
7293 -- Dims_Checked is used to avoid generating two checks (one in
7294 -- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks)
7295 -- for the same index value in cases where the index check eliminates
7296 -- the need for the validity check. The Is_Array_Type test avoids
7297 -- cascading errors.
7300 Generate_Index_Checks
(N
, Checks_Generated
=> Dims_Checked
);
7302 if Validity_Checks_On
7303 and then (Validity_Check_Subscripts
7304 or else Wild_Reads_May_Have_Bad_Side_Effects
7305 or else Type_Requires_Subscript_Validity_Checks_For_Reads
7307 or else Is_Renamed_Variable_Name
(N
))
7309 if Validity_Check_Subscripts
then
7310 -- If we index into an array with an uninitialized variable
7311 -- and we generate an index check that passes at run time,
7312 -- passing that check does not ensure that the variable is
7313 -- valid (although it does in the common case where the
7314 -- object's subtype matches the index subtype).
7315 -- Consider an uninitialized variable with subtype 1 .. 10
7316 -- used to index into an array with bounds 1 .. 20 when the
7317 -- value of the uninitialized variable happens to be 15.
7318 -- The index check will succeed but the variable is invalid.
7319 -- If Validity_Check_Subscripts is True then we need to
7320 -- ensure validity, so we adjust Dims_Checked accordingly.
7321 Dims_Checked
.Elements
:= (others => False);
7323 elsif Is_Array_Type
(T
) then
7324 -- We are only adding extra validity checks here to
7325 -- deal with uninitialized variables (but this includes
7326 -- assigning one uninitialized variable to another). Other
7327 -- ways of producing invalid objects imply erroneousness, so
7328 -- the compiler can do whatever it wants for those cases.
7329 -- If an index type has the Default_Value aspect specified,
7330 -- then we don't have to worry about the possibility of an
7331 -- uninitialized variable, so no need for these extra
7335 Idx
: Node_Id
:= First_Index
(T
);
7337 for No_Check_Needed
of Dims_Checked
.Elements
loop
7338 No_Check_Needed
:= No_Check_Needed
7339 or else Has_Aspect
(Etype
(Idx
), Aspect_Default_Value
);
7345 Apply_Subscript_Validity_Checks
7346 (N
, No_Check_Needed
=> Dims_Checked
);
7350 -- If selecting from an array with atomic components, and atomic sync
7351 -- is not suppressed for this array type, set atomic sync flag.
7353 if (Has_Atomic_Components
(T
)
7354 and then not Atomic_Synchronization_Disabled
(T
))
7355 or else (Is_Atomic
(Typ
)
7356 and then not Atomic_Synchronization_Disabled
(Typ
))
7357 or else (Is_Entity_Name
(P
)
7358 and then Has_Atomic_Components
(Entity
(P
))
7359 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
7361 Activate_Atomic_Synchronization
(N
);
7364 -- All done if the prefix is not a packed array implemented specially
7366 if not (Is_Packed
(Etype
(Prefix
(N
)))
7367 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(N
)))))
7372 -- For packed arrays that are not bit-packed (i.e. the case of an array
7373 -- with one or more index types with a non-contiguous enumeration type),
7374 -- we can always use the normal packed element get circuit.
7376 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
7377 Expand_Packed_Element_Reference
(N
);
7381 -- For a reference to a component of a bit packed array, we convert it
7382 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
7383 -- want to do this for simple references, and not for:
7385 -- Left side of assignment, or prefix of left side of assignment, or
7386 -- prefix of the prefix, to handle packed arrays of packed arrays,
7387 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
7389 -- Renaming objects in renaming associations
7390 -- This case is handled when a use of the renamed variable occurs
7392 -- Actual parameters for a subprogram call
7393 -- This case is handled in Exp_Ch6.Expand_Actuals
7395 -- The second expression in a 'Read attribute reference
7397 -- The prefix of an address or bit or size attribute reference
7399 -- The following circuit detects these exceptions. Note that we need to
7400 -- deal with implicit dereferences when climbing up the parent chain,
7401 -- with the additional difficulty that the type of parents may have yet
7402 -- to be resolved since prefixes are usually resolved first.
7405 Child
: Node_Id
:= N
;
7406 Parnt
: Node_Id
:= Parent
(N
);
7410 if Nkind
(Parnt
) = N_Unchecked_Expression
then
7413 elsif Nkind
(Parnt
) = N_Object_Renaming_Declaration
then
7416 elsif Nkind
(Parnt
) in N_Subprogram_Call
7417 or else (Nkind
(Parnt
) = N_Parameter_Association
7418 and then Nkind
(Parent
(Parnt
)) in N_Subprogram_Call
)
7422 elsif Nkind
(Parnt
) = N_Attribute_Reference
7423 and then Attribute_Name
(Parnt
) in Name_Address
7426 and then Prefix
(Parnt
) = Child
7430 elsif Nkind
(Parnt
) = N_Assignment_Statement
7431 and then Name
(Parnt
) = Child
7435 -- If the expression is an index of an indexed component, it must
7436 -- be expanded regardless of context.
7438 elsif Nkind
(Parnt
) = N_Indexed_Component
7439 and then Child
/= Prefix
(Parnt
)
7441 Expand_Packed_Element_Reference
(N
);
7444 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
7445 and then Name
(Parent
(Parnt
)) = Parnt
7449 elsif Nkind
(Parnt
) = N_Attribute_Reference
7450 and then Attribute_Name
(Parnt
) = Name_Read
7451 and then Next
(First
(Expressions
(Parnt
))) = Child
7455 elsif Nkind
(Parnt
) = N_Indexed_Component
7456 and then Prefix
(Parnt
) = Child
7460 elsif Nkind
(Parnt
) = N_Selected_Component
7461 and then Prefix
(Parnt
) = Child
7462 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
7464 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
7468 -- If the parent is a dereference, either implicit or explicit,
7469 -- then the packed reference needs to be expanded.
7472 Expand_Packed_Element_Reference
(N
);
7476 -- Keep looking up tree for unchecked expression, or if we are the
7477 -- prefix of a possible assignment left side.
7480 Parnt
:= Parent
(Child
);
7483 end Expand_N_Indexed_Component
;
7485 ---------------------
7486 -- Expand_N_Not_In --
7487 ---------------------
7489 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7490 -- can be done. This avoids needing to duplicate this expansion code.
7492 procedure Expand_N_Not_In
(N
: Node_Id
) is
7493 Loc
: constant Source_Ptr
:= Sloc
(N
);
7494 Typ
: constant Entity_Id
:= Etype
(N
);
7495 Cfs
: constant Boolean := Comes_From_Source
(N
);
7502 Left_Opnd
=> Left_Opnd
(N
),
7503 Right_Opnd
=> Right_Opnd
(N
))));
7505 -- If this is a set membership, preserve list of alternatives
7507 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
7509 -- We want this to appear as coming from source if original does (see
7510 -- transformations in Expand_N_In).
7512 Set_Comes_From_Source
(N
, Cfs
);
7513 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
7515 -- Now analyze transformed node
7517 Analyze_And_Resolve
(N
, Typ
);
7518 end Expand_N_Not_In
;
7524 -- The only replacement required is for the case of a null of a type that
7525 -- is an access to protected subprogram, or a subtype thereof. We represent
7526 -- such access values as a record, and so we must replace the occurrence of
7527 -- null by the equivalent record (with a null address and a null pointer in
7528 -- it), so that the back end creates the proper value.
7530 procedure Expand_N_Null
(N
: Node_Id
) is
7531 Loc
: constant Source_Ptr
:= Sloc
(N
);
7532 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
7536 if Is_Access_Protected_Subprogram_Type
(Typ
) then
7538 Make_Aggregate
(Loc
,
7539 Expressions
=> New_List
(
7540 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
7544 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
7546 -- For subsequent semantic analysis, the node must retain its type.
7547 -- Gigi in any case replaces this type by the corresponding record
7548 -- type before processing the node.
7554 when RE_Not_Available
=>
7558 ---------------------
7559 -- Expand_N_Op_Abs --
7560 ---------------------
7562 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
7563 Loc
: constant Source_Ptr
:= Sloc
(N
);
7564 Expr
: constant Node_Id
:= Right_Opnd
(N
);
7565 Typ
: constant Entity_Id
:= Etype
(N
);
7568 Unary_Op_Validity_Checks
(N
);
7570 -- Check for MINIMIZED/ELIMINATED overflow mode
7572 if Minimized_Eliminated_Overflow_Check
(N
) then
7573 Apply_Arithmetic_Overflow_Check
(N
);
7577 -- Try to narrow the operation
7579 if Typ
= Universal_Integer
then
7580 Narrow_Large_Operation
(N
);
7582 if Nkind
(N
) /= N_Op_Abs
then
7587 -- Deal with software overflow checking
7589 if Is_Signed_Integer_Type
(Typ
)
7590 and then Do_Overflow_Check
(N
)
7592 -- The only case to worry about is when the argument is equal to the
7593 -- largest negative number, so what we do is to insert the check:
7595 -- [constraint_error when Expr = typ'Base'First]
7597 -- with the usual Duplicate_Subexpr use coding for expr
7600 Make_Raise_Constraint_Error
(Loc
,
7603 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
7605 Make_Attribute_Reference
(Loc
,
7607 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
7608 Attribute_Name
=> Name_First
)),
7609 Reason
=> CE_Overflow_Check_Failed
));
7611 Set_Do_Overflow_Check
(N
, False);
7613 end Expand_N_Op_Abs
;
7615 ---------------------
7616 -- Expand_N_Op_Add --
7617 ---------------------
7619 procedure Expand_N_Op_Add
(N
: Node_Id
) is
7620 Typ
: constant Entity_Id
:= Etype
(N
);
7623 Binary_Op_Validity_Checks
(N
);
7625 -- Check for MINIMIZED/ELIMINATED overflow mode
7627 if Minimized_Eliminated_Overflow_Check
(N
) then
7628 Apply_Arithmetic_Overflow_Check
(N
);
7632 -- N + 0 = 0 + N = N for integer types
7634 if Is_Integer_Type
(Typ
) then
7635 if Compile_Time_Known_Value
(Right_Opnd
(N
))
7636 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
7638 Rewrite
(N
, Left_Opnd
(N
));
7641 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
7642 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
7644 Rewrite
(N
, Right_Opnd
(N
));
7649 -- Try to narrow the operation
7651 if Typ
= Universal_Integer
then
7652 Narrow_Large_Operation
(N
);
7654 if Nkind
(N
) /= N_Op_Add
then
7659 -- Arithmetic overflow checks for signed integer/fixed point types
7661 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
7662 Apply_Arithmetic_Overflow_Check
(N
);
7666 -- Overflow checks for floating-point if -gnateF mode active
7668 Check_Float_Op_Overflow
(N
);
7670 Expand_Nonbinary_Modular_Op
(N
);
7671 end Expand_N_Op_Add
;
7673 ---------------------
7674 -- Expand_N_Op_And --
7675 ---------------------
7677 procedure Expand_N_Op_And
(N
: Node_Id
) is
7678 Typ
: constant Entity_Id
:= Etype
(N
);
7681 Binary_Op_Validity_Checks
(N
);
7683 if Is_Array_Type
(Etype
(N
)) then
7684 Expand_Boolean_Operator
(N
);
7686 elsif Is_Boolean_Type
(Etype
(N
)) then
7687 Adjust_Condition
(Left_Opnd
(N
));
7688 Adjust_Condition
(Right_Opnd
(N
));
7689 Set_Etype
(N
, Standard_Boolean
);
7690 Adjust_Result_Type
(N
, Typ
);
7692 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
7693 Expand_Intrinsic_Call
(N
, Entity
(N
));
7696 Expand_Nonbinary_Modular_Op
(N
);
7697 end Expand_N_Op_And
;
7699 ------------------------
7700 -- Expand_N_Op_Concat --
7701 ------------------------
7703 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
7705 -- List of operands to be concatenated
7708 -- Node which is to be replaced by the result of concatenating the nodes
7709 -- in the list Opnds.
7712 -- Ensure validity of both operands
7714 Binary_Op_Validity_Checks
(N
);
7716 -- If we are the left operand of a concatenation higher up the tree,
7717 -- then do nothing for now, since we want to deal with a series of
7718 -- concatenations as a unit.
7720 if Nkind
(Parent
(N
)) = N_Op_Concat
7721 and then N
= Left_Opnd
(Parent
(N
))
7726 -- We get here with a concatenation whose left operand may be a
7727 -- concatenation itself with a consistent type. We need to process
7728 -- these concatenation operands from left to right, which means
7729 -- from the deepest node in the tree to the highest node.
7732 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
7733 Cnode
:= Left_Opnd
(Cnode
);
7736 -- Now Cnode is the deepest concatenation, and its parents are the
7737 -- concatenation nodes above, so now we process bottom up, doing the
7740 -- The outer loop runs more than once if more than one concatenation
7741 -- type is involved.
7744 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
7745 Set_Parent
(Opnds
, N
);
7747 -- The inner loop gathers concatenation operands
7749 Inner
: while Cnode
/= N
7750 and then Base_Type
(Etype
(Cnode
)) =
7751 Base_Type
(Etype
(Parent
(Cnode
)))
7753 Cnode
:= Parent
(Cnode
);
7754 Append
(Right_Opnd
(Cnode
), Opnds
);
7757 -- Note: The following code is a temporary workaround for N731-034
7758 -- and N829-028 and will be kept until the general issue of internal
7759 -- symbol serialization is addressed. The workaround is kept under a
7760 -- debug switch to avoid permiating into the general case.
7762 -- Wrap the node to concatenate into an expression actions node to
7763 -- keep it nicely packaged. This is useful in the case of an assert
7764 -- pragma with a concatenation where we want to be able to delete
7765 -- the concatenation and all its expansion stuff.
7767 if Debug_Flag_Dot_H
then
7769 Cnod
: constant Node_Id
:= New_Copy_Tree
(Cnode
);
7770 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
7773 -- Note: use Rewrite rather than Replace here, so that for
7774 -- example Why_Not_Static can find the original concatenation
7778 Make_Expression_With_Actions
(Sloc
(Cnode
),
7779 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
7780 Expression
=> Cnod
));
7782 Expand_Concatenate
(Cnod
, Opnds
);
7783 Analyze_And_Resolve
(Cnode
, Typ
);
7789 Expand_Concatenate
(Cnode
, Opnds
);
7792 exit Outer
when Cnode
= N
;
7793 Cnode
:= Parent
(Cnode
);
7795 end Expand_N_Op_Concat
;
7797 ------------------------
7798 -- Expand_N_Op_Divide --
7799 ------------------------
7801 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
7802 Loc
: constant Source_Ptr
:= Sloc
(N
);
7803 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
7804 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
7805 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
7806 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
7807 Typ
: Entity_Id
:= Etype
(N
);
7808 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
7810 Compile_Time_Known_Value
(Ropnd
);
7814 Binary_Op_Validity_Checks
(N
);
7816 -- Check for MINIMIZED/ELIMINATED overflow mode
7818 if Minimized_Eliminated_Overflow_Check
(N
) then
7819 Apply_Arithmetic_Overflow_Check
(N
);
7823 -- Otherwise proceed with expansion of division
7826 Rval
:= Expr_Value
(Ropnd
);
7829 -- N / 1 = N for integer types
7831 if Rknow
and then Rval
= Uint_1
then
7836 -- Try to narrow the operation
7838 if Typ
= Universal_Integer
then
7839 Narrow_Large_Operation
(N
);
7841 if Nkind
(N
) /= N_Op_Divide
then
7846 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7847 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7848 -- operand is an unsigned integer, as required for this to work.
7850 if Nkind
(Ropnd
) = N_Op_Expon
7851 and then Is_Power_Of_2_For_Shift
(Ropnd
)
7853 -- We cannot do this transformation in configurable run time mode if we
7854 -- have 64-bit integers and long shifts are not available.
7856 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
7859 Make_Op_Shift_Right
(Loc
,
7862 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
7863 Analyze_And_Resolve
(N
, Typ
);
7867 -- Do required fixup of universal fixed operation
7869 if Typ
= Universal_Fixed
then
7870 Fixup_Universal_Fixed_Operation
(N
);
7874 -- Divisions with fixed-point results
7876 if Is_Fixed_Point_Type
(Typ
) then
7878 if Is_Integer_Type
(Rtyp
) then
7879 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
7881 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
7884 -- Deal with divide-by-zero check if back end cannot handle them
7885 -- and the flag is set indicating that we need such a check. Note
7886 -- that we don't need to bother here with the case of mixed-mode
7887 -- (Right operand an integer type), since these will be rewritten
7888 -- with conversions to a divide with a fixed-point right operand.
7890 if Nkind
(N
) = N_Op_Divide
7891 and then Do_Division_Check
(N
)
7892 and then not Backend_Divide_Checks_On_Target
7893 and then not Is_Integer_Type
(Rtyp
)
7895 Set_Do_Division_Check
(N
, False);
7897 Make_Raise_Constraint_Error
(Loc
,
7900 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
7901 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
7902 Reason
=> CE_Divide_By_Zero
));
7905 -- Other cases of division of fixed-point operands
7907 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
7908 if Is_Integer_Type
(Typ
) then
7909 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
7911 pragma Assert
(Is_Floating_Point_Type
(Typ
));
7912 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
7915 -- Mixed-mode operations can appear in a non-static universal context,
7916 -- in which case the integer argument must be converted explicitly.
7918 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
7920 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
7922 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
7924 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
7926 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
7928 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
7930 -- Non-fixed point cases, do integer zero divide and overflow checks
7932 elsif Is_Integer_Type
(Typ
) then
7933 Apply_Divide_Checks
(N
);
7936 -- Overflow checks for floating-point if -gnateF mode active
7938 Check_Float_Op_Overflow
(N
);
7940 Expand_Nonbinary_Modular_Op
(N
);
7941 end Expand_N_Op_Divide
;
7943 --------------------
7944 -- Expand_N_Op_Eq --
7945 --------------------
7947 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
7948 Loc
: constant Source_Ptr
:= Sloc
(N
);
7949 Typ
: constant Entity_Id
:= Etype
(N
);
7950 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
7951 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
7952 Bodies
: constant List_Id
:= New_List
;
7953 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
7955 procedure Build_Equality_Call
(Eq
: Entity_Id
);
7956 -- If a constructed equality exists for the type or for its parent,
7957 -- build and analyze call, adding conversions if the operation is
7960 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
;
7961 -- Find a primitive equality function within primitive operation list
7964 function Has_Unconstrained_UU_Component
(Typ
: Entity_Id
) return Boolean;
7965 -- Determines whether a type has a subcomponent of an unconstrained
7966 -- Unchecked_Union subtype. Typ is a record type.
7968 -------------------------
7969 -- Build_Equality_Call --
7970 -------------------------
7972 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
7973 Op_Typ
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
7975 L_Exp
, R_Exp
: Node_Id
;
7978 -- Adjust operands if necessary to comparison type
7980 if Base_Type
(A_Typ
) /= Base_Type
(Op_Typ
)
7981 and then not Is_Class_Wide_Type
(A_Typ
)
7983 L_Exp
:= OK_Convert_To
(Op_Typ
, Lhs
);
7984 R_Exp
:= OK_Convert_To
(Op_Typ
, Rhs
);
7987 L_Exp
:= Relocate_Node
(Lhs
);
7988 R_Exp
:= Relocate_Node
(Rhs
);
7992 Make_Function_Call
(Loc
,
7993 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7994 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7996 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7997 end Build_Equality_Call
;
8003 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
is
8004 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
;
8005 -- Find an equality in a possible alias chain starting from primitive
8008 ---------------------------
8009 -- Find_Aliased_Equality --
8010 ---------------------------
8012 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
is
8016 -- Inspect each candidate in the alias chain, checking whether it
8017 -- denotes an equality.
8020 while Present
(Candid
) loop
8021 if Is_User_Defined_Equality
(Candid
) then
8025 Candid
:= Alias
(Candid
);
8029 end Find_Aliased_Equality
;
8033 Eq_Prim
: Entity_Id
;
8034 Prim_Elmt
: Elmt_Id
;
8036 -- Start of processing for Find_Equality
8039 -- Assume that the tagged type lacks an equality
8043 -- Inspect the list of primitives looking for a suitable equality
8044 -- within a possible chain of aliases.
8046 Prim_Elmt
:= First_Elmt
(Prims
);
8047 while Present
(Prim_Elmt
) and then No
(Eq_Prim
) loop
8048 Eq_Prim
:= Find_Aliased_Equality
(Node
(Prim_Elmt
));
8050 Next_Elmt
(Prim_Elmt
);
8053 -- A tagged type should always have an equality
8055 pragma Assert
(Present
(Eq_Prim
));
8060 ------------------------------------
8061 -- Has_Unconstrained_UU_Component --
8062 ------------------------------------
8064 function Has_Unconstrained_UU_Component
8065 (Typ
: Entity_Id
) return Boolean
8067 function Unconstrained_UU_In_Component_Declaration
8068 (N
: Node_Id
) return Boolean;
8070 function Unconstrained_UU_In_Component_Items
8071 (L
: List_Id
) return Boolean;
8073 function Unconstrained_UU_In_Component_List
8074 (N
: Node_Id
) return Boolean;
8076 function Unconstrained_UU_In_Variant_Part
8077 (N
: Node_Id
) return Boolean;
8078 -- A family of routines that determine whether a particular construct
8079 -- of a record type definition contains a subcomponent of an
8080 -- unchecked union type whose nominal subtype is unconstrained.
8082 -- Individual routines correspond to the production rules of the Ada
8083 -- grammar, as described in the Ada RM (P).
8085 -----------------------------------------------
8086 -- Unconstrained_UU_In_Component_Declaration --
8087 -----------------------------------------------
8089 function Unconstrained_UU_In_Component_Declaration
8090 (N
: Node_Id
) return Boolean
8092 pragma Assert
(Nkind
(N
) = N_Component_Declaration
);
8094 Sindic
: constant Node_Id
:=
8095 Subtype_Indication
(Component_Definition
(N
));
8097 -- If the component declaration includes a subtype indication
8098 -- it is not an unchecked_union. Otherwise verify that it carries
8099 -- the Unchecked_Union flag and is either a record or a private
8100 -- type. A Record_Subtype declared elsewhere does not qualify,
8101 -- even if its parent type carries the flag.
8103 return Nkind
(Sindic
) in N_Expanded_Name | N_Identifier
8104 and then Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)))
8105 and then Ekind
(Entity
(Sindic
)) in
8106 E_Private_Type | E_Record_Type
;
8107 end Unconstrained_UU_In_Component_Declaration
;
8109 -----------------------------------------
8110 -- Unconstrained_UU_In_Component_Items --
8111 -----------------------------------------
8113 function Unconstrained_UU_In_Component_Items
8114 (L
: List_Id
) return Boolean
8116 N
: Node_Id
:= First
(L
);
8118 while Present
(N
) loop
8119 if Nkind
(N
) = N_Component_Declaration
8120 and then Unconstrained_UU_In_Component_Declaration
(N
)
8129 end Unconstrained_UU_In_Component_Items
;
8131 ----------------------------------------
8132 -- Unconstrained_UU_In_Component_List --
8133 ----------------------------------------
8135 function Unconstrained_UU_In_Component_List
8136 (N
: Node_Id
) return Boolean
8138 pragma Assert
(Nkind
(N
) = N_Component_List
);
8140 Optional_Variant_Part
: Node_Id
;
8142 if Unconstrained_UU_In_Component_Items
(Component_Items
(N
)) then
8146 Optional_Variant_Part
:= Variant_Part
(N
);
8149 Present
(Optional_Variant_Part
)
8151 Unconstrained_UU_In_Variant_Part
(Optional_Variant_Part
);
8152 end Unconstrained_UU_In_Component_List
;
8154 --------------------------------------
8155 -- Unconstrained_UU_In_Variant_Part --
8156 --------------------------------------
8158 function Unconstrained_UU_In_Variant_Part
8159 (N
: Node_Id
) return Boolean
8161 pragma Assert
(Nkind
(N
) = N_Variant_Part
);
8163 Variant
: Node_Id
:= First
(Variants
(N
));
8166 if Unconstrained_UU_In_Component_List
(Component_List
(Variant
))
8172 exit when No
(Variant
);
8176 end Unconstrained_UU_In_Variant_Part
;
8178 Typ_Def
: constant Node_Id
:=
8179 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
8181 Optional_Component_List
: constant Node_Id
:=
8182 Component_List
(Typ_Def
);
8184 -- Start of processing for Has_Unconstrained_UU_Component
8187 return Present
(Optional_Component_List
)
8189 Unconstrained_UU_In_Component_List
(Optional_Component_List
);
8190 end Has_Unconstrained_UU_Component
;
8196 -- Start of processing for Expand_N_Op_Eq
8199 Binary_Op_Validity_Checks
(N
);
8201 -- Deal with private types
8203 Typl
:= Underlying_Type
(A_Typ
);
8205 -- It may happen in error situations that the underlying type is not
8206 -- set. The error will be detected later, here we just defend the
8213 -- Now get the implementation base type (note that plain Base_Type here
8214 -- might lead us back to the private type, which is not what we want!)
8216 Typl
:= Implementation_Base_Type
(Typl
);
8218 -- Equality between variant records results in a call to a routine
8219 -- that has conditional tests of the discriminant value(s), and hence
8220 -- violates the No_Implicit_Conditionals restriction.
8222 if Has_Variant_Part
(Typl
) then
8227 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
8231 ("\comparison of variant records tests discriminants", N
);
8237 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8238 -- means we no longer have a comparison operation, we are all done.
8240 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
)) then
8241 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8244 if Nkind
(N
) /= N_Op_Eq
then
8248 -- Boolean types (requiring handling of non-standard case)
8250 if Is_Boolean_Type
(Typl
) then
8251 Adjust_Condition
(Left_Opnd
(N
));
8252 Adjust_Condition
(Right_Opnd
(N
));
8253 Set_Etype
(N
, Standard_Boolean
);
8254 Adjust_Result_Type
(N
, Typ
);
8258 elsif Is_Array_Type
(Typl
) then
8260 -- If we are doing full validity checking, and it is possible for the
8261 -- array elements to be invalid then expand out array comparisons to
8262 -- make sure that we check the array elements.
8264 if Validity_Check_Operands
8265 and then not Is_Known_Valid
(Component_Type
(Typl
))
8268 Save_Force_Validity_Checks
: constant Boolean :=
8269 Force_Validity_Checks
;
8271 Force_Validity_Checks
:= True;
8273 Expand_Array_Equality
8275 Relocate_Node
(Lhs
),
8276 Relocate_Node
(Rhs
),
8279 Insert_Actions
(N
, Bodies
);
8280 Analyze_And_Resolve
(N
, Standard_Boolean
);
8281 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
8284 -- Packed case where both operands are known aligned
8286 elsif Is_Bit_Packed_Array
(Typl
)
8287 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8288 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8290 Expand_Packed_Eq
(N
);
8292 -- Where the component type is elementary we can use a block bit
8293 -- comparison (if supported on the target) exception in the case
8294 -- of floating-point (negative zero issues require element by
8295 -- element comparison), and full access types (where we must be sure
8296 -- to load elements independently) and possibly unaligned arrays.
8298 elsif Is_Elementary_Type
(Component_Type
(Typl
))
8299 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
8300 and then not Is_Full_Access
(Component_Type
(Typl
))
8301 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8302 and then not Is_Possibly_Unaligned_Slice
(Lhs
)
8303 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8304 and then not Is_Possibly_Unaligned_Slice
(Rhs
)
8305 and then Support_Composite_Compare_On_Target
8309 -- For composite and floating-point cases, expand equality loop to
8310 -- make sure of using proper comparisons for tagged types, and
8311 -- correctly handling the floating-point case.
8315 Expand_Array_Equality
8317 Relocate_Node
(Lhs
),
8318 Relocate_Node
(Rhs
),
8321 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8322 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8327 elsif Is_Record_Type
(Typl
) then
8329 -- For tagged types, use the primitive "="
8331 if Is_Tagged_Type
(Typl
) then
8333 -- No need to do anything else compiling under restriction
8334 -- No_Dispatching_Calls. During the semantic analysis we
8335 -- already notified such violation.
8337 if Restriction_Active
(No_Dispatching_Calls
) then
8341 -- If this is an untagged private type completed with a derivation
8342 -- of an untagged private type whose full view is a tagged type,
8343 -- we use the primitive operations of the private type (since it
8344 -- does not have a full view, and also because its equality
8345 -- primitive may have been overridden in its untagged full view).
8347 if Inherits_From_Tagged_Full_View
(A_Typ
) then
8349 (Find_Equality
(Collect_Primitive_Operations
(A_Typ
)));
8351 -- Find the type's predefined equality or an overriding
8352 -- user-defined equality. The reason for not simply calling
8353 -- Find_Prim_Op here is that there may be a user-defined
8354 -- overloaded equality op that precedes the equality that we
8355 -- want, so we have to explicitly search (e.g., there could be
8356 -- an equality with two different parameter types).
8359 if Is_Class_Wide_Type
(Typl
) then
8360 Typl
:= Find_Specific_Type
(Typl
);
8364 (Find_Equality
(Primitive_Operations
(Typl
)));
8367 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8368 -- predefined equality operator for a type which has a subcomponent
8369 -- of an unchecked union type whose nominal subtype is unconstrained.
8371 elsif Has_Unconstrained_UU_Component
(Typl
) then
8373 Make_Raise_Program_Error
(Loc
,
8374 Reason
=> PE_Unchecked_Union_Restriction
));
8377 New_Occurrence_Of
(Standard_False
, Loc
));
8379 -- If a type support function is present, e.g. if there is a variant
8380 -- part, including an unchecked union type, use it.
8382 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
8384 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8386 -- When comparing two Bounded_Strings, use the primitive equality of
8387 -- the root Super_String type.
8389 elsif Is_Bounded_String
(Typl
) then
8392 (Collect_Primitive_Operations
(Root_Type
(Typl
))));
8394 -- Otherwise expand the component by component equality. Note that
8395 -- we never use block-bit comparisons for records, because of the
8396 -- problems with gaps. The back end will often be able to recombine
8397 -- the separate comparisons that we generate here.
8400 Remove_Side_Effects
(Lhs
);
8401 Remove_Side_Effects
(Rhs
);
8402 Rewrite
(N
, Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
));
8404 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8407 -- If unnesting, handle elementary types whose Equivalent_Types are
8408 -- records because there may be padding or undefined fields.
8410 elsif Unnest_Subprogram_Mode
8411 and then Ekind
(Typl
) in E_Class_Wide_Type
8412 | E_Class_Wide_Subtype
8413 | E_Access_Subprogram_Type
8414 | E_Access_Protected_Subprogram_Type
8415 | E_Anonymous_Access_Protected_Subprogram_Type
8417 and then Present
(Equivalent_Type
(Typl
))
8418 and then Is_Record_Type
(Equivalent_Type
(Typl
))
8420 Typl
:= Equivalent_Type
(Typl
);
8421 Remove_Side_Effects
(Lhs
);
8422 Remove_Side_Effects
(Rhs
);
8424 Expand_Record_Equality
(N
, Typl
,
8425 Unchecked_Convert_To
(Typl
, Lhs
),
8426 Unchecked_Convert_To
(Typl
, Rhs
)));
8428 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8431 -- Test if result is known at compile time
8433 Rewrite_Comparison
(N
);
8435 -- Try to narrow the operation
8437 if Typl
= Universal_Integer
and then Nkind
(N
) = N_Op_Eq
then
8438 Narrow_Large_Operation
(N
);
8441 -- Special optimization of length comparison
8443 Optimize_Length_Comparison
(N
);
8445 -- One more special case: if we have a comparison of X'Result = expr
8446 -- in floating-point, then if not already there, change expr to be
8447 -- f'Machine (expr) to eliminate surprise from extra precision.
8449 if Is_Floating_Point_Type
(Typl
)
8450 and then Is_Attribute_Result
(Original_Node
(Lhs
))
8452 -- Stick in the Typ'Machine call if not already there
8454 if Nkind
(Rhs
) /= N_Attribute_Reference
8455 or else Attribute_Name
(Rhs
) /= Name_Machine
8458 Make_Attribute_Reference
(Loc
,
8459 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
8460 Attribute_Name
=> Name_Machine
,
8461 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
8462 Analyze_And_Resolve
(Rhs
, Typl
);
8467 -----------------------
8468 -- Expand_N_Op_Expon --
8469 -----------------------
8471 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
8472 Loc
: constant Source_Ptr
:= Sloc
(N
);
8473 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
8474 Typ
: constant Entity_Id
:= Etype
(N
);
8475 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
8479 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
8480 -- Given an expression Exp, if the root type is Float or Long_Float,
8481 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8482 -- extra precision. This is done to ensure that X**A = X**B when A is
8483 -- a static constant and B is a variable with the same value. For any
8484 -- other type, the node Exp is returned unchanged.
8490 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
8491 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
8494 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
8496 Make_Attribute_Reference
(Loc
,
8497 Attribute_Name
=> Name_Machine
,
8498 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
8499 Expressions
=> New_List
(Relocate_Node
(Exp
)));
8517 -- Start of processing for Expand_N_Op_Expon
8520 Binary_Op_Validity_Checks
(N
);
8522 -- CodePeer wants to see the unexpanded N_Op_Expon node
8524 if CodePeer_Mode
then
8528 -- Relocation of left and right operands must be done after performing
8529 -- the validity checks since the generation of validation checks may
8530 -- remove side effects.
8532 Base
:= Relocate_Node
(Left_Opnd
(N
));
8533 Bastyp
:= Etype
(Base
);
8534 Exp
:= Relocate_Node
(Right_Opnd
(N
));
8535 Exptyp
:= Etype
(Exp
);
8537 -- If either operand is of a private type, then we have the use of an
8538 -- intrinsic operator, and we get rid of the privateness, by using root
8539 -- types of underlying types for the actual operation. Otherwise the
8540 -- private types will cause trouble if we expand multiplications or
8541 -- shifts etc. We also do this transformation if the result type is
8542 -- different from the base type.
8544 if Is_Private_Type
(Etype
(Base
))
8545 or else Is_Private_Type
(Typ
)
8546 or else Is_Private_Type
(Exptyp
)
8547 or else Rtyp
/= Root_Type
(Bastyp
)
8550 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
8551 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
8554 Unchecked_Convert_To
(Typ
,
8556 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
8557 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
8558 Analyze_And_Resolve
(N
, Typ
);
8563 -- Check for MINIMIZED/ELIMINATED overflow mode
8565 if Minimized_Eliminated_Overflow_Check
(N
) then
8566 Apply_Arithmetic_Overflow_Check
(N
);
8570 -- Test for case of known right argument where we can replace the
8571 -- exponentiation by an equivalent expression using multiplication.
8573 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8574 -- configurable run-time mode, we may not have the exponentiation
8575 -- routine available, and we don't want the legality of the program
8576 -- to depend on how clever the compiler is in knowing values.
8578 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
8579 Expv
:= Expr_Value
(Exp
);
8581 -- We only fold small non-negative exponents. You might think we
8582 -- could fold small negative exponents for the real case, but we
8583 -- can't because we are required to raise Constraint_Error for
8584 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8585 -- See ACVC test C4A012B, and it is not worth generating the test.
8587 -- For small negative exponents, we return the reciprocal of
8588 -- the folding of the exponentiation for the opposite (positive)
8589 -- exponent, as required by Ada RM 4.5.6(11/3).
8591 if abs Expv
<= 4 then
8593 -- X ** 0 = 1 (or 1.0)
8597 -- Call Remove_Side_Effects to ensure that any side effects
8598 -- in the ignored left operand (in particular function calls
8599 -- to user defined functions) are properly executed.
8601 Remove_Side_Effects
(Base
);
8603 if Ekind
(Typ
) in Integer_Kind
then
8604 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
8606 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
8619 Make_Op_Multiply
(Loc
,
8620 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8621 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8623 -- X ** 3 = X * X * X
8628 Make_Op_Multiply
(Loc
,
8630 Make_Op_Multiply
(Loc
,
8631 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8632 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
8633 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8638 -- En : constant base'type := base * base;
8643 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
8646 Make_Expression_With_Actions
(Loc
,
8647 Actions
=> New_List
(
8648 Make_Object_Declaration
(Loc
,
8649 Defining_Identifier
=> Temp
,
8650 Constant_Present
=> True,
8651 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8654 Make_Op_Multiply
(Loc
,
8656 Duplicate_Subexpr
(Base
),
8658 Duplicate_Subexpr_No_Checks
(Base
))))),
8662 Make_Op_Multiply
(Loc
,
8663 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
8664 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
8666 -- X ** N = 1.0 / X ** (-N)
8671 (Expv
= -1 or Expv
= -2 or Expv
= -3 or Expv
= -4);
8674 Make_Op_Divide
(Loc
,
8676 Make_Float_Literal
(Loc
,
8678 Significand
=> Uint_1
,
8679 Exponent
=> Uint_0
),
8682 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8684 Make_Integer_Literal
(Loc
,
8689 Analyze_And_Resolve
(N
, Typ
);
8694 -- Optimize 2 ** expression to shift where possible
8696 -- Note: we used to check that Exptyp was an unsigned type. But that is
8697 -- an unnecessary check, since if Exp is negative, we have a run-time
8698 -- error that is either caught (so we get the right result) or we have
8699 -- suppressed the check, in which case the code is erroneous anyway.
8701 if Is_Integer_Type
(Rtyp
)
8703 -- The base value must be "safe compile-time known", and exactly 2
8705 and then Nkind
(Base
) = N_Integer_Literal
8706 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
8707 and then Expr_Value
(Base
) = Uint_2
8709 -- This transformation is not applicable for a modular type with a
8710 -- nonbinary modulus because shifting makes no sense in that case.
8712 and then not Non_Binary_Modulus
(Typ
)
8714 -- Handle the cases where our parent is a division or multiplication
8715 -- specially. In these cases we can convert to using a shift at the
8716 -- parent level if we are not doing overflow checking, since it is
8717 -- too tricky to combine the overflow check at the parent level.
8720 and then Nkind
(Parent
(N
)) in N_Op_Divide | N_Op_Multiply
8723 P
: constant Node_Id
:= Parent
(N
);
8724 L
: constant Node_Id
:= Left_Opnd
(P
);
8725 R
: constant Node_Id
:= Right_Opnd
(P
);
8728 if (Nkind
(P
) = N_Op_Multiply
8730 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
8732 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
8733 and then not Do_Overflow_Check
(P
))
8736 (Nkind
(P
) = N_Op_Divide
8737 and then Is_Integer_Type
(Etype
(L
))
8738 and then Is_Unsigned_Type
(Etype
(L
))
8740 and then not Do_Overflow_Check
(P
))
8742 Set_Is_Power_Of_2_For_Shift
(N
);
8747 -- Here we have 2 ** N on its own, so we can convert this into a
8751 -- Op_Shift_Left (generated below) has modular-shift semantics;
8752 -- therefore we might need to generate an overflow check here
8753 -- if the type is signed.
8755 if Is_Signed_Integer_Type
(Typ
) and then Ovflo
then
8761 MaxS
: constant Uint
:= Esize
(Rtyp
) - 2;
8762 -- Maximum shift count with no overflow
8764 Determine_Range
(Exp
, OK
, Lo
, Hi
, Assume_Valid
=> True);
8766 if not OK
or else Hi
> MaxS
then
8768 Make_Raise_Constraint_Error
(Loc
,
8771 Left_Opnd
=> Duplicate_Subexpr
(Exp
),
8772 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
8773 Reason
=> CE_Overflow_Check_Failed
));
8778 -- Generate Shift_Left (1, Exp)
8781 Make_Op_Shift_Left
(Loc
,
8782 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
8783 Right_Opnd
=> Exp
));
8785 Analyze_And_Resolve
(N
, Typ
);
8790 -- Fall through if exponentiation must be done using a runtime routine
8792 -- First deal with modular case
8794 if Is_Modular_Integer_Type
(Rtyp
) then
8796 -- Nonbinary modular case, we call the special exponentiation
8797 -- routine for the nonbinary case, converting the argument to
8798 -- Long_Long_Integer and passing the modulus value. Then the
8799 -- result is converted back to the base type.
8801 if Non_Binary_Modulus
(Rtyp
) then
8804 Make_Function_Call
(Loc
,
8806 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
8807 Parameter_Associations
=> New_List
(
8808 Convert_To
(RTE
(RE_Unsigned
), Base
),
8809 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
8812 -- Binary modular case, in this case, we call one of three routines,
8813 -- either the unsigned integer case, or the unsigned long long
8814 -- integer case, or the unsigned long long long integer case, with a
8815 -- final "and" operation to do the required mod.
8818 if Esize
(Rtyp
) <= Standard_Integer_Size
then
8819 Ent
:= RTE
(RE_Exp_Unsigned
);
8820 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
8821 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
8823 Ent
:= RTE
(RE_Exp_Long_Long_Long_Unsigned
);
8830 Make_Function_Call
(Loc
,
8831 Name
=> New_Occurrence_Of
(Ent
, Loc
),
8832 Parameter_Associations
=> New_List
(
8833 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
8836 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
8840 -- Common exit point for modular type case
8842 Analyze_And_Resolve
(N
, Typ
);
8845 -- Signed integer cases, using either Integer, Long_Long_Integer or
8846 -- Long_Long_Long_Integer. It is not worth also having routines for
8847 -- Short_[Short_]Integer, since for most machines it would not help,
8848 -- and it would generate more code that might need certification when
8849 -- a certified run time is required.
8851 -- In the integer cases, we have two routines, one for when overflow
8852 -- checks are required, and one when they are not required, since there
8853 -- is a real gain in omitting checks on many machines.
8855 elsif Is_Signed_Integer_Type
(Rtyp
) then
8856 if Esize
(Rtyp
) <= Standard_Integer_Size
then
8857 Etyp
:= Standard_Integer
;
8860 Rent
:= RE_Exp_Integer
;
8862 Rent
:= RE_Exn_Integer
;
8865 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
8866 Etyp
:= Standard_Long_Long_Integer
;
8869 Rent
:= RE_Exp_Long_Long_Integer
;
8871 Rent
:= RE_Exn_Long_Long_Integer
;
8875 Etyp
:= Standard_Long_Long_Long_Integer
;
8878 Rent
:= RE_Exp_Long_Long_Long_Integer
;
8880 Rent
:= RE_Exn_Long_Long_Long_Integer
;
8884 -- Floating-point cases. We do not need separate routines for the
8885 -- overflow case here, since in the case of floating-point, we generate
8886 -- infinities anyway as a rule (either that or we automatically trap
8887 -- overflow), and if there is an infinity generated and a range check
8888 -- is required, the check will fail anyway.
8891 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
8893 -- Short_Float and Float are the same type for GNAT
8895 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
8896 Etyp
:= Standard_Float
;
8897 Rent
:= RE_Exn_Float
;
8899 elsif Rtyp
= Standard_Long_Float
then
8900 Etyp
:= Standard_Long_Float
;
8901 Rent
:= RE_Exn_Long_Float
;
8904 Etyp
:= Standard_Long_Long_Float
;
8905 Rent
:= RE_Exn_Long_Long_Float
;
8909 -- Common processing for integer cases and floating-point cases.
8910 -- If we are in the right type, we can call runtime routine directly
8913 and then not Is_Universal_Numeric_Type
(Rtyp
)
8917 Make_Function_Call
(Loc
,
8918 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8919 Parameter_Associations
=> New_List
(Base
, Exp
))));
8921 -- Otherwise we have to introduce conversions (conversions are also
8922 -- required in the universal cases, since the runtime routine is
8923 -- typed using one of the standard types).
8928 Make_Function_Call
(Loc
,
8929 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8930 Parameter_Associations
=> New_List
(
8931 Convert_To
(Etyp
, Base
),
8935 Analyze_And_Resolve
(N
, Typ
);
8939 when RE_Not_Available
=>
8941 end Expand_N_Op_Expon
;
8943 --------------------
8944 -- Expand_N_Op_Ge --
8945 --------------------
8947 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
8948 Typ
: constant Entity_Id
:= Etype
(N
);
8949 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8950 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8951 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8954 Binary_Op_Validity_Checks
(N
);
8956 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8957 -- means we no longer have a comparison operation, we are all done.
8959 if Minimized_Eliminated_Overflow_Check
(Op1
) then
8960 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8963 if Nkind
(N
) /= N_Op_Ge
then
8969 if Is_Array_Type
(Typ1
) then
8970 Expand_Array_Comparison
(N
);
8974 -- Deal with boolean operands
8976 if Is_Boolean_Type
(Typ1
) then
8977 Adjust_Condition
(Op1
);
8978 Adjust_Condition
(Op2
);
8979 Set_Etype
(N
, Standard_Boolean
);
8980 Adjust_Result_Type
(N
, Typ
);
8983 Rewrite_Comparison
(N
);
8985 -- Try to narrow the operation
8987 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Ge
then
8988 Narrow_Large_Operation
(N
);
8991 Optimize_Length_Comparison
(N
);
8994 --------------------
8995 -- Expand_N_Op_Gt --
8996 --------------------
8998 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
8999 Typ
: constant Entity_Id
:= Etype
(N
);
9000 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9001 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9002 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9005 Binary_Op_Validity_Checks
(N
);
9007 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9008 -- means we no longer have a comparison operation, we are all done.
9010 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9011 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9014 if Nkind
(N
) /= N_Op_Gt
then
9018 -- Deal with array type operands
9020 if Is_Array_Type
(Typ1
) then
9021 Expand_Array_Comparison
(N
);
9025 -- Deal with boolean type operands
9027 if Is_Boolean_Type
(Typ1
) then
9028 Adjust_Condition
(Op1
);
9029 Adjust_Condition
(Op2
);
9030 Set_Etype
(N
, Standard_Boolean
);
9031 Adjust_Result_Type
(N
, Typ
);
9034 Rewrite_Comparison
(N
);
9036 -- Try to narrow the operation
9038 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Gt
then
9039 Narrow_Large_Operation
(N
);
9042 Optimize_Length_Comparison
(N
);
9045 --------------------
9046 -- Expand_N_Op_Le --
9047 --------------------
9049 procedure Expand_N_Op_Le
(N
: Node_Id
) is
9050 Typ
: constant Entity_Id
:= Etype
(N
);
9051 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9052 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9053 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9056 Binary_Op_Validity_Checks
(N
);
9058 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9059 -- means we no longer have a comparison operation, we are all done.
9061 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9062 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9065 if Nkind
(N
) /= N_Op_Le
then
9069 -- Deal with array type operands
9071 if Is_Array_Type
(Typ1
) then
9072 Expand_Array_Comparison
(N
);
9076 -- Deal with Boolean type operands
9078 if Is_Boolean_Type
(Typ1
) then
9079 Adjust_Condition
(Op1
);
9080 Adjust_Condition
(Op2
);
9081 Set_Etype
(N
, Standard_Boolean
);
9082 Adjust_Result_Type
(N
, Typ
);
9085 Rewrite_Comparison
(N
);
9087 -- Try to narrow the operation
9089 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Le
then
9090 Narrow_Large_Operation
(N
);
9093 Optimize_Length_Comparison
(N
);
9096 --------------------
9097 -- Expand_N_Op_Lt --
9098 --------------------
9100 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
9101 Typ
: constant Entity_Id
:= Etype
(N
);
9102 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9103 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9104 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9107 Binary_Op_Validity_Checks
(N
);
9109 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9110 -- means we no longer have a comparison operation, we are all done.
9112 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9113 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9116 if Nkind
(N
) /= N_Op_Lt
then
9120 -- Deal with array type operands
9122 if Is_Array_Type
(Typ1
) then
9123 Expand_Array_Comparison
(N
);
9127 -- Deal with Boolean type operands
9129 if Is_Boolean_Type
(Typ1
) then
9130 Adjust_Condition
(Op1
);
9131 Adjust_Condition
(Op2
);
9132 Set_Etype
(N
, Standard_Boolean
);
9133 Adjust_Result_Type
(N
, Typ
);
9136 Rewrite_Comparison
(N
);
9138 -- Try to narrow the operation
9140 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Lt
then
9141 Narrow_Large_Operation
(N
);
9144 Optimize_Length_Comparison
(N
);
9147 -----------------------
9148 -- Expand_N_Op_Minus --
9149 -----------------------
9151 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
9152 Loc
: constant Source_Ptr
:= Sloc
(N
);
9153 Typ
: constant Entity_Id
:= Etype
(N
);
9156 Unary_Op_Validity_Checks
(N
);
9158 -- Check for MINIMIZED/ELIMINATED overflow mode
9160 if Minimized_Eliminated_Overflow_Check
(N
) then
9161 Apply_Arithmetic_Overflow_Check
(N
);
9165 -- Try to narrow the operation
9167 if Typ
= Universal_Integer
then
9168 Narrow_Large_Operation
(N
);
9170 if Nkind
(N
) /= N_Op_Minus
then
9175 if not Backend_Overflow_Checks_On_Target
9176 and then Is_Signed_Integer_Type
(Typ
)
9177 and then Do_Overflow_Check
(N
)
9179 -- Software overflow checking expands -expr into (0 - expr)
9182 Make_Op_Subtract
(Loc
,
9183 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
9184 Right_Opnd
=> Right_Opnd
(N
)));
9186 Analyze_And_Resolve
(N
, Typ
);
9189 Expand_Nonbinary_Modular_Op
(N
);
9190 end Expand_N_Op_Minus
;
9192 ---------------------
9193 -- Expand_N_Op_Mod --
9194 ---------------------
9196 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
9197 Loc
: constant Source_Ptr
:= Sloc
(N
);
9198 Typ
: constant Entity_Id
:= Etype
(N
);
9199 DDC
: constant Boolean := Do_Division_Check
(N
);
9201 Is_Stoele_Mod
: constant Boolean :=
9202 Is_RTE
(Typ
, RE_Address
)
9203 and then Nkind
(Right_Opnd
(N
)) = N_Unchecked_Type_Conversion
9205 Is_RTE
(Etype
(Expression
(Right_Opnd
(N
))), RE_Storage_Offset
);
9206 -- True if this is the special mod operator of System.Storage_Elements
9219 pragma Warnings
(Off
, Lhi
);
9222 Binary_Op_Validity_Checks
(N
);
9224 -- Check for MINIMIZED/ELIMINATED overflow mode
9226 if Minimized_Eliminated_Overflow_Check
(N
) then
9227 Apply_Arithmetic_Overflow_Check
(N
);
9231 -- Try to narrow the operation
9233 if Typ
= Universal_Integer
then
9234 Narrow_Large_Operation
(N
);
9236 if Nkind
(N
) /= N_Op_Mod
then
9241 -- For the special mod operator of System.Storage_Elements, the checks
9242 -- are subsumed into the handling of the negative case below.
9244 if Is_Integer_Type
(Typ
) and then not Is_Stoele_Mod
then
9245 Apply_Divide_Checks
(N
);
9247 -- All done if we don't have a MOD any more, which can happen as a
9248 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9250 if Nkind
(N
) /= N_Op_Mod
then
9255 -- Proceed with expansion of mod operator
9257 Left
:= Left_Opnd
(N
);
9258 Right
:= Right_Opnd
(N
);
9260 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
9261 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
9263 -- Convert mod to rem if operands are both known to be non-negative, or
9264 -- both known to be non-positive (these are the cases in which rem and
9265 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9266 -- likely that this will improve the quality of code, (the operation now
9267 -- corresponds to the hardware remainder), and it does not seem likely
9268 -- that it could be harmful. It also avoids some cases of the elaborate
9269 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9272 and then ((Llo
>= 0 and then Rlo
>= 0)
9274 (Lhi
<= 0 and then Rhi
<= 0))
9275 and then not Is_Stoele_Mod
9278 Make_Op_Rem
(Sloc
(N
),
9279 Left_Opnd
=> Left_Opnd
(N
),
9280 Right_Opnd
=> Right_Opnd
(N
)));
9282 -- Instead of reanalyzing the node we do the analysis manually. This
9283 -- avoids anomalies when the replacement is done in an instance and
9284 -- is epsilon more efficient.
9286 pragma Assert
(Entity
(N
) = Standard_Op_Rem
);
9288 Set_Do_Division_Check
(N
, DDC
);
9289 Expand_N_Op_Rem
(N
);
9293 -- Otherwise, normal mod processing
9296 -- Apply optimization x mod 1 = 0. We don't really need that with
9297 -- gcc, but it is useful with other back ends and is certainly
9300 if Is_Integer_Type
(Etype
(N
))
9301 and then Compile_Time_Known_Value
(Right
)
9302 and then Expr_Value
(Right
) = Uint_1
9304 -- Call Remove_Side_Effects to ensure that any side effects in
9305 -- the ignored left operand (in particular function calls to
9306 -- user defined functions) are properly executed.
9308 Remove_Side_Effects
(Left
);
9310 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9311 Analyze_And_Resolve
(N
, Typ
);
9315 -- The negative case makes no sense since it is a case of a mod where
9316 -- the left argument is unsigned and the right argument is signed. In
9317 -- accordance with the (spirit of the) permission of RM 13.7.1(16),
9318 -- we raise CE, and also include the zero case here. Yes, the RM says
9319 -- PE, but this really is so obviously more like a constraint error.
9321 if Is_Stoele_Mod
and then (not ROK
or else Rlo
<= 0) then
9323 Make_Raise_Constraint_Error
(Loc
,
9327 Duplicate_Subexpr_No_Checks
(Expression
(Right
)),
9328 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9329 Reason
=> CE_Overflow_Check_Failed
));
9333 -- If we still have a mod operator and we are in Modify_Tree_For_C
9334 -- mode, and we have a signed integer type, then here is where we do
9335 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9336 -- for the special handling of the annoying case of largest negative
9337 -- number mod minus one.
9339 if Nkind
(N
) = N_Op_Mod
9340 and then Is_Signed_Integer_Type
(Typ
)
9341 and then Modify_Tree_For_C
9343 -- In the general case, we expand A mod B as
9345 -- Tnn : constant typ := A rem B;
9347 -- (if (A >= 0) = (B >= 0) then Tnn
9348 -- elsif Tnn = 0 then 0
9351 -- The comparison can be written simply as A >= 0 if we know that
9352 -- B >= 0 which is a very common case.
9354 -- An important optimization is when B is known at compile time
9355 -- to be 2**K for some constant. In this case we can simply AND
9356 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9357 -- and that works for both the positive and negative cases.
9360 P2
: constant Nat
:= Power_Of_Two
(Right
);
9365 Unchecked_Convert_To
(Typ
,
9368 Unchecked_Convert_To
9369 (Corresponding_Unsigned_Type
(Typ
), Left
),
9371 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
9372 Analyze_And_Resolve
(N
, Typ
);
9377 -- Here for the full rewrite
9380 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
9386 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9387 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
9389 if not LOK
or else Rlo
< 0 then
9395 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
9396 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
9400 Make_Object_Declaration
(Loc
,
9401 Defining_Identifier
=> Tnn
,
9402 Constant_Present
=> True,
9403 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9407 Right_Opnd
=> Right
)));
9410 Make_If_Expression
(Loc
,
9411 Expressions
=> New_List
(
9413 New_Occurrence_Of
(Tnn
, Loc
),
9414 Make_If_Expression
(Loc
,
9416 Expressions
=> New_List
(
9418 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9419 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9420 Make_Integer_Literal
(Loc
, 0),
9422 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9424 Duplicate_Subexpr_No_Checks
(Right
)))))));
9426 Analyze_And_Resolve
(N
, Typ
);
9431 -- Deal with annoying case of largest negative number mod minus one.
9432 -- Gigi may not handle this case correctly, because on some targets,
9433 -- the mod value is computed using a divide instruction which gives
9434 -- an overflow trap for this case.
9436 -- It would be a bit more efficient to figure out which targets
9437 -- this is really needed for, but in practice it is reasonable
9438 -- to do the following special check in all cases, since it means
9439 -- we get a clearer message, and also the overhead is minimal given
9440 -- that division is expensive in any case.
9442 -- In fact the check is quite easy, if the right operand is -1, then
9443 -- the mod value is always 0, and we can just ignore the left operand
9444 -- completely in this case.
9446 -- This only applies if we still have a mod operator. Skip if we
9447 -- have already rewritten this (e.g. in the case of eliminated
9448 -- overflow checks which have driven us into bignum mode).
9450 if Nkind
(N
) = N_Op_Mod
then
9452 -- The operand type may be private (e.g. in the expansion of an
9453 -- intrinsic operation) so we must use the underlying type to get
9454 -- the bounds, and convert the literals explicitly.
9458 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
9460 if (not ROK
or else (Rlo
<= (-1) and then (-1) <= Rhi
))
9461 and then (not LOK
or else Llo
= LLB
)
9462 and then not CodePeer_Mode
9465 Make_If_Expression
(Loc
,
9466 Expressions
=> New_List
(
9468 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9470 Unchecked_Convert_To
(Typ
,
9471 Make_Integer_Literal
(Loc
, -1))),
9472 Unchecked_Convert_To
(Typ
,
9473 Make_Integer_Literal
(Loc
, Uint_0
)),
9474 Relocate_Node
(N
))));
9476 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9477 Analyze_And_Resolve
(N
, Typ
);
9481 end Expand_N_Op_Mod
;
9483 --------------------------
9484 -- Expand_N_Op_Multiply --
9485 --------------------------
9487 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
9488 Loc
: constant Source_Ptr
:= Sloc
(N
);
9489 Lop
: constant Node_Id
:= Left_Opnd
(N
);
9490 Rop
: constant Node_Id
:= Right_Opnd
(N
);
9492 Lp2
: constant Boolean :=
9493 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
9494 Rp2
: constant Boolean :=
9495 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
9497 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
9498 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
9499 Typ
: Entity_Id
:= Etype
(N
);
9502 Binary_Op_Validity_Checks
(N
);
9504 -- Check for MINIMIZED/ELIMINATED overflow mode
9506 if Minimized_Eliminated_Overflow_Check
(N
) then
9507 Apply_Arithmetic_Overflow_Check
(N
);
9511 -- Special optimizations for integer types
9513 if Is_Integer_Type
(Typ
) then
9515 -- N * 0 = 0 for integer types
9517 if Compile_Time_Known_Value
(Rop
)
9518 and then Expr_Value
(Rop
) = Uint_0
9520 -- Call Remove_Side_Effects to ensure that any side effects in
9521 -- the ignored left operand (in particular function calls to
9522 -- user defined functions) are properly executed.
9524 Remove_Side_Effects
(Lop
);
9526 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9527 Analyze_And_Resolve
(N
, Typ
);
9531 -- Similar handling for 0 * N = 0
9533 if Compile_Time_Known_Value
(Lop
)
9534 and then Expr_Value
(Lop
) = Uint_0
9536 Remove_Side_Effects
(Rop
);
9537 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9538 Analyze_And_Resolve
(N
, Typ
);
9542 -- N * 1 = 1 * N = N for integer types
9544 -- This optimisation is not done if we are going to
9545 -- rewrite the product 1 * 2 ** N to a shift.
9547 if Compile_Time_Known_Value
(Rop
)
9548 and then Expr_Value
(Rop
) = Uint_1
9554 elsif Compile_Time_Known_Value
(Lop
)
9555 and then Expr_Value
(Lop
) = Uint_1
9563 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9564 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9565 -- operand is an integer, as required for this to work.
9570 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9574 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
9577 Left_Opnd
=> Right_Opnd
(Lop
),
9578 Right_Opnd
=> Right_Opnd
(Rop
))));
9579 Analyze_And_Resolve
(N
, Typ
);
9583 -- If the result is modular, perform the reduction of the result
9586 if Is_Modular_Integer_Type
(Typ
)
9587 and then not Non_Binary_Modulus
(Typ
)
9592 Make_Op_Shift_Left
(Loc
,
9595 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
9597 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9601 Make_Op_Shift_Left
(Loc
,
9604 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
9607 Analyze_And_Resolve
(N
, Typ
);
9611 -- Same processing for the operands the other way round
9614 if Is_Modular_Integer_Type
(Typ
)
9615 and then not Non_Binary_Modulus
(Typ
)
9620 Make_Op_Shift_Left
(Loc
,
9623 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
9625 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
9629 Make_Op_Shift_Left
(Loc
,
9632 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
9635 Analyze_And_Resolve
(N
, Typ
);
9639 -- Try to narrow the operation
9641 if Typ
= Universal_Integer
then
9642 Narrow_Large_Operation
(N
);
9644 if Nkind
(N
) /= N_Op_Multiply
then
9649 -- Do required fixup of universal fixed operation
9651 if Typ
= Universal_Fixed
then
9652 Fixup_Universal_Fixed_Operation
(N
);
9656 -- Multiplications with fixed-point results
9658 if Is_Fixed_Point_Type
(Typ
) then
9660 -- Case of fixed * integer => fixed
9662 if Is_Integer_Type
(Rtyp
) then
9663 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
9665 -- Case of integer * fixed => fixed
9667 elsif Is_Integer_Type
(Ltyp
) then
9668 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
9670 -- Case of fixed * fixed => fixed
9673 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
9676 -- Other cases of multiplication of fixed-point operands
9678 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
9679 if Is_Integer_Type
(Typ
) then
9680 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
9682 pragma Assert
(Is_Floating_Point_Type
(Typ
));
9683 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
9686 -- Mixed-mode operations can appear in a non-static universal context,
9687 -- in which case the integer argument must be converted explicitly.
9689 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
9690 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
9691 Analyze_And_Resolve
(Rop
, Universal_Real
);
9693 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
9694 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
9695 Analyze_And_Resolve
(Lop
, Universal_Real
);
9697 -- Non-fixed point cases, check software overflow checking required
9699 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
9700 Apply_Arithmetic_Overflow_Check
(N
);
9703 -- Overflow checks for floating-point if -gnateF mode active
9705 Check_Float_Op_Overflow
(N
);
9707 Expand_Nonbinary_Modular_Op
(N
);
9708 end Expand_N_Op_Multiply
;
9710 --------------------
9711 -- Expand_N_Op_Ne --
9712 --------------------
9714 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
9715 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
9718 -- Case of elementary type with standard operator. But if unnesting,
9719 -- handle elementary types whose Equivalent_Types are records because
9720 -- there may be padding or undefined fields.
9722 if Is_Elementary_Type
(Typ
)
9723 and then Sloc
(Entity
(N
)) = Standard_Location
9724 and then not (Ekind
(Typ
) in E_Class_Wide_Type
9725 | E_Class_Wide_Subtype
9726 | E_Access_Subprogram_Type
9727 | E_Access_Protected_Subprogram_Type
9728 | E_Anonymous_Access_Protected_Subprogram_Type
9730 and then Present
(Equivalent_Type
(Typ
))
9731 and then Is_Record_Type
(Equivalent_Type
(Typ
)))
9733 Binary_Op_Validity_Checks
(N
);
9735 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9736 -- means we no longer have a /= operation, we are all done.
9738 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
)) then
9739 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9742 if Nkind
(N
) /= N_Op_Ne
then
9746 -- Boolean types (requiring handling of non-standard case)
9748 if Is_Boolean_Type
(Typ
) then
9749 Adjust_Condition
(Left_Opnd
(N
));
9750 Adjust_Condition
(Right_Opnd
(N
));
9751 Set_Etype
(N
, Standard_Boolean
);
9752 Adjust_Result_Type
(N
, Typ
);
9755 Rewrite_Comparison
(N
);
9757 -- Try to narrow the operation
9759 if Typ
= Universal_Integer
and then Nkind
(N
) = N_Op_Ne
then
9760 Narrow_Large_Operation
(N
);
9763 -- For all cases other than elementary types, we rewrite node as the
9764 -- negation of an equality operation, and reanalyze. The equality to be
9765 -- used is defined in the same scope and has the same signature. This
9766 -- signature must be set explicitly since in an instance it may not have
9767 -- the same visibility as in the generic unit. This avoids duplicating
9768 -- or factoring the complex code for record/array equality tests etc.
9770 -- This case is also used for the minimal expansion performed in
9775 Loc
: constant Source_Ptr
:= Sloc
(N
);
9777 Ne
: constant Entity_Id
:= Entity
(N
);
9780 Binary_Op_Validity_Checks
(N
);
9786 Left_Opnd
=> Left_Opnd
(N
),
9787 Right_Opnd
=> Right_Opnd
(N
)));
9789 if Scope
(Ne
) /= Standard_Standard
then
9790 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
9793 -- For navigation purposes, we want to treat the inequality as an
9794 -- implicit reference to the corresponding equality. Preserve the
9795 -- Comes_From_ source flag to generate proper Xref entries.
9797 Preserve_Comes_From_Source
(Neg
, N
);
9798 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
9800 Analyze_And_Resolve
(N
, Standard_Boolean
);
9804 -- No need for optimization in GNATprove mode, where we would rather see
9805 -- the original source expression.
9807 if not GNATprove_Mode
then
9808 Optimize_Length_Comparison
(N
);
9812 ---------------------
9813 -- Expand_N_Op_Not --
9814 ---------------------
9816 -- If the argument is other than a Boolean array type, there is no special
9817 -- expansion required, except for dealing with validity checks, and non-
9818 -- standard boolean representations.
9820 -- For the packed array case, we call the special routine in Exp_Pakd,
9821 -- except that if the component size is greater than one, we use the
9822 -- standard routine generating a gruesome loop (it is so peculiar to have
9823 -- packed arrays with non-standard Boolean representations anyway, so it
9824 -- does not matter that we do not handle this case efficiently).
9826 -- For the unpacked array case (and for the special packed case where we
9827 -- have non standard Booleans, as discussed above), we generate and insert
9828 -- into the tree the following function definition:
9830 -- function Nnnn (A : arr) is
9833 -- for J in a'range loop
9834 -- B (J) := not A (J);
9839 -- or in the case of Transform_Function_Array:
9841 -- procedure Nnnn (A : arr; RESULT : out arr) is
9843 -- for J in a'range loop
9844 -- RESULT (J) := not A (J);
9848 -- Here arr is the actual subtype of the parameter (and hence always
9849 -- constrained). Then we replace the not with a call to this subprogram.
9851 procedure Expand_N_Op_Not
(N
: Node_Id
) is
9852 Loc
: constant Source_Ptr
:= Sloc
(N
);
9853 Typ
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9862 Func_Name
: Entity_Id
;
9863 Loop_Statement
: Node_Id
;
9866 Unary_Op_Validity_Checks
(N
);
9868 -- For boolean operand, deal with non-standard booleans
9870 if Is_Boolean_Type
(Typ
) then
9871 Adjust_Condition
(Right_Opnd
(N
));
9872 Set_Etype
(N
, Standard_Boolean
);
9873 Adjust_Result_Type
(N
, Typ
);
9877 -- Only array types need any other processing
9879 if not Is_Array_Type
(Typ
) then
9883 -- Case of array operand. If bit packed with a component size of 1,
9884 -- handle it in Exp_Pakd if the operand is known to be aligned.
9886 if Is_Bit_Packed_Array
(Typ
)
9887 and then Component_Size
(Typ
) = 1
9888 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
9890 Expand_Packed_Not
(N
);
9894 -- Case of array operand which is not bit-packed. If the context is
9895 -- a safe assignment, call in-place operation, If context is a larger
9896 -- boolean expression in the context of a safe assignment, expansion is
9897 -- done by enclosing operation.
9899 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
9900 Convert_To_Actual_Subtype
(Opnd
);
9901 Arr
:= Etype
(Opnd
);
9902 Ensure_Defined
(Arr
, N
);
9903 Silly_Boolean_Array_Not_Test
(N
, Arr
);
9905 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
9906 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
9907 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9910 -- Special case the negation of a binary operation
9912 elsif Nkind
(Opnd
) in N_Op_And | N_Op_Or | N_Op_Xor
9913 and then Safe_In_Place_Array_Op
9914 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
9916 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
9920 elsif Nkind
(Parent
(N
)) in N_Binary_Op
9921 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
9924 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
9925 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
9926 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
9929 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
9931 -- (not A) op (not B) can be reduced to a single call
9933 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
9936 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
9939 -- A xor (not B) can also be special-cased
9941 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
9948 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
9950 if Transform_Function_Array
then
9951 B
:= Make_Defining_Identifier
(Loc
, Name_UP_RESULT
);
9953 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
9956 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
9959 Make_Indexed_Component
(Loc
,
9960 Prefix
=> New_Occurrence_Of
(A
, Loc
),
9961 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9964 Make_Indexed_Component
(Loc
,
9965 Prefix
=> New_Occurrence_Of
(B
, Loc
),
9966 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
9969 Make_Implicit_Loop_Statement
(N
,
9970 Identifier
=> Empty
,
9973 Make_Iteration_Scheme
(Loc
,
9974 Loop_Parameter_Specification
=>
9975 Make_Loop_Parameter_Specification
(Loc
,
9976 Defining_Identifier
=> J
,
9977 Discrete_Subtype_Definition
=>
9978 Make_Attribute_Reference
(Loc
,
9979 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
9980 Attribute_Name
=> Name_Range
))),
9982 Statements
=> New_List
(
9983 Make_Assignment_Statement
(Loc
,
9985 Expression
=> Make_Op_Not
(Loc
, A_J
))));
9987 Func_Name
:= Make_Temporary
(Loc
, 'N');
9988 Set_Is_Inlined
(Func_Name
);
9990 if Transform_Function_Array
then
9992 Make_Subprogram_Body
(Loc
,
9994 Make_Procedure_Specification
(Loc
,
9995 Defining_Unit_Name
=> Func_Name
,
9996 Parameter_Specifications
=> New_List
(
9997 Make_Parameter_Specification
(Loc
,
9998 Defining_Identifier
=> A
,
9999 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
10000 Make_Parameter_Specification
(Loc
,
10001 Defining_Identifier
=> B
,
10002 Out_Present
=> True,
10003 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
10005 Declarations
=> New_List
,
10007 Handled_Statement_Sequence
=>
10008 Make_Handled_Sequence_Of_Statements
(Loc
,
10009 Statements
=> New_List
(Loop_Statement
))));
10012 Temp_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
10021 Make_Object_Declaration
(Loc
,
10022 Defining_Identifier
=> Temp_Id
,
10023 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10026 -- Proc_Call (Opnd, Temp);
10029 Make_Procedure_Call_Statement
(Loc
,
10030 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
10031 Parameter_Associations
=>
10032 New_List
(Opnd
, New_Occurrence_Of
(Temp_Id
, Loc
)));
10034 Insert_Actions
(Parent
(N
), New_List
(Decl
, Call
));
10035 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
10039 Make_Subprogram_Body
(Loc
,
10041 Make_Function_Specification
(Loc
,
10042 Defining_Unit_Name
=> Func_Name
,
10043 Parameter_Specifications
=> New_List
(
10044 Make_Parameter_Specification
(Loc
,
10045 Defining_Identifier
=> A
,
10046 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
10047 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
10049 Declarations
=> New_List
(
10050 Make_Object_Declaration
(Loc
,
10051 Defining_Identifier
=> B
,
10052 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
10054 Handled_Statement_Sequence
=>
10055 Make_Handled_Sequence_Of_Statements
(Loc
,
10056 Statements
=> New_List
(
10058 Make_Simple_Return_Statement
(Loc
,
10059 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
10062 Make_Function_Call
(Loc
,
10063 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
10064 Parameter_Associations
=> New_List
(Opnd
)));
10067 Analyze_And_Resolve
(N
, Typ
);
10068 end Expand_N_Op_Not
;
10070 --------------------
10071 -- Expand_N_Op_Or --
10072 --------------------
10074 procedure Expand_N_Op_Or
(N
: Node_Id
) is
10075 Typ
: constant Entity_Id
:= Etype
(N
);
10078 Binary_Op_Validity_Checks
(N
);
10080 if Is_Array_Type
(Etype
(N
)) then
10081 Expand_Boolean_Operator
(N
);
10083 elsif Is_Boolean_Type
(Etype
(N
)) then
10084 Adjust_Condition
(Left_Opnd
(N
));
10085 Adjust_Condition
(Right_Opnd
(N
));
10086 Set_Etype
(N
, Standard_Boolean
);
10087 Adjust_Result_Type
(N
, Typ
);
10089 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10090 Expand_Intrinsic_Call
(N
, Entity
(N
));
10093 Expand_Nonbinary_Modular_Op
(N
);
10094 end Expand_N_Op_Or
;
10096 ----------------------
10097 -- Expand_N_Op_Plus --
10098 ----------------------
10100 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
10101 Typ
: constant Entity_Id
:= Etype
(N
);
10104 Unary_Op_Validity_Checks
(N
);
10106 -- Check for MINIMIZED/ELIMINATED overflow mode
10108 if Minimized_Eliminated_Overflow_Check
(N
) then
10109 Apply_Arithmetic_Overflow_Check
(N
);
10113 -- Try to narrow the operation
10115 if Typ
= Universal_Integer
then
10116 Narrow_Large_Operation
(N
);
10118 end Expand_N_Op_Plus
;
10120 ---------------------
10121 -- Expand_N_Op_Rem --
10122 ---------------------
10124 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
10125 Loc
: constant Source_Ptr
:= Sloc
(N
);
10126 Typ
: constant Entity_Id
:= Etype
(N
);
10137 -- Set if corresponding operand can be negative
10140 Binary_Op_Validity_Checks
(N
);
10142 -- Check for MINIMIZED/ELIMINATED overflow mode
10144 if Minimized_Eliminated_Overflow_Check
(N
) then
10145 Apply_Arithmetic_Overflow_Check
(N
);
10149 -- Try to narrow the operation
10151 if Typ
= Universal_Integer
then
10152 Narrow_Large_Operation
(N
);
10154 if Nkind
(N
) /= N_Op_Rem
then
10159 if Is_Integer_Type
(Etype
(N
)) then
10160 Apply_Divide_Checks
(N
);
10162 -- All done if we don't have a REM any more, which can happen as a
10163 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
10165 if Nkind
(N
) /= N_Op_Rem
then
10170 -- Proceed with expansion of REM
10172 Left
:= Left_Opnd
(N
);
10173 Right
:= Right_Opnd
(N
);
10175 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
10176 -- but it is useful with other back ends, and is certainly harmless.
10178 if Is_Integer_Type
(Etype
(N
))
10179 and then Compile_Time_Known_Value
(Right
)
10180 and then Expr_Value
(Right
) = Uint_1
10182 -- Call Remove_Side_Effects to ensure that any side effects in the
10183 -- ignored left operand (in particular function calls to user defined
10184 -- functions) are properly executed.
10186 Remove_Side_Effects
(Left
);
10188 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10189 Analyze_And_Resolve
(N
, Typ
);
10193 -- Deal with annoying case of largest negative number remainder minus
10194 -- one. Gigi may not handle this case correctly, because on some
10195 -- targets, the mod value is computed using a divide instruction
10196 -- which gives an overflow trap for this case.
10198 -- It would be a bit more efficient to figure out which targets this
10199 -- is really needed for, but in practice it is reasonable to do the
10200 -- following special check in all cases, since it means we get a clearer
10201 -- message, and also the overhead is minimal given that division is
10202 -- expensive in any case.
10204 -- In fact the check is quite easy, if the right operand is -1, then
10205 -- the remainder is always 0, and we can just ignore the left operand
10206 -- completely in this case.
10208 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10209 Lneg
:= not OK
or else Lo
< 0;
10211 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10212 Rneg
:= not OK
or else Lo
< 0;
10214 -- We won't mess with trying to find out if the left operand can really
10215 -- be the largest negative number (that's a pain in the case of private
10216 -- types and this is really marginal). We will just assume that we need
10217 -- the test if the left operand can be negative at all.
10220 and then not CodePeer_Mode
10223 Make_If_Expression
(Loc
,
10224 Expressions
=> New_List
(
10226 Left_Opnd
=> Duplicate_Subexpr
(Right
),
10228 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
10230 Unchecked_Convert_To
(Typ
,
10231 Make_Integer_Literal
(Loc
, Uint_0
)),
10233 Relocate_Node
(N
))));
10235 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
10236 Analyze_And_Resolve
(N
, Typ
);
10238 end Expand_N_Op_Rem
;
10240 -----------------------------
10241 -- Expand_N_Op_Rotate_Left --
10242 -----------------------------
10244 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
10246 Binary_Op_Validity_Checks
(N
);
10248 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10249 -- so we rewrite in terms of logical shifts
10251 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10253 -- where Bits is the shift count mod Esize (the mod operation here
10254 -- deals with ludicrous large shift counts, which are apparently OK).
10256 if Modify_Tree_For_C
then
10258 Loc
: constant Source_Ptr
:= Sloc
(N
);
10259 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10260 Typ
: constant Entity_Id
:= Etype
(N
);
10263 -- Sem_Intr should prevent getting there with a non binary modulus
10265 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10267 Rewrite
(Right_Opnd
(N
),
10269 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10270 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10272 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10277 Make_Op_Shift_Left
(Loc
,
10278 Left_Opnd
=> Left_Opnd
(N
),
10279 Right_Opnd
=> Right_Opnd
(N
)),
10282 Make_Op_Shift_Right
(Loc
,
10283 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10285 Make_Op_Subtract
(Loc
,
10286 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10288 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10290 Analyze_And_Resolve
(N
, Typ
);
10293 end Expand_N_Op_Rotate_Left
;
10295 ------------------------------
10296 -- Expand_N_Op_Rotate_Right --
10297 ------------------------------
10299 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
10301 Binary_Op_Validity_Checks
(N
);
10303 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10304 -- so we rewrite in terms of logical shifts
10306 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10308 -- where Bits is the shift count mod Esize (the mod operation here
10309 -- deals with ludicrous large shift counts, which are apparently OK).
10311 if Modify_Tree_For_C
then
10313 Loc
: constant Source_Ptr
:= Sloc
(N
);
10314 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10315 Typ
: constant Entity_Id
:= Etype
(N
);
10318 -- Sem_Intr should prevent getting there with a non binary modulus
10320 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10322 Rewrite
(Right_Opnd
(N
),
10324 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10325 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10327 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10332 Make_Op_Shift_Right
(Loc
,
10333 Left_Opnd
=> Left_Opnd
(N
),
10334 Right_Opnd
=> Right_Opnd
(N
)),
10337 Make_Op_Shift_Left
(Loc
,
10338 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10340 Make_Op_Subtract
(Loc
,
10341 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10343 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10345 Analyze_And_Resolve
(N
, Typ
);
10348 end Expand_N_Op_Rotate_Right
;
10350 ----------------------------
10351 -- Expand_N_Op_Shift_Left --
10352 ----------------------------
10354 -- Note: nothing in this routine depends on left as opposed to right shifts
10355 -- so we share the routine for expanding shift right operations.
10357 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
10359 Binary_Op_Validity_Checks
(N
);
10361 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10362 -- operand is not greater than the word size (since that would not
10363 -- be defined properly by the corresponding C shift operator).
10365 if Modify_Tree_For_C
then
10367 Right
: constant Node_Id
:= Right_Opnd
(N
);
10368 Loc
: constant Source_Ptr
:= Sloc
(Right
);
10369 Typ
: constant Entity_Id
:= Etype
(N
);
10370 Siz
: constant Uint
:= Esize
(Typ
);
10377 -- Sem_Intr should prevent getting there with a non binary modulus
10379 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10381 if Compile_Time_Known_Value
(Right
) then
10382 if Expr_Value
(Right
) >= Siz
then
10383 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10384 Analyze_And_Resolve
(N
, Typ
);
10387 -- Not compile time known, find range
10390 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10392 -- Nothing to do if known to be OK range, otherwise expand
10394 if not OK
or else Hi
>= Siz
then
10396 -- Prevent recursion on copy of shift node
10398 Orig
:= Relocate_Node
(N
);
10399 Set_Analyzed
(Orig
);
10401 -- Now do the rewrite
10404 Make_If_Expression
(Loc
,
10405 Expressions
=> New_List
(
10407 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
10408 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
10409 Make_Integer_Literal
(Loc
, 0),
10411 Analyze_And_Resolve
(N
, Typ
);
10416 end Expand_N_Op_Shift_Left
;
10418 -----------------------------
10419 -- Expand_N_Op_Shift_Right --
10420 -----------------------------
10422 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
10424 -- Share shift left circuit
10426 Expand_N_Op_Shift_Left
(N
);
10427 end Expand_N_Op_Shift_Right
;
10429 ----------------------------------------
10430 -- Expand_N_Op_Shift_Right_Arithmetic --
10431 ----------------------------------------
10433 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
10435 Binary_Op_Validity_Checks
(N
);
10437 -- If we are in Modify_Tree_For_C mode, there is no shift right
10438 -- arithmetic in C, so we rewrite in terms of logical shifts for
10439 -- modular integers, and keep the Shift_Right intrinsic for signed
10440 -- integers: even though doing a shift on a signed integer is not
10441 -- fully guaranteed by the C standard, this is what C compilers
10442 -- implement in practice.
10443 -- Consider also taking advantage of this for modular integers by first
10444 -- performing an unchecked conversion of the modular integer to a signed
10445 -- integer of the same sign, and then convert back.
10447 -- Shift_Right (Num, Bits) or
10449 -- then not (Shift_Right (Mask, bits))
10452 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10454 -- Note: the above works fine for shift counts greater than or equal
10455 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10456 -- generates all 1'bits.
10458 if Modify_Tree_For_C
and then Is_Modular_Integer_Type
(Etype
(N
)) then
10460 Loc
: constant Source_Ptr
:= Sloc
(N
);
10461 Typ
: constant Entity_Id
:= Etype
(N
);
10462 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
10463 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
10464 Left
: constant Node_Id
:= Left_Opnd
(N
);
10465 Right
: constant Node_Id
:= Right_Opnd
(N
);
10469 -- Sem_Intr should prevent getting there with a non binary modulus
10471 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10473 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10474 -- compile time as a single constant.
10476 if Compile_Time_Known_Value
(Right
) then
10478 Val
: constant Uint
:= Expr_Value
(Right
);
10481 if Val
>= Esize
(Typ
) then
10482 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
10486 Make_Integer_Literal
(Loc
,
10487 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
10495 Make_Op_Shift_Right
(Loc
,
10496 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
10497 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
10500 -- Now do the rewrite
10505 Make_Op_Shift_Right
(Loc
,
10507 Right_Opnd
=> Right
),
10509 Make_If_Expression
(Loc
,
10510 Expressions
=> New_List
(
10512 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
10513 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
10515 Make_Integer_Literal
(Loc
, 0)))));
10516 Analyze_And_Resolve
(N
, Typ
);
10519 end Expand_N_Op_Shift_Right_Arithmetic
;
10521 --------------------------
10522 -- Expand_N_Op_Subtract --
10523 --------------------------
10525 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
10526 Typ
: constant Entity_Id
:= Etype
(N
);
10529 Binary_Op_Validity_Checks
(N
);
10531 -- Check for MINIMIZED/ELIMINATED overflow mode
10533 if Minimized_Eliminated_Overflow_Check
(N
) then
10534 Apply_Arithmetic_Overflow_Check
(N
);
10538 -- Try to narrow the operation
10540 if Typ
= Universal_Integer
then
10541 Narrow_Large_Operation
(N
);
10543 if Nkind
(N
) /= N_Op_Subtract
then
10548 -- N - 0 = N for integer types
10550 if Is_Integer_Type
(Typ
)
10551 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
10552 and then Expr_Value
(Right_Opnd
(N
)) = 0
10554 Rewrite
(N
, Left_Opnd
(N
));
10558 -- Arithmetic overflow checks for signed integer/fixed point types
10560 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
10561 Apply_Arithmetic_Overflow_Check
(N
);
10564 -- Overflow checks for floating-point if -gnateF mode active
10566 Check_Float_Op_Overflow
(N
);
10568 Expand_Nonbinary_Modular_Op
(N
);
10569 end Expand_N_Op_Subtract
;
10571 ---------------------
10572 -- Expand_N_Op_Xor --
10573 ---------------------
10575 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
10576 Typ
: constant Entity_Id
:= Etype
(N
);
10579 Binary_Op_Validity_Checks
(N
);
10581 if Is_Array_Type
(Etype
(N
)) then
10582 Expand_Boolean_Operator
(N
);
10584 elsif Is_Boolean_Type
(Etype
(N
)) then
10585 Adjust_Condition
(Left_Opnd
(N
));
10586 Adjust_Condition
(Right_Opnd
(N
));
10587 Set_Etype
(N
, Standard_Boolean
);
10588 Adjust_Result_Type
(N
, Typ
);
10590 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10591 Expand_Intrinsic_Call
(N
, Entity
(N
));
10594 Expand_Nonbinary_Modular_Op
(N
);
10595 end Expand_N_Op_Xor
;
10597 ----------------------
10598 -- Expand_N_Or_Else --
10599 ----------------------
10601 procedure Expand_N_Or_Else
(N
: Node_Id
)
10602 renames Expand_Short_Circuit_Operator
;
10604 -----------------------------------
10605 -- Expand_N_Qualified_Expression --
10606 -----------------------------------
10608 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
10609 Operand
: constant Node_Id
:= Expression
(N
);
10610 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
10613 -- Do validity check if validity checking operands
10615 if Validity_Checks_On
and Validity_Check_Operands
then
10616 Ensure_Valid
(Operand
);
10619 Freeze_Before
(Operand
, Target_Type
);
10621 -- Apply possible constraint check
10623 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
10625 -- Apply possible predicate check
10627 Apply_Predicate_Check
(Operand
, Target_Type
);
10629 if Do_Range_Check
(Operand
) then
10630 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
10632 end Expand_N_Qualified_Expression
;
10634 ------------------------------------
10635 -- Expand_N_Quantified_Expression --
10636 ------------------------------------
10640 -- for all X in range => Cond
10645 -- for X in range loop
10646 -- if not Cond then
10652 -- Similarly, an existentially quantified expression:
10654 -- for some X in range => Cond
10659 -- for X in range loop
10666 -- In both cases, the iteration may be over a container in which case it is
10667 -- given by an iterator specification, not a loop parameter specification.
10669 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
10670 Actions
: constant List_Id
:= New_List
;
10671 For_All
: constant Boolean := All_Present
(N
);
10672 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
10673 Loc
: constant Source_Ptr
:= Sloc
(N
);
10674 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
10682 -- Ensure that the bound variable as well as the type of Name of the
10683 -- Iter_Spec if present are properly frozen. We must do this before
10684 -- expansion because the expression is about to be converted into a
10685 -- loop, and resulting freeze nodes may end up in the wrong place in the
10688 if Present
(Iter_Spec
) then
10689 Var
:= Defining_Identifier
(Iter_Spec
);
10691 Var
:= Defining_Identifier
(Loop_Spec
);
10695 P
: Node_Id
:= Parent
(N
);
10697 while Nkind
(P
) in N_Subexpr
loop
10701 if Present
(Iter_Spec
) then
10702 Freeze_Before
(P
, Etype
(Name
(Iter_Spec
)));
10705 Freeze_Before
(P
, Etype
(Var
));
10708 -- Create the declaration of the flag which tracks the status of the
10709 -- quantified expression. Generate:
10711 -- Flag : Boolean := (True | False);
10713 Flag
:= Make_Temporary
(Loc
, 'T', N
);
10715 Append_To
(Actions
,
10716 Make_Object_Declaration
(Loc
,
10717 Defining_Identifier
=> Flag
,
10718 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
10720 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
10722 -- Construct the circuitry which tracks the status of the quantified
10723 -- expression. Generate:
10725 -- if [not] Cond then
10726 -- Flag := (False | True);
10730 Cond
:= Relocate_Node
(Condition
(N
));
10733 Cond
:= Make_Op_Not
(Loc
, Cond
);
10736 Stmts
:= New_List
(
10737 Make_Implicit_If_Statement
(N
,
10739 Then_Statements
=> New_List
(
10740 Make_Assignment_Statement
(Loc
,
10741 Name
=> New_Occurrence_Of
(Flag
, Loc
),
10743 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
10744 Make_Exit_Statement
(Loc
))));
10746 -- Build the loop equivalent of the quantified expression
10748 if Present
(Iter_Spec
) then
10750 Make_Iteration_Scheme
(Loc
,
10751 Iterator_Specification
=> Iter_Spec
);
10754 Make_Iteration_Scheme
(Loc
,
10755 Loop_Parameter_Specification
=> Loop_Spec
);
10758 Append_To
(Actions
,
10759 Make_Loop_Statement
(Loc
,
10760 Iteration_Scheme
=> Scheme
,
10761 Statements
=> Stmts
,
10762 End_Label
=> Empty
));
10764 -- Transform the quantified expression
10767 Make_Expression_With_Actions
(Loc
,
10768 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
10769 Actions
=> Actions
));
10770 Analyze_And_Resolve
(N
, Standard_Boolean
);
10771 end Expand_N_Quantified_Expression
;
10773 ---------------------------------
10774 -- Expand_N_Selected_Component --
10775 ---------------------------------
10777 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
10778 Loc
: constant Source_Ptr
:= Sloc
(N
);
10779 Par
: constant Node_Id
:= Parent
(N
);
10780 P
: constant Node_Id
:= Prefix
(N
);
10781 S
: constant Node_Id
:= Selector_Name
(N
);
10782 Ptyp
: constant Entity_Id
:= Underlying_Type
(Etype
(P
));
10788 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
10789 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10790 -- unless the context of an assignment can provide size information.
10791 -- Don't we have a general routine that does this???
10793 function Is_Subtype_Declaration
return Boolean;
10794 -- The replacement of a discriminant reference by its value is required
10795 -- if this is part of the initialization of an temporary generated by a
10796 -- change of representation. This shows up as the construction of a
10797 -- discriminant constraint for a subtype declared at the same point as
10798 -- the entity in the prefix of the selected component. We recognize this
10799 -- case when the context of the reference is:
10800 -- subtype ST is T(Obj.D);
10801 -- where the entity for Obj comes from source, and ST has the same sloc.
10803 -----------------------
10804 -- In_Left_Hand_Side --
10805 -----------------------
10807 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
10809 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
10810 and then Comp
= Name
(Parent
(Comp
)))
10811 or else (Present
(Parent
(Comp
))
10812 and then Nkind
(Parent
(Comp
)) in N_Subexpr
10813 and then In_Left_Hand_Side
(Parent
(Comp
)));
10814 end In_Left_Hand_Side
;
10816 -----------------------------
10817 -- Is_Subtype_Declaration --
10818 -----------------------------
10820 function Is_Subtype_Declaration
return Boolean is
10821 Par
: constant Node_Id
:= Parent
(N
);
10824 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
10825 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
10826 and then Comes_From_Source
(Entity
(Prefix
(N
)))
10827 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
10828 end Is_Subtype_Declaration
;
10830 -- Start of processing for Expand_N_Selected_Component
10833 -- Deal with discriminant check required
10835 if Do_Discriminant_Check
(N
) then
10836 if Present
(Discriminant_Checking_Func
10837 (Original_Record_Component
(Entity
(S
))))
10839 -- Present the discriminant checking function to the backend, so
10840 -- that it can inline the call to the function.
10843 (Discriminant_Checking_Func
10844 (Original_Record_Component
(Entity
(S
))),
10847 -- Now reset the flag and generate the call
10849 Set_Do_Discriminant_Check
(N
, False);
10850 Generate_Discriminant_Check
(N
);
10852 -- In the case of Unchecked_Union, no discriminant checking is
10853 -- actually performed.
10856 if not Is_Unchecked_Union
10857 (Implementation_Base_Type
(Etype
(Prefix
(N
))))
10858 and then not Is_Predefined_Unit
(Get_Source_Unit
(N
))
10861 ("sorry - unable to generate discriminant check for" &
10862 " reference to variant component &",
10863 Selector_Name
(N
));
10866 Set_Do_Discriminant_Check
(N
, False);
10870 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10871 -- function, then additional actuals must be passed.
10873 if Is_Build_In_Place_Function_Call
(P
) then
10874 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
10876 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10877 -- containing build-in-place function calls whose returned object covers
10878 -- interface types.
10880 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
10881 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
10884 -- Gigi cannot handle unchecked conversions that are the prefix of a
10885 -- selected component with discriminants. This must be checked during
10886 -- expansion, because during analysis the type of the selector is not
10887 -- known at the point the prefix is analyzed. If the conversion is the
10888 -- target of an assignment, then we cannot force the evaluation.
10890 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
10891 and then Has_Discriminants
(Etype
(N
))
10892 and then not In_Left_Hand_Side
(N
)
10894 Force_Evaluation
(Prefix
(N
));
10897 -- Remaining processing applies only if selector is a discriminant
10899 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
10901 -- If the selector is a discriminant of a constrained record type,
10902 -- we may be able to rewrite the expression with the actual value
10903 -- of the discriminant, a useful optimization in some cases.
10905 if Is_Record_Type
(Ptyp
)
10906 and then Has_Discriminants
(Ptyp
)
10907 and then Is_Constrained
(Ptyp
)
10909 -- Do this optimization for discrete types only, and not for
10910 -- access types (access discriminants get us into trouble).
10912 if not Is_Discrete_Type
(Etype
(N
)) then
10915 -- Don't do this on the left-hand side of an assignment statement.
10916 -- Normally one would think that references like this would not
10917 -- occur, but they do in generated code, and mean that we really
10918 -- do want to assign the discriminant.
10920 elsif Nkind
(Par
) = N_Assignment_Statement
10921 and then Name
(Par
) = N
10925 -- Don't do this optimization for the prefix of an attribute or
10926 -- the name of an object renaming declaration since these are
10927 -- contexts where we do not want the value anyway.
10929 elsif (Nkind
(Par
) = N_Attribute_Reference
10930 and then Prefix
(Par
) = N
)
10931 or else Is_Renamed_Object
(N
)
10935 -- Don't do this optimization if we are within the code for a
10936 -- discriminant check, since the whole point of such a check may
10937 -- be to verify the condition on which the code below depends.
10939 elsif Is_In_Discriminant_Check
(N
) then
10942 -- Green light to see if we can do the optimization. There is
10943 -- still one condition that inhibits the optimization below but
10944 -- now is the time to check the particular discriminant.
10947 -- Loop through discriminants to find the matching discriminant
10948 -- constraint to see if we can copy it.
10950 Disc
:= First_Discriminant
(Ptyp
);
10951 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
10952 Discr_Loop
: while Present
(Dcon
) loop
10953 Dval
:= Node
(Dcon
);
10955 -- Check if this is the matching discriminant and if the
10956 -- discriminant value is simple enough to make sense to
10957 -- copy. We don't want to copy complex expressions, and
10958 -- indeed to do so can cause trouble (before we put in
10959 -- this guard, a discriminant expression containing an
10960 -- AND THEN was copied, causing problems for coverage
10961 -- analysis tools).
10963 -- However, if the reference is part of the initialization
10964 -- code generated for an object declaration, we must use
10965 -- the discriminant value from the subtype constraint,
10966 -- because the selected component may be a reference to the
10967 -- object being initialized, whose discriminant is not yet
10968 -- set. This only happens in complex cases involving changes
10969 -- of representation.
10971 if Disc
= Entity
(Selector_Name
(N
))
10972 and then (Is_Entity_Name
(Dval
)
10973 or else Compile_Time_Known_Value
(Dval
)
10974 or else Is_Subtype_Declaration
)
10976 -- Here we have the matching discriminant. Check for
10977 -- the case of a discriminant of a component that is
10978 -- constrained by an outer discriminant, which cannot
10979 -- be optimized away.
10981 if Denotes_Discriminant
(Dval
, Check_Concurrent
=> True)
10985 -- Do not retrieve value if constraint is not static. It
10986 -- is generally not useful, and the constraint may be a
10987 -- rewritten outer discriminant in which case it is in
10990 elsif Is_Entity_Name
(Dval
)
10992 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
10993 and then Present
(Expression
(Parent
(Entity
(Dval
))))
10995 Is_OK_Static_Expression
10996 (Expression
(Parent
(Entity
(Dval
))))
11000 -- In the context of a case statement, the expression may
11001 -- have the base type of the discriminant, and we need to
11002 -- preserve the constraint to avoid spurious errors on
11005 elsif Nkind
(Parent
(N
)) = N_Case_Statement
11006 and then Etype
(Dval
) /= Etype
(Disc
)
11009 Make_Qualified_Expression
(Loc
,
11011 New_Occurrence_Of
(Etype
(Disc
), Loc
),
11013 New_Copy_Tree
(Dval
)));
11014 Analyze_And_Resolve
(N
, Etype
(Disc
));
11016 -- In case that comes out as a static expression,
11017 -- reset it (a selected component is never static).
11019 Set_Is_Static_Expression
(N
, False);
11022 -- Otherwise we can just copy the constraint, but the
11023 -- result is certainly not static. In some cases the
11024 -- discriminant constraint has been analyzed in the
11025 -- context of the original subtype indication, but for
11026 -- itypes the constraint might not have been analyzed
11027 -- yet, and this must be done now.
11030 Rewrite
(N
, New_Copy_Tree
(Dval
));
11031 Analyze_And_Resolve
(N
);
11032 Set_Is_Static_Expression
(N
, False);
11038 Next_Discriminant
(Disc
);
11039 end loop Discr_Loop
;
11041 -- Note: the above loop should always find a matching
11042 -- discriminant, but if it does not, we just missed an
11043 -- optimization due to some glitch (perhaps a previous
11044 -- error), so ignore.
11049 -- The only remaining processing is in the case of a discriminant of
11050 -- a concurrent object, where we rewrite the prefix to denote the
11051 -- corresponding record type. If the type is derived and has renamed
11052 -- discriminants, use corresponding discriminant, which is the one
11053 -- that appears in the corresponding record.
11055 if not Is_Concurrent_Type
(Ptyp
) then
11059 Disc
:= Entity
(Selector_Name
(N
));
11061 if Is_Derived_Type
(Ptyp
)
11062 and then Present
(Corresponding_Discriminant
(Disc
))
11064 Disc
:= Corresponding_Discriminant
(Disc
);
11068 Make_Selected_Component
(Loc
,
11070 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
11071 New_Copy_Tree
(P
)),
11072 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
11074 Rewrite
(N
, New_N
);
11078 -- Set Atomic_Sync_Required if necessary for atomic component
11080 if Nkind
(N
) = N_Selected_Component
then
11082 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
11086 -- If component is atomic, but type is not, setting depends on
11087 -- disable/enable state for the component.
11089 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
11090 Set
:= not Atomic_Synchronization_Disabled
(E
);
11092 -- If component is not atomic, but its type is atomic, setting
11093 -- depends on disable/enable state for the type.
11095 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
11096 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
11098 -- If both component and type are atomic, we disable if either
11099 -- component or its type have sync disabled.
11101 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
11102 Set
:= not Atomic_Synchronization_Disabled
(E
)
11104 not Atomic_Synchronization_Disabled
(Etype
(E
));
11110 -- Set flag if required
11113 Activate_Atomic_Synchronization
(N
);
11117 end Expand_N_Selected_Component
;
11119 --------------------
11120 -- Expand_N_Slice --
11121 --------------------
11123 procedure Expand_N_Slice
(N
: Node_Id
) is
11124 Loc
: constant Source_Ptr
:= Sloc
(N
);
11125 Typ
: constant Entity_Id
:= Etype
(N
);
11127 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
11128 -- Check whether the argument is an actual for a procedure call, in
11129 -- which case the expansion of a bit-packed slice is deferred until the
11130 -- call itself is expanded. The reason this is required is that we might
11131 -- have an IN OUT or OUT parameter, and the copy out is essential, and
11132 -- that copy out would be missed if we created a temporary here in
11133 -- Expand_N_Slice. Note that we don't bother to test specifically for an
11134 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
11135 -- is harmless to defer expansion in the IN case, since the call
11136 -- processing will still generate the appropriate copy in operation,
11137 -- which will take care of the slice.
11139 procedure Make_Temporary_For_Slice
;
11140 -- Create a named variable for the value of the slice, in cases where
11141 -- the back end cannot handle it properly, e.g. when packed types or
11142 -- unaligned slices are involved.
11144 -------------------------
11145 -- Is_Procedure_Actual --
11146 -------------------------
11148 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
11149 Par
: Node_Id
:= Parent
(N
);
11153 -- If our parent is a procedure call we can return
11155 if Nkind
(Par
) = N_Procedure_Call_Statement
then
11158 -- If our parent is a type conversion, keep climbing the tree,
11159 -- since a type conversion can be a procedure actual. Also keep
11160 -- climbing if parameter association or a qualified expression,
11161 -- since these are additional cases that do can appear on
11162 -- procedure actuals.
11164 elsif Nkind
(Par
) in N_Type_Conversion
11165 | N_Parameter_Association
11166 | N_Qualified_Expression
11168 Par
:= Parent
(Par
);
11170 -- Any other case is not what we are looking for
11176 end Is_Procedure_Actual
;
11178 ------------------------------
11179 -- Make_Temporary_For_Slice --
11180 ------------------------------
11182 procedure Make_Temporary_For_Slice
is
11183 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
11188 Make_Object_Declaration
(Loc
,
11189 Defining_Identifier
=> Ent
,
11190 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
11192 Set_No_Initialization
(Decl
);
11194 Insert_Actions
(N
, New_List
(
11196 Make_Assignment_Statement
(Loc
,
11197 Name
=> New_Occurrence_Of
(Ent
, Loc
),
11198 Expression
=> Relocate_Node
(N
))));
11200 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
11201 Analyze_And_Resolve
(N
, Typ
);
11202 end Make_Temporary_For_Slice
;
11206 Pref
: constant Node_Id
:= Prefix
(N
);
11208 -- Start of processing for Expand_N_Slice
11211 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11212 -- function, then additional actuals must be passed.
11214 if Is_Build_In_Place_Function_Call
(Pref
) then
11215 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
11217 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11218 -- containing build-in-place function calls whose returned object covers
11219 -- interface types.
11221 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
11222 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
11225 -- The remaining case to be handled is packed slices. We can leave
11226 -- packed slices as they are in the following situations:
11228 -- 1. Right or left side of an assignment (we can handle this
11229 -- situation correctly in the assignment statement expansion).
11231 -- 2. Prefix of indexed component (the slide is optimized away in this
11232 -- case, see the start of Expand_N_Indexed_Component.)
11234 -- 3. Object renaming declaration, since we want the name of the
11235 -- slice, not the value.
11237 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11238 -- be required, and this is handled in the expansion of call
11241 -- 5. Prefix of an address attribute (this is an error which is caught
11242 -- elsewhere, and the expansion would interfere with generating the
11243 -- error message) or of a size attribute (because 'Size may change
11244 -- when applied to the temporary instead of the slice directly).
11246 if not Is_Packed
(Typ
) then
11248 -- Apply transformation for actuals of a function call, where
11249 -- Expand_Actuals is not used.
11251 if Nkind
(Parent
(N
)) = N_Function_Call
11252 and then Is_Possibly_Unaligned_Slice
(N
)
11254 Make_Temporary_For_Slice
;
11257 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
11258 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
11259 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
11263 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
11264 or else Is_Renamed_Object
(N
)
11265 or else Is_Procedure_Actual
(N
)
11269 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
11270 and then (Attribute_Name
(Parent
(N
)) = Name_Address
11271 or else Attribute_Name
(Parent
(N
)) = Name_Size
)
11276 Make_Temporary_For_Slice
;
11278 end Expand_N_Slice
;
11280 ------------------------------
11281 -- Expand_N_Type_Conversion --
11282 ------------------------------
11284 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
11285 Loc
: constant Source_Ptr
:= Sloc
(N
);
11286 Operand
: constant Node_Id
:= Expression
(N
);
11287 Operand_Acc
: Node_Id
:= Operand
;
11288 Target_Type
: Entity_Id
:= Etype
(N
);
11289 Operand_Type
: Entity_Id
:= Etype
(Operand
);
11291 procedure Discrete_Range_Check
;
11292 -- Handles generation of range check for discrete target value
11294 procedure Handle_Changed_Representation
;
11295 -- This is called in the case of record and array type conversions to
11296 -- see if there is a change of representation to be handled. Change of
11297 -- representation is actually handled at the assignment statement level,
11298 -- and what this procedure does is rewrite node N conversion as an
11299 -- assignment to temporary. If there is no change of representation,
11300 -- then the conversion node is unchanged.
11302 procedure Raise_Accessibility_Error
;
11303 -- Called when we know that an accessibility check will fail. Rewrites
11304 -- node N to an appropriate raise statement and outputs warning msgs.
11305 -- The Etype of the raise node is set to Target_Type. Note that in this
11306 -- case the rest of the processing should be skipped (i.e. the call to
11307 -- this procedure will be followed by "goto Done").
11309 procedure Real_Range_Check
;
11310 -- Handles generation of range check for real target value
11312 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
11313 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11314 -- evaluates to True.
11316 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
11318 -- Given a target type for a conversion, determine whether the
11319 -- statically deeper accessibility rules apply to it.
11321 --------------------------
11322 -- Discrete_Range_Check --
11323 --------------------------
11325 -- Case of conversions to a discrete type. We let Generate_Range_Check
11326 -- do the heavy lifting, after converting a fixed-point operand to an
11327 -- appropriate integer type.
11329 procedure Discrete_Range_Check
is
11333 procedure Generate_Temporary
;
11334 -- Generate a temporary to facilitate in the C backend the code
11335 -- generation of the unchecked conversion since the size of the
11336 -- source type may differ from the size of the target type.
11338 ------------------------
11339 -- Generate_Temporary --
11340 ------------------------
11342 procedure Generate_Temporary
is
11344 if Esize
(Etype
(Expr
)) < Esize
(Etype
(Ityp
)) then
11346 Exp_Type
: constant Entity_Id
:= Ityp
;
11347 Def_Id
: constant Entity_Id
:=
11348 Make_Temporary
(Loc
, 'R', Expr
);
11353 Set_Is_Internal
(Def_Id
);
11354 Set_Etype
(Def_Id
, Exp_Type
);
11355 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
11358 Make_Object_Declaration
(Loc
,
11359 Defining_Identifier
=> Def_Id
,
11360 Object_Definition
=> New_Occurrence_Of
11362 Constant_Present
=> True,
11363 Expression
=> Relocate_Node
(Expr
));
11365 Set_Assignment_OK
(E
);
11366 Insert_Action
(Expr
, E
);
11368 Set_Assignment_OK
(Res
, Assignment_OK
(Expr
));
11370 Rewrite
(Expr
, Res
);
11371 Analyze_And_Resolve
(Expr
, Exp_Type
);
11374 end Generate_Temporary
;
11376 -- Start of processing for Discrete_Range_Check
11379 -- Nothing more to do if conversion was rewritten
11381 if Nkind
(N
) /= N_Type_Conversion
then
11385 Expr
:= Expression
(N
);
11387 -- Clear the Do_Range_Check flag on Expr
11389 Set_Do_Range_Check
(Expr
, False);
11391 -- Nothing to do if range checks suppressed
11393 if Range_Checks_Suppressed
(Target_Type
) then
11397 -- Nothing to do if expression is an entity on which checks have been
11400 if Is_Entity_Name
(Expr
)
11401 and then Range_Checks_Suppressed
(Entity
(Expr
))
11406 -- Before we do a range check, we have to deal with treating
11407 -- a fixed-point operand as an integer. The way we do this
11408 -- is simply to do an unchecked conversion to an appropriate
11409 -- integer type with the smallest size, so that we can suppress
11412 if Is_Fixed_Point_Type
(Etype
(Expr
)) then
11413 Ityp
:= Small_Integer_Type_For
11414 (Esize
(Base_Type
(Etype
(Expr
))), Uns
=> False);
11416 -- Generate a temporary with the integer type to facilitate in the
11417 -- C backend the code generation for the unchecked conversion.
11419 if Modify_Tree_For_C
then
11420 Generate_Temporary
;
11423 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11426 -- Reset overflow flag, since the range check will include
11427 -- dealing with possible overflow, and generate the check.
11429 Set_Do_Overflow_Check
(N
, False);
11431 Generate_Range_Check
(Expr
, Target_Type
, CE_Range_Check_Failed
);
11432 end Discrete_Range_Check
;
11434 -----------------------------------
11435 -- Handle_Changed_Representation --
11436 -----------------------------------
11438 procedure Handle_Changed_Representation
is
11446 -- Nothing else to do if no change of representation
11448 if Has_Compatible_Representation
(Target_Type
, Operand_Type
) then
11451 -- The real change of representation work is done by the assignment
11452 -- statement processing. So if this type conversion is appearing as
11453 -- the expression of an assignment statement, nothing needs to be
11454 -- done to the conversion.
11456 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
11459 -- Otherwise we need to generate a temporary variable, and do the
11460 -- change of representation assignment into that temporary variable.
11461 -- The conversion is then replaced by a reference to this variable.
11466 -- If type is unconstrained we have to add a constraint, copied
11467 -- from the actual value of the left-hand side.
11469 if not Is_Constrained
(Target_Type
) then
11470 if Has_Discriminants
(Operand_Type
) then
11472 -- A change of representation can only apply to untagged
11473 -- types. We need to build the constraint that applies to
11474 -- the target type, using the constraints of the operand.
11475 -- The analysis is complicated if there are both inherited
11476 -- discriminants and constrained discriminants.
11477 -- We iterate over the discriminants of the target, and
11478 -- find the discriminant of the same name:
11480 -- a) If there is a corresponding discriminant in the object
11481 -- then the value is a selected component of the operand.
11483 -- b) Otherwise the value of a constrained discriminant is
11484 -- found in the stored constraint of the operand.
11487 Stored
: constant Elist_Id
:=
11488 Stored_Constraint
(Operand_Type
);
11489 -- Stored constraints of the operand. If present, they
11490 -- correspond to the discriminants of the parent type.
11492 Disc_O
: Entity_Id
;
11493 -- Discriminant of the operand type. Its value in the
11494 -- object is captured in a selected component.
11496 Disc_T
: Entity_Id
;
11497 -- Discriminant of the target type
11502 Disc_O
:= First_Discriminant
(Operand_Type
);
11503 Disc_T
:= First_Discriminant
(Target_Type
);
11504 Elmt
:= (if Present
(Stored
)
11505 then First_Elmt
(Stored
)
11509 while Present
(Disc_T
) loop
11510 if Present
(Disc_O
)
11511 and then Chars
(Disc_T
) = Chars
(Disc_O
)
11514 Make_Selected_Component
(Loc
,
11516 Duplicate_Subexpr_Move_Checks
(Operand
),
11518 Make_Identifier
(Loc
, Chars
(Disc_O
))));
11519 Next_Discriminant
(Disc_O
);
11521 elsif Present
(Elmt
) then
11522 Append_To
(Cons
, New_Copy_Tree
(Node
(Elmt
)));
11525 if Present
(Elmt
) then
11529 Next_Discriminant
(Disc_T
);
11533 elsif Is_Array_Type
(Operand_Type
) then
11534 N_Ix
:= First_Index
(Target_Type
);
11537 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
11539 -- We convert the bounds explicitly. We use an unchecked
11540 -- conversion because bounds checks are done elsewhere.
11545 Unchecked_Convert_To
(Etype
(N_Ix
),
11546 Make_Attribute_Reference
(Loc
,
11548 Duplicate_Subexpr_No_Checks
11549 (Operand
, Name_Req
=> True),
11550 Attribute_Name
=> Name_First
,
11551 Expressions
=> New_List
(
11552 Make_Integer_Literal
(Loc
, J
)))),
11555 Unchecked_Convert_To
(Etype
(N_Ix
),
11556 Make_Attribute_Reference
(Loc
,
11558 Duplicate_Subexpr_No_Checks
11559 (Operand
, Name_Req
=> True),
11560 Attribute_Name
=> Name_Last
,
11561 Expressions
=> New_List
(
11562 Make_Integer_Literal
(Loc
, J
))))));
11569 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
11571 if Present
(Cons
) then
11573 Make_Subtype_Indication
(Loc
,
11574 Subtype_Mark
=> Odef
,
11576 Make_Index_Or_Discriminant_Constraint
(Loc
,
11577 Constraints
=> Cons
));
11580 Temp
:= Make_Temporary
(Loc
, 'C');
11582 Make_Object_Declaration
(Loc
,
11583 Defining_Identifier
=> Temp
,
11584 Object_Definition
=> Odef
);
11586 Set_No_Initialization
(Decl
, True);
11588 -- Insert required actions. It is essential to suppress checks
11589 -- since we have suppressed default initialization, which means
11590 -- that the variable we create may have no discriminants.
11595 Make_Assignment_Statement
(Loc
,
11596 Name
=> New_Occurrence_Of
(Temp
, Loc
),
11597 Expression
=> Relocate_Node
(N
))),
11598 Suppress
=> All_Checks
);
11600 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
11603 end Handle_Changed_Representation
;
11605 -------------------------------
11606 -- Raise_Accessibility_Error --
11607 -------------------------------
11609 procedure Raise_Accessibility_Error
is
11611 Error_Msg_Warn
:= SPARK_Mode
/= On
;
11613 Make_Raise_Program_Error
(Sloc
(N
),
11614 Reason
=> PE_Accessibility_Check_Failed
));
11615 Set_Etype
(N
, Target_Type
);
11617 Error_Msg_N
("accessibility check failure<<", N
);
11618 Error_Msg_N
("\Program_Error [<<", N
);
11619 end Raise_Accessibility_Error
;
11621 ----------------------
11622 -- Real_Range_Check --
11623 ----------------------
11625 -- Case of conversions to floating-point or fixed-point. If range checks
11626 -- are enabled and the target type has a range constraint, we convert:
11632 -- Tnn : typ'Base := typ'Base (x);
11633 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11636 -- This is necessary when there is a conversion of integer to float or
11637 -- to fixed-point to ensure that the correct checks are made. It is not
11638 -- necessary for the float-to-float case where it is enough to just set
11639 -- the Do_Range_Check flag on the expression.
11641 procedure Real_Range_Check
is
11642 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
11643 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
11644 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
11655 -- Nothing more to do if conversion was rewritten
11657 if Nkind
(N
) /= N_Type_Conversion
then
11661 Expr
:= Expression
(N
);
11663 -- Clear the Do_Range_Check flag on Expr
11665 Set_Do_Range_Check
(Expr
, False);
11667 -- Nothing to do if range checks suppressed, or target has the same
11668 -- range as the base type (or is the base type).
11670 if Range_Checks_Suppressed
(Target_Type
)
11671 or else (Lo
= Type_Low_Bound
(Btyp
)
11673 Hi
= Type_High_Bound
(Btyp
))
11678 -- Nothing to do if expression is an entity on which checks have been
11681 if Is_Entity_Name
(Expr
)
11682 and then Range_Checks_Suppressed
(Entity
(Expr
))
11687 -- Nothing to do if expression was rewritten into a float-to-float
11688 -- conversion, since this kind of conversion is handled elsewhere.
11690 if Is_Floating_Point_Type
(Etype
(Expr
))
11691 and then Is_Floating_Point_Type
(Target_Type
)
11696 -- Nothing to do if bounds are all static and we can tell that the
11697 -- expression is within the bounds of the target. Note that if the
11698 -- operand is of an unconstrained floating-point type, then we do
11699 -- not trust it to be in range (might be infinite)
11702 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Expr
));
11703 S_Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Expr
));
11706 if (not Is_Floating_Point_Type
(Etype
(Expr
))
11707 or else Is_Constrained
(Etype
(Expr
)))
11708 and then Compile_Time_Known_Value
(S_Lo
)
11709 and then Compile_Time_Known_Value
(S_Hi
)
11710 and then Compile_Time_Known_Value
(Hi
)
11711 and then Compile_Time_Known_Value
(Lo
)
11714 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
11715 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
11720 if Is_Real_Type
(Etype
(Expr
)) then
11721 S_Lov
:= Expr_Value_R
(S_Lo
);
11722 S_Hiv
:= Expr_Value_R
(S_Hi
);
11724 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
11725 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
11729 and then S_Lov
>= D_Lov
11730 and then S_Hiv
<= D_Hiv
11738 -- Otherwise rewrite the conversion as described above
11740 Conv
:= Convert_To
(Btyp
, Expr
);
11742 -- If a conversion is necessary, then copy the specific flags from
11743 -- the original one and also move the Do_Overflow_Check flag since
11744 -- this new conversion is to the base type.
11746 if Nkind
(Conv
) = N_Type_Conversion
then
11747 Set_Conversion_OK
(Conv
, Conversion_OK
(N
));
11748 Set_Float_Truncate
(Conv
, Float_Truncate
(N
));
11749 Set_Rounded_Result
(Conv
, Rounded_Result
(N
));
11751 if Do_Overflow_Check
(N
) then
11752 Set_Do_Overflow_Check
(Conv
);
11753 Set_Do_Overflow_Check
(N
, False);
11757 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
11759 -- For a conversion from Float to Fixed where the bounds of the
11760 -- fixed-point type are static, we can obtain a more accurate
11761 -- fixed-point value by converting the result of the floating-
11762 -- point expression to an appropriate integer type, and then
11763 -- performing an unchecked conversion to the target fixed-point
11764 -- type. The range check can then use the corresponding integer
11765 -- value of the bounds instead of requiring further conversions.
11766 -- This preserves the identity:
11768 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11770 -- which used to fail when Fix_Val was a bound of the type and
11771 -- the 'Small was not a representable number.
11772 -- This transformation requires an integer type large enough to
11773 -- accommodate a fixed-point value.
11775 if Is_Ordinary_Fixed_Point_Type
(Target_Type
)
11776 and then Is_Floating_Point_Type
(Etype
(Expr
))
11777 and then RM_Size
(Btyp
) <= System_Max_Integer_Size
11778 and then Nkind
(Lo
) = N_Real_Literal
11779 and then Nkind
(Hi
) = N_Real_Literal
11782 Expr_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Conv
);
11783 Int_Typ
: constant Entity_Id
:=
11784 Small_Integer_Type_For
(RM_Size
(Btyp
), Uns
=> False);
11785 Trunc
: constant Boolean := Float_Truncate
(Conv
);
11788 Conv
:= Convert_To
(Int_Typ
, Expression
(Conv
));
11789 Set_Float_Truncate
(Conv
, Trunc
);
11791 -- Generate a temporary with the integer value. Required in the
11792 -- CCG compiler to ensure that run-time checks reference this
11793 -- integer expression (instead of the resulting fixed-point
11794 -- value because fixed-point values are handled by means of
11795 -- unsigned integer types).
11798 Make_Object_Declaration
(Loc
,
11799 Defining_Identifier
=> Expr_Id
,
11800 Object_Definition
=> New_Occurrence_Of
(Int_Typ
, Loc
),
11801 Constant_Present
=> True,
11802 Expression
=> Conv
));
11804 -- Create integer objects for range checking of result.
11807 Unchecked_Convert_To
11808 (Int_Typ
, New_Occurrence_Of
(Expr_Id
, Loc
));
11811 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Lo
));
11814 Unchecked_Convert_To
11815 (Int_Typ
, New_Occurrence_Of
(Expr_Id
, Loc
));
11818 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Hi
));
11820 -- Rewrite conversion as an integer conversion of the
11821 -- original floating-point expression, followed by an
11822 -- unchecked conversion to the target fixed-point type.
11825 Unchecked_Convert_To
11826 (Target_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
11829 -- All other conversions
11832 Lo_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11834 Make_Attribute_Reference
(Loc
,
11835 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11836 Attribute_Name
=> Name_First
);
11838 Hi_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
11840 Make_Attribute_Reference
(Loc
,
11841 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11842 Attribute_Name
=> Name_Last
);
11845 -- Build code for range checking. Note that checks are suppressed
11846 -- here since we don't want a recursive range check popping up.
11848 Insert_Actions
(N
, New_List
(
11849 Make_Object_Declaration
(Loc
,
11850 Defining_Identifier
=> Tnn
,
11851 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
11852 Constant_Present
=> True,
11853 Expression
=> Conv
),
11855 Make_Raise_Constraint_Error
(Loc
,
11860 Left_Opnd
=> Lo_Arg
,
11861 Right_Opnd
=> Lo_Val
),
11865 Left_Opnd
=> Hi_Arg
,
11866 Right_Opnd
=> Hi_Val
)),
11867 Reason
=> CE_Range_Check_Failed
)),
11868 Suppress
=> All_Checks
);
11870 Rewrite
(Expr
, New_Occurrence_Of
(Tnn
, Loc
));
11871 end Real_Range_Check
;
11873 -----------------------------
11874 -- Has_Extra_Accessibility --
11875 -----------------------------
11877 -- Returns true for a formal of an anonymous access type or for an Ada
11878 -- 2012-style stand-alone object of an anonymous access type.
11880 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
11882 if Is_Formal
(Id
) or else Ekind
(Id
) in E_Constant | E_Variable
then
11883 return Present
(Effective_Extra_Accessibility
(Id
));
11887 end Has_Extra_Accessibility
;
11889 ----------------------------------------
11890 -- Statically_Deeper_Relation_Applies --
11891 ----------------------------------------
11893 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
11897 -- The case where the target type is an anonymous access type is
11898 -- ignored since they have different semantics and get covered by
11899 -- various runtime checks depending on context.
11901 -- Note, the current implementation of this predicate is incomplete
11902 -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
11905 return Ekind
(Targ_Typ
) /= E_Anonymous_Access_Type
;
11906 end Statically_Deeper_Relation_Applies
;
11908 -- Start of processing for Expand_N_Type_Conversion
11911 -- First remove check marks put by the semantic analysis on the type
11912 -- conversion between array types. We need these checks, and they will
11913 -- be generated by this expansion routine, but we do not depend on these
11914 -- flags being set, and since we do intend to expand the checks in the
11915 -- front end, we don't want them on the tree passed to the back end.
11917 if Is_Array_Type
(Target_Type
) then
11918 if Is_Constrained
(Target_Type
) then
11919 Set_Do_Length_Check
(N
, False);
11921 Set_Do_Range_Check
(Operand
, False);
11925 -- Nothing at all to do if conversion is to the identical type so remove
11926 -- the conversion completely, it is useless, except that it may carry
11927 -- an Assignment_OK attribute, which must be propagated to the operand
11928 -- and the Do_Range_Check flag on the operand must be cleared, if any.
11930 if Operand_Type
= Target_Type
then
11931 if Assignment_OK
(N
) then
11932 Set_Assignment_OK
(Operand
);
11935 Set_Do_Range_Check
(Operand
, False);
11937 Rewrite
(N
, Relocate_Node
(Operand
));
11942 -- Nothing to do if this is the second argument of read. This is a
11943 -- "backwards" conversion that will be handled by the specialized code
11944 -- in attribute processing.
11946 if Nkind
(Parent
(N
)) = N_Attribute_Reference
11947 and then Attribute_Name
(Parent
(N
)) = Name_Read
11948 and then Next
(First
(Expressions
(Parent
(N
)))) = N
11953 -- Check for case of converting to a type that has an invariant
11954 -- associated with it. This requires an invariant check. We insert
11957 -- invariant_check (typ (expr))
11959 -- in the code, after removing side effects from the expression.
11960 -- This is clearer than replacing the conversion into an expression
11961 -- with actions, because the context may impose additional actions
11962 -- (tag checks, membership tests, etc.) that conflict with this
11963 -- rewriting (used previously).
11965 -- Note: the Comes_From_Source check, and then the resetting of this
11966 -- flag prevents what would otherwise be an infinite recursion.
11968 if Has_Invariants
(Target_Type
)
11969 and then Present
(Invariant_Procedure
(Target_Type
))
11970 and then Comes_From_Source
(N
)
11972 Set_Comes_From_Source
(N
, False);
11973 Remove_Side_Effects
(N
);
11974 Insert_Action
(N
, Make_Invariant_Call
(Duplicate_Subexpr
(N
)));
11977 -- AI12-0042: For a view conversion to a class-wide type occurring
11978 -- within the immediate scope of T, from a specific type that is
11979 -- a descendant of T (including T itself), an invariant check is
11980 -- performed on the part of the object that is of type T. (We don't
11981 -- need to explicitly check for the operand type being a descendant,
11982 -- just that it's a specific type, because the conversion would be
11983 -- illegal if it's specific and not a descendant -- downward conversion
11984 -- is not allowed).
11986 elsif Is_Class_Wide_Type
(Target_Type
)
11987 and then not Is_Class_Wide_Type
(Etype
(Expression
(N
)))
11988 and then Present
(Invariant_Procedure
(Root_Type
(Target_Type
)))
11989 and then Comes_From_Source
(N
)
11990 and then Within_Scope
(Find_Enclosing_Scope
(N
), Scope
(Target_Type
))
11992 Remove_Side_Effects
(N
);
11994 -- Perform the invariant check on a conversion to the class-wide
11995 -- type's root type.
11998 Root_Conv
: constant Node_Id
:=
11999 Make_Type_Conversion
(Loc
,
12001 New_Occurrence_Of
(Root_Type
(Target_Type
), Loc
),
12002 Expression
=> Duplicate_Subexpr
(Expression
(N
)));
12004 Set_Etype
(Root_Conv
, Root_Type
(Target_Type
));
12006 Insert_Action
(N
, Make_Invariant_Call
(Root_Conv
));
12011 -- Here if we may need to expand conversion
12013 -- If the operand of the type conversion is an arithmetic operation on
12014 -- signed integers, and the based type of the signed integer type in
12015 -- question is smaller than Standard.Integer, we promote both of the
12016 -- operands to type Integer.
12018 -- For example, if we have
12020 -- target-type (opnd1 + opnd2)
12022 -- and opnd1 and opnd2 are of type short integer, then we rewrite
12025 -- target-type (integer(opnd1) + integer(opnd2))
12027 -- We do this because we are always allowed to compute in a larger type
12028 -- if we do the right thing with the result, and in this case we are
12029 -- going to do a conversion which will do an appropriate check to make
12030 -- sure that things are in range of the target type in any case. This
12031 -- avoids some unnecessary intermediate overflows.
12033 -- We might consider a similar transformation in the case where the
12034 -- target is a real type or a 64-bit integer type, and the operand
12035 -- is an arithmetic operation using a 32-bit integer type. However,
12036 -- we do not bother with this case, because it could cause significant
12037 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
12038 -- much cheaper, but we don't want different behavior on 32-bit and
12039 -- 64-bit machines. Note that the exclusion of the 64-bit case also
12040 -- handles the configurable run-time cases where 64-bit arithmetic
12041 -- may simply be unavailable.
12043 -- Note: this circuit is partially redundant with respect to the circuit
12044 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
12045 -- the processing here. Also we still need the Checks circuit, since we
12046 -- have to be sure not to generate junk overflow checks in the first
12047 -- place, since it would be tricky to remove them here.
12049 if Integer_Promotion_Possible
(N
) then
12051 -- All conditions met, go ahead with transformation
12058 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
12060 R
:= Convert_To
(Standard_Integer
, Right_Opnd
(Operand
));
12061 Set_Right_Opnd
(Opnd
, R
);
12063 if Nkind
(Operand
) in N_Binary_Op
then
12064 L
:= Convert_To
(Standard_Integer
, Left_Opnd
(Operand
));
12065 Set_Left_Opnd
(Opnd
, L
);
12069 Make_Type_Conversion
(Loc
,
12070 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
12071 Expression
=> Opnd
));
12073 Analyze_And_Resolve
(N
, Target_Type
);
12078 -- If the conversion is from Universal_Integer and requires an overflow
12079 -- check, try to do an intermediate conversion to a narrower type first
12080 -- without overflow check, in order to avoid doing the overflow check
12081 -- in Universal_Integer, which can be a very large type.
12083 if Operand_Type
= Universal_Integer
and then Do_Overflow_Check
(N
) then
12085 Lo
, Hi
, Siz
: Uint
;
12090 Determine_Range
(Operand
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12093 Siz
:= Get_Size_For_Range
(Lo
, Hi
);
12095 -- We use the base type instead of the first subtype because
12096 -- overflow checks are done in the base type, so this avoids
12097 -- the need for useless conversions.
12099 if Siz
< System_Max_Integer_Size
then
12100 Typ
:= Etype
(Integer_Type_For
(Siz
, Uns
=> False));
12102 Convert_To_And_Rewrite
(Typ
, Operand
);
12103 Analyze_And_Resolve
12104 (Operand
, Typ
, Suppress
=> Overflow_Check
);
12106 Analyze_And_Resolve
(N
, Target_Type
);
12113 -- Do validity check if validity checking operands
12115 if Validity_Checks_On
and Validity_Check_Operands
then
12116 Ensure_Valid
(Operand
);
12119 -- Special case of converting from non-standard boolean type
12121 if Is_Boolean_Type
(Operand_Type
)
12122 and then Nonzero_Is_True
(Operand_Type
)
12124 Adjust_Condition
(Operand
);
12125 Set_Etype
(Operand
, Standard_Boolean
);
12126 Operand_Type
:= Standard_Boolean
;
12129 -- Case of converting to an access type
12131 if Is_Access_Type
(Target_Type
) then
12132 -- In terms of accessibility rules, an anonymous access discriminant
12133 -- is not considered separate from its parent object.
12135 if Nkind
(Operand
) = N_Selected_Component
12136 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
12137 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
12139 Operand_Acc
:= Original_Node
(Prefix
(Operand
));
12142 -- If this type conversion was internally generated by the front end
12143 -- to displace the pointer to the object to reference an interface
12144 -- type and the original node was an Unrestricted_Access attribute,
12145 -- then skip applying accessibility checks (because, according to the
12146 -- GNAT Reference Manual, this attribute is similar to 'Access except
12147 -- that all accessibility and aliased view checks are omitted).
12149 if not Comes_From_Source
(N
)
12150 and then Is_Interface
(Designated_Type
(Target_Type
))
12151 and then Nkind
(Original_Node
(N
)) = N_Attribute_Reference
12152 and then Attribute_Name
(Original_Node
(N
)) =
12153 Name_Unrestricted_Access
12157 -- Apply an accessibility check when the conversion operand is an
12158 -- access parameter (or a renaming thereof), unless conversion was
12159 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
12160 -- or for the actual of a class-wide interface parameter. Note that
12161 -- other checks may still need to be applied below (such as tagged
12164 elsif Is_Entity_Name
(Operand_Acc
)
12165 and then Has_Extra_Accessibility
(Entity
(Operand_Acc
))
12166 and then Ekind
(Etype
(Operand_Acc
)) = E_Anonymous_Access_Type
12167 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
12168 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
12169 and then not No_Dynamic_Accessibility_Checks_Enabled
(N
)
12171 if not Comes_From_Source
(N
)
12172 and then Nkind
(Parent
(N
)) in N_Function_Call
12173 | N_Parameter_Association
12174 | N_Procedure_Call_Statement
12175 and then Is_Interface
(Designated_Type
(Target_Type
))
12176 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
12181 Apply_Accessibility_Check
12182 (Operand
, Target_Type
, Insert_Node
=> Operand
);
12185 -- If the level of the operand type is statically deeper than the
12186 -- level of the target type, then force Program_Error. Note that this
12187 -- can only occur for cases where the attribute is within the body of
12188 -- an instantiation, otherwise the conversion will already have been
12189 -- rejected as illegal.
12191 -- Note: warnings are issued by the analyzer for the instance cases,
12192 -- and, since we are late in expansion, a check is performed to
12193 -- verify that neither the target type nor the operand type are
12194 -- internally generated - as this can lead to spurious errors when,
12195 -- for example, the operand type is a result of BIP expansion.
12197 elsif In_Instance_Body
12198 and then Statically_Deeper_Relation_Applies
(Target_Type
)
12199 and then not Is_Internal
(Target_Type
)
12200 and then not Is_Internal
(Operand_Type
)
12202 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
12204 Raise_Accessibility_Error
;
12207 -- When the operand is a selected access discriminant the check needs
12208 -- to be made against the level of the object denoted by the prefix
12209 -- of the selected name. Force Program_Error for this case as well
12210 -- (this accessibility violation can only happen if within the body
12211 -- of an instantiation).
12213 elsif In_Instance_Body
12214 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
12215 and then Nkind
(Operand
) = N_Selected_Component
12216 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
12217 and then Static_Accessibility_Level
(Operand
, Zero_On_Dynamic_Level
)
12218 > Type_Access_Level
(Target_Type
)
12220 Raise_Accessibility_Error
;
12225 -- Case of conversions of tagged types and access to tagged types
12227 -- When needed, that is to say when the expression is class-wide, Add
12228 -- runtime a tag check for (strict) downward conversion by using the
12229 -- membership test, generating:
12231 -- [constraint_error when Operand not in Target_Type'Class]
12233 -- or in the access type case
12235 -- [constraint_error
12236 -- when Operand /= null
12237 -- and then Operand.all not in
12238 -- Designated_Type (Target_Type)'Class]
12240 if (Is_Access_Type
(Target_Type
)
12241 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
12242 or else Is_Tagged_Type
(Target_Type
)
12244 -- Do not do any expansion in the access type case if the parent is a
12245 -- renaming, since this is an error situation which will be caught by
12246 -- Sem_Ch8, and the expansion can interfere with this error check.
12248 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
12252 -- Otherwise, proceed with processing tagged conversion
12254 Tagged_Conversion
: declare
12255 Actual_Op_Typ
: Entity_Id
;
12256 Actual_Targ_Typ
: Entity_Id
;
12257 Root_Op_Typ
: Entity_Id
;
12259 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
12260 -- Create a membership check to test whether Operand is a member
12261 -- of Targ_Typ. If the original Target_Type is an access, include
12262 -- a test for null value. The check is inserted at N.
12264 --------------------
12265 -- Make_Tag_Check --
12266 --------------------
12268 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
12273 -- [Constraint_Error
12274 -- when Operand /= null
12275 -- and then Operand.all not in Targ_Typ]
12277 if Is_Access_Type
(Target_Type
) then
12279 Make_And_Then
(Loc
,
12282 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12283 Right_Opnd
=> Make_Null
(Loc
)),
12288 Make_Explicit_Dereference
(Loc
,
12289 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
12290 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
12293 -- [Constraint_Error when Operand not in Targ_Typ]
12298 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12299 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
12303 Make_Raise_Constraint_Error
(Loc
,
12305 Reason
=> CE_Tag_Check_Failed
),
12306 Suppress
=> All_Checks
);
12307 end Make_Tag_Check
;
12309 -- Start of processing for Tagged_Conversion
12312 -- Handle entities from the limited view
12314 if Is_Access_Type
(Operand_Type
) then
12316 Available_View
(Designated_Type
(Operand_Type
));
12318 Actual_Op_Typ
:= Operand_Type
;
12321 if Is_Access_Type
(Target_Type
) then
12323 Available_View
(Designated_Type
(Target_Type
));
12325 Actual_Targ_Typ
:= Target_Type
;
12328 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
12330 -- Ada 2005 (AI-251): Handle interface type conversion
12332 if Is_Interface
(Actual_Op_Typ
)
12334 Is_Interface
(Actual_Targ_Typ
)
12336 Expand_Interface_Conversion
(N
);
12340 -- Create a runtime tag check for a downward CW type conversion
12342 if Is_Class_Wide_Type
(Actual_Op_Typ
)
12343 and then Actual_Op_Typ
/= Actual_Targ_Typ
12344 and then Root_Op_Typ
/= Actual_Targ_Typ
12345 and then Is_Ancestor
12346 (Root_Op_Typ
, Actual_Targ_Typ
, Use_Full_View
=> True)
12347 and then not Tag_Checks_Suppressed
(Actual_Targ_Typ
)
12352 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
12353 Conv
:= Unchecked_Convert_To
(Target_Type
, Expression
(N
));
12355 Analyze_And_Resolve
(N
, Target_Type
);
12358 end Tagged_Conversion
;
12360 -- Case of other access type conversions
12362 elsif Is_Access_Type
(Target_Type
) then
12363 Apply_Constraint_Check
(Operand
, Target_Type
);
12365 -- Case of conversions from a fixed-point type
12367 -- These conversions require special expansion and processing, found in
12368 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12369 -- since from a semantic point of view, these are simple integer
12370 -- conversions, which do not need further processing except for the
12371 -- generation of range checks, which is performed at the end of this
12374 elsif Is_Fixed_Point_Type
(Operand_Type
)
12375 and then not Conversion_OK
(N
)
12377 -- We should never see universal fixed at this case, since the
12378 -- expansion of the constituent divide or multiply should have
12379 -- eliminated the explicit mention of universal fixed.
12381 pragma Assert
(Operand_Type
/= Universal_Fixed
);
12383 -- Check for special case of the conversion to universal real that
12384 -- occurs as a result of the use of a round attribute. In this case,
12385 -- the real type for the conversion is taken from the target type of
12386 -- the Round attribute and the result must be marked as rounded.
12388 if Target_Type
= Universal_Real
12389 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
12390 and then Attribute_Name
(Parent
(N
)) = Name_Round
12392 Set_Etype
(N
, Etype
(Parent
(N
)));
12393 Target_Type
:= Etype
(N
);
12394 Set_Rounded_Result
(N
);
12397 if Is_Fixed_Point_Type
(Target_Type
) then
12398 Expand_Convert_Fixed_To_Fixed
(N
);
12399 elsif Is_Integer_Type
(Target_Type
) then
12400 Expand_Convert_Fixed_To_Integer
(N
);
12402 pragma Assert
(Is_Floating_Point_Type
(Target_Type
));
12403 Expand_Convert_Fixed_To_Float
(N
);
12406 -- Case of conversions to a fixed-point type
12408 -- These conversions require special expansion and processing, found in
12409 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12410 -- since from a semantic point of view, these are simple integer
12411 -- conversions, which do not need further processing.
12413 elsif Is_Fixed_Point_Type
(Target_Type
)
12414 and then not Conversion_OK
(N
)
12416 if Is_Integer_Type
(Operand_Type
) then
12417 Expand_Convert_Integer_To_Fixed
(N
);
12419 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
12420 Expand_Convert_Float_To_Fixed
(N
);
12423 -- Case of array conversions
12425 -- Expansion of array conversions, add required length/range checks but
12426 -- only do this if there is no change of representation. For handling of
12427 -- this case, see Handle_Changed_Representation.
12429 elsif Is_Array_Type
(Target_Type
) then
12430 if Is_Constrained
(Target_Type
) then
12431 Apply_Length_Check
(Operand
, Target_Type
);
12433 -- If the object has an unconstrained array subtype with fixed
12434 -- lower bound, then sliding to that bound may be needed.
12436 if Is_Fixed_Lower_Bound_Array_Subtype
(Target_Type
) then
12437 Expand_Sliding_Conversion
(Operand
, Target_Type
);
12440 Apply_Range_Check
(Operand
, Target_Type
);
12443 Handle_Changed_Representation
;
12445 -- Case of conversions of discriminated types
12447 -- Add required discriminant checks if target is constrained. Again this
12448 -- change is skipped if we have a change of representation.
12450 elsif Has_Discriminants
(Target_Type
)
12451 and then Is_Constrained
(Target_Type
)
12453 Apply_Discriminant_Check
(Operand
, Target_Type
);
12454 Handle_Changed_Representation
;
12456 -- Case of all other record conversions. The only processing required
12457 -- is to check for a change of representation requiring the special
12458 -- assignment processing.
12460 elsif Is_Record_Type
(Target_Type
) then
12462 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12463 -- a derived Unchecked_Union type to an unconstrained type that is
12464 -- not Unchecked_Union if the operand lacks inferable discriminants.
12466 if Is_Derived_Type
(Operand_Type
)
12467 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
12468 and then not Is_Constrained
(Target_Type
)
12469 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
12470 and then not Has_Inferable_Discriminants
(Operand
)
12472 -- To prevent Gigi from generating illegal code, we generate a
12473 -- Program_Error node, but we give it the target type of the
12474 -- conversion (is this requirement documented somewhere ???)
12477 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
12478 Reason
=> PE_Unchecked_Union_Restriction
);
12481 Set_Etype
(PE
, Target_Type
);
12486 Handle_Changed_Representation
;
12489 -- Case of conversions of enumeration types
12491 elsif Is_Enumeration_Type
(Target_Type
) then
12493 -- Special processing is required if there is a change of
12494 -- representation (from enumeration representation clauses).
12496 if not Has_Compatible_Representation
(Target_Type
, Operand_Type
)
12497 and then not Conversion_OK
(N
)
12499 if Optimization_Level
> 0
12500 and then Is_Boolean_Type
(Target_Type
)
12502 -- Convert x(y) to (if y then x'(True) else x'(False)).
12503 -- Use literals, instead of indexing x'val, to enable
12504 -- further optimizations in the middle-end.
12507 Make_If_Expression
(Loc
,
12508 Expressions
=> New_List
(
12510 Convert_To
(Target_Type
,
12511 New_Occurrence_Of
(Standard_True
, Loc
)),
12512 Convert_To
(Target_Type
,
12513 New_Occurrence_Of
(Standard_False
, Loc
)))));
12516 -- Convert: x(y) to x'val (ytyp'pos (y))
12519 Make_Attribute_Reference
(Loc
,
12520 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
12521 Attribute_Name
=> Name_Val
,
12522 Expressions
=> New_List
(
12523 Make_Attribute_Reference
(Loc
,
12524 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
12525 Attribute_Name
=> Name_Pos
,
12526 Expressions
=> New_List
(Operand
)))));
12529 Analyze_And_Resolve
(N
, Target_Type
);
12533 -- At this stage, either the conversion node has been transformed into
12534 -- some other equivalent expression, or left as a conversion that can be
12535 -- handled by Gigi.
12537 -- The only remaining step is to generate a range check if we still have
12538 -- a type conversion at this stage and Do_Range_Check is set. Note that
12539 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12540 -- conversions here, because the float-to-integer case is entirely dealt
12541 -- with by Apply_Float_Conversion_Check.
12543 if Nkind
(N
) = N_Type_Conversion
12544 and then Do_Range_Check
(Expression
(N
))
12546 -- Float-to-float conversions
12548 if Is_Floating_Point_Type
(Target_Type
)
12549 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
12551 -- Reset overflow flag, since the range check will include
12552 -- dealing with possible overflow, and generate the check.
12554 Set_Do_Overflow_Check
(N
, False);
12556 Generate_Range_Check
12557 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
12559 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12560 -- conversions when Conversion_OK is set.
12562 elsif Is_Discrete_Type
(Target_Type
)
12563 and then (Is_Discrete_Type
(Etype
(Expression
(N
)))
12564 or else (Is_Fixed_Point_Type
(Etype
(Expression
(N
)))
12565 and then Conversion_OK
(N
)))
12567 -- If Address is either a source type or target type,
12568 -- suppress range check to avoid typing anomalies when
12569 -- it is a visible integer type.
12571 if Is_Descendant_Of_Address
(Etype
(Expression
(N
)))
12572 or else Is_Descendant_Of_Address
(Target_Type
)
12574 Set_Do_Range_Check
(Expression
(N
), False);
12576 Discrete_Range_Check
;
12579 -- Conversions to floating- or fixed-point when Conversion_OK is set
12581 elsif Is_Floating_Point_Type
(Target_Type
)
12582 or else (Is_Fixed_Point_Type
(Target_Type
)
12583 and then Conversion_OK
(N
))
12588 pragma Assert
(not Do_Range_Check
(Expression
(N
)));
12591 -- Here at end of processing
12594 -- Apply predicate check if required. Note that we can't just call
12595 -- Apply_Predicate_Check here, because the type looks right after
12596 -- the conversion and it would omit the check. The Comes_From_Source
12597 -- guard is necessary to prevent infinite recursions when we generate
12598 -- internal conversions for the purpose of checking predicates.
12600 -- A view conversion of a tagged object is an object and can appear
12601 -- in an assignment context, in which case no predicate check applies
12602 -- to the now-dead value.
12604 if Nkind
(Parent
(N
)) = N_Assignment_Statement
12605 and then N
= Name
(Parent
(N
))
12609 elsif Predicate_Enabled
(Target_Type
)
12610 and then Target_Type
/= Operand_Type
12611 and then Comes_From_Source
(N
)
12614 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
12617 -- Avoid infinite recursion on the subsequent expansion of the
12618 -- copy of the original type conversion. When needed, a range
12619 -- check has already been applied to the expression.
12621 Set_Comes_From_Source
(New_Expr
, False);
12623 Make_Predicate_Check
(Target_Type
, New_Expr
),
12624 Suppress
=> Range_Check
);
12627 end Expand_N_Type_Conversion
;
12629 -----------------------------------
12630 -- Expand_N_Unchecked_Expression --
12631 -----------------------------------
12633 -- Remove the unchecked expression node from the tree. Its job was simply
12634 -- to make sure that its constituent expression was handled with checks
12635 -- off, and now that is done, we can remove it from the tree, and indeed
12636 -- must, since Gigi does not expect to see these nodes.
12638 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
12639 Exp
: constant Node_Id
:= Expression
(N
);
12641 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
12643 end Expand_N_Unchecked_Expression
;
12645 ----------------------------------------
12646 -- Expand_N_Unchecked_Type_Conversion --
12647 ----------------------------------------
12649 -- If this cannot be handled by Gigi and we haven't already made a
12650 -- temporary for it, do it now.
12652 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
12653 Target_Type
: constant Entity_Id
:= Etype
(N
);
12654 Operand
: constant Node_Id
:= Expression
(N
);
12655 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12658 -- Nothing at all to do if conversion is to the identical type so remove
12659 -- the conversion completely, it is useless, except that it may carry
12660 -- an Assignment_OK indication which must be propagated to the operand.
12662 if Operand_Type
= Target_Type
then
12663 Expand_N_Unchecked_Expression
(N
);
12667 -- Generate an extra temporary for cases unsupported by the C backend
12669 if Modify_Tree_For_C
then
12671 Source
: constant Node_Id
:= Unqual_Conv
(Expression
(N
));
12672 Source_Typ
: Entity_Id
:= Get_Full_View
(Etype
(Source
));
12675 if Is_Packed_Array
(Source_Typ
) then
12676 Source_Typ
:= Packed_Array_Impl_Type
(Source_Typ
);
12679 if Nkind
(Source
) = N_Function_Call
12680 and then (Is_Composite_Type
(Etype
(Source
))
12681 or else Is_Composite_Type
(Target_Type
))
12683 Force_Evaluation
(Source
);
12688 -- Nothing to do if conversion is safe
12690 if Safe_Unchecked_Type_Conversion
(N
) then
12694 if Assignment_OK
(N
) then
12697 Force_Evaluation
(N
);
12699 end Expand_N_Unchecked_Type_Conversion
;
12701 ----------------------------
12702 -- Expand_Record_Equality --
12703 ----------------------------
12705 -- For non-variant records, Equality is expanded when needed into:
12707 -- and then Lhs.Discr1 = Rhs.Discr1
12709 -- and then Lhs.Discrn = Rhs.Discrn
12710 -- and then Lhs.Cmp1 = Rhs.Cmp1
12712 -- and then Lhs.Cmpn = Rhs.Cmpn
12714 -- The expression is folded by the back end for adjacent fields. This
12715 -- function is called for tagged record in only one occasion: for imple-
12716 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12717 -- otherwise the primitive "=" is used directly.
12719 function Expand_Record_Equality
12723 Rhs
: Node_Id
) return Node_Id
12725 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12730 First_Time
: Boolean := True;
12732 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
12733 -- Return the next discriminant or component to compare, starting with
12734 -- C, skipping inherited components.
12736 ------------------------
12737 -- Element_To_Compare --
12738 ------------------------
12740 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
12741 Comp
: Entity_Id
:= C
;
12744 while Present
(Comp
) loop
12745 -- Skip inherited components
12747 -- Note: for a tagged type, we always generate the "=" primitive
12748 -- for the base type (not on the first subtype), so the test for
12749 -- Comp /= Original_Record_Component (Comp) is True for inherited
12750 -- components only.
12752 if (Is_Tagged_Type
(Typ
)
12753 and then Comp
/= Original_Record_Component
(Comp
))
12757 or else Chars
(Comp
) = Name_uTag
12759 -- Skip interface elements (secondary tags???)
12761 or else Is_Interface
(Etype
(Comp
))
12763 Next_Component_Or_Discriminant
(Comp
);
12770 end Element_To_Compare
;
12772 -- Start of processing for Expand_Record_Equality
12775 -- Generates the following code: (assuming that Typ has one Discr and
12776 -- component C2 is also a record)
12778 -- Lhs.Discr1 = Rhs.Discr1
12779 -- and then Lhs.C1 = Rhs.C1
12780 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12782 -- and then Lhs.Cmpn = Rhs.Cmpn
12784 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
12785 C
:= Element_To_Compare
(First_Component_Or_Discriminant
(Typ
));
12786 while Present
(C
) loop
12797 New_Lhs
:= New_Copy_Tree
(Lhs
);
12798 New_Rhs
:= New_Copy_Tree
(Rhs
);
12802 Expand_Composite_Equality
12803 (Outer_Type
=> Typ
, Nod
=> Nod
, Comp_Type
=> Etype
(C
),
12805 Make_Selected_Component
(Loc
,
12807 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
12809 Make_Selected_Component
(Loc
,
12811 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)));
12813 -- If some (sub)component is an unchecked_union, the whole
12814 -- operation will raise program error.
12816 if Nkind
(Check
) = N_Raise_Program_Error
then
12818 Set_Etype
(Result
, Standard_Boolean
);
12824 -- Generate logical "and" for CodePeer to simplify the
12825 -- generated code and analysis.
12827 elsif CodePeer_Mode
then
12830 Left_Opnd
=> Result
,
12831 Right_Opnd
=> Check
);
12835 Make_And_Then
(Loc
,
12836 Left_Opnd
=> Result
,
12837 Right_Opnd
=> Check
);
12842 First_Time
:= False;
12843 C
:= Element_To_Compare
(Next_Component_Or_Discriminant
(C
));
12847 end Expand_Record_Equality
;
12849 ---------------------------
12850 -- Expand_Set_Membership --
12851 ---------------------------
12853 procedure Expand_Set_Membership
(N
: Node_Id
) is
12854 Lop
: constant Node_Id
:= Left_Opnd
(N
);
12856 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
12857 -- If the alternative is a subtype mark, create a simple membership
12858 -- test. Otherwise create an equality test for it.
12864 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
12866 L
: constant Node_Id
:= New_Copy_Tree
(Lop
);
12867 R
: constant Node_Id
:= Relocate_Node
(Alt
);
12870 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
12871 or else Nkind
(Alt
) = N_Range
12873 Cond
:= Make_In
(Sloc
(Alt
), Left_Opnd
=> L
, Right_Opnd
=> R
);
12876 Cond
:= Make_Op_Eq
(Sloc
(Alt
), Left_Opnd
=> L
, Right_Opnd
=> R
);
12877 Resolve_Membership_Equality
(Cond
, Etype
(Alt
));
12886 Res
: Node_Id
:= Empty
;
12888 -- Start of processing for Expand_Set_Membership
12891 Remove_Side_Effects
(Lop
);
12893 -- We use left associativity as in the equivalent boolean case. This
12894 -- kind of canonicalization helps the optimizer of the code generator.
12896 Alt
:= First
(Alternatives
(N
));
12897 while Present
(Alt
) loop
12898 Evolve_Or_Else
(Res
, Make_Cond
(Alt
));
12903 Analyze_And_Resolve
(N
, Standard_Boolean
);
12904 end Expand_Set_Membership
;
12906 -----------------------------------
12907 -- Expand_Short_Circuit_Operator --
12908 -----------------------------------
12910 -- Deal with special expansion if actions are present for the right operand
12911 -- and deal with optimizing case of arguments being True or False. We also
12912 -- deal with the special case of non-standard boolean values.
12914 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
12915 Loc
: constant Source_Ptr
:= Sloc
(N
);
12916 Typ
: constant Entity_Id
:= Etype
(N
);
12917 Left
: constant Node_Id
:= Left_Opnd
(N
);
12918 Right
: constant Node_Id
:= Right_Opnd
(N
);
12919 LocR
: constant Source_Ptr
:= Sloc
(Right
);
12922 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
12923 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
12924 -- If Left = Shortcut_Value then Right need not be evaluated
12926 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
12927 -- For Opnd a boolean expression, return a Boolean expression equivalent
12928 -- to Opnd /= Shortcut_Value.
12930 function Useful
(Actions
: List_Id
) return Boolean;
12931 -- Return True if Actions is not empty and contains useful nodes to
12934 --------------------
12935 -- Make_Test_Expr --
12936 --------------------
12938 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
12940 if Shortcut_Value
then
12941 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
12945 end Make_Test_Expr
;
12951 function Useful
(Actions
: List_Id
) return Boolean is
12954 if Present
(Actions
) then
12955 L
:= First
(Actions
);
12957 -- For now "useful" means not N_Variable_Reference_Marker.
12958 -- Consider stripping other nodes in the future.
12960 while Present
(L
) loop
12961 if Nkind
(L
) /= N_Variable_Reference_Marker
then
12974 Op_Var
: Entity_Id
;
12975 -- Entity for a temporary variable holding the value of the operator,
12976 -- used for expansion in the case where actions are present.
12978 -- Start of processing for Expand_Short_Circuit_Operator
12981 -- Deal with non-standard booleans
12983 if Is_Boolean_Type
(Typ
) then
12984 Adjust_Condition
(Left
);
12985 Adjust_Condition
(Right
);
12986 Set_Etype
(N
, Standard_Boolean
);
12989 -- Check for cases where left argument is known to be True or False
12991 if Compile_Time_Known_Value
(Left
) then
12993 -- Mark SCO for left condition as compile time known
12995 if Generate_SCO
and then Comes_From_Source
(Left
) then
12996 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
12999 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
13000 -- Any actions associated with Right will be executed unconditionally
13001 -- and can thus be inserted into the tree unconditionally.
13003 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
13004 if Present
(Actions
(N
)) then
13005 Insert_Actions
(N
, Actions
(N
));
13008 Rewrite
(N
, Right
);
13010 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
13011 -- In this case we can forget the actions associated with Right,
13012 -- since they will never be executed.
13015 Kill_Dead_Code
(Right
);
13016 Kill_Dead_Code
(Actions
(N
));
13017 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
13020 Adjust_Result_Type
(N
, Typ
);
13024 -- If Actions are present for the right operand, we have to do some
13025 -- special processing. We can't just let these actions filter back into
13026 -- code preceding the short circuit (which is what would have happened
13027 -- if we had not trapped them in the short-circuit form), since they
13028 -- must only be executed if the right operand of the short circuit is
13029 -- executed and not otherwise.
13031 if Useful
(Actions
(N
)) then
13032 Actlist
:= Actions
(N
);
13034 -- The old approach is to expand:
13036 -- left AND THEN right
13040 -- C : Boolean := False;
13048 -- and finally rewrite the operator into a reference to C. Similarly
13049 -- for left OR ELSE right, with negated values. Note that this
13050 -- rewrite causes some difficulties for coverage analysis because
13051 -- of the introduction of the new variable C, which obscures the
13052 -- structure of the test.
13054 -- We use this "old approach" if Minimize_Expression_With_Actions
13057 if Minimize_Expression_With_Actions
then
13058 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
13061 Make_Object_Declaration
(Loc
,
13062 Defining_Identifier
=> Op_Var
,
13063 Object_Definition
=>
13064 New_Occurrence_Of
(Standard_Boolean
, Loc
),
13066 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
13068 Append_To
(Actlist
,
13069 Make_Implicit_If_Statement
(Right
,
13070 Condition
=> Make_Test_Expr
(Right
),
13071 Then_Statements
=> New_List
(
13072 Make_Assignment_Statement
(LocR
,
13073 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
13076 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
13079 Make_Implicit_If_Statement
(Left
,
13080 Condition
=> Make_Test_Expr
(Left
),
13081 Then_Statements
=> Actlist
));
13083 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
13084 Analyze_And_Resolve
(N
, Standard_Boolean
);
13086 -- The new approach (the default) is to use an
13087 -- Expression_With_Actions node for the right operand of the
13088 -- short-circuit form. Note that this solves the traceability
13089 -- problems for coverage analysis.
13093 Make_Expression_With_Actions
(LocR
,
13094 Expression
=> Relocate_Node
(Right
),
13095 Actions
=> Actlist
));
13097 Set_Actions
(N
, No_List
);
13098 Analyze_And_Resolve
(Right
, Standard_Boolean
);
13101 Adjust_Result_Type
(N
, Typ
);
13105 -- No actions present, check for cases of right argument True/False
13107 if Compile_Time_Known_Value
(Right
) then
13109 -- Mark SCO for left condition as compile time known
13111 if Generate_SCO
and then Comes_From_Source
(Right
) then
13112 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
13115 -- Change (Left and then True), (Left or else False) to Left. Note
13116 -- that we know there are no actions associated with the right
13117 -- operand, since we just checked for this case above.
13119 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
13122 -- Change (Left and then False), (Left or else True) to Right,
13123 -- making sure to preserve any side effects associated with the Left
13127 Remove_Side_Effects
(Left
);
13128 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
13132 Adjust_Result_Type
(N
, Typ
);
13133 end Expand_Short_Circuit_Operator
;
13135 -------------------------------------
13136 -- Expand_Unchecked_Union_Equality --
13137 -------------------------------------
13139 procedure Expand_Unchecked_Union_Equality
(N
: Node_Id
) is
13140 Loc
: constant Source_Ptr
:= Sloc
(N
);
13141 Eq
: constant Entity_Id
:= Entity
(Name
(N
));
13142 Lhs
: constant Node_Id
:= First_Actual
(N
);
13143 Rhs
: constant Node_Id
:= Next_Actual
(Lhs
);
13145 function Get_Discr_Values
(Op
: Node_Id
; Lhs
: Boolean) return Elist_Id
;
13146 -- Return the list of inferred discriminant values for Op
13148 ----------------------
13149 -- Get_Discr_Values --
13150 ----------------------
13152 function Get_Discr_Values
(Op
: Node_Id
; Lhs
: Boolean) return Elist_Id
13154 Typ
: constant Entity_Id
:= Etype
(Op
);
13155 Values
: constant Elist_Id
:= New_Elmt_List
;
13157 function Get_Extra_Formal
(Nam
: Name_Id
) return Entity_Id
;
13158 -- Return the extra formal Nam from the current scope, which must be
13159 -- an equality function for an unchecked union type.
13161 ----------------------
13162 -- Get_Extra_Formal --
13163 ----------------------
13165 function Get_Extra_Formal
(Nam
: Name_Id
) return Entity_Id
is
13166 Func
: constant Entity_Id
:= Current_Scope
;
13168 Formal
: Entity_Id
;
13171 pragma Assert
(Ekind
(Func
) = E_Function
);
13173 Formal
:= Extra_Formals
(Func
);
13174 while Present
(Formal
) loop
13175 if Chars
(Formal
) = Nam
then
13179 Formal
:= Extra_Formal
(Formal
);
13182 -- An extra formal of the proper name must be found
13184 raise Program_Error
;
13185 end Get_Extra_Formal
;
13191 -- Start of processing for Get_Discr_Values
13194 -- Per-object constrained selected components require special
13195 -- attention. If the enclosing scope of the component is an
13196 -- Unchecked_Union, we cannot reference its discriminants
13197 -- directly. This is why we use the extra parameters of the
13198 -- equality function of the enclosing Unchecked_Union.
13200 -- type UU_Type (Discr : Integer := 0) is
13203 -- pragma Unchecked_Union (UU_Type);
13205 -- 1. Unchecked_Union enclosing record:
13207 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
13209 -- Comp : UU_Type (Discr);
13211 -- end Enclosing_UU_Type;
13212 -- pragma Unchecked_Union (Enclosing_UU_Type);
13214 -- Obj1 : Enclosing_UU_Type;
13215 -- Obj2 : Enclosing_UU_Type (1);
13217 -- [. . .] Obj1 = Obj2 [. . .]
13221 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
13223 -- A and B are the formal parameters of the equality function
13224 -- of Enclosing_UU_Type. The function always has two extra
13225 -- formals to capture the inferred discriminant values for
13226 -- each discriminant of the type.
13228 -- 2. Non-Unchecked_Union enclosing record:
13231 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
13234 -- Comp : UU_Type (Discr);
13236 -- end Enclosing_Non_UU_Type;
13238 -- Obj1 : Enclosing_Non_UU_Type;
13239 -- Obj2 : Enclosing_Non_UU_Type (1);
13241 -- ... Obj1 = Obj2 ...
13245 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
13246 -- obj1.discr, obj2.discr)) then
13248 -- In this case we can directly reference the discriminants of
13249 -- the enclosing record.
13251 if Nkind
(Op
) = N_Selected_Component
13252 and then Has_Per_Object_Constraint
(Entity
(Selector_Name
(Op
)))
13254 -- If enclosing record is an Unchecked_Union, use formals
13255 -- corresponding to each discriminant. The name of the
13256 -- formal is that of the discriminant, with added suffix,
13257 -- see Exp_Ch3.Build_Variant_Record_Equality for details.
13259 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Op
)))) then
13262 (Scope
(Entity
(Selector_Name
(Op
))));
13263 while Present
(Discr
) loop
13268 (Chars
(Discr
), (if Lhs
then 'A' else 'B'))), Loc
),
13270 Next_Discriminant
(Discr
);
13273 -- If enclosing record is of a non-Unchecked_Union type, it
13274 -- is possible to reference its discriminants directly.
13277 Discr
:= First_Discriminant
(Typ
);
13278 while Present
(Discr
) loop
13280 (Make_Selected_Component
(Loc
,
13281 Prefix
=> Prefix
(Op
),
13284 (Get_Discriminant_Value
(Discr
,
13286 Stored_Constraint
(Typ
)))),
13288 Next_Discriminant
(Discr
);
13292 -- Otherwise operand is on object with a constrained type.
13293 -- Infer the discriminant values from the constraint.
13296 Discr
:= First_Discriminant
(Typ
);
13297 while Present
(Discr
) loop
13300 (Get_Discriminant_Value
(Discr
,
13302 Stored_Constraint
(Typ
))),
13304 Next_Discriminant
(Discr
);
13309 end Get_Discr_Values
;
13311 -- Start of processing for Expand_Unchecked_Union_Equality
13314 -- Guard against repeated invocation on the same node
13316 if Present
(Next_Actual
(Rhs
)) then
13320 -- If we can infer the discriminants of the operands, make a call to Eq
13322 if Has_Inferable_Discriminants
(Lhs
)
13324 Has_Inferable_Discriminants
(Rhs
)
13327 Lhs_Values
: constant Elist_Id
:= Get_Discr_Values
(Lhs
, True);
13328 Rhs_Values
: constant Elist_Id
:= Get_Discr_Values
(Rhs
, False);
13330 Formal
: Entity_Id
;
13335 -- Add the inferred discriminant values as extra actuals
13337 Formal
:= Extra_Formals
(Eq
);
13338 L_Elmt
:= First_Elmt
(Lhs_Values
);
13339 R_Elmt
:= First_Elmt
(Rhs_Values
);
13341 while Present
(L_Elmt
) loop
13342 Analyze_And_Resolve
(Node
(L_Elmt
), Etype
(Formal
));
13343 Add_Extra_Actual_To_Call
(N
, Formal
, Node
(L_Elmt
));
13345 Formal
:= Extra_Formal
(Formal
);
13347 Analyze_And_Resolve
(Node
(R_Elmt
), Etype
(Formal
));
13348 Add_Extra_Actual_To_Call
(N
, Formal
, Node
(R_Elmt
));
13350 Formal
:= Extra_Formal
(Formal
);
13351 Next_Elmt
(L_Elmt
);
13352 Next_Elmt
(R_Elmt
);
13356 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
13357 -- the predefined equality operator for an Unchecked_Union type
13358 -- if either of the operands lack inferable discriminants.
13362 Make_Raise_Program_Error
(Loc
,
13363 Reason
=> PE_Unchecked_Union_Restriction
));
13365 -- Give a warning on source equalities only, otherwise the message
13366 -- may appear out of place due to internal use. It is unconditional
13367 -- because it is required by the language.
13369 if Comes_From_Source
(Original_Node
(N
)) then
13371 ("Unchecked_Union discriminants cannot be determined??", N
);
13373 ("\Program_Error will be raised for equality operation??", N
);
13376 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
13378 end Expand_Unchecked_Union_Equality
;
13380 ------------------------------------
13381 -- Fixup_Universal_Fixed_Operation --
13382 -------------------------------------
13384 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
13385 Conv
: constant Node_Id
:= Parent
(N
);
13388 -- We must have a type conversion immediately above us
13390 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
13392 -- Normally the type conversion gives our target type. The exception
13393 -- occurs in the case of the Round attribute, where the conversion
13394 -- will be to universal real, and our real type comes from the Round
13395 -- attribute (as well as an indication that we must round the result)
13397 if Etype
(Conv
) = Universal_Real
13398 and then Nkind
(Parent
(Conv
)) = N_Attribute_Reference
13399 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
13401 Set_Etype
(N
, Base_Type
(Etype
(Parent
(Conv
))));
13402 Set_Rounded_Result
(N
);
13404 -- Normal case where type comes from conversion above us
13407 Set_Etype
(N
, Base_Type
(Etype
(Conv
)));
13409 end Fixup_Universal_Fixed_Operation
;
13411 ----------------------------
13412 -- Get_First_Index_Bounds --
13413 ----------------------------
13415 procedure Get_First_Index_Bounds
(T
: Entity_Id
; Lo
, Hi
: out Uint
) is
13419 pragma Assert
(Is_Array_Type
(T
));
13421 -- This follows Sem_Eval.Compile_Time_Known_Bounds
13423 if Ekind
(T
) = E_String_Literal_Subtype
then
13424 Lo
:= Expr_Value
(String_Literal_Low_Bound
(T
));
13425 Hi
:= Lo
+ String_Literal_Length
(T
) - 1;
13428 Typ
:= Underlying_Type
(Etype
(First_Index
(T
)));
13430 Lo
:= Expr_Value
(Type_Low_Bound
(Typ
));
13431 Hi
:= Expr_Value
(Type_High_Bound
(Typ
));
13433 end Get_First_Index_Bounds
;
13435 ------------------------
13436 -- Get_Size_For_Range --
13437 ------------------------
13439 function Get_Size_For_Range
(Lo
, Hi
: Uint
) return Uint
is
13441 function Is_OK_For_Range
(Siz
: Uint
) return Boolean;
13442 -- Return True if a signed integer with given size can cover Lo .. Hi
13444 --------------------------
13445 -- Is_OK_For_Range --
13446 --------------------------
13448 function Is_OK_For_Range
(Siz
: Uint
) return Boolean is
13449 B
: constant Uint
:= Uint_2
** (Siz
- 1);
13452 -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
13454 return Lo
>= -B
and then Hi
>= -B
and then Lo
< B
and then Hi
< B
;
13455 end Is_OK_For_Range
;
13458 -- This is (almost always) the size of Integer
13460 if Is_OK_For_Range
(Uint_32
) then
13465 elsif Is_OK_For_Range
(Uint_63
) then
13468 -- This is (almost always) the size of Long_Long_Integer
13470 elsif Is_OK_For_Range
(Uint_64
) then
13475 elsif Is_OK_For_Range
(Uint_127
) then
13481 end Get_Size_For_Range
;
13483 -------------------------------
13484 -- Insert_Dereference_Action --
13485 -------------------------------
13487 procedure Insert_Dereference_Action
(N
: Node_Id
) is
13488 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
13489 -- Return true if type of P is derived from Checked_Pool;
13491 -----------------------------
13492 -- Is_Checked_Storage_Pool --
13493 -----------------------------
13495 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
13504 while T
/= Etype
(T
) loop
13505 if Is_RTE
(T
, RE_Checked_Pool
) then
13513 end Is_Checked_Storage_Pool
;
13517 Context
: constant Node_Id
:= Parent
(N
);
13518 Ptr_Typ
: constant Entity_Id
:= Etype
(N
);
13519 Desig_Typ
: constant Entity_Id
:=
13520 Available_View
(Designated_Type
(Ptr_Typ
));
13521 Loc
: constant Source_Ptr
:= Sloc
(N
);
13522 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
13528 Size_Bits
: Node_Id
;
13531 -- Start of processing for Insert_Dereference_Action
13534 pragma Assert
(Nkind
(Context
) = N_Explicit_Dereference
);
13536 -- Do not re-expand a dereference which has already been processed by
13539 if Has_Dereference_Action
(Context
) then
13542 -- Do not perform this type of expansion for internally-generated
13545 elsif not Comes_From_Source
(Original_Node
(Context
)) then
13548 -- A dereference action is only applicable to objects which have been
13549 -- allocated on a checked pool.
13551 elsif not Is_Checked_Storage_Pool
(Pool
) then
13555 -- Extract the address of the dereferenced object. Generate:
13557 -- Addr : System.Address := <N>'Pool_Address;
13559 Addr
:= Make_Temporary
(Loc
, 'P');
13562 Make_Object_Declaration
(Loc
,
13563 Defining_Identifier
=> Addr
,
13564 Object_Definition
=>
13565 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
13567 Make_Attribute_Reference
(Loc
,
13568 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
13569 Attribute_Name
=> Name_Pool_Address
)));
13571 -- Calculate the size of the dereferenced object. Generate:
13573 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13576 Make_Explicit_Dereference
(Loc
,
13577 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13578 Set_Has_Dereference_Action
(Deref
);
13581 Make_Attribute_Reference
(Loc
,
13583 Attribute_Name
=> Name_Size
);
13585 -- Special case of an unconstrained array: need to add descriptor size
13587 if Is_Array_Type
(Desig_Typ
)
13588 and then not Is_Constrained
(First_Subtype
(Desig_Typ
))
13593 Make_Attribute_Reference
(Loc
,
13595 New_Occurrence_Of
(First_Subtype
(Desig_Typ
), Loc
),
13596 Attribute_Name
=> Name_Descriptor_Size
),
13597 Right_Opnd
=> Size_Bits
);
13600 Size
:= Make_Temporary
(Loc
, 'S');
13602 Make_Object_Declaration
(Loc
,
13603 Defining_Identifier
=> Size
,
13604 Object_Definition
=>
13605 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13607 Make_Op_Divide
(Loc
,
13608 Left_Opnd
=> Size_Bits
,
13609 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
13611 -- Calculate the alignment of the dereferenced object. Generate:
13612 -- Alig : constant Storage_Count := <N>.all'Alignment;
13615 Make_Explicit_Dereference
(Loc
,
13616 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13617 Set_Has_Dereference_Action
(Deref
);
13619 Alig
:= Make_Temporary
(Loc
, 'A');
13621 Make_Object_Declaration
(Loc
,
13622 Defining_Identifier
=> Alig
,
13623 Object_Definition
=>
13624 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13626 Make_Attribute_Reference
(Loc
,
13628 Attribute_Name
=> Name_Alignment
)));
13630 -- A dereference of a controlled object requires special processing. The
13631 -- finalization machinery requests additional space from the underlying
13632 -- pool to allocate and hide two pointers. As a result, a checked pool
13633 -- may mark the wrong memory as valid. Since checked pools do not have
13634 -- knowledge of hidden pointers, we have to bring the two pointers back
13635 -- in view in order to restore the original state of the object.
13637 -- The address manipulation is not performed for access types that are
13638 -- subject to pragma No_Heap_Finalization because the two pointers do
13639 -- not exist in the first place.
13641 if No_Heap_Finalization
(Ptr_Typ
) then
13644 elsif Needs_Finalization
(Desig_Typ
) then
13646 -- Adjust the address and size of the dereferenced object. Generate:
13647 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13650 Make_Procedure_Call_Statement
(Loc
,
13652 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
13653 Parameter_Associations
=> New_List
(
13654 New_Occurrence_Of
(Addr
, Loc
),
13655 New_Occurrence_Of
(Size
, Loc
),
13656 New_Occurrence_Of
(Alig
, Loc
)));
13658 -- Class-wide types complicate things because we cannot determine
13659 -- statically whether the actual object is truly controlled. We must
13660 -- generate a runtime check to detect this property. Generate:
13662 -- if Needs_Finalization (<N>.all'Tag) then
13666 if Is_Class_Wide_Type
(Desig_Typ
) then
13668 Make_Explicit_Dereference
(Loc
,
13669 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13670 Set_Has_Dereference_Action
(Deref
);
13673 Make_Implicit_If_Statement
(N
,
13675 Make_Function_Call
(Loc
,
13677 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
13678 Parameter_Associations
=> New_List
(
13679 Make_Attribute_Reference
(Loc
,
13681 Attribute_Name
=> Name_Tag
))),
13682 Then_Statements
=> New_List
(Stmt
));
13685 Insert_Action
(N
, Stmt
);
13689 -- Dereference (Pool, Addr, Size, Alig);
13692 Make_Procedure_Call_Statement
(Loc
,
13695 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
13696 Parameter_Associations
=> New_List
(
13697 New_Occurrence_Of
(Pool
, Loc
),
13698 New_Occurrence_Of
(Addr
, Loc
),
13699 New_Occurrence_Of
(Size
, Loc
),
13700 New_Occurrence_Of
(Alig
, Loc
))));
13702 -- Mark the explicit dereference as processed to avoid potential
13703 -- infinite expansion.
13705 Set_Has_Dereference_Action
(Context
);
13708 when RE_Not_Available
=>
13710 end Insert_Dereference_Action
;
13712 --------------------------------
13713 -- Integer_Promotion_Possible --
13714 --------------------------------
13716 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
13717 Operand
: constant Node_Id
:= Expression
(N
);
13718 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
13719 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
13722 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
13726 -- We only do the transformation for source constructs. We assume
13727 -- that the expander knows what it is doing when it generates code.
13729 Comes_From_Source
(N
)
13731 -- If the operand type is Short_Integer or Short_Short_Integer,
13732 -- then we will promote to Integer, which is available on all
13733 -- targets, and is sufficient to ensure no intermediate overflow.
13734 -- Furthermore it is likely to be as efficient or more efficient
13735 -- than using the smaller type for the computation so we do this
13736 -- unconditionally.
13739 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
13741 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
13743 -- Test for interesting operation, which includes addition,
13744 -- division, exponentiation, multiplication, subtraction, absolute
13745 -- value and unary negation. Unary "+" is omitted since it is a
13746 -- no-op and thus can't overflow.
13748 and then Nkind
(Operand
) in
13749 N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
13750 N_Op_Minus | N_Op_Multiply | N_Op_Subtract
;
13751 end Integer_Promotion_Possible
;
13753 ------------------------------
13754 -- Make_Array_Comparison_Op --
13755 ------------------------------
13757 -- This is a hand-coded expansion of the following generic function:
13760 -- type elem is (<>);
13761 -- type index is (<>);
13762 -- type a is array (index range <>) of elem;
13764 -- function Gnnn (X : a; Y: a) return boolean is
13765 -- J : index := Y'first;
13768 -- if X'length = 0 then
13771 -- elsif Y'length = 0 then
13775 -- for I in X'range loop
13776 -- if X (I) = Y (J) then
13777 -- if J = Y'last then
13780 -- J := index'succ (J);
13784 -- return X (I) > Y (J);
13788 -- return X'length > Y'length;
13792 -- Note that since we are essentially doing this expansion by hand, we
13793 -- do not need to generate an actual or formal generic part, just the
13794 -- instantiated function itself.
13796 function Make_Array_Comparison_Op
13798 Nod
: Node_Id
) return Node_Id
13800 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
13802 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
13803 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
13804 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
13805 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13807 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
13809 Loop_Statement
: Node_Id
;
13810 Loop_Body
: Node_Id
;
13812 Inner_If
: Node_Id
;
13813 Final_Expr
: Node_Id
;
13814 Func_Body
: Node_Id
;
13815 Func_Name
: Entity_Id
;
13821 -- if J = Y'last then
13824 -- J := index'succ (J);
13828 Make_Implicit_If_Statement
(Nod
,
13831 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
13833 Make_Attribute_Reference
(Loc
,
13834 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13835 Attribute_Name
=> Name_Last
)),
13837 Then_Statements
=> New_List
(
13838 Make_Exit_Statement
(Loc
)),
13842 Make_Assignment_Statement
(Loc
,
13843 Name
=> New_Occurrence_Of
(J
, Loc
),
13845 Make_Attribute_Reference
(Loc
,
13846 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
13847 Attribute_Name
=> Name_Succ
,
13848 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
13850 -- if X (I) = Y (J) then
13853 -- return X (I) > Y (J);
13857 Make_Implicit_If_Statement
(Nod
,
13861 Make_Indexed_Component
(Loc
,
13862 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13863 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13866 Make_Indexed_Component
(Loc
,
13867 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13868 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
13870 Then_Statements
=> New_List
(Inner_If
),
13872 Else_Statements
=> New_List
(
13873 Make_Simple_Return_Statement
(Loc
,
13877 Make_Indexed_Component
(Loc
,
13878 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13879 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
13882 Make_Indexed_Component
(Loc
,
13883 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13884 Expressions
=> New_List
(
13885 New_Occurrence_Of
(J
, Loc
)))))));
13887 -- for I in X'range loop
13892 Make_Implicit_Loop_Statement
(Nod
,
13893 Identifier
=> Empty
,
13895 Iteration_Scheme
=>
13896 Make_Iteration_Scheme
(Loc
,
13897 Loop_Parameter_Specification
=>
13898 Make_Loop_Parameter_Specification
(Loc
,
13899 Defining_Identifier
=> I
,
13900 Discrete_Subtype_Definition
=>
13901 Make_Attribute_Reference
(Loc
,
13902 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13903 Attribute_Name
=> Name_Range
))),
13905 Statements
=> New_List
(Loop_Body
));
13907 -- if X'length = 0 then
13909 -- elsif Y'length = 0 then
13912 -- for ... loop ... end loop;
13913 -- return X'length > Y'length;
13917 Make_Attribute_Reference
(Loc
,
13918 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13919 Attribute_Name
=> Name_Length
);
13922 Make_Attribute_Reference
(Loc
,
13923 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13924 Attribute_Name
=> Name_Length
);
13928 Left_Opnd
=> Length1
,
13929 Right_Opnd
=> Length2
);
13932 Make_Implicit_If_Statement
(Nod
,
13936 Make_Attribute_Reference
(Loc
,
13937 Prefix
=> New_Occurrence_Of
(X
, Loc
),
13938 Attribute_Name
=> Name_Length
),
13940 Make_Integer_Literal
(Loc
, 0)),
13944 Make_Simple_Return_Statement
(Loc
,
13945 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
13947 Elsif_Parts
=> New_List
(
13948 Make_Elsif_Part
(Loc
,
13952 Make_Attribute_Reference
(Loc
,
13953 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
13954 Attribute_Name
=> Name_Length
),
13956 Make_Integer_Literal
(Loc
, 0)),
13960 Make_Simple_Return_Statement
(Loc
,
13961 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
13963 Else_Statements
=> New_List
(
13965 Make_Simple_Return_Statement
(Loc
,
13966 Expression
=> Final_Expr
)));
13970 Formals
:= New_List
(
13971 Make_Parameter_Specification
(Loc
,
13972 Defining_Identifier
=> X
,
13973 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
13975 Make_Parameter_Specification
(Loc
,
13976 Defining_Identifier
=> Y
,
13977 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
13979 -- function Gnnn (...) return boolean is
13980 -- J : index := Y'first;
13985 Func_Name
:= Make_Temporary
(Loc
, 'G');
13988 Make_Subprogram_Body
(Loc
,
13990 Make_Function_Specification
(Loc
,
13991 Defining_Unit_Name
=> Func_Name
,
13992 Parameter_Specifications
=> Formals
,
13993 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
13995 Declarations
=> New_List
(
13996 Make_Object_Declaration
(Loc
,
13997 Defining_Identifier
=> J
,
13998 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
14000 Make_Attribute_Reference
(Loc
,
14001 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
14002 Attribute_Name
=> Name_First
))),
14004 Handled_Statement_Sequence
=>
14005 Make_Handled_Sequence_Of_Statements
(Loc
,
14006 Statements
=> New_List
(If_Stat
)));
14009 end Make_Array_Comparison_Op
;
14011 ---------------------------
14012 -- Make_Boolean_Array_Op --
14013 ---------------------------
14015 -- For logical operations on boolean arrays, expand in line the following,
14016 -- replacing 'and' with 'or' or 'xor' where needed:
14018 -- function Annn (A : typ; B: typ) return typ is
14021 -- for J in A'range loop
14022 -- C (J) := A (J) op B (J);
14027 -- or in the case of Transform_Function_Array:
14029 -- procedure Annn (A : typ; B: typ; RESULT: out typ) is
14031 -- for J in A'range loop
14032 -- RESULT (J) := A (J) op B (J);
14036 -- Here typ is the boolean array type
14038 function Make_Boolean_Array_Op
14040 N
: Node_Id
) return Node_Id
14042 Loc
: constant Source_Ptr
:= Sloc
(N
);
14044 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
14045 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
14046 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
14056 Func_Name
: Entity_Id
;
14057 Func_Body
: Node_Id
;
14058 Loop_Statement
: Node_Id
;
14061 if Transform_Function_Array
then
14062 C
:= Make_Defining_Identifier
(Loc
, Name_UP_RESULT
);
14064 C
:= Make_Defining_Identifier
(Loc
, Name_uC
);
14068 Make_Indexed_Component
(Loc
,
14069 Prefix
=> New_Occurrence_Of
(A
, Loc
),
14070 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14073 Make_Indexed_Component
(Loc
,
14074 Prefix
=> New_Occurrence_Of
(B
, Loc
),
14075 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14078 Make_Indexed_Component
(Loc
,
14079 Prefix
=> New_Occurrence_Of
(C
, Loc
),
14080 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14082 if Nkind
(N
) = N_Op_And
then
14086 Right_Opnd
=> B_J
);
14088 elsif Nkind
(N
) = N_Op_Or
then
14092 Right_Opnd
=> B_J
);
14098 Right_Opnd
=> B_J
);
14102 Make_Implicit_Loop_Statement
(N
,
14103 Identifier
=> Empty
,
14105 Iteration_Scheme
=>
14106 Make_Iteration_Scheme
(Loc
,
14107 Loop_Parameter_Specification
=>
14108 Make_Loop_Parameter_Specification
(Loc
,
14109 Defining_Identifier
=> J
,
14110 Discrete_Subtype_Definition
=>
14111 Make_Attribute_Reference
(Loc
,
14112 Prefix
=> New_Occurrence_Of
(A
, Loc
),
14113 Attribute_Name
=> Name_Range
))),
14115 Statements
=> New_List
(
14116 Make_Assignment_Statement
(Loc
,
14118 Expression
=> Op
)));
14120 Formals
:= New_List
(
14121 Make_Parameter_Specification
(Loc
,
14122 Defining_Identifier
=> A
,
14123 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
14125 Make_Parameter_Specification
(Loc
,
14126 Defining_Identifier
=> B
,
14127 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
14129 if Transform_Function_Array
then
14130 Append_To
(Formals
,
14131 Make_Parameter_Specification
(Loc
,
14132 Defining_Identifier
=> C
,
14133 Out_Present
=> True,
14134 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
14137 Func_Name
:= Make_Temporary
(Loc
, 'A');
14138 Set_Is_Inlined
(Func_Name
);
14140 if Transform_Function_Array
then
14142 Make_Subprogram_Body
(Loc
,
14144 Make_Procedure_Specification
(Loc
,
14145 Defining_Unit_Name
=> Func_Name
,
14146 Parameter_Specifications
=> Formals
),
14148 Declarations
=> New_List
,
14150 Handled_Statement_Sequence
=>
14151 Make_Handled_Sequence_Of_Statements
(Loc
,
14152 Statements
=> New_List
(Loop_Statement
)));
14156 Make_Subprogram_Body
(Loc
,
14158 Make_Function_Specification
(Loc
,
14159 Defining_Unit_Name
=> Func_Name
,
14160 Parameter_Specifications
=> Formals
,
14161 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
14163 Declarations
=> New_List
(
14164 Make_Object_Declaration
(Loc
,
14165 Defining_Identifier
=> C
,
14166 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
14168 Handled_Statement_Sequence
=>
14169 Make_Handled_Sequence_Of_Statements
(Loc
,
14170 Statements
=> New_List
(
14172 Make_Simple_Return_Statement
(Loc
,
14173 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
14177 end Make_Boolean_Array_Op
;
14179 -----------------------------------------
14180 -- Minimized_Eliminated_Overflow_Check --
14181 -----------------------------------------
14183 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
14185 -- The MINIMIZED mode operates in Long_Long_Integer so we cannot use it
14186 -- if the type of the expression is already larger.
14189 Is_Signed_Integer_Type
(Etype
(N
))
14190 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
14191 and then not (Overflow_Check_Mode
= Minimized
14193 Esize
(Etype
(N
)) > Standard_Long_Long_Integer_Size
);
14194 end Minimized_Eliminated_Overflow_Check
;
14196 ----------------------------
14197 -- Narrow_Large_Operation --
14198 ----------------------------
14200 procedure Narrow_Large_Operation
(N
: Node_Id
) is
14201 Kind
: constant Node_Kind
:= Nkind
(N
);
14202 Otyp
: constant Entity_Id
:= Etype
(N
);
14203 In_Rng
: constant Boolean := Kind
= N_In
;
14204 Binary
: constant Boolean := Kind
in N_Binary_Op
or else In_Rng
;
14205 Compar
: constant Boolean := Kind
in N_Op_Compare
or else In_Rng
;
14206 R
: constant Node_Id
:= Right_Opnd
(N
);
14207 Typ
: constant Entity_Id
:= Etype
(R
);
14208 Tsiz
: constant Uint
:= RM_Size
(Typ
);
14222 -- Start of processing for Narrow_Large_Operation
14225 -- First, determine the range of the left operand, if any
14228 L
:= Left_Opnd
(N
);
14229 Determine_Range
(L
, OK
, Llo
, Lhi
, Assume_Valid
=> True);
14240 -- Second, determine the range of the right operand, which can itself
14241 -- be a range, in which case we take the lower bound of the low bound
14242 -- and the upper bound of the high bound.
14250 (Low_Bound
(R
), OK
, Rlo
, Zhi
, Assume_Valid
=> True);
14256 (High_Bound
(R
), OK
, Zlo
, Rhi
, Assume_Valid
=> True);
14263 Determine_Range
(R
, OK
, Rlo
, Rhi
, Assume_Valid
=> True);
14269 -- Then compute a size suitable for each range
14272 Lsiz
:= Get_Size_For_Range
(Llo
, Lhi
);
14277 Rsiz
:= Get_Size_For_Range
(Rlo
, Rhi
);
14279 -- Now compute the size of the narrower type
14282 -- The type must be able to accommodate the operands
14284 Nsiz
:= UI_Max
(Lsiz
, Rsiz
);
14287 -- The type must be able to accommodate the operand(s) and result.
14289 -- Note that Determine_Range typically does not report the bounds of
14290 -- the value as being larger than those of the base type, which means
14291 -- that it does not report overflow (see also Enable_Overflow_Check).
14293 Determine_Range
(N
, OK
, Nlo
, Nhi
, Assume_Valid
=> True);
14298 -- Therefore, if Nsiz is not lower than the size of the original type
14299 -- here, we cannot be sure that the operation does not overflow.
14301 Nsiz
:= Get_Size_For_Range
(Nlo
, Nhi
);
14302 Nsiz
:= UI_Max
(Nsiz
, Lsiz
);
14303 Nsiz
:= UI_Max
(Nsiz
, Rsiz
);
14306 -- If the size is not lower than the size of the original type, then
14307 -- there is no point in changing the type, except in the case where
14308 -- we can remove a conversion to the original type from an operand.
14311 and then not (Binary
14312 and then Nkind
(L
) = N_Type_Conversion
14313 and then Entity
(Subtype_Mark
(L
)) = Typ
)
14314 and then not (Nkind
(R
) = N_Type_Conversion
14315 and then Entity
(Subtype_Mark
(R
)) = Typ
)
14320 -- Now pick the narrower type according to the size. We use the base
14321 -- type instead of the first subtype because operations are done in
14322 -- the base type, so this avoids the need for useless conversions.
14324 if Nsiz
<= System_Max_Integer_Size
then
14325 Ntyp
:= Etype
(Integer_Type_For
(Nsiz
, Uns
=> False));
14330 -- Finally, rewrite the operation in the narrower type, but make sure
14331 -- not to perform name resolution for the operator again.
14333 Nop
:= New_Op_Node
(Kind
, Sloc
(N
));
14334 if Nkind
(N
) in N_Has_Entity
then
14335 Set_Entity
(Nop
, Entity
(N
));
14339 Set_Left_Opnd
(Nop
, Convert_To
(Ntyp
, L
));
14343 Set_Right_Opnd
(Nop
,
14344 Make_Range
(Sloc
(N
),
14345 Convert_To
(Ntyp
, Low_Bound
(R
)),
14346 Convert_To
(Ntyp
, High_Bound
(R
))));
14348 Set_Right_Opnd
(Nop
, Convert_To
(Ntyp
, R
));
14354 -- Analyze it with the comparison type and checks suppressed since
14355 -- the conversions of the operands cannot overflow.
14357 Analyze_And_Resolve
(N
, Otyp
, Suppress
=> Overflow_Check
);
14360 -- Analyze it with the narrower type and checks suppressed, but only
14361 -- when we are sure that the operation does not overflow, see above.
14363 if Nsiz
< Tsiz
then
14364 Analyze_And_Resolve
(N
, Ntyp
, Suppress
=> Overflow_Check
);
14366 Analyze_And_Resolve
(N
, Ntyp
);
14369 -- Put back a conversion to the original type
14371 Convert_To_And_Rewrite
(Typ
, N
);
14373 end Narrow_Large_Operation
;
14375 --------------------------------
14376 -- Optimize_Length_Comparison --
14377 --------------------------------
14379 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
14380 Loc
: constant Source_Ptr
:= Sloc
(N
);
14381 Typ
: constant Entity_Id
:= Etype
(N
);
14386 -- First and Last attribute reference nodes, which end up as left and
14387 -- right operands of the optimized result.
14390 -- True for comparison operand of zero
14392 Maybe_Superflat
: Boolean;
14393 -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set
14394 -- to false but the comparison operand can be zero at run time. In this
14395 -- case, we normally cannot do anything because the canonical formula of
14396 -- the length is not valid, but there is one exception: when the operand
14397 -- is itself the length of an array with the same bounds as the array on
14398 -- the LHS, we can entirely optimize away the comparison.
14401 -- Comparison operand, set only if Is_Zero is false
14403 Ent
: array (Pos
range 1 .. 2) of Entity_Id
:= (Empty
, Empty
);
14404 -- Entities whose length is being compared
14406 Index
: array (Pos
range 1 .. 2) of Node_Id
:= (Empty
, Empty
);
14407 -- Integer_Literal nodes for length attribute expressions, or Empty
14408 -- if there is no such expression present.
14410 Op
: Node_Kind
:= Nkind
(N
);
14411 -- Kind of comparison operator, gets flipped if operands backwards
14413 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
;
14414 -- Given a discrete expression, returns a Long_Long_Integer typed
14415 -- expression representing the underlying value of the expression.
14416 -- This is done with an unchecked conversion to Long_Long_Integer.
14417 -- We use unchecked conversion to handle the enumeration type case.
14419 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean;
14420 -- Tests if N is a length attribute applied to a simple entity. If so,
14421 -- returns True, and sets Ent to the entity, and Index to the integer
14422 -- literal provided as an attribute expression, or to Empty if none.
14423 -- Num is the index designating the relevant slot in Ent and Index.
14424 -- Also returns True if the expression is a generated type conversion
14425 -- whose expression is of the desired form. This latter case arises
14426 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
14427 -- to check for being in range, which is not needed in this context.
14428 -- Returns False if neither condition holds.
14430 function Is_Optimizable
(N
: Node_Id
) return Boolean;
14431 -- Tests N to see if it is an optimizable comparison value (defined as
14432 -- constant zero or one, or something else where the value is known to
14433 -- be nonnegative and in the 32-bit range and where the corresponding
14434 -- Length value is also known to be 32 bits). If result is true, sets
14435 -- Is_Zero, Maybe_Superflat and Comp accordingly.
14437 procedure Rewrite_For_Equal_Lengths
;
14438 -- Rewrite the comparison of two equal lengths into either True or False
14440 ----------------------------------
14441 -- Convert_To_Long_Long_Integer --
14442 ----------------------------------
14444 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
is
14446 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
14447 end Convert_To_Long_Long_Integer
;
14449 ----------------------
14450 -- Is_Entity_Length --
14451 ----------------------
14453 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean is
14455 if Nkind
(N
) = N_Attribute_Reference
14456 and then Attribute_Name
(N
) = Name_Length
14457 and then Is_Entity_Name
(Prefix
(N
))
14459 Ent
(Num
) := Entity
(Prefix
(N
));
14461 if Present
(Expressions
(N
)) then
14462 Index
(Num
) := First
(Expressions
(N
));
14464 Index
(Num
) := Empty
;
14469 elsif Nkind
(N
) = N_Type_Conversion
14470 and then not Comes_From_Source
(N
)
14472 return Is_Entity_Length
(Expression
(N
), Num
);
14477 end Is_Entity_Length
;
14479 --------------------
14480 -- Is_Optimizable --
14481 --------------------
14483 function Is_Optimizable
(N
: Node_Id
) return Boolean is
14493 if Compile_Time_Known_Value
(N
) then
14494 Val
:= Expr_Value
(N
);
14496 if Val
= Uint_0
then
14498 Maybe_Superflat
:= False;
14502 elsif Val
= Uint_1
then
14504 Maybe_Superflat
:= False;
14510 -- Here we have to make sure of being within a 32-bit range (take the
14511 -- full unsigned range so the length of 32-bit arrays is accepted).
14513 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
14516 or else Lo
< Uint_0
14517 or else Hi
> Uint_2
** 32
14522 Maybe_Superflat
:= (Lo
= Uint_0
);
14524 -- Tests if N is also a length attribute applied to a simple entity
14526 Dbl
:= Is_Entity_Length
(N
, 2);
14528 -- We can deal with the superflat case only if N is also a length
14530 if Maybe_Superflat
and then not Dbl
then
14534 -- Comparison value was within range, so now we must check the index
14535 -- value to make sure it is also within 32 bits.
14537 for K
in Pos
range 1 .. 2 loop
14538 Indx
:= First_Index
(Etype
(Ent
(K
)));
14540 if Present
(Index
(K
)) then
14541 for J
in 2 .. UI_To_Int
(Intval
(Index
(K
))) loop
14546 Ityp
:= Etype
(Indx
);
14548 if Esize
(Ityp
) > 32 then
14558 end Is_Optimizable
;
14560 -------------------------------
14561 -- Rewrite_For_Equal_Lengths --
14562 -------------------------------
14564 procedure Rewrite_For_Equal_Lengths
is
14573 New_Occurrence_Of
(Standard_True
, Sloc
(N
))));
14581 New_Occurrence_Of
(Standard_False
, Sloc
(N
))));
14584 raise Program_Error
;
14587 Analyze_And_Resolve
(N
, Typ
);
14588 end Rewrite_For_Equal_Lengths
;
14590 -- Start of processing for Optimize_Length_Comparison
14593 -- Nothing to do if not a comparison
14595 if Op
not in N_Op_Compare
then
14599 -- Nothing to do if special -gnatd.P debug flag set.
14601 if Debug_Flag_Dot_PP
then
14605 -- Ent'Length op 0/1
14607 if Is_Entity_Length
(Left_Opnd
(N
), 1)
14608 and then Is_Optimizable
(Right_Opnd
(N
))
14612 -- 0/1 op Ent'Length
14614 elsif Is_Entity_Length
(Right_Opnd
(N
), 1)
14615 and then Is_Optimizable
(Left_Opnd
(N
))
14617 -- Flip comparison to opposite sense
14620 when N_Op_Lt
=> Op
:= N_Op_Gt
;
14621 when N_Op_Le
=> Op
:= N_Op_Ge
;
14622 when N_Op_Gt
=> Op
:= N_Op_Lt
;
14623 when N_Op_Ge
=> Op
:= N_Op_Le
;
14624 when others => null;
14627 -- Else optimization not possible
14633 -- Fall through if we will do the optimization
14635 -- Cases to handle:
14637 -- X'Length = 0 => X'First > X'Last
14638 -- X'Length = 1 => X'First = X'Last
14639 -- X'Length = n => X'First + (n - 1) = X'Last
14641 -- X'Length /= 0 => X'First <= X'Last
14642 -- X'Length /= 1 => X'First /= X'Last
14643 -- X'Length /= n => X'First + (n - 1) /= X'Last
14645 -- X'Length >= 0 => always true, warn
14646 -- X'Length >= 1 => X'First <= X'Last
14647 -- X'Length >= n => X'First + (n - 1) <= X'Last
14649 -- X'Length > 0 => X'First <= X'Last
14650 -- X'Length > 1 => X'First < X'Last
14651 -- X'Length > n => X'First + (n - 1) < X'Last
14653 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
14654 -- X'Length <= 1 => X'First >= X'Last
14655 -- X'Length <= n => X'First + (n - 1) >= X'Last
14657 -- X'Length < 0 => always false (warn)
14658 -- X'Length < 1 => X'First > X'Last
14659 -- X'Length < n => X'First + (n - 1) > X'Last
14661 -- Note: for the cases of n (not constant 0,1), we require that the
14662 -- corresponding index type be integer or shorter (i.e. not 64-bit),
14663 -- and the same for the comparison value. Then we do the comparison
14664 -- using 64-bit arithmetic (actually long long integer), so that we
14665 -- cannot have overflow intefering with the result.
14667 -- First deal with warning cases
14676 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
14677 Analyze_And_Resolve
(N
, Typ
);
14678 Warn_On_Known_Condition
(N
);
14685 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
14686 Analyze_And_Resolve
(N
, Typ
);
14687 Warn_On_Known_Condition
(N
);
14691 if Constant_Condition_Warnings
14692 and then Comes_From_Source
(Original_Node
(N
))
14694 Error_Msg_N
("could replace by ""'=""?c?", N
);
14704 -- Build the First reference we will use
14707 Make_Attribute_Reference
(Loc
,
14708 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14709 Attribute_Name
=> Name_First
);
14711 if Present
(Index
(1)) then
14712 Set_Expressions
(Left
, New_List
(New_Copy
(Index
(1))));
14715 -- Build the Last reference we will use
14718 Make_Attribute_Reference
(Loc
,
14719 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14720 Attribute_Name
=> Name_Last
);
14722 if Present
(Index
(1)) then
14723 Set_Expressions
(Right
, New_List
(New_Copy
(Index
(1))));
14726 -- If general value case, then do the addition of (n - 1), and
14727 -- also add the needed conversions to type Long_Long_Integer.
14729 -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into:
14731 -- Y'Last + (X'First - Y'First) op X'Last
14733 -- in the hope that X'First - Y'First can be computed statically.
14735 if Present
(Comp
) then
14736 if Present
(Ent
(2)) then
14738 Y_First
: constant Node_Id
:=
14739 Make_Attribute_Reference
(Loc
,
14740 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14741 Attribute_Name
=> Name_First
);
14742 Y_Last
: constant Node_Id
:=
14743 Make_Attribute_Reference
(Loc
,
14744 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14745 Attribute_Name
=> Name_Last
);
14746 R
: Compare_Result
;
14749 if Present
(Index
(2)) then
14750 Set_Expressions
(Y_First
, New_List
(New_Copy
(Index
(2))));
14751 Set_Expressions
(Y_Last
, New_List
(New_Copy
(Index
(2))));
14757 -- If X'First = Y'First, simplify the above formula into a
14758 -- direct comparison of Y'Last and X'Last.
14760 R
:= Compile_Time_Compare
(Left
, Y_First
, Assume_Valid
=> True);
14766 R
:= Compile_Time_Compare
14767 (Right
, Y_Last
, Assume_Valid
=> True);
14769 -- If the pairs of attributes are equal, we are done
14772 Rewrite_For_Equal_Lengths
;
14776 -- If the base types are different, convert both operands to
14777 -- Long_Long_Integer, else compare them directly.
14779 if Base_Type
(Etype
(Right
)) /= Base_Type
(Etype
(Y_Last
))
14781 Left
:= Convert_To_Long_Long_Integer
(Y_Last
);
14787 -- Otherwise, use the above formula as-is
14793 Convert_To_Long_Long_Integer
(Y_Last
),
14795 Make_Op_Subtract
(Loc
,
14797 Convert_To_Long_Long_Integer
(Left
),
14799 Convert_To_Long_Long_Integer
(Y_First
)));
14803 -- General value case
14808 Left_Opnd
=> Convert_To_Long_Long_Integer
(Left
),
14810 Make_Op_Subtract
(Loc
,
14811 Left_Opnd
=> Convert_To_Long_Long_Integer
(Comp
),
14812 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
14816 -- We cannot do anything in the superflat case past this point
14818 if Maybe_Superflat
then
14822 -- If general operand, convert Last reference to Long_Long_Integer
14824 if Present
(Comp
) then
14825 Right
:= Convert_To_Long_Long_Integer
(Right
);
14828 -- Check for cases to optimize
14830 -- X'Length = 0 => X'First > X'Last
14831 -- X'Length < 1 => X'First > X'Last
14832 -- X'Length < n => X'First + (n - 1) > X'Last
14834 if (Is_Zero
and then Op
= N_Op_Eq
)
14835 or else (not Is_Zero
and then Op
= N_Op_Lt
)
14840 Right_Opnd
=> Right
);
14842 -- X'Length = 1 => X'First = X'Last
14843 -- X'Length = n => X'First + (n - 1) = X'Last
14845 elsif not Is_Zero
and then Op
= N_Op_Eq
then
14849 Right_Opnd
=> Right
);
14851 -- X'Length /= 0 => X'First <= X'Last
14852 -- X'Length > 0 => X'First <= X'Last
14854 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
14858 Right_Opnd
=> Right
);
14860 -- X'Length /= 1 => X'First /= X'Last
14861 -- X'Length /= n => X'First + (n - 1) /= X'Last
14863 elsif not Is_Zero
and then Op
= N_Op_Ne
then
14867 Right_Opnd
=> Right
);
14869 -- X'Length >= 1 => X'First <= X'Last
14870 -- X'Length >= n => X'First + (n - 1) <= X'Last
14872 elsif not Is_Zero
and then Op
= N_Op_Ge
then
14876 Right_Opnd
=> Right
);
14878 -- X'Length > 1 => X'First < X'Last
14879 -- X'Length > n => X'First + (n = 1) < X'Last
14881 elsif not Is_Zero
and then Op
= N_Op_Gt
then
14885 Right_Opnd
=> Right
);
14887 -- X'Length <= 1 => X'First >= X'Last
14888 -- X'Length <= n => X'First + (n - 1) >= X'Last
14890 elsif not Is_Zero
and then Op
= N_Op_Le
then
14894 Right_Opnd
=> Right
);
14896 -- Should not happen at this stage
14899 raise Program_Error
;
14902 -- Rewrite and finish up (we can suppress overflow checks, see above)
14904 Rewrite
(N
, Result
);
14905 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Overflow_Check
);
14906 end Optimize_Length_Comparison
;
14908 --------------------------------------
14909 -- Process_Transients_In_Expression --
14910 --------------------------------------
14912 procedure Process_Transients_In_Expression
14916 procedure Process_Transient_In_Expression
(Obj_Decl
: Node_Id
);
14917 -- Process the object whose declaration Obj_Decl is present in Stmts
14919 -------------------------------------
14920 -- Process_Transient_In_Expression --
14921 -------------------------------------
14923 procedure Process_Transient_In_Expression
(Obj_Decl
: Node_Id
) is
14924 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
14925 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Obj_Decl
);
14927 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Expr
);
14928 -- The node on which to insert the hook as an action. This is usually
14929 -- the innermost enclosing non-transient construct.
14931 Fin_Call
: Node_Id
;
14932 Hook_Assign
: Node_Id
;
14933 Hook_Clear
: Node_Id
;
14934 Hook_Decl
: Node_Id
;
14935 Hook_Insert
: Node_Id
;
14936 Ptr_Decl
: Node_Id
;
14938 Fin_Context
: Node_Id
;
14939 -- The node after which to insert the finalization actions of the
14940 -- transient object.
14943 pragma Assert
(Nkind
(Expr
) in N_Case_Expression
14944 | N_Expression_With_Actions
14945 | N_If_Expression
);
14947 -- When the context is a Boolean evaluation, all three nodes capture
14948 -- the result of their computation in a local temporary:
14951 -- Trans_Id : Ctrl_Typ := ...;
14952 -- Result : constant Boolean := ... Trans_Id ...;
14953 -- <finalize Trans_Id>
14956 -- As a result, the finalization of any transient objects can take
14957 -- place just after the result is captured, except for the case of
14958 -- conditional expressions in a simple return statement because the
14959 -- return statement will be distributed into dependent expressions
14960 -- (see the special handling of simple return statements below).
14962 -- ??? could this be extended to elementary types?
14964 if Is_Boolean_Type
(Etype
(Expr
))
14966 (Nkind
(Expr
) = N_Expression_With_Actions
14967 or else Nkind
(Parent
(Expr
)) /= N_Simple_Return_Statement
)
14969 Fin_Context
:= Last
(Stmts
);
14971 -- Otherwise the immediate context may not be safe enough to carry
14972 -- out transient object finalization due to aliasing and nesting of
14973 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14974 -- enclosing non-transient construct.
14977 Fin_Context
:= Hook_Context
;
14980 -- Mark the transient object as successfully processed to avoid
14981 -- double finalization.
14983 Set_Is_Finalized_Transient
(Obj_Id
);
14985 -- Construct all the pieces necessary to hook and finalize a
14986 -- transient object.
14988 Build_Transient_Object_Statements
14989 (Obj_Decl
=> Obj_Decl
,
14990 Fin_Call
=> Fin_Call
,
14991 Hook_Assign
=> Hook_Assign
,
14992 Hook_Clear
=> Hook_Clear
,
14993 Hook_Decl
=> Hook_Decl
,
14994 Ptr_Decl
=> Ptr_Decl
,
14995 Finalize_Obj
=> False);
14997 -- Add the access type which provides a reference to the transient
14998 -- object. Generate:
15000 -- type Ptr_Typ is access all Desig_Typ;
15002 Insert_Action
(Hook_Context
, Ptr_Decl
);
15004 -- Add the temporary which acts as a hook to the transient object.
15007 -- Hook : Ptr_Id := null;
15009 Insert_Action
(Hook_Context
, Hook_Decl
);
15011 -- When the transient object is initialized by an aggregate, the hook
15012 -- must capture the object after the last aggregate assignment takes
15013 -- place. Only then is the object considered initialized. Generate:
15015 -- Hook := Ptr_Typ (Obj_Id);
15017 -- Hook := Obj_Id'Unrestricted_Access;
15019 if Ekind
(Obj_Id
) in E_Constant | E_Variable
15020 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
15022 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
15024 -- Otherwise the hook seizes the related object immediately
15027 Hook_Insert
:= Obj_Decl
;
15030 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
15032 -- When the node is part of a return statement, there is no need to
15033 -- insert a finalization call, as the general finalization mechanism
15034 -- (see Build_Finalizer) would take care of the transient object on
15035 -- subprogram exit. Note that it would also be impossible to insert
15036 -- the finalization code after the return statement as this will
15037 -- render it unreachable.
15039 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
15042 -- Finalize the hook after the context has been evaluated. Generate:
15044 -- if Hook /= null then
15045 -- [Deep_]Finalize (Hook.all);
15049 -- But the node returned by Find_Hook_Context may be an operator,
15050 -- which is not a list member. We must locate the proper node
15051 -- in the tree after which to insert the finalization code.
15054 while not Is_List_Member
(Fin_Context
) loop
15055 Fin_Context
:= Parent
(Fin_Context
);
15058 pragma Assert
(Present
(Fin_Context
));
15060 Insert_Action_After
(Fin_Context
,
15061 Make_Implicit_If_Statement
(Obj_Decl
,
15065 New_Occurrence_Of
(Defining_Entity
(Hook_Decl
), Loc
),
15066 Right_Opnd
=> Make_Null
(Loc
)),
15068 Then_Statements
=> New_List
(
15072 end Process_Transient_In_Expression
;
15078 -- Start of processing for Process_Transients_In_Expression
15081 pragma Assert
(Nkind
(Expr
) in N_Case_Expression
15082 | N_Expression_With_Actions
15083 | N_If_Expression
);
15085 Decl
:= First
(Stmts
);
15086 while Present
(Decl
) loop
15087 if Nkind
(Decl
) = N_Object_Declaration
15088 and then Is_Finalizable_Transient
(Decl
, Expr
)
15090 Process_Transient_In_Expression
(Decl
);
15095 end Process_Transients_In_Expression
;
15097 ------------------------
15098 -- Rewrite_Comparison --
15099 ------------------------
15101 procedure Rewrite_Comparison
(N
: Node_Id
) is
15102 Typ
: constant Entity_Id
:= Etype
(N
);
15104 False_Result
: Boolean;
15105 True_Result
: Boolean;
15108 if Nkind
(N
) = N_Type_Conversion
then
15109 Rewrite_Comparison
(Expression
(N
));
15112 elsif Nkind
(N
) not in N_Op_Compare
then
15116 -- If both operands are static, then the comparison has been already
15117 -- folded in evaluation.
15120 (not Is_Static_Expression
(Left_Opnd
(N
))
15122 not Is_Static_Expression
(Right_Opnd
(N
)));
15124 -- Determine the potential outcome of the comparison assuming that the
15125 -- operands are valid and emit a warning when the comparison evaluates
15126 -- to True or False only in the presence of invalid values.
15128 Warn_On_Constant_Valid_Condition
(N
);
15130 -- Determine the potential outcome of the comparison assuming that the
15131 -- operands are not valid.
15135 Assume_Valid
=> False,
15136 True_Result
=> True_Result
,
15137 False_Result
=> False_Result
);
15139 -- The outcome is a decisive False or True, rewrite the operator into a
15140 -- non-static literal.
15142 if False_Result
or True_Result
then
15145 New_Occurrence_Of
(Boolean_Literals
(True_Result
), Sloc
(N
))));
15147 Analyze_And_Resolve
(N
, Typ
);
15148 Set_Is_Static_Expression
(N
, False);
15149 Warn_On_Known_Condition
(N
);
15151 end Rewrite_Comparison
;
15153 ----------------------------
15154 -- Safe_In_Place_Array_Op --
15155 ----------------------------
15157 function Safe_In_Place_Array_Op
15160 Op2
: Node_Id
) return Boolean
15162 Target
: Entity_Id
;
15164 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
15165 -- Operand is safe if it cannot overlap part of the target of the
15166 -- operation. If the operand and the target are identical, the operand
15167 -- is safe. The operand can be empty in the case of negation.
15169 function Is_Unaliased
(N
: Node_Id
) return Boolean;
15170 -- Check that N is a stand-alone entity
15176 function Is_Unaliased
(N
: Node_Id
) return Boolean is
15180 and then No
(Address_Clause
(Entity
(N
)))
15181 and then No
(Renamed_Object
(Entity
(N
)));
15184 ---------------------
15185 -- Is_Safe_Operand --
15186 ---------------------
15188 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
15193 elsif Is_Entity_Name
(Op
) then
15194 return Is_Unaliased
(Op
);
15196 elsif Nkind
(Op
) in N_Indexed_Component | N_Selected_Component
then
15197 return Is_Unaliased
(Prefix
(Op
));
15199 elsif Nkind
(Op
) = N_Slice
then
15201 Is_Unaliased
(Prefix
(Op
))
15202 and then Entity
(Prefix
(Op
)) /= Target
;
15204 elsif Nkind
(Op
) = N_Op_Not
then
15205 return Is_Safe_Operand
(Right_Opnd
(Op
));
15210 end Is_Safe_Operand
;
15212 -- Start of processing for Safe_In_Place_Array_Op
15215 -- Skip this processing if the component size is different from system
15216 -- storage unit (since at least for NOT this would cause problems).
15218 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
15221 -- Cannot do in place stuff if non-standard Boolean representation
15223 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
15226 elsif not Is_Unaliased
(Lhs
) then
15230 Target
:= Entity
(Lhs
);
15231 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
15233 end Safe_In_Place_Array_Op
;
15235 -----------------------
15236 -- Tagged_Membership --
15237 -----------------------
15239 -- There are two different cases to consider depending on whether the right
15240 -- operand is a class-wide type or not. If not we just compare the actual
15241 -- tag of the left expr to the target type tag:
15243 -- Left_Expr.Tag = Right_Type'Tag;
15245 -- If it is a class-wide type we use the RT function CW_Membership which is
15246 -- usually implemented by looking in the ancestor tables contained in the
15247 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
15249 -- In both cases if Left_Expr is an access type, we first check whether it
15252 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
15253 -- function IW_Membership which is usually implemented by looking in the
15254 -- table of abstract interface types plus the ancestor table contained in
15255 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
15257 procedure Tagged_Membership
15259 SCIL_Node
: out Node_Id
;
15260 Result
: out Node_Id
)
15262 Left
: constant Node_Id
:= Left_Opnd
(N
);
15263 Right
: constant Node_Id
:= Right_Opnd
(N
);
15264 Loc
: constant Source_Ptr
:= Sloc
(N
);
15266 -- Handle entities from the limited view
15268 Orig_Right_Type
: constant Entity_Id
:= Available_View
(Etype
(Right
));
15270 Full_R_Typ
: Entity_Id
;
15271 Left_Type
: Entity_Id
:= Available_View
(Etype
(Left
));
15272 Right_Type
: Entity_Id
:= Orig_Right_Type
;
15276 SCIL_Node
:= Empty
;
15278 -- We have to examine the corresponding record type when dealing with
15279 -- protected types instead of the original, unexpanded, type.
15281 if Ekind
(Right_Type
) = E_Protected_Type
then
15282 Right_Type
:= Corresponding_Record_Type
(Right_Type
);
15285 if Ekind
(Left_Type
) = E_Protected_Type
then
15286 Left_Type
:= Corresponding_Record_Type
(Left_Type
);
15289 -- In the case where the type is an access type, the test is applied
15290 -- using the designated types (needed in Ada 2012 for implicit anonymous
15291 -- access conversions, for AI05-0149).
15293 if Is_Access_Type
(Right_Type
) then
15294 Left_Type
:= Designated_Type
(Left_Type
);
15295 Right_Type
:= Designated_Type
(Right_Type
);
15298 if Is_Class_Wide_Type
(Left_Type
) then
15299 Left_Type
:= Root_Type
(Left_Type
);
15302 if Is_Class_Wide_Type
(Right_Type
) then
15303 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
15305 Full_R_Typ
:= Underlying_Type
(Right_Type
);
15309 Make_Selected_Component
(Loc
,
15310 Prefix
=> Relocate_Node
(Left
),
15312 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
15314 if Is_Class_Wide_Type
(Right_Type
) then
15316 -- No need to issue a run-time check if we statically know that the
15317 -- result of this membership test is always true. For example,
15318 -- considering the following declarations:
15320 -- type Iface is interface;
15321 -- type T is tagged null record;
15322 -- type DT is new T and Iface with null record;
15327 -- These membership tests are always true:
15330 -- Obj2 in T'Class;
15331 -- Obj2 in Iface'Class;
15333 -- We do not need to handle cases where the membership is illegal.
15336 -- Obj1 in DT'Class; -- Compile time error
15337 -- Obj1 in Iface'Class; -- Compile time error
15339 if not Is_Interface
(Left_Type
)
15340 and then not Is_Class_Wide_Type
(Left_Type
)
15341 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
15342 Use_Full_View
=> True)
15343 or else (Is_Interface
(Etype
(Right_Type
))
15344 and then Interface_Present_In_Ancestor
15346 Iface
=> Etype
(Right_Type
))))
15348 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
15352 -- Ada 2005 (AI-251): Class-wide applied to interfaces
15354 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
15356 -- Support to: "Iface_CW_Typ in Typ'Class"
15358 or else Is_Interface
(Left_Type
)
15360 -- Issue error if IW_Membership operation not available in a
15361 -- configurable run-time setting.
15363 if not RTE_Available
(RE_IW_Membership
) then
15365 ("dynamic membership test on interface types", N
);
15371 Make_Function_Call
(Loc
,
15372 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
15373 Parameter_Associations
=> New_List
(
15374 Make_Attribute_Reference
(Loc
,
15376 Attribute_Name
=> Name_Address
),
15377 New_Occurrence_Of
(
15378 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15381 -- Ada 95: Normal case
15384 -- Issue error if CW_Membership operation not available in a
15385 -- configurable run-time setting.
15387 if not RTE_Available
(RE_CW_Membership
) then
15389 ("dynamic membership test on tagged types", N
);
15395 Make_Function_Call
(Loc
,
15396 Name
=> New_Occurrence_Of
(RTE
(RE_CW_Membership
), Loc
),
15397 Parameter_Associations
=> New_List
(
15399 New_Occurrence_Of
(
15400 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15403 -- Generate the SCIL node for this class-wide membership test.
15405 if Generate_SCIL
then
15406 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
15407 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
15408 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
15412 -- Right_Type is not a class-wide type
15415 -- No need to check the tag of the object if Right_Typ is abstract
15417 if Is_Abstract_Type
(Right_Type
) then
15418 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
15423 Left_Opnd
=> Obj_Tag
,
15426 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
15430 -- if Left is an access object then generate test of the form:
15431 -- * if Right_Type excludes null: Left /= null and then ...
15432 -- * if Right_Type includes null: Left = null or else ...
15434 if Is_Access_Type
(Orig_Right_Type
) then
15435 if Can_Never_Be_Null
(Orig_Right_Type
) then
15436 Result
:= Make_And_Then
(Loc
,
15440 Right_Opnd
=> Make_Null
(Loc
)),
15441 Right_Opnd
=> Result
);
15444 Result
:= Make_Or_Else
(Loc
,
15448 Right_Opnd
=> Make_Null
(Loc
)),
15449 Right_Opnd
=> Result
);
15452 end Tagged_Membership
;
15454 ------------------------------
15455 -- Unary_Op_Validity_Checks --
15456 ------------------------------
15458 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
15460 if Validity_Checks_On
and Validity_Check_Operands
then
15461 Ensure_Valid
(Right_Opnd
(N
));
15463 end Unary_Op_Validity_Checks
;