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_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
);
245 -- Inspect and process statement list Stmt of if or case expression N for
246 -- transient objects. If such objects are found, the routine generates code
247 -- to clean them up when the context of the expression is evaluated.
249 procedure Process_Transient_In_Expression
253 -- Subsidiary routine to the expansion of expression_with_actions, if and
254 -- case expressions. Generate all necessary code to finalize a transient
255 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
256 -- denotes the declaration of the transient object, which is usually the
257 -- result of a controlled function call. Expr denotes the expression with
258 -- actions, if expression, or case expression node. Stmts denotes the
259 -- statement list which contains Decl, either at the top level or within a
262 procedure Rewrite_Comparison
(N
: Node_Id
);
263 -- If N is the node for a comparison whose outcome can be determined at
264 -- compile time, then the node N can be rewritten with True or False. If
265 -- the outcome cannot be determined at compile time, the call has no
266 -- effect. If N is a type conversion, then this processing is applied to
267 -- its expression. If N is neither comparison nor a type conversion, the
268 -- call has no effect.
270 procedure Tagged_Membership
272 SCIL_Node
: out Node_Id
;
273 Result
: out Node_Id
);
274 -- Construct the expression corresponding to the tagged membership test.
275 -- Deals with a second operand being (or not) a class-wide type.
277 function Safe_In_Place_Array_Op
280 Op2
: Node_Id
) return Boolean;
281 -- In the context of an assignment, where the right-hand side is a boolean
282 -- operation on arrays, check whether operation can be performed in place.
284 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
285 pragma Inline
(Unary_Op_Validity_Checks
);
286 -- Performs validity checks for a unary operator
288 -------------------------------
289 -- Binary_Op_Validity_Checks --
290 -------------------------------
292 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
294 if Validity_Checks_On
and Validity_Check_Operands
then
295 Ensure_Valid
(Left_Opnd
(N
));
296 Ensure_Valid
(Right_Opnd
(N
));
298 end Binary_Op_Validity_Checks
;
300 ------------------------------------
301 -- Build_Boolean_Array_Proc_Call --
302 ------------------------------------
304 procedure Build_Boolean_Array_Proc_Call
309 Loc
: constant Source_Ptr
:= Sloc
(N
);
310 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
311 Target
: constant Node_Id
:=
312 Make_Attribute_Reference
(Loc
,
314 Attribute_Name
=> Name_Address
);
316 Arg1
: Node_Id
:= Op1
;
317 Arg2
: Node_Id
:= Op2
;
319 Proc_Name
: Entity_Id
;
322 if Kind
= N_Op_Not
then
323 if Nkind
(Op1
) in N_Binary_Op
then
325 -- Use negated version of the binary operators
327 if Nkind
(Op1
) = N_Op_And
then
328 Proc_Name
:= RTE
(RE_Vector_Nand
);
330 elsif Nkind
(Op1
) = N_Op_Or
then
331 Proc_Name
:= RTE
(RE_Vector_Nor
);
333 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
334 Proc_Name
:= RTE
(RE_Vector_Xor
);
338 Make_Procedure_Call_Statement
(Loc
,
339 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
341 Parameter_Associations
=> New_List
(
343 Make_Attribute_Reference
(Loc
,
344 Prefix
=> Left_Opnd
(Op1
),
345 Attribute_Name
=> Name_Address
),
347 Make_Attribute_Reference
(Loc
,
348 Prefix
=> Right_Opnd
(Op1
),
349 Attribute_Name
=> Name_Address
),
351 Make_Attribute_Reference
(Loc
,
352 Prefix
=> Left_Opnd
(Op1
),
353 Attribute_Name
=> Name_Length
)));
356 Proc_Name
:= RTE
(RE_Vector_Not
);
359 Make_Procedure_Call_Statement
(Loc
,
360 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
361 Parameter_Associations
=> New_List
(
364 Make_Attribute_Reference
(Loc
,
366 Attribute_Name
=> Name_Address
),
368 Make_Attribute_Reference
(Loc
,
370 Attribute_Name
=> Name_Length
)));
374 -- We use the following equivalences:
376 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
377 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
378 -- (not X) xor (not Y) = X xor Y
379 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
381 if Nkind
(Op1
) = N_Op_Not
then
382 Arg1
:= Right_Opnd
(Op1
);
383 Arg2
:= Right_Opnd
(Op2
);
385 if Kind
= N_Op_And
then
386 Proc_Name
:= RTE
(RE_Vector_Nor
);
387 elsif Kind
= N_Op_Or
then
388 Proc_Name
:= RTE
(RE_Vector_Nand
);
390 Proc_Name
:= RTE
(RE_Vector_Xor
);
394 if Kind
= N_Op_And
then
395 Proc_Name
:= RTE
(RE_Vector_And
);
396 elsif Kind
= N_Op_Or
then
397 Proc_Name
:= RTE
(RE_Vector_Or
);
398 elsif Nkind
(Op2
) = N_Op_Not
then
399 Proc_Name
:= RTE
(RE_Vector_Nxor
);
400 Arg2
:= Right_Opnd
(Op2
);
402 Proc_Name
:= RTE
(RE_Vector_Xor
);
407 Make_Procedure_Call_Statement
(Loc
,
408 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
409 Parameter_Associations
=> New_List
(
411 Make_Attribute_Reference
(Loc
,
413 Attribute_Name
=> Name_Address
),
414 Make_Attribute_Reference
(Loc
,
416 Attribute_Name
=> Name_Address
),
417 Make_Attribute_Reference
(Loc
,
419 Attribute_Name
=> Name_Length
)));
422 Rewrite
(N
, Call_Node
);
426 when RE_Not_Available
=>
428 end Build_Boolean_Array_Proc_Call
;
430 -----------------------
432 -----------------------
434 function Build_Eq_Call
438 Rhs
: Node_Id
) return Node_Id
440 Eq
: constant Entity_Id
:= Get_User_Defined_Equality
(Typ
);
444 if Is_Abstract_Subprogram
(Eq
) then
445 return Make_Raise_Program_Error
(Loc
,
446 Reason
=> PE_Explicit_Raise
);
450 Make_Function_Call
(Loc
,
451 Name
=> New_Occurrence_Of
(Eq
, Loc
),
452 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
456 -- If not found, predefined operation will be used
461 --------------------------------
462 -- Displace_Allocator_Pointer --
463 --------------------------------
465 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
466 Loc
: constant Source_Ptr
:= Sloc
(N
);
467 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
473 -- Do nothing in case of VM targets: the virtual machine will handle
474 -- interfaces directly.
476 if not Tagged_Type_Expansion
then
480 pragma Assert
(Nkind
(N
) = N_Identifier
481 and then Nkind
(Orig_Node
) = N_Allocator
);
483 PtrT
:= Etype
(Orig_Node
);
484 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
485 Etyp
:= Etype
(Expression
(Orig_Node
));
487 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
489 -- If the type of the allocator expression is not an interface type
490 -- we can generate code to reference the record component containing
491 -- the pointer to the secondary dispatch table.
493 if not Is_Interface
(Etyp
) then
495 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
498 -- 1) Get access to the allocated object
501 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
505 -- 2) Add the conversion to displace the pointer to reference
506 -- the secondary dispatch table.
508 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
509 Analyze_And_Resolve
(N
, Dtyp
);
511 -- 3) The 'access to the secondary dispatch table will be used
512 -- as the value returned by the allocator.
515 Make_Attribute_Reference
(Loc
,
516 Prefix
=> Relocate_Node
(N
),
517 Attribute_Name
=> Name_Access
));
518 Set_Etype
(N
, Saved_Typ
);
522 -- If the type of the allocator expression is an interface type we
523 -- generate a run-time call to displace "this" to reference the
524 -- component containing the pointer to the secondary dispatch table
525 -- or else raise Constraint_Error if the actual object does not
526 -- implement the target interface. This case corresponds to the
527 -- following example:
529 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
531 -- return new Iface_2'Class'(Obj);
536 Unchecked_Convert_To
(PtrT
,
537 Make_Function_Call
(Loc
,
538 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
539 Parameter_Associations
=> New_List
(
540 Unchecked_Convert_To
(RTE
(RE_Address
),
546 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
548 Analyze_And_Resolve
(N
, PtrT
);
551 end Displace_Allocator_Pointer
;
553 ---------------------------------
554 -- Expand_Allocator_Expression --
555 ---------------------------------
557 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
558 Loc
: constant Source_Ptr
:= Sloc
(N
);
559 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
560 PtrT
: constant Entity_Id
:= Etype
(N
);
561 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
565 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
566 T
: constant Entity_Id
:= Entity
(Indic
);
568 Aggr_In_Place
: Boolean;
570 Tag_Assign
: Node_Id
;
574 TagT
: Entity_Id
:= Empty
;
575 -- Type used as source for tag assignment
577 TagR
: Node_Id
:= Empty
;
578 -- Target reference for tag assignment
580 -- Start of processing for Expand_Allocator_Expression
583 -- Handle call to C++ constructor
585 if Is_CPP_Constructor_Call
(Exp
) then
586 Make_CPP_Constructor_Call_In_Allocator
588 Function_Call
=> Exp
);
593 -- type A is access T1;
594 -- X : A := new T2'(...);
595 -- T1 and T2 can be different subtypes, and we might need to check
596 -- both constraints. First check against the type of the qualified
599 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
601 Apply_Predicate_Check
(Exp
, T
);
603 -- Check that any anonymous access discriminants are suitable
604 -- for use in an allocator.
606 -- Note: This check is performed here instead of during analysis so that
607 -- we can check against the fully resolved etype of Exp.
609 if Is_Entity_Name
(Exp
)
610 and then Has_Anonymous_Access_Discriminant
(Etype
(Exp
))
611 and then Static_Accessibility_Level
(Exp
, Object_Decl_Level
)
612 > Static_Accessibility_Level
(N
, Object_Decl_Level
)
614 -- A dynamic check and a warning are generated when we are within
619 Make_Raise_Program_Error
(Loc
,
620 Reason
=> PE_Accessibility_Check_Failed
));
622 Error_Msg_Warn
:= SPARK_Mode
/= On
;
623 Error_Msg_N
("anonymous access discriminant is too deep for use"
624 & " in allocator<<", N
);
625 Error_Msg_N
("\Program_Error [<<", N
);
627 -- Otherwise, make the error static
630 Error_Msg_N
("anonymous access discriminant is too deep for use"
631 & " in allocator", N
);
635 if Do_Range_Check
(Exp
) then
636 Generate_Range_Check
(Exp
, T
, CE_Range_Check_Failed
);
639 -- A check is also needed in cases where the designated subtype is
640 -- constrained and differs from the subtype given in the qualified
641 -- expression. Note that the check on the qualified expression does
642 -- not allow sliding, but this check does (a relaxation from Ada 83).
644 if Is_Constrained
(DesigT
)
645 and then not Subtypes_Statically_Match
(T
, DesigT
)
647 Apply_Constraint_Check
(Exp
, DesigT
, No_Sliding
=> False);
649 Apply_Predicate_Check
(Exp
, DesigT
);
651 if Do_Range_Check
(Exp
) then
652 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
656 if Nkind
(Exp
) = N_Raise_Constraint_Error
then
657 Rewrite
(N
, New_Copy
(Exp
));
662 Aggr_In_Place
:= Is_Delayed_Aggregate
(Exp
);
664 -- Case of tagged type or type requiring finalization
666 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
668 -- Ada 2005 (AI-318-02): If the initialization expression is a call
669 -- to a build-in-place function, then access to the allocated object
670 -- must be passed to the function.
672 if Is_Build_In_Place_Function_Call
(Exp
) then
673 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
674 Apply_Accessibility_Check_For_Allocator
675 (N
, Exp
, N
, Built_In_Place
=> True);
678 -- Ada 2005 (AI-318-02): Specialization of the previous case for
679 -- expressions containing a build-in-place function call whose
680 -- returned object covers interface types, and Expr has calls to
681 -- Ada.Tags.Displace to displace the pointer to the returned build-
682 -- in-place object to reference the secondary dispatch table of a
683 -- covered interface type.
685 elsif Present
(Unqual_BIP_Iface_Function_Call
(Exp
)) then
686 Make_Build_In_Place_Iface_Call_In_Allocator
(N
, Exp
);
687 Apply_Accessibility_Check_For_Allocator
688 (N
, Exp
, N
, Built_In_Place
=> True);
692 -- Actions inserted before:
693 -- Temp : constant ptr_T := new T'(Expression);
694 -- Temp._tag = T'tag; -- when not class-wide
695 -- [Deep_]Adjust (Temp.all);
697 -- We analyze by hand the new internal allocator to avoid any
698 -- recursion and inappropriate call to Initialize.
700 -- We don't want to remove side effects when the expression must be
701 -- built in place. In the case of a build-in-place function call,
702 -- that could lead to a duplication of the call, which was already
703 -- substituted for the allocator.
705 if not Aggr_In_Place
then
706 Remove_Side_Effects
(Exp
);
709 Temp
:= Make_Temporary
(Loc
, 'P', N
);
711 -- For a class wide allocation generate the following code:
713 -- type Equiv_Record is record ... end record;
714 -- implicit subtype CW is <Class_Wide_Subytpe>;
715 -- temp : PtrT := new CW'(CW!(expr));
717 if Is_Class_Wide_Type
(T
) then
718 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
720 -- Ada 2005 (AI-251): If the expression is a class-wide interface
721 -- object we generate code to move up "this" to reference the
722 -- base of the object before allocating the new object.
724 -- Note that Exp'Address is recursively expanded into a call
725 -- to Base_Address (Exp.Tag)
727 if Is_Class_Wide_Type
(Etype
(Exp
))
728 and then Is_Interface
(Etype
(Exp
))
729 and then Tagged_Type_Expansion
733 Unchecked_Convert_To
(Entity
(Indic
),
734 Make_Explicit_Dereference
(Loc
,
735 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
736 Make_Attribute_Reference
(Loc
,
738 Attribute_Name
=> Name_Address
)))));
742 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
745 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
748 -- Processing for allocators returning non-interface types
750 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
751 if Aggr_In_Place
then
753 Make_Object_Declaration
(Loc
,
754 Defining_Identifier
=> Temp
,
755 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
759 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
761 -- Copy the Comes_From_Source flag for the allocator we just
762 -- built, since logically this allocator is a replacement of
763 -- the original allocator node. This is for proper handling of
764 -- restriction No_Implicit_Heap_Allocations.
766 Preserve_Comes_From_Source
767 (Expression
(Temp_Decl
), N
);
769 Set_No_Initialization
(Expression
(Temp_Decl
));
770 Insert_Action
(N
, Temp_Decl
);
772 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
773 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
776 Node
:= Relocate_Node
(N
);
780 Make_Object_Declaration
(Loc
,
781 Defining_Identifier
=> Temp
,
782 Constant_Present
=> True,
783 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
786 Insert_Action
(N
, Temp_Decl
);
787 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
790 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
791 -- interface type. In this case we use the type of the qualified
792 -- expression to allocate the object.
796 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
801 Make_Full_Type_Declaration
(Loc
,
802 Defining_Identifier
=> Def_Id
,
804 Make_Access_To_Object_Definition
(Loc
,
806 Null_Exclusion_Present
=> False,
808 Is_Access_Constant
(Etype
(N
)),
809 Subtype_Indication
=>
810 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
812 Insert_Action
(N
, New_Decl
);
814 -- Inherit the allocation-related attributes from the original
817 Set_Finalization_Master
818 (Def_Id
, Finalization_Master
(PtrT
));
820 Set_Associated_Storage_Pool
821 (Def_Id
, Associated_Storage_Pool
(PtrT
));
823 -- Declare the object using the previous type declaration
825 if Aggr_In_Place
then
827 Make_Object_Declaration
(Loc
,
828 Defining_Identifier
=> Temp
,
829 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
832 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
834 -- Copy the Comes_From_Source flag for the allocator we just
835 -- built, since logically this allocator is a replacement of
836 -- the original allocator node. This is for proper handling
837 -- of restriction No_Implicit_Heap_Allocations.
839 Set_Comes_From_Source
840 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
842 Set_No_Initialization
(Expression
(Temp_Decl
));
843 Insert_Action
(N
, Temp_Decl
);
845 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
846 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
849 Node
:= Relocate_Node
(N
);
853 Make_Object_Declaration
(Loc
,
854 Defining_Identifier
=> Temp
,
855 Constant_Present
=> True,
856 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
859 Insert_Action
(N
, Temp_Decl
);
860 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
863 -- Generate an additional object containing the address of the
864 -- returned object. The type of this second object declaration
865 -- is the correct type required for the common processing that
866 -- is still performed by this subprogram. The displacement of
867 -- this pointer to reference the component associated with the
868 -- interface type will be done at the end of common processing.
871 Make_Object_Declaration
(Loc
,
872 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
873 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
875 Unchecked_Convert_To
(PtrT
,
876 New_Occurrence_Of
(Temp
, Loc
)));
878 Insert_Action
(N
, New_Decl
);
880 Temp_Decl
:= New_Decl
;
881 Temp
:= Defining_Identifier
(New_Decl
);
885 -- Generate the tag assignment
887 -- Suppress the tag assignment for VM targets because VM tags are
888 -- represented implicitly in objects.
890 if not Tagged_Type_Expansion
then
893 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
894 -- interface objects because in this case the tag does not change.
896 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
897 pragma Assert
(Is_Class_Wide_Type
898 (Directly_Designated_Type
(Etype
(N
))));
901 -- Likewise if the allocator is made for a special return object
903 elsif For_Special_Return_Object
(N
) then
906 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
909 Make_Explicit_Dereference
(Loc
,
910 Prefix
=> New_Occurrence_Of
(Temp
, Loc
));
912 elsif Is_Private_Type
(T
)
913 and then Is_Tagged_Type
(Underlying_Type
(T
))
915 TagT
:= Underlying_Type
(T
);
917 Unchecked_Convert_To
(Underlying_Type
(T
),
918 Make_Explicit_Dereference
(Loc
,
919 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
922 if Present
(TagT
) then
924 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
928 Make_Assignment_Statement
(Loc
,
930 Make_Selected_Component
(Loc
,
934 (First_Tag_Component
(Full_T
), Loc
)),
937 Unchecked_Convert_To
(RTE
(RE_Tag
),
940 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
943 -- The previous assignment has to be done in any case
945 Set_Assignment_OK
(Name
(Tag_Assign
));
946 Insert_Action
(N
, Tag_Assign
);
949 -- Generate an Adjust call if the object will be moved. In Ada 2005,
950 -- the object may be inherently limited, in which case there is no
951 -- Adjust procedure, and the object is built in place. In Ada 95, the
952 -- object can be limited but not inherently limited if this allocator
953 -- came from a return statement (we're allocating the result on the
954 -- secondary stack); in that case, the object will be moved, so we do
955 -- want to Adjust. But the call is always skipped if the allocator is
956 -- made for a special return object because it's generated elsewhere.
958 -- Needs_Finalization (DesigT) may differ from Needs_Finalization (T)
959 -- if one of the two types is class-wide, and the other is not.
961 if Needs_Finalization
(DesigT
)
962 and then Needs_Finalization
(T
)
963 and then not Aggr_In_Place
964 and then not Is_Limited_View
(T
)
965 and then not For_Special_Return_Object
(N
)
967 -- An unchecked conversion is needed in the classwide case because
968 -- the designated type can be an ancestor of the subtype mark of
974 Unchecked_Convert_To
(T
,
975 Make_Explicit_Dereference
(Loc
,
976 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
979 if Present
(Adj_Call
) then
980 Insert_Action
(N
, Adj_Call
);
984 -- Note: the accessibility check must be inserted after the call to
985 -- [Deep_]Adjust to ensure proper completion of the assignment.
987 Apply_Accessibility_Check_For_Allocator
(N
, Exp
, Temp
);
989 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
990 Analyze_And_Resolve
(N
, PtrT
);
992 -- Ada 2005 (AI-251): Displace the pointer to reference the record
993 -- component containing the secondary dispatch table of the interface
996 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
997 Displace_Allocator_Pointer
(N
);
1000 -- Always force the generation of a temporary for aggregates when
1001 -- generating C code, to simplify the work in the code generator.
1004 or else (Modify_Tree_For_C
and then Nkind
(Exp
) = N_Aggregate
)
1006 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1008 Make_Object_Declaration
(Loc
,
1009 Defining_Identifier
=> Temp
,
1010 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1012 Make_Allocator
(Loc
,
1013 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1015 -- Copy the Comes_From_Source flag for the allocator we just built,
1016 -- since logically this allocator is a replacement of the original
1017 -- allocator node. This is for proper handling of restriction
1018 -- No_Implicit_Heap_Allocations.
1020 Set_Comes_From_Source
1021 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1023 Set_No_Initialization
(Expression
(Temp_Decl
));
1024 Insert_Action
(N
, Temp_Decl
);
1026 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1027 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1029 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1030 Analyze_And_Resolve
(N
, PtrT
);
1032 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1033 Install_Null_Excluding_Check
(Exp
);
1035 elsif Is_Access_Type
(DesigT
)
1036 and then Nkind
(Exp
) = N_Allocator
1037 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1039 -- Apply constraint to designated subtype indication
1041 Apply_Constraint_Check
1042 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1044 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1046 -- Propagate constraint_error to enclosing allocator
1048 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1052 Build_Allocate_Deallocate_Proc
(N
, True);
1054 -- For an access to unconstrained packed array, GIGI needs to see an
1055 -- expression with a constrained subtype in order to compute the
1056 -- proper size for the allocator.
1058 if Is_Packed_Array
(T
)
1059 and then not Is_Constrained
(T
)
1062 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1063 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1066 Make_Subtype_Declaration
(Loc
,
1067 Defining_Identifier
=> ConstrT
,
1068 Subtype_Indication
=>
1069 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1070 Freeze_Itype
(ConstrT
, Exp
);
1071 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1075 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1076 -- to a build-in-place function, then access to the allocated object
1077 -- must be passed to the function.
1079 if Is_Build_In_Place_Function_Call
(Exp
) then
1080 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1085 when RE_Not_Available
=>
1087 end Expand_Allocator_Expression
;
1089 -----------------------------
1090 -- Expand_Array_Comparison --
1091 -----------------------------
1093 -- Expansion is only required in the case of array types. For the unpacked
1094 -- case, an appropriate runtime routine is called. For packed cases, and
1095 -- also in some other cases where a runtime routine cannot be called, the
1096 -- form of the expansion is:
1098 -- [body for greater_nn; boolean_expression]
1100 -- The body is built by Make_Array_Comparison_Op, and the form of the
1101 -- Boolean expression depends on the operator involved.
1103 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1104 Loc
: constant Source_Ptr
:= Sloc
(N
);
1105 Op1
: Node_Id
:= Left_Opnd
(N
);
1106 Op2
: Node_Id
:= Right_Opnd
(N
);
1107 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1108 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1111 Func_Body
: Node_Id
;
1112 Func_Name
: Entity_Id
;
1116 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1117 -- True for byte addressable target
1119 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1120 -- Returns True if the length of the given operand is known to be less
1121 -- than 4. Returns False if this length is known to be four or greater
1122 -- or is not known at compile time.
1124 ------------------------
1125 -- Length_Less_Than_4 --
1126 ------------------------
1128 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1129 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1132 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1133 return String_Literal_Length
(Otyp
) < 4;
1135 elsif Compile_Time_Known_Bounds
(Otyp
) then
1140 Get_First_Index_Bounds
(Otyp
, Lo
, Hi
);
1147 end Length_Less_Than_4
;
1149 -- Start of processing for Expand_Array_Comparison
1152 -- Deal first with unpacked case, where we can call a runtime routine
1153 -- except that we avoid this for targets for which are not addressable
1156 if not Is_Bit_Packed_Array
(Typ1
) and then Byte_Addressable
then
1157 -- The call we generate is:
1159 -- Compare_Array_xn[_Unaligned]
1160 -- (left'address, right'address, left'length, right'length) <op> 0
1162 -- x = U for unsigned, S for signed
1163 -- n = 8,16,32,64,128 for component size
1164 -- Add _Unaligned if length < 4 and component size is 8.
1165 -- <op> is the standard comparison operator
1167 if Component_Size
(Typ1
) = 8 then
1168 if Length_Less_Than_4
(Op1
)
1170 Length_Less_Than_4
(Op2
)
1172 if Is_Unsigned_Type
(Ctyp
) then
1173 Comp
:= RE_Compare_Array_U8_Unaligned
;
1175 Comp
:= RE_Compare_Array_S8_Unaligned
;
1179 if Is_Unsigned_Type
(Ctyp
) then
1180 Comp
:= RE_Compare_Array_U8
;
1182 Comp
:= RE_Compare_Array_S8
;
1186 elsif Component_Size
(Typ1
) = 16 then
1187 if Is_Unsigned_Type
(Ctyp
) then
1188 Comp
:= RE_Compare_Array_U16
;
1190 Comp
:= RE_Compare_Array_S16
;
1193 elsif Component_Size
(Typ1
) = 32 then
1194 if Is_Unsigned_Type
(Ctyp
) then
1195 Comp
:= RE_Compare_Array_U32
;
1197 Comp
:= RE_Compare_Array_S32
;
1200 elsif Component_Size
(Typ1
) = 64 then
1201 if Is_Unsigned_Type
(Ctyp
) then
1202 Comp
:= RE_Compare_Array_U64
;
1204 Comp
:= RE_Compare_Array_S64
;
1207 else pragma Assert
(Component_Size
(Typ1
) = 128);
1208 if Is_Unsigned_Type
(Ctyp
) then
1209 Comp
:= RE_Compare_Array_U128
;
1211 Comp
:= RE_Compare_Array_S128
;
1215 if RTE_Available
(Comp
) then
1217 -- Expand to a call only if the runtime function is available,
1218 -- otherwise fall back to inline code.
1220 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1221 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1224 Comp_Call
: constant Node_Id
:=
1225 Make_Function_Call
(Loc
,
1226 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1228 Parameter_Associations
=> New_List
(
1229 Make_Attribute_Reference
(Loc
,
1230 Prefix
=> Relocate_Node
(Op1
),
1231 Attribute_Name
=> Name_Address
),
1233 Make_Attribute_Reference
(Loc
,
1234 Prefix
=> Relocate_Node
(Op2
),
1235 Attribute_Name
=> Name_Address
),
1237 Make_Attribute_Reference
(Loc
,
1238 Prefix
=> Relocate_Node
(Op1
),
1239 Attribute_Name
=> Name_Length
),
1241 Make_Attribute_Reference
(Loc
,
1242 Prefix
=> Relocate_Node
(Op2
),
1243 Attribute_Name
=> Name_Length
)));
1245 Zero
: constant Node_Id
:=
1246 Make_Integer_Literal
(Loc
,
1254 Comp_Op
:= Make_Op_Lt
(Loc
, Comp_Call
, Zero
);
1256 Comp_Op
:= Make_Op_Le
(Loc
, Comp_Call
, Zero
);
1258 Comp_Op
:= Make_Op_Gt
(Loc
, Comp_Call
, Zero
);
1260 Comp_Op
:= Make_Op_Ge
(Loc
, Comp_Call
, Zero
);
1262 raise Program_Error
;
1265 Rewrite
(N
, Comp_Op
);
1268 Analyze_And_Resolve
(N
, Standard_Boolean
);
1273 -- Cases where we cannot make runtime call
1275 -- For (a <= b) we convert to not (a > b)
1277 if Chars
(N
) = Name_Op_Le
then
1283 Right_Opnd
=> Op2
)));
1284 Analyze_And_Resolve
(N
, Standard_Boolean
);
1287 -- For < the Boolean expression is
1288 -- greater__nn (op2, op1)
1290 elsif Chars
(N
) = Name_Op_Lt
then
1291 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1295 Op1
:= Right_Opnd
(N
);
1296 Op2
:= Left_Opnd
(N
);
1298 -- For (a >= b) we convert to not (a < b)
1300 elsif Chars
(N
) = Name_Op_Ge
then
1306 Right_Opnd
=> Op2
)));
1307 Analyze_And_Resolve
(N
, Standard_Boolean
);
1310 -- For > the Boolean expression is
1311 -- greater__nn (op1, op2)
1314 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1315 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1318 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1320 Make_Function_Call
(Loc
,
1321 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1322 Parameter_Associations
=> New_List
(Op1
, Op2
));
1324 Insert_Action
(N
, Func_Body
);
1326 Analyze_And_Resolve
(N
, Standard_Boolean
);
1327 end Expand_Array_Comparison
;
1329 ---------------------------
1330 -- Expand_Array_Equality --
1331 ---------------------------
1333 -- Expand an equality function for multi-dimensional arrays. Here is an
1334 -- example of such a function for Nb_Dimension = 2
1336 -- function Enn (A : atyp; B : btyp) return boolean is
1338 -- if (A'length (1) = 0 or else A'length (2) = 0)
1340 -- (B'length (1) = 0 or else B'length (2) = 0)
1342 -- return true; -- RM 4.5.2(22)
1345 -- if A'length (1) /= B'length (1)
1347 -- A'length (2) /= B'length (2)
1349 -- return false; -- RM 4.5.2(23)
1353 -- A1 : Index_T1 := A'first (1);
1354 -- B1 : Index_T1 := B'first (1);
1358 -- A2 : Index_T2 := A'first (2);
1359 -- B2 : Index_T2 := B'first (2);
1362 -- if A (A1, A2) /= B (B1, B2) then
1366 -- exit when A2 = A'last (2);
1367 -- A2 := Index_T2'succ (A2);
1368 -- B2 := Index_T2'succ (B2);
1372 -- exit when A1 = A'last (1);
1373 -- A1 := Index_T1'succ (A1);
1374 -- B1 := Index_T1'succ (B1);
1381 -- Note on the formal types used (atyp and btyp). If either of the arrays
1382 -- is of a private type, we use the underlying type, and do an unchecked
1383 -- conversion of the actual. If either of the arrays has a bound depending
1384 -- on a discriminant, then we use the base type since otherwise we have an
1385 -- escaped discriminant in the function.
1387 -- If both arrays are constrained and have the same bounds, we can generate
1388 -- a loop with an explicit iteration scheme using a 'Range attribute over
1391 function Expand_Array_Equality
1396 Typ
: Entity_Id
) return Node_Id
1398 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1399 Decls
: constant List_Id
:= New_List
;
1400 Index_List1
: constant List_Id
:= New_List
;
1401 Index_List2
: constant List_Id
:= New_List
;
1403 First_Idx
: Node_Id
;
1405 Func_Name
: Entity_Id
;
1406 Func_Body
: Node_Id
;
1408 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1409 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1413 -- The parameter types to be used for the formals
1417 -- The LHS and RHS converted to the parameter types
1422 Dim
: Pos
) return Node_Id
;
1423 -- This builds the attribute reference Arr'Nam (Dim)
1425 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1426 -- Create one statement to compare corresponding components, designated
1427 -- by a full set of indexes.
1429 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1430 -- Given one of the arguments, computes the appropriate type to be used
1431 -- for that argument in the corresponding function formal
1433 function Handle_One_Dimension
1435 Index
: Node_Id
) return Node_Id
;
1436 -- This procedure returns the following code
1439 -- An : Index_T := A'First (N);
1440 -- Bn : Index_T := B'First (N);
1444 -- exit when An = A'Last (N);
1445 -- An := Index_T'Succ (An)
1446 -- Bn := Index_T'Succ (Bn)
1450 -- If both indexes are constrained and identical, the procedure
1451 -- returns a simpler loop:
1453 -- for An in A'Range (N) loop
1457 -- N is the dimension for which we are generating a loop. Index is the
1458 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1459 -- xxx statement is either the loop or declare for the next dimension
1460 -- or if this is the last dimension the comparison of corresponding
1461 -- components of the arrays.
1463 -- The actual way the code works is to return the comparison of
1464 -- corresponding components for the N+1 call. That's neater.
1466 function Test_Empty_Arrays
return Node_Id
;
1467 -- This function constructs the test for both arrays being empty
1468 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1470 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1472 function Test_Lengths_Correspond
return Node_Id
;
1473 -- This function constructs the test for arrays having different lengths
1474 -- in at least one index position, in which case the resulting code is:
1476 -- A'length (1) /= B'length (1)
1478 -- A'length (2) /= B'length (2)
1489 Dim
: Pos
) return Node_Id
1493 Make_Attribute_Reference
(Loc
,
1494 Attribute_Name
=> Nam
,
1495 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1496 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
1499 ------------------------
1500 -- Component_Equality --
1501 ------------------------
1503 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1508 -- if a(i1...) /= b(j1...) then return false; end if;
1511 Make_Indexed_Component
(Loc
,
1512 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1513 Expressions
=> Index_List1
);
1516 Make_Indexed_Component
(Loc
,
1517 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1518 Expressions
=> Index_List2
);
1520 Test
:= Expand_Composite_Equality
1521 (Outer_Type
=> Typ
, Nod
=> Nod
, Comp_Type
=> Component_Type
(Typ
),
1522 Lhs
=> L
, Rhs
=> R
);
1524 -- If some (sub)component is an unchecked_union, the whole operation
1525 -- will raise program error.
1527 if Nkind
(Test
) = N_Raise_Program_Error
then
1529 -- This node is going to be inserted at a location where a
1530 -- statement is expected: clear its Etype so analysis will set
1531 -- it to the expected Standard_Void_Type.
1533 Set_Etype
(Test
, Empty
);
1538 Make_Implicit_If_Statement
(Nod
,
1539 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1540 Then_Statements
=> New_List
(
1541 Make_Simple_Return_Statement
(Loc
,
1542 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1544 end Component_Equality
;
1550 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1561 T
:= Underlying_Type
(T
);
1563 X
:= First_Index
(T
);
1564 while Present
(X
) loop
1565 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1567 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1580 --------------------------
1581 -- Handle_One_Dimension --
1582 ---------------------------
1584 function Handle_One_Dimension
1586 Index
: Node_Id
) return Node_Id
1588 Need_Separate_Indexes
: constant Boolean :=
1589 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1590 -- If the index types are identical, and we are working with
1591 -- constrained types, then we can use the same index for both
1594 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1597 Index_T
: Entity_Id
;
1602 if N
> Number_Dimensions
(Ltyp
) then
1603 return Component_Equality
(Ltyp
);
1606 -- Case where we generate a loop
1608 Index_T
:= Base_Type
(Etype
(Index
));
1610 if Need_Separate_Indexes
then
1611 Bn
:= Make_Temporary
(Loc
, 'B');
1616 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1617 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1619 Stm_List
:= New_List
(
1620 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1622 if Need_Separate_Indexes
then
1624 -- Generate guard for loop, followed by increments of indexes
1626 Append_To
(Stm_List
,
1627 Make_Exit_Statement
(Loc
,
1630 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1631 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1633 Append_To
(Stm_List
,
1634 Make_Assignment_Statement
(Loc
,
1635 Name
=> New_Occurrence_Of
(An
, Loc
),
1637 Make_Attribute_Reference
(Loc
,
1638 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1639 Attribute_Name
=> Name_Succ
,
1640 Expressions
=> New_List
(
1641 New_Occurrence_Of
(An
, Loc
)))));
1643 Append_To
(Stm_List
,
1644 Make_Assignment_Statement
(Loc
,
1645 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1647 Make_Attribute_Reference
(Loc
,
1648 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1649 Attribute_Name
=> Name_Succ
,
1650 Expressions
=> New_List
(
1651 New_Occurrence_Of
(Bn
, Loc
)))));
1654 -- If separate indexes, we need a declare block for An and Bn, and a
1655 -- loop without an iteration scheme.
1657 if Need_Separate_Indexes
then
1659 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1662 Make_Block_Statement
(Loc
,
1663 Declarations
=> New_List
(
1664 Make_Object_Declaration
(Loc
,
1665 Defining_Identifier
=> An
,
1666 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1667 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1669 Make_Object_Declaration
(Loc
,
1670 Defining_Identifier
=> Bn
,
1671 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1672 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1674 Handled_Statement_Sequence
=>
1675 Make_Handled_Sequence_Of_Statements
(Loc
,
1676 Statements
=> New_List
(Loop_Stm
)));
1678 -- If no separate indexes, return loop statement with explicit
1679 -- iteration scheme on its own.
1683 Make_Implicit_Loop_Statement
(Nod
,
1684 Statements
=> Stm_List
,
1686 Make_Iteration_Scheme
(Loc
,
1687 Loop_Parameter_Specification
=>
1688 Make_Loop_Parameter_Specification
(Loc
,
1689 Defining_Identifier
=> An
,
1690 Discrete_Subtype_Definition
=>
1691 Arr_Attr
(A
, Name_Range
, N
))));
1694 end Handle_One_Dimension
;
1696 -----------------------
1697 -- Test_Empty_Arrays --
1698 -----------------------
1700 function Test_Empty_Arrays
return Node_Id
is
1701 Alist
: Node_Id
:= Empty
;
1702 Blist
: Node_Id
:= Empty
;
1705 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1706 Evolve_Or_Else
(Alist
,
1708 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1709 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
1711 Evolve_Or_Else
(Blist
,
1713 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1714 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
1720 Right_Opnd
=> Blist
);
1721 end Test_Empty_Arrays
;
1723 -----------------------------
1724 -- Test_Lengths_Correspond --
1725 -----------------------------
1727 function Test_Lengths_Correspond
return Node_Id
is
1728 Result
: Node_Id
:= Empty
;
1731 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1732 Evolve_Or_Else
(Result
,
1734 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1735 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
)));
1739 end Test_Lengths_Correspond
;
1741 -- Start of processing for Expand_Array_Equality
1744 Ltyp
:= Get_Arg_Type
(Lhs
);
1745 Rtyp
:= Get_Arg_Type
(Rhs
);
1747 -- For now, if the argument types are not the same, go to the base type,
1748 -- since the code assumes that the formals have the same type. This is
1749 -- fixable in future ???
1751 if Ltyp
/= Rtyp
then
1752 Ltyp
:= Base_Type
(Ltyp
);
1753 Rtyp
:= Base_Type
(Rtyp
);
1756 -- If the array type is distinct from the type of the arguments, it
1757 -- is the full view of a private type. Apply an unchecked conversion
1758 -- to ensure that analysis of the code below succeeds.
1761 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1763 New_Lhs
:= OK_Convert_To
(Ltyp
, Lhs
);
1769 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1771 New_Rhs
:= OK_Convert_To
(Rtyp
, Rhs
);
1776 pragma Assert
(Ltyp
= Rtyp
);
1777 First_Idx
:= First_Index
(Ltyp
);
1779 -- If optimization is enabled and the array boils down to a couple of
1780 -- consecutive elements, generate a simple conjunction of comparisons
1781 -- which should be easier to optimize by the code generator.
1783 if Optimization_Level
> 0
1784 and then Is_Constrained
(Ltyp
)
1785 and then Number_Dimensions
(Ltyp
) = 1
1786 and then Compile_Time_Known_Bounds
(Ltyp
)
1787 and then Expr_Value
(Type_High_Bound
(Etype
(First_Idx
))) =
1788 Expr_Value
(Type_Low_Bound
(Etype
(First_Idx
))) + 1
1791 Ctyp
: constant Entity_Id
:= Component_Type
(Ltyp
);
1792 Low_B
: constant Node_Id
:=
1793 Type_Low_Bound
(Etype
(First_Idx
));
1794 High_B
: constant Node_Id
:=
1795 Type_High_Bound
(Etype
(First_Idx
));
1797 TestL
, TestH
: Node_Id
;
1801 Make_Indexed_Component
(Loc
,
1802 Prefix
=> New_Copy_Tree
(New_Lhs
),
1803 Expressions
=> New_List
(New_Copy_Tree
(Low_B
)));
1806 Make_Indexed_Component
(Loc
,
1807 Prefix
=> New_Copy_Tree
(New_Rhs
),
1808 Expressions
=> New_List
(New_Copy_Tree
(Low_B
)));
1810 TestL
:= Expand_Composite_Equality
1811 (Outer_Type
=> Ltyp
, Nod
=> Nod
, Comp_Type
=> Ctyp
,
1812 Lhs
=> L
, Rhs
=> R
);
1815 Make_Indexed_Component
(Loc
,
1817 Expressions
=> New_List
(New_Copy_Tree
(High_B
)));
1820 Make_Indexed_Component
(Loc
,
1822 Expressions
=> New_List
(New_Copy_Tree
(High_B
)));
1824 TestH
:= Expand_Composite_Equality
1825 (Outer_Type
=> Ltyp
, Nod
=> Nod
, Comp_Type
=> Ctyp
,
1826 Lhs
=> L
, Rhs
=> R
);
1829 Make_And_Then
(Loc
, Left_Opnd
=> TestL
, Right_Opnd
=> TestH
);
1833 -- Build list of formals for function
1835 Formals
:= New_List
(
1836 Make_Parameter_Specification
(Loc
,
1837 Defining_Identifier
=> A
,
1838 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
1840 Make_Parameter_Specification
(Loc
,
1841 Defining_Identifier
=> B
,
1842 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
1844 Func_Name
:= Make_Temporary
(Loc
, 'E');
1846 -- Build statement sequence for function
1849 Make_Subprogram_Body
(Loc
,
1851 Make_Function_Specification
(Loc
,
1852 Defining_Unit_Name
=> Func_Name
,
1853 Parameter_Specifications
=> Formals
,
1854 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1856 Declarations
=> Decls
,
1858 Handled_Statement_Sequence
=>
1859 Make_Handled_Sequence_Of_Statements
(Loc
,
1860 Statements
=> New_List
(
1862 Make_Implicit_If_Statement
(Nod
,
1863 Condition
=> Test_Empty_Arrays
,
1864 Then_Statements
=> New_List
(
1865 Make_Simple_Return_Statement
(Loc
,
1867 New_Occurrence_Of
(Standard_True
, Loc
)))),
1869 Make_Implicit_If_Statement
(Nod
,
1870 Condition
=> Test_Lengths_Correspond
,
1871 Then_Statements
=> New_List
(
1872 Make_Simple_Return_Statement
(Loc
,
1873 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
1875 Handle_One_Dimension
(1, First_Idx
),
1877 Make_Simple_Return_Statement
(Loc
,
1878 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1880 Set_Has_Completion
(Func_Name
, True);
1881 Set_Is_Inlined
(Func_Name
);
1883 Append_To
(Bodies
, Func_Body
);
1886 Make_Function_Call
(Loc
,
1887 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1888 Parameter_Associations
=> New_List
(New_Lhs
, New_Rhs
));
1889 end Expand_Array_Equality
;
1891 -----------------------------
1892 -- Expand_Boolean_Operator --
1893 -----------------------------
1895 -- Note that we first get the actual subtypes of the operands, since we
1896 -- always want to deal with types that have bounds.
1898 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
1899 Typ
: constant Entity_Id
:= Etype
(N
);
1902 -- Special case of bit packed array where both operands are known to be
1903 -- properly aligned. In this case we use an efficient run time routine
1904 -- to carry out the operation (see System.Bit_Ops).
1906 if Is_Bit_Packed_Array
(Typ
)
1907 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
1908 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
1910 Expand_Packed_Boolean_Operator
(N
);
1914 -- For the normal non-packed case, the general expansion is to build
1915 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1916 -- and then inserting it into the tree. The original operator node is
1917 -- then rewritten as a call to this function. We also use this in the
1918 -- packed case if either operand is a possibly unaligned object.
1921 Loc
: constant Source_Ptr
:= Sloc
(N
);
1922 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
1923 R
: Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
1924 Func_Body
: Node_Id
;
1925 Func_Name
: Entity_Id
;
1928 Convert_To_Actual_Subtype
(L
);
1929 Convert_To_Actual_Subtype
(R
);
1930 Ensure_Defined
(Etype
(L
), N
);
1931 Ensure_Defined
(Etype
(R
), N
);
1932 Apply_Length_Check
(R
, Etype
(L
));
1934 if Nkind
(N
) = N_Op_Xor
then
1935 R
:= Duplicate_Subexpr
(R
);
1936 Silly_Boolean_Array_Xor_Test
(N
, R
, Etype
(L
));
1939 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1940 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
1942 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
1944 elsif Nkind
(Parent
(N
)) = N_Op_Not
1945 and then Nkind
(N
) = N_Op_And
1946 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
1947 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
1951 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
1952 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1953 Insert_Action
(N
, Func_Body
);
1955 -- Now rewrite the expression with a call
1957 if Transform_Function_Array
then
1959 Temp_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
1968 Make_Object_Declaration
(Loc
,
1969 Defining_Identifier
=> Temp_Id
,
1970 Object_Definition
=>
1971 New_Occurrence_Of
(Etype
(L
), Loc
));
1974 -- Proc_Call (L, R, Temp);
1977 Make_Procedure_Call_Statement
(Loc
,
1978 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1979 Parameter_Associations
=>
1982 Make_Type_Conversion
1983 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
),
1984 New_Occurrence_Of
(Temp_Id
, Loc
)));
1986 Insert_Actions
(Parent
(N
), New_List
(Decl
, Call
));
1987 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1991 Make_Function_Call
(Loc
,
1992 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1993 Parameter_Associations
=>
1996 Make_Type_Conversion
1997 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2000 Analyze_And_Resolve
(N
, Typ
);
2003 end Expand_Boolean_Operator
;
2005 ------------------------------------------------
2006 -- Expand_Compare_Minimize_Eliminate_Overflow --
2007 ------------------------------------------------
2009 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2010 Loc
: constant Source_Ptr
:= Sloc
(N
);
2012 Result_Type
: constant Entity_Id
:= Etype
(N
);
2013 -- Capture result type (could be a derived boolean type)
2018 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2019 -- Entity for Long_Long_Integer'Base
2022 procedure Set_False
;
2023 -- These procedures rewrite N with an occurrence of Standard_True or
2024 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2030 procedure Set_False
is
2032 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2033 Warn_On_Known_Condition
(N
);
2040 procedure Set_True
is
2042 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2043 Warn_On_Known_Condition
(N
);
2046 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2049 -- OK, this is the case we are interested in. First step is to process
2050 -- our operands using the Minimize_Eliminate circuitry which applies
2051 -- this processing to the two operand subtrees.
2053 Minimize_Eliminate_Overflows
2054 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2055 Minimize_Eliminate_Overflows
2056 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2058 -- See if the range information decides the result of the comparison.
2059 -- We can only do this if we in fact have full range information (which
2060 -- won't be the case if either operand is bignum at this stage).
2062 if Present
(Llo
) and then Present
(Rlo
) then
2063 case N_Op_Compare
(Nkind
(N
)) is
2065 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2067 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2074 elsif Lhi
< Rlo
then
2081 elsif Lhi
<= Rlo
then
2088 elsif Lhi
<= Rlo
then
2095 elsif Lhi
< Rlo
then
2100 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2102 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2107 -- All done if we did the rewrite
2109 if Nkind
(N
) not in N_Op_Compare
then
2114 -- Otherwise, time to do the comparison
2117 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2118 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2121 -- If the two operands have the same signed integer type we are
2122 -- all set, nothing more to do. This is the case where either
2123 -- both operands were unchanged, or we rewrote both of them to
2124 -- be Long_Long_Integer.
2126 -- Note: Entity for the comparison may be wrong, but it's not worth
2127 -- the effort to change it, since the back end does not use it.
2129 if Is_Signed_Integer_Type
(Ltype
)
2130 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2134 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2136 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2138 Left
: Node_Id
:= Left_Opnd
(N
);
2139 Right
: Node_Id
:= Right_Opnd
(N
);
2140 -- Bignum references for left and right operands
2143 if not Is_RTE
(Ltype
, RE_Bignum
) then
2144 Left
:= Convert_To_Bignum
(Left
);
2145 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2146 Right
:= Convert_To_Bignum
(Right
);
2149 -- We rewrite our node with:
2152 -- Bnn : Result_Type;
2154 -- M : Mark_Id := SS_Mark;
2156 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2164 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2165 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2169 case N_Op_Compare
(Nkind
(N
)) is
2170 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2171 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2172 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2173 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2174 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2175 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2178 -- Insert assignment to Bnn into the bignum block
2181 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2182 Make_Assignment_Statement
(Loc
,
2183 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2185 Make_Function_Call
(Loc
,
2187 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2188 Parameter_Associations
=> New_List
(Left
, Right
))));
2190 -- Now do the rewrite with expression actions
2193 Make_Expression_With_Actions
(Loc
,
2194 Actions
=> New_List
(
2195 Make_Object_Declaration
(Loc
,
2196 Defining_Identifier
=> Bnn
,
2197 Object_Definition
=>
2198 New_Occurrence_Of
(Result_Type
, Loc
)),
2200 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2201 Analyze_And_Resolve
(N
, Result_Type
);
2205 -- No bignums involved, but types are different, so we must have
2206 -- rewritten one of the operands as a Long_Long_Integer but not
2209 -- If left operand is Long_Long_Integer, convert right operand
2210 -- and we are done (with a comparison of two Long_Long_Integers).
2212 elsif Ltype
= LLIB
then
2213 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2214 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2217 -- If right operand is Long_Long_Integer, convert left operand
2218 -- and we are done (with a comparison of two Long_Long_Integers).
2220 -- This is the only remaining possibility
2222 else pragma Assert
(Rtype
= LLIB
);
2223 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2224 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2228 end Expand_Compare_Minimize_Eliminate_Overflow
;
2230 -------------------------------
2231 -- Expand_Composite_Equality --
2232 -------------------------------
2234 -- This function is only called for comparing internal fields of composite
2235 -- types when these fields are themselves composites. This is a special
2236 -- case because it is not possible to respect normal Ada visibility rules.
2238 function Expand_Composite_Equality
2239 (Outer_Type
: Entity_Id
;
2241 Comp_Type
: Entity_Id
;
2243 Rhs
: Node_Id
) return Node_Id
2245 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2246 Full_Type
: Entity_Id
;
2250 if Is_Private_Type
(Comp_Type
) then
2251 Full_Type
:= Underlying_Type
(Comp_Type
);
2253 Full_Type
:= Comp_Type
;
2256 -- If the private type has no completion the context may be the
2257 -- expansion of a composite equality for a composite type with some
2258 -- still incomplete components. The expression will not be analyzed
2259 -- until the enclosing type is completed, at which point this will be
2260 -- properly expanded, unless there is a bona fide completion error.
2262 if No
(Full_Type
) then
2263 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2266 Full_Type
:= Base_Type
(Full_Type
);
2268 -- When the base type itself is private, use the full view to expand
2269 -- the composite equality.
2271 if Is_Private_Type
(Full_Type
) then
2272 Full_Type
:= Underlying_Type
(Full_Type
);
2275 -- Case of tagged record types
2277 if Is_Tagged_Type
(Full_Type
) then
2278 Eq_Op
:= Find_Primitive_Eq
(Comp_Type
);
2279 pragma Assert
(Present
(Eq_Op
));
2282 Make_Function_Call
(Loc
,
2283 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2284 Parameter_Associations
=>
2286 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2287 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2289 -- Case of untagged record types
2291 elsif Is_Record_Type
(Full_Type
) then
2292 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2294 if Present
(Eq_Op
) then
2295 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2297 -- Inherited equality from parent type. Convert the actuals to
2298 -- match signature of operation.
2301 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2305 Make_Function_Call
(Loc
,
2306 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2307 Parameter_Associations
=> New_List
(
2308 OK_Convert_To
(T
, Lhs
),
2309 OK_Convert_To
(T
, Rhs
)));
2313 -- Comparison between Unchecked_Union components
2315 if Is_Unchecked_Union
(Full_Type
) then
2317 Lhs_Type
: Node_Id
:= Full_Type
;
2318 Rhs_Type
: Node_Id
:= Full_Type
;
2319 Lhs_Discr_Val
: Node_Id
;
2320 Rhs_Discr_Val
: Node_Id
;
2325 if Nkind
(Lhs
) = N_Selected_Component
then
2326 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2331 if Nkind
(Rhs
) = N_Selected_Component
then
2332 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2335 -- Lhs of the composite equality
2337 if Is_Constrained
(Lhs_Type
) then
2339 -- Since the enclosing record type can never be an
2340 -- Unchecked_Union (this code is executed for records
2341 -- that do not have variants), we may reference its
2344 if Nkind
(Lhs
) = N_Selected_Component
2345 and then Has_Per_Object_Constraint
2346 (Entity
(Selector_Name
(Lhs
)))
2349 Make_Selected_Component
(Loc
,
2350 Prefix
=> Prefix
(Lhs
),
2353 (Get_Discriminant_Value
2354 (First_Discriminant
(Lhs_Type
),
2356 Stored_Constraint
(Lhs_Type
))));
2361 (Get_Discriminant_Value
2362 (First_Discriminant
(Lhs_Type
),
2364 Stored_Constraint
(Lhs_Type
)));
2368 -- It is not possible to infer the discriminant since
2369 -- the subtype is not constrained.
2372 Make_Raise_Program_Error
(Loc
,
2373 Reason
=> PE_Unchecked_Union_Restriction
);
2376 -- Rhs of the composite equality
2378 if Is_Constrained
(Rhs_Type
) then
2379 if Nkind
(Rhs
) = N_Selected_Component
2380 and then Has_Per_Object_Constraint
2381 (Entity
(Selector_Name
(Rhs
)))
2384 Make_Selected_Component
(Loc
,
2385 Prefix
=> Prefix
(Rhs
),
2388 (Get_Discriminant_Value
2389 (First_Discriminant
(Rhs_Type
),
2391 Stored_Constraint
(Rhs_Type
))));
2396 (Get_Discriminant_Value
2397 (First_Discriminant
(Rhs_Type
),
2399 Stored_Constraint
(Rhs_Type
)));
2404 Make_Raise_Program_Error
(Loc
,
2405 Reason
=> PE_Unchecked_Union_Restriction
);
2408 -- Call the TSS equality function with the inferred
2409 -- discriminant values.
2412 Make_Function_Call
(Loc
,
2413 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2414 Parameter_Associations
=> New_List
(
2421 -- All cases other than comparing Unchecked_Union types
2425 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2428 Make_Function_Call
(Loc
,
2430 New_Occurrence_Of
(Eq_Op
, Loc
),
2431 Parameter_Associations
=> New_List
(
2432 OK_Convert_To
(T
, Lhs
),
2433 OK_Convert_To
(T
, Rhs
)));
2438 -- Equality composes in Ada 2012 for untagged record types. It also
2439 -- composes for bounded strings, because they are part of the
2440 -- predefined environment (see 4.5.2(32.1/1)). We could make it
2441 -- compose for bounded strings by making them tagged, or by making
2442 -- sure all subcomponents are set to the same value, even when not
2443 -- used. Instead, we have this special case in the compiler, because
2444 -- it's more efficient.
2446 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Comp_Type
)
2448 -- If no TSS has been created for the type, check whether there is
2449 -- a primitive equality declared for it.
2452 Op
: constant Node_Id
:=
2453 Build_Eq_Call
(Comp_Type
, Loc
, Lhs
, Rhs
);
2456 -- Use user-defined primitive if it exists, otherwise use
2457 -- predefined equality.
2459 if Present
(Op
) then
2462 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2467 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
);
2470 -- Case of non-record types (always use predefined equality)
2473 -- Print a warning if there is a user-defined "=", because it can be
2474 -- surprising that the predefined "=" takes precedence over it.
2476 -- Suppress the warning if the "user-defined" one is in the
2477 -- predefined library, because those are defined to compose
2478 -- properly by RM-4.5.2(32.1/1). Intrinsics also compose.
2481 Op
: constant Entity_Id
:= Find_Primitive_Eq
(Comp_Type
);
2483 if Warn_On_Ignored_Equality
2484 and then Present
(Op
)
2485 and then not In_Predefined_Unit
(Base_Type
(Comp_Type
))
2486 and then not Is_Intrinsic_Subprogram
(Op
)
2489 (Is_First_Subtype
(Outer_Type
)
2490 or else Is_Generic_Actual_Type
(Outer_Type
));
2491 Error_Msg_Node_1
:= Outer_Type
;
2492 Error_Msg_Node_2
:= Comp_Type
;
2494 ("?_q?""="" for type & uses predefined ""="" for }", Loc
);
2495 Error_Msg_Sloc
:= Sloc
(Op
);
2496 Error_Msg
("\?_q?""="" # is ignored here", Loc
);
2500 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2502 end Expand_Composite_Equality
;
2504 ------------------------
2505 -- Expand_Concatenate --
2506 ------------------------
2508 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2509 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2511 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2512 -- Result type of concatenation
2514 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2515 -- Component type. Elements of this component type can appear as one
2516 -- of the operands of concatenation as well as arrays.
2518 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2521 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2522 -- Index type. This is the base type of the index subtype, and is used
2523 -- for all computed bounds (which may be out of range of Istyp in the
2524 -- case of null ranges).
2527 -- This is the type we use to do arithmetic to compute the bounds and
2528 -- lengths of operands. The choice of this type is a little subtle and
2529 -- is discussed in a separate section at the start of the body code.
2531 Result_May_Be_Null
: Boolean := True;
2532 -- Reset to False if at least one operand is encountered which is known
2533 -- at compile time to be non-null. Used for handling the special case
2534 -- of setting the high bound to the last operand high bound for a null
2535 -- result, thus ensuring a proper high bound in the super-flat case.
2537 N
: constant Nat
:= List_Length
(Opnds
);
2538 -- Number of concatenation operands including possibly null operands
2541 -- Number of operands excluding any known to be null, except that the
2542 -- last operand is always retained, in case it provides the bounds for
2545 Opnd
: Node_Id
:= Empty
;
2546 -- Current operand being processed in the loop through operands. After
2547 -- this loop is complete, always contains the last operand (which is not
2548 -- the same as Operands (NN), since null operands are skipped).
2550 -- Arrays describing the operands, only the first NN entries of each
2551 -- array are set (NN < N when we exclude known null operands).
2553 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2554 -- True if length of corresponding operand known at compile time
2556 Operands
: array (1 .. N
) of Node_Id
;
2557 -- Set to the corresponding entry in the Opnds list (but note that null
2558 -- operands are excluded, so not all entries in the list are stored).
2560 Fixed_Length
: array (1 .. N
) of Unat
;
2561 -- Set to length of operand. Entries in this array are set only if the
2562 -- corresponding entry in Is_Fixed_Length is True.
2564 Max_Length
: array (1 .. N
) of Unat
;
2565 -- Set to the maximum length of operand, or Too_Large_Length_For_Array
2566 -- if it is not known. Entries in this array are set only if the
2567 -- corresponding entry in Is_Fixed_Length is False;
2569 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2570 -- Set to lower bound of operand. Either an integer literal in the case
2571 -- where the bound is known at compile time, else actual lower bound.
2572 -- The operand low bound is of type Ityp.
2574 Var_Length
: array (1 .. N
) of Entity_Id
;
2575 -- Set to an entity of type Natural that contains the length of an
2576 -- operand whose length is not known at compile time. Entries in this
2577 -- array are set only if the corresponding entry in Is_Fixed_Length
2578 -- is False. The entity is of type Artyp.
2580 Aggr_Length
: array (0 .. N
) of Node_Id
;
2581 -- The J'th entry is an expression node that represents the total length
2582 -- of operands 1 through J. It is either an integer literal node, or a
2583 -- reference to a constant entity with the right value, so it is fine
2584 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth
2585 -- entry always is set to zero. The length is of type Artyp.
2587 Max_Aggr_Length
: Unat
:= Too_Large_Length_For_Array
;
2588 -- Set to the maximum total length, or Too_Large_Length_For_Array at
2589 -- least if it is not known.
2591 Low_Bound
: Node_Id
:= Empty
;
2592 -- A tree node representing the low bound of the result (of type Ityp).
2593 -- This is either an integer literal node, or an identifier reference to
2594 -- a constant entity initialized to the appropriate value.
2596 High_Bound
: Node_Id
:= Empty
;
2597 -- A tree node representing the high bound of the result (of type Ityp)
2599 Last_Opnd_Low_Bound
: Node_Id
:= Empty
;
2600 -- A tree node representing the low bound of the last operand. This
2601 -- need only be set if the result could be null. It is used for the
2602 -- special case of setting the right low bound for a null result.
2603 -- This is of type Ityp.
2605 Last_Opnd_High_Bound
: Node_Id
:= Empty
;
2606 -- A tree node representing the high bound of the last operand. This
2607 -- need only be set if the result could be null. It is used for the
2608 -- special case of setting the right high bound for a null result.
2609 -- This is of type Ityp.
2611 Result
: Node_Id
:= Empty
;
2612 -- Result of the concatenation (of type Ityp)
2614 Actions
: constant List_Id
:= New_List
;
2615 -- Collect actions to be inserted
2617 Known_Non_Null_Operand_Seen
: Boolean;
2618 -- Set True during generation of the assignments of operands into
2619 -- result once an operand known to be non-null has been seen.
2621 function Library_Level_Target
return Boolean;
2622 -- Return True if the concatenation is within the expression of the
2623 -- declaration of a library-level object.
2625 function Make_Artyp_Literal
(Val
: Uint
) return Node_Id
;
2626 -- This function makes an N_Integer_Literal node that is returned in
2627 -- analyzed form with the type set to Artyp. Importantly this literal
2628 -- is not flagged as static, so that if we do computations with it that
2629 -- result in statically detected out of range conditions, we will not
2630 -- generate error messages but instead warning messages.
2632 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2633 -- Given a node of type Ityp, returns the corresponding value of type
2634 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2635 -- For enum types, the Pos of the value is returned.
2637 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2638 -- The inverse function (uses Val in the case of enumeration types)
2640 --------------------------
2641 -- Library_Level_Target --
2642 --------------------------
2644 function Library_Level_Target
return Boolean is
2645 P
: Node_Id
:= Parent
(Cnode
);
2648 while Present
(P
) loop
2649 if Nkind
(P
) = N_Object_Declaration
then
2650 return Is_Library_Level_Entity
(Defining_Identifier
(P
));
2652 -- Prevent the search from going too far
2654 elsif Is_Body_Or_Package_Declaration
(P
) then
2662 end Library_Level_Target
;
2664 ------------------------
2665 -- Make_Artyp_Literal --
2666 ------------------------
2668 function Make_Artyp_Literal
(Val
: Uint
) return Node_Id
is
2669 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2671 Set_Etype
(Result
, Artyp
);
2672 Set_Analyzed
(Result
, True);
2673 Set_Is_Static_Expression
(Result
, False);
2675 end Make_Artyp_Literal
;
2681 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2683 if Ityp
= Base_Type
(Artyp
) then
2686 elsif Is_Enumeration_Type
(Ityp
) then
2688 Make_Attribute_Reference
(Loc
,
2689 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2690 Attribute_Name
=> Name_Pos
,
2691 Expressions
=> New_List
(X
));
2694 return Convert_To
(Artyp
, X
);
2702 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2704 if Is_Enumeration_Type
(Ityp
) then
2706 Make_Attribute_Reference
(Loc
,
2707 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2708 Attribute_Name
=> Name_Val
,
2709 Expressions
=> New_List
(X
));
2711 -- Case where we will do a type conversion
2714 if Ityp
= Base_Type
(Artyp
) then
2717 return Convert_To
(Ityp
, X
);
2722 -- Local Declarations
2724 Opnd_Typ
: Entity_Id
;
2725 Slice_Rng
: Entity_Id
;
2726 Subtyp_Ind
: Entity_Id
;
2733 -- Start of processing for Expand_Concatenate
2736 -- Choose an appropriate computational type
2738 -- We will be doing calculations of lengths and bounds in this routine
2739 -- and computing one from the other in some cases, e.g. getting the high
2740 -- bound by adding the length-1 to the low bound.
2742 -- We can't just use the index type, or even its base type for this
2743 -- purpose for two reasons. First it might be an enumeration type which
2744 -- is not suitable for computations of any kind, and second it may
2745 -- simply not have enough range. For example if the index type is
2746 -- -128..+127 then lengths can be up to 256, which is out of range of
2749 -- For enumeration types, we can simply use Standard_Integer, this is
2750 -- sufficient since the actual number of enumeration literals cannot
2751 -- possibly exceed the range of integer (remember we will be doing the
2752 -- arithmetic with POS values, not representation values).
2754 if Is_Enumeration_Type
(Ityp
) then
2755 Artyp
:= Standard_Integer
;
2757 -- For modular types, we use a 32-bit modular type for types whose size
2758 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2759 -- identity type, and for larger unsigned types we use a 64-bit type.
2761 elsif Is_Modular_Integer_Type
(Ityp
) then
2762 if RM_Size
(Ityp
) < Standard_Integer_Size
then
2763 Artyp
:= Standard_Unsigned
;
2764 elsif RM_Size
(Ityp
) = Standard_Integer_Size
then
2767 Artyp
:= Standard_Long_Long_Unsigned
;
2770 -- Similar treatment for signed types
2773 if RM_Size
(Ityp
) < Standard_Integer_Size
then
2774 Artyp
:= Standard_Integer
;
2775 elsif RM_Size
(Ityp
) = Standard_Integer_Size
then
2778 Artyp
:= Standard_Long_Long_Integer
;
2782 -- Supply dummy entry at start of length array
2784 Aggr_Length
(0) := Make_Artyp_Literal
(Uint_0
);
2786 -- Go through operands setting up the above arrays
2790 Opnd
:= Remove_Head
(Opnds
);
2791 Opnd_Typ
:= Etype
(Opnd
);
2793 -- The parent got messed up when we put the operands in a list,
2794 -- so now put back the proper parent for the saved operand, that
2795 -- is to say the concatenation node, to make sure that each operand
2796 -- is seen as a subexpression, e.g. if actions must be inserted.
2798 Set_Parent
(Opnd
, Cnode
);
2800 -- Set will be True when we have setup one entry in the array
2804 -- Singleton element (or character literal) case
2806 if Base_Type
(Opnd_Typ
) = Ctyp
then
2808 Operands
(NN
) := Opnd
;
2809 Is_Fixed_Length
(NN
) := True;
2810 Fixed_Length
(NN
) := Uint_1
;
2811 Result_May_Be_Null
:= False;
2813 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2814 -- since we know that the result cannot be null).
2816 Opnd_Low_Bound
(NN
) :=
2817 Make_Attribute_Reference
(Loc
,
2818 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
2819 Attribute_Name
=> Name_First
);
2823 -- String literal case (can only occur for strings of course)
2825 elsif Nkind
(Opnd
) = N_String_Literal
then
2826 Len
:= String_Literal_Length
(Opnd_Typ
);
2829 Result_May_Be_Null
:= False;
2832 -- Capture last operand low and high bound if result could be null
2834 if J
= N
and then Result_May_Be_Null
then
2835 Last_Opnd_Low_Bound
:=
2836 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2838 Last_Opnd_High_Bound
:=
2839 Make_Op_Subtract
(Loc
,
2841 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
2842 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
2845 -- Skip null string literal
2847 if J
< N
and then Len
= 0 then
2852 Operands
(NN
) := Opnd
;
2853 Is_Fixed_Length
(NN
) := True;
2855 -- Set length and bounds
2857 Fixed_Length
(NN
) := Len
;
2859 Opnd_Low_Bound
(NN
) :=
2860 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2867 -- Check constrained case with known bounds
2869 if Is_Constrained
(Opnd_Typ
)
2870 and then Compile_Time_Known_Bounds
(Opnd_Typ
)
2876 -- Fixed length constrained array type with known at compile
2877 -- time bounds is last case of fixed length operand.
2879 Get_First_Index_Bounds
(Opnd_Typ
, Lo
, Hi
);
2880 Len
:= UI_Max
(Hi
- Lo
+ 1, Uint_0
);
2883 Result_May_Be_Null
:= False;
2886 -- Capture last operand bounds if result could be null
2888 if J
= N
and then Result_May_Be_Null
then
2889 Last_Opnd_Low_Bound
:=
2890 To_Ityp
(Make_Integer_Literal
(Loc
, Lo
));
2892 Last_Opnd_High_Bound
:=
2893 To_Ityp
(Make_Integer_Literal
(Loc
, Hi
));
2896 -- Exclude null length case unless last operand
2898 if J
< N
and then Len
= 0 then
2903 Operands
(NN
) := Opnd
;
2904 Is_Fixed_Length
(NN
) := True;
2905 Fixed_Length
(NN
) := Len
;
2907 Opnd_Low_Bound
(NN
) :=
2908 To_Ityp
(Make_Integer_Literal
(Loc
, Lo
));
2913 -- All cases where the length is not known at compile time, or the
2914 -- special case of an operand which is known to be null but has a
2915 -- lower bound other than 1 or is other than a string type.
2920 -- Capture operand bounds
2922 Opnd_Low_Bound
(NN
) :=
2923 Make_Attribute_Reference
(Loc
,
2925 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2926 Attribute_Name
=> Name_First
);
2928 -- Capture last operand bounds if result could be null
2930 if J
= N
and Result_May_Be_Null
then
2931 Last_Opnd_Low_Bound
:=
2933 Make_Attribute_Reference
(Loc
,
2935 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2936 Attribute_Name
=> Name_First
));
2938 Last_Opnd_High_Bound
:=
2940 Make_Attribute_Reference
(Loc
,
2942 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2943 Attribute_Name
=> Name_Last
));
2946 -- Capture length of operand in entity
2948 Operands
(NN
) := Opnd
;
2949 Is_Fixed_Length
(NN
) := False;
2951 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
2953 -- If the operand is a slice, try to compute an upper bound for
2956 if Nkind
(Opnd
) = N_Slice
2957 and then Is_Constrained
(Etype
(Prefix
(Opnd
)))
2958 and then Compile_Time_Known_Bounds
(Etype
(Prefix
(Opnd
)))
2964 Get_First_Index_Bounds
(Etype
(Prefix
(Opnd
)), Lo
, Hi
);
2965 Max_Length
(NN
) := UI_Max
(Hi
- Lo
+ 1, Uint_0
);
2969 Max_Length
(NN
) := Too_Large_Length_For_Array
;
2973 Make_Object_Declaration
(Loc
,
2974 Defining_Identifier
=> Var_Length
(NN
),
2975 Constant_Present
=> True,
2976 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
2978 Make_Attribute_Reference
(Loc
,
2980 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2981 Attribute_Name
=> Name_Length
)));
2985 -- Set next entry in aggregate length array
2987 -- For first entry, make either integer literal for fixed length
2988 -- or a reference to the saved length for variable length.
2991 if Is_Fixed_Length
(1) then
2992 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
2993 Max_Aggr_Length
:= Fixed_Length
(1);
2995 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
2996 Max_Aggr_Length
:= Max_Length
(1);
2999 -- If entry is fixed length and only fixed lengths so far, make
3000 -- appropriate new integer literal adding new length.
3002 elsif Is_Fixed_Length
(NN
)
3003 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3006 Make_Integer_Literal
(Loc
,
3007 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3008 Max_Aggr_Length
:= Intval
(Aggr_Length
(NN
));
3010 -- All other cases, construct an addition node for the length and
3011 -- create an entity initialized to this length.
3014 Ent
:= Make_Temporary
(Loc
, 'L');
3016 if Is_Fixed_Length
(NN
) then
3017 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3018 Max_Aggr_Length
:= Max_Aggr_Length
+ Fixed_Length
(NN
);
3021 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3022 Max_Aggr_Length
:= Max_Aggr_Length
+ Max_Length
(NN
);
3026 Make_Object_Declaration
(Loc
,
3027 Defining_Identifier
=> Ent
,
3028 Constant_Present
=> True,
3029 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3032 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
- 1)),
3033 Right_Opnd
=> Clen
)));
3035 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3042 -- If we have only skipped null operands, return the last operand
3049 -- If we have only one non-null operand, return it and we are done.
3050 -- There is one case in which this cannot be done, and that is when
3051 -- the sole operand is of the element type, in which case it must be
3052 -- converted to an array, and the easiest way of doing that is to go
3053 -- through the normal general circuit.
3055 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3056 Result
:= Operands
(1);
3060 -- Cases where we have a real concatenation
3062 -- Next step is to find the low bound for the result array that we
3063 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3065 -- If the ultimate ancestor of the index subtype is a constrained array
3066 -- definition, then the lower bound is that of the index subtype as
3067 -- specified by (RM 4.5.3(6)).
3069 -- The right test here is to go to the root type, and then the ultimate
3070 -- ancestor is the first subtype of this root type.
3072 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3074 Make_Attribute_Reference
(Loc
,
3076 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3077 Attribute_Name
=> Name_First
);
3079 -- If the first operand in the list has known length we know that
3080 -- the lower bound of the result is the lower bound of this operand.
3082 elsif Is_Fixed_Length
(1) then
3083 Low_Bound
:= Opnd_Low_Bound
(1);
3085 -- OK, we don't know the lower bound, we have to build a horrible
3086 -- if expression node of the form
3088 -- if Cond1'Length /= 0 then
3091 -- if Opnd2'Length /= 0 then
3096 -- The nesting ends either when we hit an operand whose length is known
3097 -- at compile time, or on reaching the last operand, whose low bound we
3098 -- take unconditionally whether or not it is null. It's easiest to do
3099 -- this with a recursive procedure:
3103 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3104 -- Returns the lower bound determined by operands J .. NN
3106 ---------------------
3107 -- Get_Known_Bound --
3108 ---------------------
3110 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3112 if Is_Fixed_Length
(J
) or else J
= NN
then
3113 return New_Copy_Tree
(Opnd_Low_Bound
(J
));
3117 Make_If_Expression
(Loc
,
3118 Expressions
=> New_List
(
3122 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3124 Make_Integer_Literal
(Loc
, 0)),
3126 New_Copy_Tree
(Opnd_Low_Bound
(J
)),
3127 Get_Known_Bound
(J
+ 1)));
3129 end Get_Known_Bound
;
3132 Ent
:= Make_Temporary
(Loc
, 'L');
3135 Make_Object_Declaration
(Loc
,
3136 Defining_Identifier
=> Ent
,
3137 Constant_Present
=> True,
3138 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3139 Expression
=> Get_Known_Bound
(1)));
3141 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3145 pragma Assert
(Present
(Low_Bound
));
3147 -- Now we can compute the high bound as Low_Bound + Length - 1
3149 if Compile_Time_Known_Value
(Low_Bound
)
3150 and then Nkind
(Aggr_Length
(NN
)) = N_Integer_Literal
3155 (Expr_Value
(Low_Bound
) + Intval
(Aggr_Length
(NN
)) - 1));
3161 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3163 Make_Op_Subtract
(Loc
,
3164 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3165 Right_Opnd
=> Make_Artyp_Literal
(Uint_1
))));
3167 -- Note that calculation of the high bound may cause overflow in some
3168 -- very weird cases, so in the general case we need an overflow check
3169 -- on the high bound. We can avoid this for the common case of string
3170 -- types and other types whose index is Positive, since we chose a
3171 -- wider range for the arithmetic type. If checks are suppressed, we
3172 -- do not set the flag so superfluous warnings may be omitted.
3174 if Istyp
/= Standard_Positive
3175 and then not Overflow_Checks_Suppressed
(Istyp
)
3177 Activate_Overflow_Check
(High_Bound
);
3181 -- Handle the exceptional case where the result is null, in which case
3182 -- case the bounds come from the last operand (so that we get the proper
3183 -- bounds if the last operand is super-flat).
3185 if Result_May_Be_Null
then
3187 Make_If_Expression
(Loc
,
3188 Expressions
=> New_List
(
3190 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3191 Right_Opnd
=> Make_Artyp_Literal
(Uint_0
)),
3192 Last_Opnd_Low_Bound
,
3196 Make_If_Expression
(Loc
,
3197 Expressions
=> New_List
(
3199 Left_Opnd
=> New_Copy_Tree
(Aggr_Length
(NN
)),
3200 Right_Opnd
=> Make_Artyp_Literal
(Uint_0
)),
3201 Last_Opnd_High_Bound
,
3205 -- Here is where we insert the saved up actions
3207 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3209 -- If the low bound is known at compile time and not the high bound, but
3210 -- we have computed a sensible upper bound for the length, then adjust
3211 -- the high bound for the subtype of the array. This will change it into
3212 -- a static subtype and thus help the code generator.
3214 if Compile_Time_Known_Value
(Low_Bound
)
3215 and then not Compile_Time_Known_Value
(High_Bound
)
3216 and then Max_Aggr_Length
< Too_Large_Length_For_Array
3219 Known_High_Bound
: constant Node_Id
:=
3222 (Expr_Value
(Low_Bound
) + Max_Aggr_Length
- 1));
3225 if not Is_Out_Of_Range
(Known_High_Bound
, Ityp
) then
3226 Slice_Rng
:= Make_Range
(Loc
, Low_Bound
, High_Bound
);
3227 High_Bound
:= Known_High_Bound
;
3238 -- Now we construct an array object with appropriate bounds. We mark
3239 -- the target as internal to prevent useless initialization when
3240 -- Initialize_Scalars is enabled. Also since this is the actual result
3241 -- entity, we make sure we have debug information for the result.
3244 Make_Subtype_Indication
(Loc
,
3245 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3247 Make_Index_Or_Discriminant_Constraint
(Loc
,
3248 Constraints
=> New_List
(
3250 Low_Bound
=> Low_Bound
,
3251 High_Bound
=> High_Bound
))));
3253 Ent
:= Make_Temporary
(Loc
, 'S');
3254 Set_Is_Internal
(Ent
);
3255 Set_Debug_Info_Needed
(Ent
);
3257 -- If we are concatenating strings and the current scope already uses
3258 -- the secondary stack, allocate the result also on the secondary stack
3259 -- to avoid putting too much pressure on the primary stack.
3261 -- Don't do this if -gnatd.h is set, as this will break the wrapping of
3262 -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat.
3264 if Atyp
= Standard_String
3265 and then Uses_Sec_Stack
(Current_Scope
)
3266 and then RTE_Available
(RE_SS_Pool
)
3267 and then not Debug_Flag_Dot_H
3270 -- subtype Axx is String (<low-bound> .. <high-bound>)
3271 -- type Ayy is access Axx;
3272 -- Rxx : Ayy := new <Axx> [storage_pool = ss_pool];
3273 -- Sxx : Axx renames Rxx.all;
3276 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3277 Acc_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
3283 Insert_Action
(Cnode
,
3284 Make_Subtype_Declaration
(Loc
,
3285 Defining_Identifier
=> ConstrT
,
3286 Subtype_Indication
=> Subtyp_Ind
),
3287 Suppress
=> All_Checks
);
3289 Freeze_Itype
(ConstrT
, Cnode
);
3291 Insert_Action
(Cnode
,
3292 Make_Full_Type_Declaration
(Loc
,
3293 Defining_Identifier
=> Acc_Typ
,
3295 Make_Access_To_Object_Definition
(Loc
,
3296 Subtype_Indication
=> New_Occurrence_Of
(ConstrT
, Loc
))),
3297 Suppress
=> All_Checks
);
3299 Mutate_Ekind
(Acc_Typ
, E_Access_Type
);
3300 Set_Associated_Storage_Pool
(Acc_Typ
, RTE
(RE_SS_Pool
));
3303 Make_Allocator
(Loc
,
3304 Expression
=> New_Occurrence_Of
(ConstrT
, Loc
));
3306 -- This is currently done only for type String, which normally
3307 -- doesn't have default initialization, but we need to set the
3308 -- No_Initialization flag in case of either Initialize_Scalars
3309 -- or Normalize_Scalars.
3311 Set_No_Initialization
(Alloc
);
3313 Temp
:= Make_Temporary
(Loc
, 'R', Alloc
);
3314 Insert_Action
(Cnode
,
3315 Make_Object_Declaration
(Loc
,
3316 Defining_Identifier
=> Temp
,
3317 Object_Definition
=> New_Occurrence_Of
(Acc_Typ
, Loc
),
3318 Expression
=> Alloc
),
3319 Suppress
=> All_Checks
);
3321 Insert_Action
(Cnode
,
3322 Make_Object_Renaming_Declaration
(Loc
,
3323 Defining_Identifier
=> Ent
,
3324 Subtype_Mark
=> New_Occurrence_Of
(ConstrT
, Loc
),
3326 Make_Explicit_Dereference
(Loc
,
3327 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
3328 Suppress
=> All_Checks
);
3332 -- If the bound is statically known to be out of range, we do not
3333 -- want to abort, we want a warning and a runtime constraint error.
3334 -- Note that we have arranged that the result will not be treated
3335 -- as a static constant, so we won't get an illegality during this
3336 -- insertion. We also enable checks (in particular range checks) in
3337 -- case the bounds of Subtyp_Ind are out of range.
3339 Insert_Action
(Cnode
,
3340 Make_Object_Declaration
(Loc
,
3341 Defining_Identifier
=> Ent
,
3342 Object_Definition
=> Subtyp_Ind
));
3345 -- If the result of the concatenation appears as the initializing
3346 -- expression of an object declaration, we can just rename the
3347 -- result, rather than copying it.
3349 Set_OK_To_Rename
(Ent
);
3351 -- Catch the static out of range case now
3353 if Raises_Constraint_Error
(High_Bound
)
3354 or else Is_Out_Of_Range
(High_Bound
, Ityp
)
3356 -- Kill warning generated for the declaration of the static out of
3357 -- range high bound, and instead generate a Constraint_Error with
3358 -- an appropriate specific message.
3360 if Nkind
(High_Bound
) = N_Integer_Literal
then
3361 Kill_Dead_Code
(High_Bound
);
3362 Rewrite
(High_Bound
, New_Copy_Tree
(Low_Bound
));
3365 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3368 Apply_Compile_Time_Constraint_Error
3370 Msg
=> "concatenation result upper bound out of range??",
3371 Reason
=> CE_Range_Check_Failed
);
3376 -- Now we will generate the assignments to do the actual concatenation
3378 -- There is one case in which we will not do this, namely when all the
3379 -- following conditions are met:
3381 -- The result type is Standard.String
3383 -- There are nine or fewer retained (non-null) operands
3385 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3386 -- and the debug flag gnatd.c is not set.
3388 -- The corresponding System.Concat_n.Str_Concat_n routine is
3389 -- available in the run time.
3391 -- If all these conditions are met then we generate a call to the
3392 -- relevant concatenation routine. The purpose of this is to avoid
3393 -- undesirable code bloat at -O0.
3395 -- If the concatenation is within the declaration of a library-level
3396 -- object, we call the built-in concatenation routines to prevent code
3397 -- bloat, regardless of the optimization level. This is space efficient
3398 -- and prevents linking problems when units are compiled with different
3399 -- optimization levels.
3401 if Atyp
= Standard_String
3402 and then NN
in 2 .. 9
3403 and then (((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3404 and then not Debug_Flag_Dot_C
)
3405 or else Library_Level_Target
)
3408 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3419 if RTE_Available
(RR
(NN
)) then
3421 Opnds
: constant List_Id
:=
3422 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3425 for J
in 1 .. NN
loop
3426 if Is_List_Member
(Operands
(J
)) then
3427 Remove
(Operands
(J
));
3430 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3432 Make_Aggregate
(Loc
,
3433 Component_Associations
=> New_List
(
3434 Make_Component_Association
(Loc
,
3435 Choices
=> New_List
(
3436 Make_Integer_Literal
(Loc
, 1)),
3437 Expression
=> Operands
(J
)))));
3440 Append_To
(Opnds
, Operands
(J
));
3444 Insert_Action
(Cnode
,
3445 Make_Procedure_Call_Statement
(Loc
,
3446 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3447 Parameter_Associations
=> Opnds
));
3449 -- No assignments left to do below
3457 -- Not special case so generate the assignments
3459 Known_Non_Null_Operand_Seen
:= False;
3461 for J
in 1 .. NN
loop
3463 Lo
: constant Node_Id
:=
3465 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3466 Right_Opnd
=> Aggr_Length
(J
- 1));
3468 Hi
: constant Node_Id
:=
3470 Left_Opnd
=> To_Artyp
(New_Copy_Tree
(Low_Bound
)),
3472 Make_Op_Subtract
(Loc
,
3473 Left_Opnd
=> Aggr_Length
(J
),
3474 Right_Opnd
=> Make_Artyp_Literal
(Uint_1
)));
3477 -- Singleton case, simple assignment
3479 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3480 Known_Non_Null_Operand_Seen
:= True;
3481 Insert_Action
(Cnode
,
3482 Make_Assignment_Statement
(Loc
,
3484 Make_Indexed_Component
(Loc
,
3485 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3486 Expressions
=> New_List
(To_Ityp
(Lo
))),
3487 Expression
=> Operands
(J
)),
3488 Suppress
=> All_Checks
);
3490 -- Array case, slice assignment, skipped when argument is fixed
3491 -- length and known to be null.
3493 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3496 Make_Assignment_Statement
(Loc
,
3500 New_Occurrence_Of
(Ent
, Loc
),
3503 Low_Bound
=> To_Ityp
(Lo
),
3504 High_Bound
=> To_Ityp
(Hi
))),
3505 Expression
=> Operands
(J
));
3507 if Is_Fixed_Length
(J
) then
3508 Known_Non_Null_Operand_Seen
:= True;
3510 elsif not Known_Non_Null_Operand_Seen
then
3512 -- Here if operand length is not statically known and no
3513 -- operand known to be non-null has been processed yet.
3514 -- If operand length is 0, we do not need to perform the
3515 -- assignment, and we must avoid the evaluation of the
3516 -- high bound of the slice, since it may underflow if the
3517 -- low bound is Ityp'First.
3520 Make_Implicit_If_Statement
(Cnode
,
3524 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3525 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3526 Then_Statements
=> New_List
(Assign
));
3529 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3535 -- Finally we build the result, which is either a direct reference to
3536 -- the array object or a slice of it.
3538 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3540 if Present
(Slice_Rng
) then
3541 Result
:= Make_Slice
(Loc
, Result
, Slice_Rng
);
3545 pragma Assert
(Present
(Result
));
3546 Rewrite
(Cnode
, Result
);
3547 Analyze_And_Resolve
(Cnode
, Atyp
);
3548 end Expand_Concatenate
;
3550 ---------------------------------------------------
3551 -- Expand_Membership_Minimize_Eliminate_Overflow --
3552 ---------------------------------------------------
3554 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3555 pragma Assert
(Nkind
(N
) = N_In
);
3556 -- Despite the name, this routine applies only to N_In, not to
3557 -- N_Not_In. The latter is always rewritten as not (X in Y).
3559 Result_Type
: constant Entity_Id
:= Etype
(N
);
3560 -- Capture result type, may be a derived boolean type
3562 Loc
: constant Source_Ptr
:= Sloc
(N
);
3563 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3564 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3566 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3567 -- is thus tempting to capture these values, but due to the rewrites
3568 -- that occur as a result of overflow checking, these values change
3569 -- as we go along, and it is safe just to always use Etype explicitly.
3571 Restype
: constant Entity_Id
:= Etype
(N
);
3575 -- Bounds in Minimize calls, not used currently
3577 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3578 -- Entity for Long_Long_Integer'Base
3581 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3583 -- If right operand is a subtype name, and the subtype name has no
3584 -- predicate, then we can just replace the right operand with an
3585 -- explicit range T'First .. T'Last, and use the explicit range code.
3587 if Nkind
(Rop
) /= N_Range
3588 and then No
(Predicate_Function
(Etype
(Rop
)))
3591 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3596 Make_Attribute_Reference
(Loc
,
3597 Attribute_Name
=> Name_First
,
3598 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3600 Make_Attribute_Reference
(Loc
,
3601 Attribute_Name
=> Name_Last
,
3602 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3603 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3607 -- Here for the explicit range case. Note that the bounds of the range
3608 -- have not been processed for minimized or eliminated checks.
3610 if Nkind
(Rop
) = N_Range
then
3611 Minimize_Eliminate_Overflows
3612 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3613 Minimize_Eliminate_Overflows
3614 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3616 -- We have A in B .. C, treated as A >= B and then A <= C
3620 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3621 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3622 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3625 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3626 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3627 L
: constant Entity_Id
:=
3628 Make_Defining_Identifier
(Loc
, Name_uL
);
3629 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3630 Lbound
: constant Node_Id
:=
3631 Convert_To_Bignum
(Low_Bound
(Rop
));
3632 Hbound
: constant Node_Id
:=
3633 Convert_To_Bignum
(High_Bound
(Rop
));
3635 -- Now we rewrite the membership test node to look like
3638 -- Bnn : Result_Type;
3640 -- M : Mark_Id := SS_Mark;
3641 -- L : Bignum := Lopnd;
3643 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3651 -- Insert declaration of L into declarations of bignum block
3654 (Last
(Declarations
(Blk
)),
3655 Make_Object_Declaration
(Loc
,
3656 Defining_Identifier
=> L
,
3657 Object_Definition
=>
3658 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3659 Expression
=> Lopnd
));
3661 -- Insert assignment to Bnn into expressions of bignum block
3664 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3665 Make_Assignment_Statement
(Loc
,
3666 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3670 Make_Function_Call
(Loc
,
3672 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3673 Parameter_Associations
=> New_List
(
3674 New_Occurrence_Of
(L
, Loc
),
3678 Make_Function_Call
(Loc
,
3680 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3681 Parameter_Associations
=> New_List
(
3682 New_Occurrence_Of
(L
, Loc
),
3685 -- Now rewrite the node
3688 Make_Expression_With_Actions
(Loc
,
3689 Actions
=> New_List
(
3690 Make_Object_Declaration
(Loc
,
3691 Defining_Identifier
=> Bnn
,
3692 Object_Definition
=>
3693 New_Occurrence_Of
(Result_Type
, Loc
)),
3695 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3696 Analyze_And_Resolve
(N
, Result_Type
);
3700 -- Here if no bignums around
3703 -- Case where types are all the same
3705 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3707 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3711 -- If types are not all the same, it means that we have rewritten
3712 -- at least one of them to be of type Long_Long_Integer, and we
3713 -- will convert the other operands to Long_Long_Integer.
3716 Convert_To_And_Rewrite
(LLIB
, Lop
);
3717 Set_Analyzed
(Lop
, False);
3718 Analyze_And_Resolve
(Lop
, LLIB
);
3720 -- For the right operand, avoid unnecessary recursion into
3721 -- this routine, we know that overflow is not possible.
3723 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3724 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3725 Set_Analyzed
(Rop
, False);
3726 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3729 -- Now the three operands are of the same signed integer type,
3730 -- so we can use the normal expansion routine for membership,
3731 -- setting the flag to prevent recursion into this procedure.
3733 Set_No_Minimize_Eliminate
(N
);
3737 -- Right operand is a subtype name and the subtype has a predicate. We
3738 -- have to make sure the predicate is checked, and for that we need to
3739 -- use the standard N_In circuitry with appropriate types.
3742 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3744 -- If types are "right", just call Expand_N_In preventing recursion
3746 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3747 Set_No_Minimize_Eliminate
(N
);
3752 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3754 -- For X in T, we want to rewrite our node as
3757 -- Bnn : Result_Type;
3760 -- M : Mark_Id := SS_Mark;
3761 -- Lnn : Long_Long_Integer'Base
3767 -- if not Bignum_In_LLI_Range (Nnn) then
3770 -- Lnn := From_Bignum (Nnn);
3772 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3773 -- and then T'Base (Lnn) in T;
3782 -- A bit gruesome, but there doesn't seem to be a simpler way
3785 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3786 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3787 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3788 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3789 T
: constant Entity_Id
:= Etype
(Rop
);
3790 TB
: constant Entity_Id
:= Base_Type
(T
);
3794 -- Mark the last membership operation to prevent recursion
3798 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3799 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3800 Set_No_Minimize_Eliminate
(Nin
);
3802 -- Now decorate the block
3805 (Last
(Declarations
(Blk
)),
3806 Make_Object_Declaration
(Loc
,
3807 Defining_Identifier
=> Lnn
,
3808 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3811 (Last
(Declarations
(Blk
)),
3812 Make_Object_Declaration
(Loc
,
3813 Defining_Identifier
=> Nnn
,
3814 Object_Definition
=>
3815 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3818 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3820 Make_Assignment_Statement
(Loc
,
3821 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3822 Expression
=> Relocate_Node
(Lop
)),
3824 Make_Implicit_If_Statement
(N
,
3828 Make_Function_Call
(Loc
,
3831 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3832 Parameter_Associations
=> New_List
(
3833 New_Occurrence_Of
(Nnn
, Loc
)))),
3835 Then_Statements
=> New_List
(
3836 Make_Assignment_Statement
(Loc
,
3837 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3839 New_Occurrence_Of
(Standard_False
, Loc
))),
3841 Else_Statements
=> New_List
(
3842 Make_Assignment_Statement
(Loc
,
3843 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3845 Make_Function_Call
(Loc
,
3847 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3848 Parameter_Associations
=> New_List
(
3849 New_Occurrence_Of
(Nnn
, Loc
)))),
3851 Make_Assignment_Statement
(Loc
,
3852 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3857 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3862 Make_Attribute_Reference
(Loc
,
3863 Attribute_Name
=> Name_First
,
3865 New_Occurrence_Of
(TB
, Loc
))),
3869 Make_Attribute_Reference
(Loc
,
3870 Attribute_Name
=> Name_Last
,
3872 New_Occurrence_Of
(TB
, Loc
))))),
3874 Right_Opnd
=> Nin
))))));
3876 -- Now we can do the rewrite
3879 Make_Expression_With_Actions
(Loc
,
3880 Actions
=> New_List
(
3881 Make_Object_Declaration
(Loc
,
3882 Defining_Identifier
=> Bnn
,
3883 Object_Definition
=>
3884 New_Occurrence_Of
(Result_Type
, Loc
)),
3886 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3887 Analyze_And_Resolve
(N
, Result_Type
);
3891 -- Not bignum case, but types don't match (this means we rewrote the
3892 -- left operand to be Long_Long_Integer).
3895 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
3897 -- We rewrite the membership test as (where T is the type with
3898 -- the predicate, i.e. the type of the right operand)
3900 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3901 -- and then T'Base (Lop) in T
3904 T
: constant Entity_Id
:= Etype
(Rop
);
3905 TB
: constant Entity_Id
:= Base_Type
(T
);
3909 -- The last membership test is marked to prevent recursion
3913 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
3914 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3915 Set_No_Minimize_Eliminate
(Nin
);
3917 -- Now do the rewrite
3928 Make_Attribute_Reference
(Loc
,
3929 Attribute_Name
=> Name_First
,
3931 New_Occurrence_Of
(TB
, Loc
))),
3934 Make_Attribute_Reference
(Loc
,
3935 Attribute_Name
=> Name_Last
,
3937 New_Occurrence_Of
(TB
, Loc
))))),
3938 Right_Opnd
=> Nin
));
3939 Set_Analyzed
(N
, False);
3940 Analyze_And_Resolve
(N
, Restype
);
3944 end Expand_Membership_Minimize_Eliminate_Overflow
;
3946 ---------------------------------
3947 -- Expand_Nonbinary_Modular_Op --
3948 ---------------------------------
3950 procedure Expand_Nonbinary_Modular_Op
(N
: Node_Id
) is
3951 Loc
: constant Source_Ptr
:= Sloc
(N
);
3952 Typ
: constant Entity_Id
:= Etype
(N
);
3954 procedure Expand_Modular_Addition
;
3955 -- Expand the modular addition, handling the special case of adding a
3958 procedure Expand_Modular_Op
;
3959 -- Compute the general rule: (lhs OP rhs) mod Modulus
3961 procedure Expand_Modular_Subtraction
;
3962 -- Expand the modular addition, handling the special case of subtracting
3965 -----------------------------
3966 -- Expand_Modular_Addition --
3967 -----------------------------
3969 procedure Expand_Modular_Addition
is
3971 -- If this is not the addition of a constant then compute it using
3972 -- the general rule: (lhs + rhs) mod Modulus
3974 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
3977 -- If this is an addition of a constant, convert it to a subtraction
3978 -- plus a conditional expression since we can compute it faster than
3979 -- computing the modulus.
3981 -- modMinusRhs = Modulus - rhs
3982 -- if lhs < modMinusRhs then lhs + rhs
3983 -- else lhs - modMinusRhs
3987 Mod_Minus_Right
: constant Uint
:=
3988 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
3990 Cond_Expr
: Node_Id
;
3991 Then_Expr
: Node_Id
;
3992 Else_Expr
: Node_Id
;
3994 -- To prevent spurious visibility issues, convert all
3995 -- operands to Standard.Unsigned.
4000 Unchecked_Convert_To
(Standard_Unsigned
,
4001 New_Copy_Tree
(Left_Opnd
(N
))),
4003 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4008 Unchecked_Convert_To
(Standard_Unsigned
,
4009 New_Copy_Tree
(Left_Opnd
(N
))),
4011 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4014 Make_Op_Subtract
(Loc
,
4016 Unchecked_Convert_To
(Standard_Unsigned
,
4017 New_Copy_Tree
(Left_Opnd
(N
))),
4019 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4022 Unchecked_Convert_To
(Typ
,
4023 Make_If_Expression
(Loc
,
4025 New_List
(Cond_Expr
, Then_Expr
, Else_Expr
))));
4028 end Expand_Modular_Addition
;
4030 -----------------------
4031 -- Expand_Modular_Op --
4032 -----------------------
4034 procedure Expand_Modular_Op
is
4035 -- We will convert to another type (not a nonbinary-modulus modular
4036 -- type), evaluate the op in that representation, reduce the result,
4037 -- and convert back to the original type. This means that the
4038 -- backend does not have to deal with nonbinary-modulus ops.
4040 Op_Expr
: constant Node_Id
:= New_Op_Node
(Nkind
(N
), Loc
);
4043 Target_Type
: Entity_Id
;
4045 -- Select a target type that is large enough to avoid spurious
4046 -- intermediate overflow on pre-reduction computation (for
4047 -- correctness) but is no larger than is needed (for performance).
4050 Required_Size
: Uint
:= RM_Size
(Etype
(N
));
4051 Use_Unsigned
: Boolean := True;
4055 -- For example, if modulus is 255 then RM_Size will be 8
4056 -- and the range of possible values (before reduction) will
4057 -- be 0 .. 508; that range requires 9 bits.
4058 Required_Size
:= Required_Size
+ 1;
4060 when N_Op_Subtract
=>
4061 -- For example, if modulus is 255 then RM_Size will be 8
4062 -- and the range of possible values (before reduction) will
4063 -- be -254 .. 254; that range requires 9 bits, signed.
4064 Use_Unsigned
:= False;
4065 Required_Size
:= Required_Size
+ 1;
4067 when N_Op_Multiply
=>
4068 -- For example, if modulus is 255 then RM_Size will be 8
4069 -- and the range of possible values (before reduction) will
4070 -- be 0 .. 64,516; that range requires 16 bits.
4071 Required_Size
:= Required_Size
* 2;
4077 if Use_Unsigned
then
4078 if Required_Size
<= Standard_Short_Short_Integer_Size
then
4079 Target_Type
:= Standard_Short_Short_Unsigned
;
4080 elsif Required_Size
<= Standard_Short_Integer_Size
then
4081 Target_Type
:= Standard_Short_Unsigned
;
4082 elsif Required_Size
<= Standard_Integer_Size
then
4083 Target_Type
:= Standard_Unsigned
;
4085 pragma Assert
(Required_Size
<= 64);
4086 Target_Type
:= Standard_Unsigned_64
;
4088 elsif Required_Size
<= 8 then
4089 Target_Type
:= Standard_Integer_8
;
4090 elsif Required_Size
<= 16 then
4091 Target_Type
:= Standard_Integer_16
;
4092 elsif Required_Size
<= 32 then
4093 Target_Type
:= Standard_Integer_32
;
4095 pragma Assert
(Required_Size
<= 64);
4096 Target_Type
:= Standard_Integer_64
;
4099 pragma Assert
(Present
(Target_Type
));
4102 Set_Left_Opnd
(Op_Expr
,
4103 Unchecked_Convert_To
(Target_Type
,
4104 New_Copy_Tree
(Left_Opnd
(N
))));
4105 Set_Right_Opnd
(Op_Expr
,
4106 Unchecked_Convert_To
(Target_Type
,
4107 New_Copy_Tree
(Right_Opnd
(N
))));
4109 -- ??? Why do this stuff for some ops and not others?
4110 if Nkind
(N
) not in N_Op_And | N_Op_Or | N_Op_Xor
then
4112 -- Link this node to the tree to analyze it
4114 -- If the parent node is an expression with actions we link it to
4115 -- N since otherwise Force_Evaluation cannot identify if this node
4116 -- comes from the Expression and rejects generating the temporary.
4118 if Nkind
(Parent
(N
)) = N_Expression_With_Actions
then
4119 Set_Parent
(Op_Expr
, N
);
4124 Set_Parent
(Op_Expr
, Parent
(N
));
4129 -- Force generating a temporary because in the expansion of this
4130 -- expression we may generate code that performs this computation
4133 Force_Evaluation
(Op_Expr
, Mode
=> Strict
);
4138 Left_Opnd
=> Op_Expr
,
4139 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modulus
(Typ
)));
4142 Unchecked_Convert_To
(Typ
, Mod_Expr
));
4143 end Expand_Modular_Op
;
4145 --------------------------------
4146 -- Expand_Modular_Subtraction --
4147 --------------------------------
4149 procedure Expand_Modular_Subtraction
is
4151 -- If this is not the addition of a constant then compute it using
4152 -- the general rule: (lhs + rhs) mod Modulus
4154 if Nkind
(Right_Opnd
(N
)) /= N_Integer_Literal
then
4157 -- If this is an addition of a constant, convert it to a subtraction
4158 -- plus a conditional expression since we can compute it faster than
4159 -- computing the modulus.
4161 -- modMinusRhs = Modulus - rhs
4162 -- if lhs < rhs then lhs + modMinusRhs
4167 Mod_Minus_Right
: constant Uint
:=
4168 Modulus
(Typ
) - Intval
(Right_Opnd
(N
));
4170 Cond_Expr
: Node_Id
;
4171 Then_Expr
: Node_Id
;
4172 Else_Expr
: Node_Id
;
4177 Unchecked_Convert_To
(Standard_Unsigned
,
4178 New_Copy_Tree
(Left_Opnd
(N
))),
4180 Make_Integer_Literal
(Loc
, Intval
(Right_Opnd
(N
))));
4185 Unchecked_Convert_To
(Standard_Unsigned
,
4186 New_Copy_Tree
(Left_Opnd
(N
))),
4188 Make_Integer_Literal
(Loc
, Mod_Minus_Right
));
4191 Make_Op_Subtract
(Loc
,
4193 Unchecked_Convert_To
(Standard_Unsigned
,
4194 New_Copy_Tree
(Left_Opnd
(N
))),
4196 Unchecked_Convert_To
(Standard_Unsigned
,
4197 New_Copy_Tree
(Right_Opnd
(N
))));
4200 Unchecked_Convert_To
(Typ
,
4201 Make_If_Expression
(Loc
,
4203 New_List
(Cond_Expr
, Then_Expr
, Else_Expr
))));
4206 end Expand_Modular_Subtraction
;
4208 -- Start of processing for Expand_Nonbinary_Modular_Op
4211 -- No action needed if front-end expansion is not required or if we
4212 -- have a binary modular operand.
4214 if not Expand_Nonbinary_Modular_Ops
4215 or else not Non_Binary_Modulus
(Typ
)
4222 Expand_Modular_Addition
;
4224 when N_Op_Subtract
=>
4225 Expand_Modular_Subtraction
;
4229 -- Expand -expr into (0 - expr)
4232 Make_Op_Subtract
(Loc
,
4233 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
4234 Right_Opnd
=> Right_Opnd
(N
)));
4235 Analyze_And_Resolve
(N
, Typ
);
4241 Analyze_And_Resolve
(N
, Typ
);
4242 end Expand_Nonbinary_Modular_Op
;
4244 ------------------------
4245 -- Expand_N_Allocator --
4246 ------------------------
4248 procedure Expand_N_Allocator
(N
: Node_Id
) is
4249 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
4250 Loc
: constant Source_Ptr
:= Sloc
(N
);
4251 PtrT
: constant Entity_Id
:= Etype
(N
);
4253 procedure Rewrite_Coextension
(N
: Node_Id
);
4254 -- Static coextensions have the same lifetime as the entity they
4255 -- constrain. Such occurrences can be rewritten as aliased objects
4256 -- and their unrestricted access used instead of the coextension.
4258 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
4259 -- Given a constrained array type E, returns a node representing the
4260 -- code to compute a close approximation of the size in storage elements
4261 -- for the given type; for indexes that are modular types we compute
4262 -- 'Last - First (instead of 'Length) because for large arrays computing
4263 -- 'Last -'First + 1 causes overflow. This is done without using the
4264 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4267 -------------------------
4268 -- Rewrite_Coextension --
4269 -------------------------
4271 procedure Rewrite_Coextension
(N
: Node_Id
) is
4272 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
4273 Temp_Decl
: Node_Id
;
4277 -- Cnn : aliased Etyp;
4280 Make_Object_Declaration
(Loc
,
4281 Defining_Identifier
=> Temp_Id
,
4282 Aliased_Present
=> True,
4283 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
4285 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4286 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
4289 Insert_Action
(N
, Temp_Decl
);
4291 Make_Attribute_Reference
(Loc
,
4292 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
4293 Attribute_Name
=> Name_Unrestricted_Access
));
4295 Analyze_And_Resolve
(N
, PtrT
);
4296 end Rewrite_Coextension
;
4298 ------------------------------
4299 -- Size_In_Storage_Elements --
4300 ------------------------------
4302 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
4303 Idx
: Node_Id
:= First_Index
(E
);
4305 Res
: Node_Id
:= Empty
;
4308 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4309 -- However, the reason for the existence of this function is to
4310 -- construct a test for sizes too large, which means near the 32-bit
4311 -- limit on a 32-bit machine, and precisely the trouble is that we
4312 -- get overflows when sizes are greater than 2**31.
4314 -- So what we end up doing for array types is to use the expression:
4316 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4318 -- which avoids this problem. All this is a bit bogus, but it does
4319 -- mean we catch common cases of trying to allocate arrays that are
4320 -- too large, and which in the absence of a check results in
4321 -- undetected chaos ???
4323 for J
in 1 .. Number_Dimensions
(E
) loop
4325 if not Is_Modular_Integer_Type
(Etype
(Idx
)) then
4327 Make_Attribute_Reference
(Loc
,
4328 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4329 Attribute_Name
=> Name_Length
,
4330 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4332 -- For indexes that are modular types we cannot generate code to
4333 -- compute 'Length since for large arrays 'Last -'First + 1 causes
4334 -- overflow; therefore we compute 'Last - 'First (which is not the
4335 -- exact number of components but it is valid for the purpose of
4336 -- this runtime check on 32-bit targets).
4340 Len_Minus_1_Expr
: Node_Id
;
4346 Make_Attribute_Reference
(Loc
,
4347 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4348 Attribute_Name
=> Name_Last
,
4350 New_List
(Make_Integer_Literal
(Loc
, J
))),
4351 Make_Attribute_Reference
(Loc
,
4352 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4353 Attribute_Name
=> Name_First
,
4355 New_List
(Make_Integer_Literal
(Loc
, J
))));
4358 Convert_To
(Standard_Unsigned
,
4359 Make_Op_Subtract
(Loc
,
4360 Make_Attribute_Reference
(Loc
,
4361 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4362 Attribute_Name
=> Name_Last
,
4364 New_List
(Make_Integer_Literal
(Loc
, J
))),
4365 Make_Attribute_Reference
(Loc
,
4366 Prefix
=> New_Occurrence_Of
(E
, Loc
),
4367 Attribute_Name
=> Name_First
,
4369 New_List
(Make_Integer_Literal
(Loc
, J
)))));
4371 -- Handle superflat arrays, i.e. arrays with such bounds as
4372 -- 4 .. 2, to ensure that the result is correct.
4375 -- (if X'Last > X'First then X'Last - X'First else 0)
4378 Make_If_Expression
(Loc
,
4379 Expressions
=> New_List
(
4382 Make_Integer_Literal
(Loc
, Uint_0
)));
4390 pragma Assert
(Present
(Res
));
4392 Make_Op_Multiply
(Loc
,
4401 Make_Op_Multiply
(Loc
,
4404 Make_Attribute_Reference
(Loc
,
4405 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4406 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4407 end Size_In_Storage_Elements
;
4411 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4415 Rel_Typ
: Entity_Id
;
4418 -- Start of processing for Expand_N_Allocator
4421 -- Warn on the presence of an allocator of an anonymous access type when
4422 -- enabled, except when it's an object declaration at library level.
4424 if Warn_On_Anonymous_Allocators
4425 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
4426 and then not (Is_Library_Level_Entity
(PtrT
)
4427 and then Nkind
(Associated_Node_For_Itype
(PtrT
)) =
4428 N_Object_Declaration
)
4430 Error_Msg_N
("?_a?use of an anonymous access type allocator", N
);
4433 -- RM E.2.2(17). We enforce that the expected type of an allocator
4434 -- shall not be a remote access-to-class-wide-limited-private type.
4435 -- We probably shouldn't be doing this legality check during expansion,
4436 -- but this is only an issue for Annex E users, and is unlikely to be a
4437 -- problem in practice.
4439 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4441 -- Processing for anonymous access-to-controlled types. These access
4442 -- types receive a special finalization master which appears in the
4443 -- declarations of the enclosing semantic unit. This expansion is done
4444 -- now to ensure that any additional types generated by this routine or
4445 -- Expand_Allocator_Expression inherit the proper type attributes.
4447 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4448 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4449 and then Needs_Finalization
(Dtyp
)
4451 -- Detect the allocation of an anonymous controlled object where the
4452 -- type of the context is named. For example:
4454 -- procedure Proc (Ptr : Named_Access_Typ);
4455 -- Proc (new Designated_Typ);
4457 -- Regardless of the anonymous-to-named access type conversion, the
4458 -- lifetime of the object must be associated with the named access
4459 -- type. Use the finalization-related attributes of this type.
4461 if Nkind
(Parent
(N
)) in N_Type_Conversion
4462 | N_Unchecked_Type_Conversion
4463 and then Ekind
(Etype
(Parent
(N
))) in E_Access_Subtype
4465 | E_General_Access_Type
4467 Rel_Typ
:= Etype
(Parent
(N
));
4472 -- Anonymous access-to-controlled types allocate on the global pool.
4473 -- Note that this is a "root type only" attribute.
4475 if No
(Associated_Storage_Pool
(PtrT
)) then
4476 if Present
(Rel_Typ
) then
4477 Set_Associated_Storage_Pool
4478 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4480 Set_Associated_Storage_Pool
4481 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4485 -- The finalization master must be inserted and analyzed as part of
4486 -- the current semantic unit. Note that the master is updated when
4487 -- analysis changes current units. Note that this is a "root type
4490 if Present
(Rel_Typ
) then
4491 Set_Finalization_Master
4492 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4494 Build_Anonymous_Master
(Root_Type
(PtrT
));
4498 -- Set the storage pool and find the appropriate version of Allocate to
4499 -- call. Do not overwrite the storage pool if it is already set, which
4500 -- can happen for build-in-place function returns (see
4501 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4503 if No
(Storage_Pool
(N
)) then
4504 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4506 if Present
(Pool
) then
4507 Set_Storage_Pool
(N
, Pool
);
4509 if Is_RTE
(Pool
, RE_RS_Pool
) then
4510 Set_Procedure_To_Call
(N
, RTE
(RE_RS_Allocate
));
4512 elsif Is_RTE
(Pool
, RE_SS_Pool
) then
4513 Check_Restriction
(No_Secondary_Stack
, N
);
4514 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4516 -- In the case of an allocator for a simple storage pool, locate
4517 -- and save a reference to the pool type's Allocate routine.
4519 elsif Present
(Get_Rep_Pragma
4520 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4523 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4524 Alloc_Op
: Entity_Id
;
4526 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4527 while Present
(Alloc_Op
) loop
4528 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4529 and then Present
(First_Formal
(Alloc_Op
))
4530 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4532 Set_Procedure_To_Call
(N
, Alloc_Op
);
4535 Alloc_Op
:= Homonym
(Alloc_Op
);
4540 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4541 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4544 Set_Procedure_To_Call
(N
,
4545 Find_Storage_Op
(Etype
(Pool
), Name_Allocate
));
4550 -- Under certain circumstances we can replace an allocator by an access
4551 -- to statically allocated storage. The conditions, as noted in AARM
4552 -- 3.10 (10c) are as follows:
4554 -- Size and initial value is known at compile time
4555 -- Access type is access-to-constant
4557 -- The allocator is not part of a constraint on a record component,
4558 -- because in that case the inserted actions are delayed until the
4559 -- record declaration is fully analyzed, which is too late for the
4560 -- analysis of the rewritten allocator.
4562 if Is_Access_Constant
(PtrT
)
4563 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4564 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4565 and then Size_Known_At_Compile_Time
4566 (Etype
(Expression
(Expression
(N
))))
4567 and then not Is_Record_Type
(Current_Scope
)
4569 -- Here we can do the optimization. For the allocator
4573 -- We insert an object declaration
4575 -- Tnn : aliased x := y;
4577 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4578 -- marked as requiring static allocation.
4580 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4581 Desig
:= Subtype_Mark
(Expression
(N
));
4583 -- If context is constrained, use constrained subtype directly,
4584 -- so that the constant is not labelled as having a nominally
4585 -- unconstrained subtype.
4587 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4588 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4592 Make_Object_Declaration
(Loc
,
4593 Defining_Identifier
=> Temp
,
4594 Aliased_Present
=> True,
4595 Constant_Present
=> Is_Access_Constant
(PtrT
),
4596 Object_Definition
=> Desig
,
4597 Expression
=> Expression
(Expression
(N
))));
4600 Make_Attribute_Reference
(Loc
,
4601 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4602 Attribute_Name
=> Name_Unrestricted_Access
));
4604 Analyze_And_Resolve
(N
, PtrT
);
4606 -- We set the variable as statically allocated, since we don't want
4607 -- it going on the stack of the current procedure.
4609 Set_Is_Statically_Allocated
(Temp
);
4613 -- Same if the allocator is an access discriminant for a local object:
4614 -- instead of an allocator we create a local value and constrain the
4615 -- enclosing object with the corresponding access attribute.
4617 if Is_Static_Coextension
(N
) then
4618 Rewrite_Coextension
(N
);
4622 -- Check for size too large, we do this because the back end misses
4623 -- proper checks here and can generate rubbish allocation calls when
4624 -- we are near the limit. We only do this for the 32-bit address case
4625 -- since that is from a practical point of view where we see a problem.
4627 if System_Address_Size
= 32
4628 and then not Storage_Checks_Suppressed
(PtrT
)
4629 and then not Storage_Checks_Suppressed
(Dtyp
)
4630 and then not Storage_Checks_Suppressed
(Etyp
)
4632 -- The check we want to generate should look like
4634 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4635 -- raise Storage_Error;
4638 -- where 3.5 gigabytes is a constant large enough to accommodate any
4639 -- reasonable request for. But we can't do it this way because at
4640 -- least at the moment we don't compute this attribute right, and
4641 -- can silently give wrong results when the result gets large. Since
4642 -- this is all about large results, that's bad, so instead we only
4643 -- apply the check for constrained arrays, and manually compute the
4644 -- value of the attribute ???
4646 -- The check on No_Initialization is used here to prevent generating
4647 -- this runtime check twice when the allocator is locally replaced by
4648 -- the expander with another one.
4650 if Is_Array_Type
(Etyp
) and then not No_Initialization
(N
) then
4653 Ins_Nod
: Node_Id
:= N
;
4654 Siz_Typ
: Entity_Id
:= Etyp
;
4658 -- For unconstrained array types initialized with a qualified
4659 -- expression we use its type to perform this check
4661 if not Is_Constrained
(Etyp
)
4662 and then not No_Initialization
(N
)
4663 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4665 Expr
:= Expression
(Expression
(N
));
4666 Siz_Typ
:= Etype
(Expression
(Expression
(N
)));
4668 -- If the qualified expression has been moved to an internal
4669 -- temporary (to remove side effects) then we must insert
4670 -- the runtime check before its declaration to ensure that
4671 -- the check is performed before the execution of the code
4672 -- computing the qualified expression.
4674 if Nkind
(Expr
) = N_Identifier
4675 and then Is_Internal_Name
(Chars
(Expr
))
4677 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
4679 Ins_Nod
:= Parent
(Entity
(Expr
));
4685 if Is_Constrained
(Siz_Typ
)
4686 and then Ekind
(Siz_Typ
) /= E_String_Literal_Subtype
4688 -- For CCG targets, the largest array may have up to 2**31-1
4689 -- components (i.e. 2 gigabytes if each array component is
4690 -- one byte). This ensures that fat pointer fields do not
4691 -- overflow, since they are 32-bit integer types, and also
4692 -- ensures that 'Length can be computed at run time.
4694 if Modify_Tree_For_C
then
4697 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4698 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4699 Uint_2
** 31 - Uint_1
));
4701 -- For native targets the largest object is 3.5 gigabytes
4706 Left_Opnd
=> Size_In_Storage_Elements
(Siz_Typ
),
4707 Right_Opnd
=> Make_Integer_Literal
(Loc
,
4708 Uint_7
* (Uint_2
** 29)));
4711 Insert_Action
(Ins_Nod
,
4712 Make_Raise_Storage_Error
(Loc
,
4714 Reason
=> SE_Object_Too_Large
));
4716 if Entity
(Cond
) = Standard_True
then
4718 ("object too large: Storage_Error will be raised at "
4726 -- If no storage pool has been specified, or the storage pool
4727 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4728 -- No_Standard_Allocators_After_Elaboration is present, then generate
4729 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4731 if Nkind
(N
) = N_Allocator
4732 and then (No
(Storage_Pool
(N
))
4733 or else Is_RTE
(Storage_Pool
(N
), RE_Global_Pool_Object
))
4734 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4737 Make_Procedure_Call_Statement
(Loc
,
4739 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4742 -- Handle case of qualified expression (other than optimization above)
4744 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4745 Expand_Allocator_Expression
(N
);
4749 -- If the allocator is for a type which requires initialization, and
4750 -- there is no initial value (i.e. operand is a subtype indication
4751 -- rather than a qualified expression), then we must generate a call to
4752 -- the initialization routine using an expressions action node:
4754 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4756 -- Here ptr_T is the pointer type for the allocator, and T is the
4757 -- subtype of the allocator. A special case arises if the designated
4758 -- type of the access type is a task or contains tasks. In this case
4759 -- the call to Init (Temp.all ...) is replaced by code that ensures
4760 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4761 -- for details). In addition, if the type T is a task type, then the
4762 -- first argument to Init must be converted to the task record type.
4765 T
: constant Entity_Id
:= Etype
(Expression
(N
));
4771 Init_Arg1
: Node_Id
;
4772 Init_Call
: Node_Id
;
4773 Temp_Decl
: Node_Id
;
4774 Temp_Type
: Entity_Id
;
4777 -- Apply constraint checks against designated subtype (RM 4.8(10/2))
4778 -- but ignore the expression if the No_Initialization flag is set.
4779 -- Discriminant checks will be generated by the expansion below.
4781 if Is_Array_Type
(Dtyp
) and then not No_Initialization
(N
) then
4782 Apply_Constraint_Check
(Expression
(N
), Dtyp
, No_Sliding
=> True);
4784 Apply_Predicate_Check
(Expression
(N
), Dtyp
);
4786 if Nkind
(Expression
(N
)) = N_Raise_Constraint_Error
then
4787 Rewrite
(N
, New_Copy
(Expression
(N
)));
4788 Set_Etype
(N
, PtrT
);
4793 if No_Initialization
(N
) then
4795 -- Even though this might be a simple allocation, create a custom
4796 -- Allocate if the context requires it.
4798 if Present
(Finalization_Master
(PtrT
)) then
4799 Build_Allocate_Deallocate_Proc
4801 Is_Allocate
=> True);
4804 -- Optimize the default allocation of an array object when pragma
4805 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4806 -- in-place initialization aggregate which may be convert into a fast
4807 -- memset by the backend.
4809 elsif Init_Or_Norm_Scalars
4810 and then Is_Array_Type
(T
)
4812 -- The array must lack atomic components because they are treated
4813 -- as non-static, and as a result the backend will not initialize
4814 -- the memory in one go.
4816 and then not Has_Atomic_Components
(T
)
4818 -- The array must not be packed because the invalid values in
4819 -- System.Scalar_Values are multiples of Storage_Unit.
4821 and then not Is_Packed
(T
)
4823 -- The array must have static non-empty ranges, otherwise the
4824 -- backend cannot initialize the memory in one go.
4826 and then Has_Static_Non_Empty_Array_Bounds
(T
)
4828 -- The optimization is only relevant for arrays of scalar types
4830 and then Is_Scalar_Type
(Component_Type
(T
))
4832 -- Similar to regular array initialization using a type init proc,
4833 -- predicate checks are not performed because the initialization
4834 -- values are intentionally invalid, and may violate the predicate.
4836 and then not Has_Predicates
(Component_Type
(T
))
4838 -- The component type must have a single initialization value
4840 and then Needs_Simple_Initialization
4841 (Typ
=> Component_Type
(T
),
4842 Consider_IS
=> True)
4845 Temp
:= Make_Temporary
(Loc
, 'P');
4848 -- Temp : Ptr_Typ := new ...;
4853 Make_Object_Declaration
(Loc
,
4854 Defining_Identifier
=> Temp
,
4855 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
4856 Expression
=> Relocate_Node
(N
)),
4857 Suppress
=> All_Checks
);
4860 -- Temp.all := (others => ...);
4865 Make_Assignment_Statement
(Loc
,
4867 Make_Explicit_Dereference
(Loc
,
4868 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
4873 Size
=> Esize
(Component_Type
(T
)))),
4874 Suppress
=> All_Checks
);
4876 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4877 Analyze_And_Resolve
(N
, PtrT
);
4879 -- Case of no initialization procedure present
4881 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4883 -- Case of simple initialization required
4885 if Needs_Simple_Initialization
(T
) then
4886 Check_Restriction
(No_Default_Initialization
, N
);
4887 Rewrite
(Expression
(N
),
4888 Make_Qualified_Expression
(Loc
,
4889 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4890 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4892 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4893 Analyze_And_Resolve
(Expression
(N
), T
);
4894 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4895 Expand_N_Allocator
(N
);
4897 -- No initialization required
4900 Build_Allocate_Deallocate_Proc
4902 Is_Allocate
=> True);
4905 -- Case of initialization procedure present, must be called
4907 -- NOTE: There is a *huge* amount of code duplication here from
4908 -- Build_Initialization_Call. We should probably refactor???
4911 Check_Restriction
(No_Default_Initialization
, N
);
4913 if not Restriction_Active
(No_Default_Initialization
) then
4914 Init
:= Base_Init_Proc
(T
);
4916 Temp
:= Make_Temporary
(Loc
, 'P');
4918 -- Construct argument list for the initialization routine call
4921 Make_Explicit_Dereference
(Loc
,
4923 New_Occurrence_Of
(Temp
, Loc
));
4925 Set_Assignment_OK
(Init_Arg1
);
4928 -- The initialization procedure expects a specific type. if the
4929 -- context is access to class wide, indicate that the object
4930 -- being allocated has the right specific type.
4932 if Is_Class_Wide_Type
(Dtyp
) then
4933 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4936 -- If designated type is a concurrent type or if it is private
4937 -- type whose definition is a concurrent type, the first
4938 -- argument in the Init routine has to be unchecked conversion
4939 -- to the corresponding record type. If the designated type is
4940 -- a derived type, also convert the argument to its root type.
4942 if Is_Concurrent_Type
(T
) then
4944 Unchecked_Convert_To
(
4945 Corresponding_Record_Type
(T
), Init_Arg1
);
4947 elsif Is_Private_Type
(T
)
4948 and then Present
(Full_View
(T
))
4949 and then Is_Concurrent_Type
(Full_View
(T
))
4952 Unchecked_Convert_To
4953 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4955 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4957 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4960 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4961 Set_Etype
(Init_Arg1
, Ftyp
);
4965 Args
:= New_List
(Init_Arg1
);
4967 -- For the task case, pass the Master_Id of the access type as
4968 -- the value of the _Master parameter, and _Chain as the value
4969 -- of the _Chain parameter (_Chain will be defined as part of
4970 -- the generated code for the allocator).
4972 -- In Ada 2005, the context may be a function that returns an
4973 -- anonymous access type. In that case the Master_Id has been
4974 -- created when expanding the function declaration.
4976 if Has_Task
(T
) then
4977 if No
(Master_Id
(Base_Type
(PtrT
))) then
4979 -- The designated type was an incomplete type, and the
4980 -- access type did not get expanded. Salvage it now.
4982 if Present
(Parent
(Base_Type
(PtrT
))) then
4983 Expand_N_Full_Type_Declaration
4984 (Parent
(Base_Type
(PtrT
)));
4986 -- The only other possibility is an itype. For this
4987 -- case, the master must exist in the context. This is
4988 -- the case when the allocator initializes an access
4989 -- component in an init-proc.
4992 pragma Assert
(Is_Itype
(PtrT
));
4993 Build_Master_Renaming
(PtrT
, N
);
4997 -- If the context of the allocator is a declaration or an
4998 -- assignment, we can generate a meaningful image for it,
4999 -- even though subsequent assignments might remove the
5000 -- connection between task and entity. We build this image
5001 -- when the left-hand side is a simple variable, a simple
5002 -- indexed assignment or a simple selected component.
5004 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
5006 Nam
: constant Node_Id
:= Name
(Parent
(N
));
5009 if Is_Entity_Name
(Nam
) then
5011 Build_Task_Image_Decls
5014 (Entity
(Nam
), Sloc
(Nam
)), T
);
5016 elsif Nkind
(Nam
) in N_Indexed_Component
5017 | N_Selected_Component
5018 and then Is_Entity_Name
(Prefix
(Nam
))
5021 Build_Task_Image_Decls
5022 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
5024 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
5028 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
5030 Build_Task_Image_Decls
5031 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
5034 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
5037 if Restriction_Active
(No_Task_Hierarchy
) then
5039 (Args
, Make_Integer_Literal
(Loc
, Library_Task_Level
));
5043 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
5046 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
5048 Decl
:= Last
(Decls
);
5050 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
5052 -- Has_Task is false, Decls not used
5058 -- Add discriminants if discriminated type
5061 Dis
: Boolean := False;
5062 Typ
: Entity_Id
:= Empty
;
5065 if Has_Discriminants
(T
) then
5069 -- Type may be a private type with no visible discriminants
5070 -- in which case check full view if in scope, or the
5071 -- underlying_full_view if dealing with a type whose full
5072 -- view may be derived from a private type whose own full
5073 -- view has discriminants.
5075 elsif Is_Private_Type
(T
) then
5076 if Present
(Full_View
(T
))
5077 and then Has_Discriminants
(Full_View
(T
))
5080 Typ
:= Full_View
(T
);
5082 elsif Present
(Underlying_Full_View
(T
))
5083 and then Has_Discriminants
(Underlying_Full_View
(T
))
5086 Typ
:= Underlying_Full_View
(T
);
5092 -- If the allocated object will be constrained by the
5093 -- default values for discriminants, then build a subtype
5094 -- with those defaults, and change the allocated subtype
5095 -- to that. Note that this happens in fewer cases in Ada
5098 if not Is_Constrained
(Typ
)
5099 and then Present
(Discriminant_Default_Value
5100 (First_Discriminant
(Typ
)))
5101 and then (Ada_Version
< Ada_2005
5103 Object_Type_Has_Constrained_Partial_View
5104 (Typ
, Current_Scope
))
5106 Typ
:= Build_Default_Subtype
(Typ
, N
);
5107 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
5110 -- When the designated subtype is unconstrained and
5111 -- the allocator specifies a constrained subtype (or
5112 -- such a subtype has been created, such as above by
5113 -- Build_Default_Subtype), associate that subtype with
5114 -- the dereference of the allocator's access value.
5115 -- This is needed by the back end for cases where
5116 -- the access type has a Designated_Storage_Model,
5117 -- to support allocation of a host object of the right
5118 -- size for passing to the initialization procedure.
5120 if not Is_Constrained
(Dtyp
)
5121 and then Is_Constrained
(Typ
)
5124 Init_Deref
: constant Node_Id
:=
5125 Unqual_Conv
(Init_Arg1
);
5128 (Nkind
(Init_Deref
) = N_Explicit_Dereference
);
5130 Set_Actual_Designated_Subtype
(Init_Deref
, Typ
);
5134 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
5135 while Present
(Discr
) loop
5136 Nod
:= Node
(Discr
);
5137 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
5139 -- AI-416: when the discriminant constraint is an
5140 -- anonymous access type make sure an accessibility
5141 -- check is inserted if necessary (3.10.2(22.q/2))
5143 if Ada_Version
>= Ada_2005
5145 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
5147 No_Dynamic_Accessibility_Checks_Enabled
(Nod
)
5149 Apply_Accessibility_Check
5150 (Nod
, Typ
, Insert_Node
=> Nod
);
5158 -- We set the allocator as analyzed so that when we analyze
5159 -- the if expression node, we do not get an unwanted recursive
5160 -- expansion of the allocator expression.
5162 Set_Analyzed
(N
, True);
5163 Nod
:= Relocate_Node
(N
);
5165 -- Here is the transformation:
5166 -- input: new Ctrl_Typ
5167 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5168 -- Ctrl_TypIP (Temp.all, ...);
5169 -- [Deep_]Initialize (Temp.all);
5171 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5172 -- is the subtype of the allocator.
5175 Make_Object_Declaration
(Loc
,
5176 Defining_Identifier
=> Temp
,
5177 Constant_Present
=> True,
5178 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
5181 Set_Assignment_OK
(Temp_Decl
);
5182 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
5184 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
5186 -- If the designated type is a task type or contains tasks,
5187 -- create block to activate created tasks, and insert
5188 -- declaration for Task_Image variable ahead of call.
5190 if Has_Task
(T
) then
5192 L
: constant List_Id
:= New_List
;
5195 Build_Task_Allocate_Block
(L
, Nod
, Args
);
5197 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
5198 Insert_Actions
(N
, L
);
5203 Make_Procedure_Call_Statement
(Loc
,
5204 Name
=> New_Occurrence_Of
(Init
, Loc
),
5205 Parameter_Associations
=> Args
));
5208 if Needs_Finalization
(T
) then
5211 -- [Deep_]Initialize (Init_Arg1);
5215 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
5218 -- Guard against a missing [Deep_]Initialize when the
5219 -- designated type was not properly frozen.
5221 if Present
(Init_Call
) then
5222 Insert_Action
(N
, Init_Call
);
5226 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5227 Analyze_And_Resolve
(N
, PtrT
);
5229 -- When designated type has Default_Initial_Condition aspects,
5230 -- make a call to the type's DIC procedure to perform the
5231 -- checks. Theoretically this might also be needed for cases
5232 -- where the type doesn't have an init proc, but those should
5233 -- be very uncommon, and for now we only support the init proc
5237 and then Present
(DIC_Procedure
(Dtyp
))
5238 and then not Has_Null_Body
(DIC_Procedure
(Dtyp
))
5241 Build_DIC_Call
(Loc
,
5242 Make_Explicit_Dereference
(Loc
,
5243 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)),
5250 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5251 -- object that has been rewritten as a reference, we displace "this"
5252 -- to reference properly its secondary dispatch table.
5254 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
5255 Displace_Allocator_Pointer
(N
);
5259 when RE_Not_Available
=>
5261 end Expand_N_Allocator
;
5263 -----------------------
5264 -- Expand_N_And_Then --
5265 -----------------------
5267 procedure Expand_N_And_Then
(N
: Node_Id
)
5268 renames Expand_Short_Circuit_Operator
;
5270 ------------------------------
5271 -- Expand_N_Case_Expression --
5272 ------------------------------
5274 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
5275 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean;
5276 -- Return True if we can copy objects of this type when expanding a case
5283 function Is_Copy_Type
(Typ
: Entity_Id
) return Boolean is
5285 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5286 -- large objects, as long as they are constrained and not limited.
5289 Is_Elementary_Type
(Underlying_Type
(Typ
))
5291 (Minimize_Expression_With_Actions
5292 and then Is_Constrained
(Underlying_Type
(Typ
))
5293 and then not Is_Limited_Type
(Underlying_Type
(Typ
)));
5298 Loc
: constant Source_Ptr
:= Sloc
(N
);
5299 Par
: constant Node_Id
:= Parent
(N
);
5300 Typ
: constant Entity_Id
:= Etype
(N
);
5304 Case_Stmt
: Node_Id
;
5307 Target
: Entity_Id
:= Empty
;
5308 Target_Typ
: Entity_Id
;
5310 In_Predicate
: Boolean := False;
5311 -- Flag set when the case expression appears within a predicate
5313 Optimize_Return_Stmt
: Boolean := False;
5314 -- Flag set when the case expression can be optimized in the context of
5315 -- a simple return statement.
5317 -- Start of processing for Expand_N_Case_Expression
5320 -- Check for MINIMIZED/ELIMINATED overflow mode
5322 if Minimized_Eliminated_Overflow_Check
(N
) then
5323 Apply_Arithmetic_Overflow_Check
(N
);
5327 -- If the case expression is a predicate specification, and the type
5328 -- to which it applies has a static predicate aspect, do not expand,
5329 -- because it will be converted to the proper predicate form later.
5331 if Ekind
(Current_Scope
) in E_Function | E_Procedure
5332 and then Is_Predicate_Function
(Current_Scope
)
5334 In_Predicate
:= True;
5336 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
5342 -- When the type of the case expression is elementary, expand
5344 -- (case X is when A => AX, when B => BX ...)
5359 -- In all other cases expand into
5362 -- type Ptr_Typ is access all Typ;
5363 -- Target : Ptr_Typ;
5366 -- Target := AX'Unrestricted_Access;
5368 -- Target := BX'Unrestricted_Access;
5371 -- in Target.all end;
5373 -- This approach avoids extra copies of potentially large objects. It
5374 -- also allows handling of values of limited or unconstrained types.
5375 -- Note that we do the copy also for constrained, nonlimited types
5376 -- when minimizing expressions with actions (e.g. when generating C
5377 -- code) since it allows us to do the optimization below in more cases.
5379 -- Small optimization: when the case expression appears in the context
5380 -- of a simple return statement, expand into
5391 Make_Case_Statement
(Loc
,
5392 Expression
=> Expression
(N
),
5393 Alternatives
=> New_List
);
5395 -- Preserve the original context for which the case statement is being
5396 -- generated. This is needed by the finalization machinery to prevent
5397 -- the premature finalization of controlled objects found within the
5400 Set_From_Conditional_Expression
(Case_Stmt
);
5405 if Is_Copy_Type
(Typ
) then
5408 -- Do not perform the optimization when the return statement is
5409 -- within a predicate function, as this causes spurious errors.
5411 Optimize_Return_Stmt
:=
5412 Nkind
(Par
) = N_Simple_Return_Statement
and then not In_Predicate
;
5414 -- Otherwise create an access type to handle the general case using
5415 -- 'Unrestricted_Access.
5418 -- type Ptr_Typ is access all Typ;
5421 if Generate_C_Code
then
5423 -- We cannot ensure that correct C code will be generated if any
5424 -- temporary is created down the line (to e.g. handle checks or
5425 -- capture values) since we might end up with dangling references
5426 -- to local variables, so better be safe and reject the construct.
5429 ("case expression too complex, use case statement instead", N
);
5432 Target_Typ
:= Make_Temporary
(Loc
, 'P');
5435 Make_Full_Type_Declaration
(Loc
,
5436 Defining_Identifier
=> Target_Typ
,
5438 Make_Access_To_Object_Definition
(Loc
,
5439 All_Present
=> True,
5440 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5443 -- Create the declaration of the target which captures the value of the
5447 -- Target : [Ptr_]Typ;
5449 if not Optimize_Return_Stmt
then
5450 Target
:= Make_Temporary
(Loc
, 'T');
5453 Make_Object_Declaration
(Loc
,
5454 Defining_Identifier
=> Target
,
5455 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
5456 Set_No_Initialization
(Decl
);
5458 Append_To
(Acts
, Decl
);
5461 -- Process the alternatives
5463 Alt
:= First
(Alternatives
(N
));
5464 while Present
(Alt
) loop
5466 Alt_Expr
: Node_Id
:= Expression
(Alt
);
5467 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
5472 -- Take the unrestricted access of the expression value for non-
5473 -- scalar types. This approach avoids big copies and covers the
5474 -- limited and unconstrained cases.
5477 -- AX'Unrestricted_Access
5479 if not Is_Copy_Type
(Typ
) then
5481 Make_Attribute_Reference
(Alt_Loc
,
5482 Prefix
=> Relocate_Node
(Alt_Expr
),
5483 Attribute_Name
=> Name_Unrestricted_Access
);
5487 -- return AX['Unrestricted_Access];
5489 if Optimize_Return_Stmt
then
5491 Make_Simple_Return_Statement
(Alt_Loc
,
5492 Expression
=> Alt_Expr
));
5495 -- Target := AX['Unrestricted_Access];
5498 LHS
:= New_Occurrence_Of
(Target
, Loc
);
5499 Set_Assignment_OK
(LHS
);
5502 Make_Assignment_Statement
(Alt_Loc
,
5504 Expression
=> Alt_Expr
));
5507 -- Propagate declarations inserted in the node by Insert_Actions
5508 -- (for example, temporaries generated to remove side effects).
5509 -- These actions must remain attached to the alternative, given
5510 -- that they are generated by the corresponding expression.
5512 if Present
(Actions
(Alt
)) then
5513 Prepend_List
(Actions
(Alt
), Stmts
);
5516 -- Finalize any transient objects on exit from the alternative.
5517 -- This is done only in the return optimization case because
5518 -- otherwise the case expression is converted into an expression
5519 -- with actions which already contains this form of processing.
5521 if Optimize_Return_Stmt
then
5522 Process_If_Case_Statements
(N
, Stmts
);
5526 (Alternatives
(Case_Stmt
),
5527 Make_Case_Statement_Alternative
(Sloc
(Alt
),
5528 Discrete_Choices
=> Discrete_Choices
(Alt
),
5529 Statements
=> Stmts
));
5535 -- Rewrite the parent return statement as a case statement
5537 if Optimize_Return_Stmt
then
5538 Rewrite
(Par
, Case_Stmt
);
5541 -- Otherwise convert the case expression into an expression with actions
5544 Append_To
(Acts
, Case_Stmt
);
5546 if Is_Copy_Type
(Typ
) then
5547 Expr
:= New_Occurrence_Of
(Target
, Loc
);
5551 Make_Explicit_Dereference
(Loc
,
5552 Prefix
=> New_Occurrence_Of
(Target
, Loc
));
5558 -- in Target[.all] end;
5561 Make_Expression_With_Actions
(Loc
,
5565 Analyze_And_Resolve
(N
, Typ
);
5567 end Expand_N_Case_Expression
;
5569 -----------------------------------
5570 -- Expand_N_Explicit_Dereference --
5571 -----------------------------------
5573 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
5575 -- Insert explicit dereference call for the checked storage pool case
5577 Insert_Dereference_Action
(Prefix
(N
));
5579 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5580 -- we set the atomic sync flag.
5582 if Is_Atomic
(Etype
(N
))
5583 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
5585 Activate_Atomic_Synchronization
(N
);
5587 end Expand_N_Explicit_Dereference
;
5589 --------------------------------------
5590 -- Expand_N_Expression_With_Actions --
5591 --------------------------------------
5593 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
5594 Acts
: constant List_Id
:= Actions
(N
);
5596 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
5597 -- Force the evaluation of Boolean expression Expr
5599 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
5600 -- Inspect and process a single action of an expression_with_actions for
5601 -- transient objects. If such objects are found, the routine generates
5602 -- code to clean them up when the context of the expression is evaluated
5605 ------------------------------
5606 -- Force_Boolean_Evaluation --
5607 ------------------------------
5609 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
5610 Loc
: constant Source_Ptr
:= Sloc
(N
);
5611 Flag_Decl
: Node_Id
;
5612 Flag_Id
: Entity_Id
;
5615 -- Relocate the expression to the actions list by capturing its value
5616 -- in a Boolean flag. Generate:
5617 -- Flag : constant Boolean := Expr;
5619 Flag_Id
:= Make_Temporary
(Loc
, 'F');
5622 Make_Object_Declaration
(Loc
,
5623 Defining_Identifier
=> Flag_Id
,
5624 Constant_Present
=> True,
5625 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5626 Expression
=> Relocate_Node
(Expr
));
5628 Append
(Flag_Decl
, Acts
);
5629 Analyze
(Flag_Decl
);
5631 -- Replace the expression with a reference to the flag
5633 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
5634 Analyze
(Expression
(N
));
5635 end Force_Boolean_Evaluation
;
5637 --------------------
5638 -- Process_Action --
5639 --------------------
5641 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
5643 if Nkind
(Act
) = N_Object_Declaration
5644 and then Is_Finalizable_Transient
(Act
, N
)
5646 Process_Transient_In_Expression
(Act
, N
, Acts
);
5649 -- Avoid processing temporary function results multiple times when
5650 -- dealing with nested expression_with_actions.
5651 -- Similarly, do not process temporary function results in loops.
5652 -- This is done by Expand_N_Loop_Statement and Build_Finalizer.
5653 -- Note that we used to wrongly return Abandon instead of Skip here:
5654 -- this is wrong since it means that we were ignoring lots of
5655 -- relevant subsequent statements.
5657 elsif Nkind
(Act
) in N_Expression_With_Actions | N_Loop_Statement
then
5664 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
5670 -- Start of processing for Expand_N_Expression_With_Actions
5673 -- Do not evaluate the expression when it denotes an entity because the
5674 -- expression_with_actions node will be replaced by the reference.
5676 if Is_Entity_Name
(Expression
(N
)) then
5679 -- Do not evaluate the expression when there are no actions because the
5680 -- expression_with_actions node will be replaced by the expression.
5682 elsif Is_Empty_List
(Acts
) then
5685 -- Force the evaluation of the expression by capturing its value in a
5686 -- temporary. This ensures that aliases of transient objects do not leak
5687 -- to the expression of the expression_with_actions node:
5690 -- Trans_Id : Ctrl_Typ := ...;
5691 -- Alias : ... := Trans_Id;
5692 -- in ... Alias ... end;
5694 -- In the example above, Trans_Id cannot be finalized at the end of the
5695 -- actions list because this may affect the alias and the final value of
5696 -- the expression_with_actions. Forcing the evaluation encapsulates the
5697 -- reference to the Alias within the actions list:
5700 -- Trans_Id : Ctrl_Typ := ...;
5701 -- Alias : ... := Trans_Id;
5702 -- Val : constant Boolean := ... Alias ...;
5703 -- <finalize Trans_Id>
5706 -- Once this transformation is performed, it is safe to finalize the
5707 -- transient object at the end of the actions list.
5709 -- Note that Force_Evaluation does not remove side effects in operators
5710 -- because it assumes that all operands are evaluated and side effect
5711 -- free. This is not the case when an operand depends implicitly on the
5712 -- transient object through the use of access types.
5714 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5715 Force_Boolean_Evaluation
(Expression
(N
));
5717 -- The expression of an expression_with_actions node may not necessarily
5718 -- be Boolean when the node appears in an if expression. In this case do
5719 -- the usual forced evaluation to encapsulate potential aliasing.
5722 Force_Evaluation
(Expression
(N
));
5725 -- Process all transient objects found within the actions of the EWA
5728 Act
:= First
(Acts
);
5729 while Present
(Act
) loop
5730 Process_Single_Action
(Act
);
5734 -- Deal with case where there are no actions. In this case we simply
5735 -- rewrite the node with its expression since we don't need the actions
5736 -- and the specification of this node does not allow a null action list.
5738 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5739 -- the expanded tree and relying on being able to retrieve the original
5740 -- tree in cases like this. This raises a whole lot of issues of whether
5741 -- we have problems elsewhere, which will be addressed in the future???
5743 if Is_Empty_List
(Acts
) then
5744 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5746 end Expand_N_Expression_With_Actions
;
5748 ----------------------------
5749 -- Expand_N_If_Expression --
5750 ----------------------------
5752 -- Deal with limited types and condition actions
5754 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5755 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5756 Loc
: constant Source_Ptr
:= Sloc
(N
);
5757 Thenx
: constant Node_Id
:= Next
(Cond
);
5758 Elsex
: constant Node_Id
:= Next
(Thenx
);
5759 Typ
: constant Entity_Id
:= Etype
(N
);
5761 Force_Expand
: constant Boolean := Is_Anonymous_Access_Actual
(N
);
5762 -- Determine if we are dealing with a special case of a conditional
5763 -- expression used as an actual for an anonymous access type which
5764 -- forces us to transform the if expression into an expression with
5765 -- actions in order to create a temporary to capture the level of the
5766 -- expression in each branch.
5768 function OK_For_Single_Subtype
(T1
, T2
: Entity_Id
) return Boolean;
5769 -- Return true if it is acceptable to use a single subtype for two
5770 -- dependent expressions of subtype T1 and T2 respectively, which are
5771 -- unidimensional arrays whose index bounds are known at compile time.
5773 ---------------------------
5774 -- OK_For_Single_Subtype --
5775 ---------------------------
5777 function OK_For_Single_Subtype
(T1
, T2
: Entity_Id
) return Boolean is
5782 Get_First_Index_Bounds
(T1
, Lo1
, Hi1
);
5783 Get_First_Index_Bounds
(T2
, Lo2
, Hi2
);
5785 -- Return true if the length of the covering subtype is not too large
5788 UI_Max
(Hi1
, Hi2
) - UI_Min
(Lo1
, Lo2
) < Too_Large_Length_For_Array
;
5789 end OK_For_Single_Subtype
;
5799 -- Start of processing for Expand_N_If_Expression
5802 -- Deal with non-standard booleans
5804 Adjust_Condition
(Cond
);
5806 -- Check for MINIMIZED/ELIMINATED overflow mode.
5807 -- Apply_Arithmetic_Overflow_Check will not deal with Then/Else_Actions
5808 -- so skip this step if any actions are present.
5810 if Minimized_Eliminated_Overflow_Check
(N
)
5811 and then No
(Then_Actions
(N
))
5812 and then No
(Else_Actions
(N
))
5814 Apply_Arithmetic_Overflow_Check
(N
);
5818 -- Fold at compile time if condition known. We have already folded
5819 -- static if expressions, but it is possible to fold any case in which
5820 -- the condition is known at compile time, even though the result is
5823 -- Note that we don't do the fold of such cases in Sem_Elab because
5824 -- it can cause infinite loops with the expander adding a conditional
5825 -- expression, and Sem_Elab circuitry removing it repeatedly.
5827 if Compile_Time_Known_Value
(Cond
) then
5829 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5830 -- Fold at compile time. Assumes condition known. Return True if
5831 -- folding occurred, meaning we're done.
5833 ----------------------
5834 -- Fold_Known_Value --
5835 ----------------------
5837 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5839 if Is_True
(Expr_Value
(Cond
)) then
5841 Actions
:= Then_Actions
(N
);
5844 Actions
:= Else_Actions
(N
);
5849 if Present
(Actions
) then
5851 -- To minimize the use of Expression_With_Actions, just skip
5852 -- the optimization as it is not critical for correctness.
5854 if Minimize_Expression_With_Actions
then
5859 Make_Expression_With_Actions
(Loc
,
5860 Expression
=> Relocate_Node
(Expr
),
5861 Actions
=> Actions
));
5862 Analyze_And_Resolve
(N
, Typ
);
5865 Rewrite
(N
, Relocate_Node
(Expr
));
5868 -- Note that the result is never static (legitimate cases of
5869 -- static if expressions were folded in Sem_Eval).
5871 Set_Is_Static_Expression
(N
, False);
5873 end Fold_Known_Value
;
5876 if Fold_Known_Value
(Cond
) then
5882 -- If the type is limited, and the back end does not handle limited
5883 -- types, then we expand as follows to avoid the possibility of
5884 -- improper copying.
5886 -- type Ptr is access all Typ;
5890 -- Cnn := then-expr'Unrestricted_Access;
5893 -- Cnn := else-expr'Unrestricted_Access;
5896 -- and replace the if expression by a reference to Cnn.all.
5898 -- This special case can be skipped if the back end handles limited
5899 -- types properly and ensures that no incorrect copies are made.
5901 if Is_By_Reference_Type
(Typ
)
5902 and then not Back_End_Handles_Limited_Types
5904 -- When the "then" or "else" expressions involve controlled function
5905 -- calls, generated temporaries are chained on the corresponding list
5906 -- of actions. These temporaries need to be finalized after the if
5907 -- expression is evaluated.
5909 Process_If_Case_Statements
(N
, Then_Actions
(N
));
5910 Process_If_Case_Statements
(N
, Else_Actions
(N
));
5913 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C', N
);
5914 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5918 -- type Ann is access all Typ;
5921 Make_Full_Type_Declaration
(Loc
,
5922 Defining_Identifier
=> Ptr_Typ
,
5924 Make_Access_To_Object_Definition
(Loc
,
5925 All_Present
=> True,
5926 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5932 Make_Object_Declaration
(Loc
,
5933 Defining_Identifier
=> Cnn
,
5934 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5938 -- Cnn := <Thenx>'Unrestricted_Access;
5940 -- Cnn := <Elsex>'Unrestricted_Access;
5944 Make_Implicit_If_Statement
(N
,
5945 Condition
=> Relocate_Node
(Cond
),
5946 Then_Statements
=> New_List
(
5947 Make_Assignment_Statement
(Sloc
(Thenx
),
5948 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5950 Make_Attribute_Reference
(Loc
,
5951 Prefix
=> Relocate_Node
(Thenx
),
5952 Attribute_Name
=> Name_Unrestricted_Access
))),
5954 Else_Statements
=> New_List
(
5955 Make_Assignment_Statement
(Sloc
(Elsex
),
5956 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5958 Make_Attribute_Reference
(Loc
,
5959 Prefix
=> Relocate_Node
(Elsex
),
5960 Attribute_Name
=> Name_Unrestricted_Access
))));
5962 -- Preserve the original context for which the if statement is
5963 -- being generated. This is needed by the finalization machinery
5964 -- to prevent the premature finalization of controlled objects
5965 -- found within the if statement.
5967 Set_From_Conditional_Expression
(New_If
);
5970 Make_Explicit_Dereference
(Loc
,
5971 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5974 -- If the result is a unidimensional unconstrained array but the two
5975 -- dependent expressions have constrained subtypes with known bounds,
5976 -- then we expand as follows:
5978 -- subtype Txx is Typ (<static low-bound> .. <static high-bound>);
5982 -- Cnn (<then low-bound .. then high-bound>) := then-expr;
5985 -- Cnn (<else low bound .. else high-bound>) := else-expr;
5988 -- and replace the if expression by a slice of Cnn, provided that Txx
5989 -- is not too large. This will create a static temporary instead of the
5990 -- dynamic one of the next case and thus help the code generator.
5992 -- Note that we need to deal with the case where the else expression is
5993 -- itself such a slice, in order to catch if expressions with more than
5994 -- two dependent expressions in the source code.
5996 -- Also note that this creates variables on branches without an explicit
5997 -- scope, causing troubles with e.g. the LLVM IR, so disable this
5998 -- optimization when Unnest_Subprogram_Mode (enabled for LLVM).
6000 elsif Is_Array_Type
(Typ
)
6001 and then Number_Dimensions
(Typ
) = 1
6002 and then not Is_Constrained
(Typ
)
6003 and then Is_Constrained
(Etype
(Thenx
))
6004 and then Compile_Time_Known_Bounds
(Etype
(Thenx
))
6006 ((Is_Constrained
(Etype
(Elsex
))
6007 and then Compile_Time_Known_Bounds
(Etype
(Elsex
))
6008 and then OK_For_Single_Subtype
(Etype
(Thenx
), Etype
(Elsex
)))
6010 (Nkind
(Elsex
) = N_Slice
6011 and then Is_Constrained
(Etype
(Prefix
(Elsex
)))
6012 and then Compile_Time_Known_Bounds
(Etype
(Prefix
(Elsex
)))
6014 OK_For_Single_Subtype
(Etype
(Thenx
), Etype
(Prefix
(Elsex
)))))
6015 and then not Generate_C_Code
6016 and then not Unnest_Subprogram_Mode
6019 Ityp
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
6021 function Build_New_Bound
6024 Slice_Bnd
: Node_Id
) return Node_Id
;
6025 -- Build a new bound from the bounds of the if expression
6027 function To_Ityp
(V
: Uint
) return Node_Id
;
6028 -- Convert V to an index value in Ityp
6030 ---------------------
6031 -- Build_New_Bound --
6032 ---------------------
6034 function Build_New_Bound
6037 Slice_Bnd
: Node_Id
) return Node_Id
is
6040 -- We need to use the special processing for slices only if
6041 -- they do not have compile-time known bounds; if they do, they
6042 -- can be treated like any other expressions.
6044 if Nkind
(Elsex
) = N_Slice
6045 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
6047 if Compile_Time_Known_Value
(Slice_Bnd
)
6048 and then Expr_Value
(Slice_Bnd
) = Then_Bnd
6050 return To_Ityp
(Then_Bnd
);
6053 return Make_If_Expression
(Loc
,
6054 Expressions
=> New_List
(
6055 Duplicate_Subexpr
(Cond
),
6057 New_Copy_Tree
(Slice_Bnd
)));
6060 elsif Then_Bnd
= Else_Bnd
then
6061 return To_Ityp
(Then_Bnd
);
6064 return Make_If_Expression
(Loc
,
6065 Expressions
=> New_List
(
6066 Duplicate_Subexpr
(Cond
),
6068 To_Ityp
(Else_Bnd
)));
6070 end Build_New_Bound
;
6076 function To_Ityp
(V
: Uint
) return Node_Id
is
6077 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, V
);
6080 if Is_Enumeration_Type
(Ityp
) then
6082 Make_Attribute_Reference
(Loc
,
6083 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
6084 Attribute_Name
=> Name_Val
,
6085 Expressions
=> New_List
(Result
));
6092 Slice_Lo
, Slice_Hi
: Node_Id
;
6093 Subtyp_Ind
: Node_Id
;
6094 Else_Lo
, Else_Hi
: Uint
;
6095 Min_Lo
, Max_Hi
: Uint
;
6096 Then_Lo
, Then_Hi
: Uint
;
6097 Then_List
, Else_List
: List_Id
;
6100 Get_First_Index_Bounds
(Etype
(Thenx
), Then_Lo
, Then_Hi
);
6102 -- See the rationale in Build_New_Bound
6104 if Nkind
(Elsex
) = N_Slice
6105 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
6107 Slice_Lo
:= Low_Bound
(Discrete_Range
(Elsex
));
6108 Slice_Hi
:= High_Bound
(Discrete_Range
(Elsex
));
6109 Get_First_Index_Bounds
6110 (Etype
(Prefix
(Elsex
)), Else_Lo
, Else_Hi
);
6115 Get_First_Index_Bounds
(Etype
(Elsex
), Else_Lo
, Else_Hi
);
6118 Min_Lo
:= UI_Min
(Then_Lo
, Else_Lo
);
6119 Max_Hi
:= UI_Max
(Then_Hi
, Else_Hi
);
6121 -- Now we construct an array object with appropriate bounds and
6122 -- mark it as internal to prevent useless initialization when
6123 -- Initialize_Scalars is enabled. Also since this is the actual
6124 -- result entity, we make sure we have debug information for it.
6127 Make_Subtype_Indication
(Loc
,
6128 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
6130 Make_Index_Or_Discriminant_Constraint
(Loc
,
6131 Constraints
=> New_List
(
6133 Low_Bound
=> To_Ityp
(Min_Lo
),
6134 High_Bound
=> To_Ityp
(Max_Hi
)))));
6136 Ent
:= Make_Temporary
(Loc
, 'C');
6137 Set_Is_Internal
(Ent
);
6138 Set_Debug_Info_Needed
(Ent
);
6141 Make_Object_Declaration
(Loc
,
6142 Defining_Identifier
=> Ent
,
6143 Object_Definition
=> Subtyp_Ind
);
6145 -- If the result of the expression appears as the initializing
6146 -- expression of an object declaration, we can just rename the
6147 -- result, rather than copying it.
6149 Mutate_Ekind
(Ent
, E_Variable
);
6150 Set_OK_To_Rename
(Ent
);
6152 Then_List
:= New_List
(
6153 Make_Assignment_Statement
(Loc
,
6156 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6159 Low_Bound
=> To_Ityp
(Then_Lo
),
6160 High_Bound
=> To_Ityp
(Then_Hi
))),
6161 Expression
=> Relocate_Node
(Thenx
)));
6163 Set_Suppress_Assignment_Checks
(Last
(Then_List
));
6165 -- See the rationale in Build_New_Bound
6167 if Nkind
(Elsex
) = N_Slice
6168 and then not Compile_Time_Known_Bounds
(Etype
(Elsex
))
6170 Else_List
:= New_List
(
6171 Make_Assignment_Statement
(Loc
,
6174 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6177 Low_Bound
=> New_Copy_Tree
(Slice_Lo
),
6178 High_Bound
=> New_Copy_Tree
(Slice_Hi
))),
6179 Expression
=> Relocate_Node
(Elsex
)));
6182 Else_List
:= New_List
(
6183 Make_Assignment_Statement
(Loc
,
6186 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6189 Low_Bound
=> To_Ityp
(Else_Lo
),
6190 High_Bound
=> To_Ityp
(Else_Hi
))),
6191 Expression
=> Relocate_Node
(Elsex
)));
6194 Set_Suppress_Assignment_Checks
(Last
(Else_List
));
6197 Make_Implicit_If_Statement
(N
,
6198 Condition
=> Duplicate_Subexpr
(Cond
),
6199 Then_Statements
=> Then_List
,
6200 Else_Statements
=> Else_List
);
6204 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6205 Discrete_Range
=> Make_Range
(Loc
,
6206 Low_Bound
=> Build_New_Bound
(Then_Lo
, Else_Lo
, Slice_Lo
),
6207 High_Bound
=> Build_New_Bound
(Then_Hi
, Else_Hi
, Slice_Hi
)));
6210 -- If the result is an unconstrained array and the if expression is in a
6211 -- context other than the initializing expression of the declaration of
6212 -- an object, then we pull out the if expression as follows:
6214 -- Cnn : constant typ := if-expression
6216 -- and then replace the if expression with an occurrence of Cnn. This
6217 -- avoids the need in the back end to create on-the-fly variable length
6218 -- temporaries (which it cannot do!)
6220 -- Note that the test for being in an object declaration avoids doing an
6221 -- unnecessary expansion, and also avoids infinite recursion.
6223 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
)
6224 and then (Nkind
(Parent
(N
)) /= N_Object_Declaration
6225 or else Expression
(Parent
(N
)) /= N
)
6228 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6232 Make_Object_Declaration
(Loc
,
6233 Defining_Identifier
=> Cnn
,
6234 Constant_Present
=> True,
6235 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6236 Expression
=> Relocate_Node
(N
),
6237 Has_Init_Expression
=> True));
6239 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
6243 -- For other types, we only need to expand if there are other actions
6244 -- associated with either branch or we need to force expansion to deal
6245 -- with if expressions used as an actual of an anonymous access type.
6247 elsif Present
(Then_Actions
(N
))
6248 or else Present
(Else_Actions
(N
))
6249 or else Force_Expand
6252 -- We now wrap the actions into the appropriate expression
6254 if Minimize_Expression_With_Actions
6255 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
6256 or else Is_Constrained
(Underlying_Type
(Typ
)))
6258 -- If we can't use N_Expression_With_Actions nodes, then we insert
6259 -- the following sequence of actions (using Insert_Actions):
6264 -- Cnn := then-expr;
6270 -- and replace the if expression by a reference to Cnn
6273 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
6277 Make_Object_Declaration
(Loc
,
6278 Defining_Identifier
=> Cnn
,
6279 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6282 Make_Implicit_If_Statement
(N
,
6283 Condition
=> Relocate_Node
(Cond
),
6285 Then_Statements
=> New_List
(
6286 Make_Assignment_Statement
(Sloc
(Thenx
),
6287 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6288 Expression
=> Relocate_Node
(Thenx
))),
6290 Else_Statements
=> New_List
(
6291 Make_Assignment_Statement
(Sloc
(Elsex
),
6292 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6293 Expression
=> Relocate_Node
(Elsex
))));
6295 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
6296 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
6298 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
6301 -- Regular path using Expression_With_Actions
6304 if Present
(Then_Actions
(N
)) then
6306 Make_Expression_With_Actions
(Sloc
(Thenx
),
6307 Actions
=> Then_Actions
(N
),
6308 Expression
=> Relocate_Node
(Thenx
)));
6310 Set_Then_Actions
(N
, No_List
);
6311 Analyze_And_Resolve
(Thenx
, Typ
);
6314 if Present
(Else_Actions
(N
)) then
6316 Make_Expression_With_Actions
(Sloc
(Elsex
),
6317 Actions
=> Else_Actions
(N
),
6318 Expression
=> Relocate_Node
(Elsex
)));
6320 Set_Else_Actions
(N
, No_List
);
6321 Analyze_And_Resolve
(Elsex
, Typ
);
6324 -- We must force expansion into an expression with actions when
6325 -- an if expression gets used directly as an actual for an
6326 -- anonymous access type.
6328 if Force_Expand
then
6330 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
6339 Make_Object_Declaration
(Loc
,
6340 Defining_Identifier
=> Cnn
,
6341 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6342 Append_To
(Acts
, Decl
);
6344 Set_No_Initialization
(Decl
);
6354 Make_Implicit_If_Statement
(N
,
6355 Condition
=> Relocate_Node
(Cond
),
6356 Then_Statements
=> New_List
(
6357 Make_Assignment_Statement
(Sloc
(Thenx
),
6358 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
6359 Expression
=> Relocate_Node
(Thenx
))),
6361 Else_Statements
=> New_List
(
6362 Make_Assignment_Statement
(Sloc
(Elsex
),
6363 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
6364 Expression
=> Relocate_Node
(Elsex
))));
6365 Append_To
(Acts
, New_If
);
6373 Make_Expression_With_Actions
(Loc
,
6374 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6376 Analyze_And_Resolve
(N
, Typ
);
6383 -- For the sake of GNATcoverage, generate an intermediate temporary in
6384 -- the case where the if expression is a condition in an outer decision,
6385 -- in order to make sure that no branch is shared between the decisions.
6387 elsif Opt
.Suppress_Control_Flow_Optimizations
6388 and then Nkind
(Original_Node
(Parent
(N
))) in N_Case_Expression
6392 | N_Goto_When_Statement
6394 | N_Return_When_Statement
6398 Cnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
6404 -- Cnn : constant Typ := N;
6408 Make_Object_Declaration
(Loc
,
6409 Defining_Identifier
=> Cnn
,
6410 Constant_Present
=> True,
6411 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6412 Expression
=> Relocate_Node
(N
)));
6415 Make_Expression_With_Actions
(Loc
,
6416 Expression
=> New_Occurrence_Of
(Cnn
, Loc
),
6419 Analyze_And_Resolve
(N
, Typ
);
6423 -- If no actions then no expansion needed, gigi will handle it using the
6424 -- same approach as a C conditional expression.
6430 -- Fall through here for either the limited expansion, or the case of
6431 -- inserting actions for nonlimited types. In both these cases, we must
6432 -- move the SLOC of the parent If statement to the newly created one and
6433 -- change it to the SLOC of the expression which, after expansion, will
6434 -- correspond to what is being evaluated.
6436 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
6437 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
6438 Set_Sloc
(Parent
(N
), Loc
);
6441 -- Move Then_Actions and Else_Actions, if any, to the new if statement
6443 Insert_List_Before
(First
(Then_Statements
(New_If
)), Then_Actions
(N
));
6444 Insert_List_Before
(First
(Else_Statements
(New_If
)), Else_Actions
(N
));
6446 Insert_Action
(N
, Decl
);
6447 Insert_Action
(N
, New_If
);
6449 Analyze_And_Resolve
(N
, Typ
);
6450 end Expand_N_If_Expression
;
6456 procedure Expand_N_In
(N
: Node_Id
) is
6457 Loc
: constant Source_Ptr
:= Sloc
(N
);
6458 Restyp
: constant Entity_Id
:= Etype
(N
);
6459 Lop
: constant Node_Id
:= Left_Opnd
(N
);
6460 Rop
: constant Node_Id
:= Right_Opnd
(N
);
6461 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
6463 procedure Substitute_Valid_Test
;
6464 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6465 -- test for the left operand being in range of its subtype.
6467 ---------------------------
6468 -- Substitute_Valid_Test --
6469 ---------------------------
6471 procedure Substitute_Valid_Test
is
6472 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
6473 -- Determine whether arbitrary node Nod denotes a source object that
6474 -- may safely act as prefix of attribute 'Valid.
6476 ----------------------------
6477 -- Is_OK_Object_Reference --
6478 ----------------------------
6480 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
6484 -- Inspect the original operand
6486 Obj_Ref
:= Original_Node
(Nod
);
6488 -- The object reference must be a source construct, otherwise the
6489 -- codefix suggestion may refer to nonexistent code from a user
6492 if Comes_From_Source
(Obj_Ref
) then
6494 if Nkind
(Obj_Ref
) in
6496 N_Unchecked_Type_Conversion |
6497 N_Qualified_Expression
6499 Obj_Ref
:= Expression
(Obj_Ref
);
6505 return Is_Object_Reference
(Obj_Ref
);
6509 end Is_OK_Object_Reference
;
6511 -- Start of processing for Substitute_Valid_Test
6515 Make_Attribute_Reference
(Loc
,
6516 Prefix
=> Relocate_Node
(Lop
),
6517 Attribute_Name
=> Name_Valid
));
6519 Analyze_And_Resolve
(N
, Restyp
);
6521 -- Emit a warning when the left-hand operand of the membership test
6522 -- is a source object, otherwise the use of attribute 'Valid would be
6523 -- illegal. The warning is not given when overflow checking is either
6524 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6525 -- eliminated above.
6527 if Is_OK_Object_Reference
(Lop
)
6528 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
6531 ("??explicit membership test may be optimized away", N
);
6532 Error_Msg_N
-- CODEFIX
6533 ("\??use ''Valid attribute instead", N
);
6535 end Substitute_Valid_Test
;
6542 -- Start of processing for Expand_N_In
6545 -- If set membership case, expand with separate procedure
6547 if Present
(Alternatives
(N
)) then
6548 Expand_Set_Membership
(N
);
6552 -- Not set membership, proceed with expansion
6554 Ltyp
:= Etype
(Left_Opnd
(N
));
6555 Rtyp
:= Etype
(Right_Opnd
(N
));
6557 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6558 -- type, then expand with a separate procedure. Note the use of the
6559 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6561 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
))
6562 and then not No_Minimize_Eliminate
(N
)
6564 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
6568 -- Check case of explicit test for an expression in range of its
6569 -- subtype. This is suspicious usage and we replace it with a 'Valid
6570 -- test and give a warning for scalar types.
6572 if Is_Scalar_Type
(Ltyp
)
6574 -- Only relevant for source comparisons
6576 and then Comes_From_Source
(N
)
6578 -- In floating-point this is a standard way to check for finite values
6579 -- and using 'Valid would typically be a pessimization.
6581 and then not Is_Floating_Point_Type
(Ltyp
)
6583 -- Don't give the message unless right operand is a type entity and
6584 -- the type of the left operand matches this type. Note that this
6585 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6586 -- checks have changed the type of the left operand.
6588 and then Is_Entity_Name
(Rop
)
6589 and then Ltyp
= Entity
(Rop
)
6591 -- Skip this for predicated types, where such expressions are a
6592 -- reasonable way of testing if something meets the predicate.
6594 and then No
(Predicate_Function
(Ltyp
))
6596 Substitute_Valid_Test
;
6600 -- Do validity check on operands
6602 if Validity_Checks_On
and Validity_Check_Operands
then
6603 Ensure_Valid
(Left_Opnd
(N
));
6604 Validity_Check_Range
(Right_Opnd
(N
));
6607 -- Case of explicit range
6609 if Nkind
(Rop
) = N_Range
then
6611 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
6612 Hi
: constant Node_Id
:= High_Bound
(Rop
);
6614 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
6615 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
6616 Rop_Orig
: constant Node_Id
:= Original_Node
(Rop
);
6618 Comes_From_Simple_Range_In_Source
: constant Boolean :=
6619 Comes_From_Source
(N
)
6621 (Is_Entity_Name
(Rop_Orig
)
6622 and then Is_Type
(Entity
(Rop_Orig
))
6623 and then Present
(Predicate_Function
(Entity
(Rop_Orig
))));
6624 -- This is true for a membership test present in the source with a
6625 -- range or mark for a subtype that is not predicated. As already
6626 -- explained a few lines above, we do not want to give warnings on
6627 -- a test with a mark for a subtype that is predicated.
6629 Warn
: constant Boolean :=
6630 Constant_Condition_Warnings
6631 and then Comes_From_Simple_Range_In_Source
6632 and then not In_Instance
;
6633 -- This must be true for any of the optimization warnings, we
6634 -- clearly want to give them only for source with the flag on. We
6635 -- also skip these warnings in an instance since it may be the
6636 -- case that different instantiations have different ranges.
6638 Lcheck
: Compare_Result
;
6639 Ucheck
: Compare_Result
;
6642 -- If test is explicit x'First .. x'Last, replace by 'Valid test
6644 if Is_Scalar_Type
(Ltyp
)
6646 -- Only relevant for source comparisons
6648 and then Comes_From_Simple_Range_In_Source
6650 -- And left operand is X'First where X matches left operand
6651 -- type (this eliminates cases of type mismatch, including
6652 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6653 -- type of the left operand.
6655 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
6656 and then Attribute_Name
(Lo_Orig
) = Name_First
6657 and then Is_Entity_Name
(Prefix
(Lo_Orig
))
6658 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
6660 -- Same tests for right operand
6662 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
6663 and then Attribute_Name
(Hi_Orig
) = Name_Last
6664 and then Is_Entity_Name
(Prefix
(Hi_Orig
))
6665 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
6667 Substitute_Valid_Test
;
6671 -- If bounds of type are known at compile time, and the end points
6672 -- are known at compile time and identical, this is another case
6673 -- for substituting a valid test. We only do this for discrete
6674 -- types, since it won't arise in practice for float types.
6676 if Comes_From_Simple_Range_In_Source
6677 and then Is_Discrete_Type
(Ltyp
)
6678 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
6679 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
6680 and then Compile_Time_Known_Value
(Lo
)
6681 and then Compile_Time_Known_Value
(Hi
)
6682 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
6683 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
6685 -- Kill warnings in instances, since they may be cases where we
6686 -- have a test in the generic that makes sense with some types
6687 -- and not with other types.
6689 -- Similarly, do not rewrite membership as a 'Valid test if
6690 -- within the predicate function for the type.
6692 -- Finally, if the original bounds are type conversions, even
6693 -- if they have been folded into constants, there are different
6694 -- types involved and 'Valid is not appropriate.
6698 or else (Ekind
(Current_Scope
) = E_Function
6699 and then Is_Predicate_Function
(Current_Scope
))
6703 elsif Nkind
(Lo_Orig
) = N_Type_Conversion
6704 or else Nkind
(Hi_Orig
) = N_Type_Conversion
6709 Substitute_Valid_Test
;
6714 -- If we have an explicit range, do a bit of optimization based on
6715 -- range analysis (we may be able to kill one or both checks).
6717 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
6718 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
6720 -- If either check is known to fail, replace result by False since
6721 -- the other check does not matter. Preserve the static flag for
6722 -- legality checks, because we are constant-folding beyond RM 4.9.
6724 if Lcheck
= LT
or else Ucheck
= GT
then
6726 Error_Msg_N
("?c?range test optimized away", N
);
6727 Error_Msg_N
("\?c?value is known to be out of range", N
);
6730 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6731 Analyze_And_Resolve
(N
, Restyp
);
6732 Set_Is_Static_Expression
(N
, Static
);
6735 -- If both checks are known to succeed, replace result by True,
6736 -- since we know we are in range.
6738 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6740 Error_Msg_N
("?c?range test optimized away", N
);
6741 Error_Msg_N
("\?c?value is known to be in range", N
);
6744 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6745 Analyze_And_Resolve
(N
, Restyp
);
6746 Set_Is_Static_Expression
(N
, Static
);
6749 -- If lower bound check succeeds and upper bound check is not
6750 -- known to succeed or fail, then replace the range check with
6751 -- a comparison against the upper bound.
6753 elsif Lcheck
in Compare_GE
then
6757 Right_Opnd
=> High_Bound
(Rop
)));
6758 Analyze_And_Resolve
(N
, Restyp
);
6761 -- Inverse of previous case.
6763 elsif Ucheck
in Compare_LE
then
6767 Right_Opnd
=> Low_Bound
(Rop
)));
6768 Analyze_And_Resolve
(N
, Restyp
);
6772 -- We couldn't optimize away the range check, but there is one
6773 -- more issue. If we are checking constant conditionals, then we
6774 -- see if we can determine the outcome assuming everything is
6775 -- valid, and if so give an appropriate warning.
6777 if Warn
and then not Assume_No_Invalid_Values
then
6778 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
6779 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
6781 -- Result is out of range for valid value
6783 if Lcheck
= LT
or else Ucheck
= GT
then
6785 ("?c?value can only be in range if it is invalid", N
);
6787 -- Result is in range for valid value
6789 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
6791 ("?c?value can only be out of range if it is invalid", N
);
6796 -- Try to narrow the operation
6798 if Ltyp
= Universal_Integer
and then Nkind
(N
) = N_In
then
6799 Narrow_Large_Operation
(N
);
6802 -- For all other cases of an explicit range, nothing to be done
6806 -- Here right operand is a subtype mark
6810 Typ
: Entity_Id
:= Etype
(Rop
);
6811 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
6812 Check_Null_Exclusion
: Boolean;
6813 Cond
: Node_Id
:= Empty
;
6815 Obj
: Node_Id
:= Lop
;
6816 SCIL_Node
: Node_Id
;
6819 Remove_Side_Effects
(Obj
);
6821 -- For tagged type, do tagged membership operation
6823 if Is_Tagged_Type
(Typ
) then
6825 -- No expansion will be performed for VM targets, as the VM
6826 -- back ends will handle the membership tests directly.
6828 if Tagged_Type_Expansion
then
6829 Tagged_Membership
(N
, SCIL_Node
, New_N
);
6831 Analyze_And_Resolve
(N
, Restyp
, Suppress
=> All_Checks
);
6833 -- Update decoration of relocated node referenced by the
6836 if Generate_SCIL
and then Present
(SCIL_Node
) then
6837 Set_SCIL_Node
(N
, SCIL_Node
);
6843 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6844 -- The reason we do this is that the bounds may have the wrong
6845 -- type if they come from the original type definition. Also this
6846 -- way we get all the processing above for an explicit range.
6848 -- Don't do this for predicated types, since in this case we want
6849 -- to generate the predicate check at the end of the function.
6851 elsif Is_Scalar_Type
(Typ
) then
6852 if No
(Predicate_Function
(Typ
)) then
6856 Make_Attribute_Reference
(Loc
,
6857 Attribute_Name
=> Name_First
,
6858 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
6861 Make_Attribute_Reference
(Loc
,
6862 Attribute_Name
=> Name_Last
,
6863 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
6865 Analyze_And_Resolve
(N
, Restyp
);
6870 -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is
6871 -- raised when evaluating an individual membership test if the
6872 -- subtype mark denotes a constrained Unchecked_Union subtype
6873 -- and the expression lacks inferable discriminants.
6875 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
6876 and then Is_Constrained
(Typ
)
6877 and then not Has_Inferable_Discriminants
(Lop
)
6880 Make_Expression_With_Actions
(Loc
,
6882 New_List
(Make_Raise_Program_Error
(Loc
,
6883 Reason
=> PE_Unchecked_Union_Restriction
)),
6885 New_Occurrence_Of
(Standard_False
, Loc
)));
6886 Analyze_And_Resolve
(N
, Restyp
);
6891 -- Here we have a non-scalar type
6895 -- If the null exclusion checks are not compatible, need to
6896 -- perform further checks. In other words, we cannot have
6897 -- Ltyp including null and Typ excluding null. All other cases
6900 Check_Null_Exclusion
:=
6901 Can_Never_Be_Null
(Typ
) and then not Can_Never_Be_Null
(Ltyp
);
6902 Typ
:= Designated_Type
(Typ
);
6905 if not Is_Constrained
(Typ
) then
6906 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6908 -- For the constrained array case, we have to check the subscripts
6909 -- for an exact match if the lengths are non-zero (the lengths
6910 -- must match in any case).
6912 elsif Is_Array_Type
(Typ
) then
6913 Check_Subscripts
: declare
6914 function Build_Attribute_Reference
6917 Dim
: Nat
) return Node_Id
;
6918 -- Build attribute reference E'Nam (Dim)
6920 -------------------------------
6921 -- Build_Attribute_Reference --
6922 -------------------------------
6924 function Build_Attribute_Reference
6927 Dim
: Nat
) return Node_Id
6931 Make_Attribute_Reference
(Loc
,
6933 Attribute_Name
=> Nam
,
6934 Expressions
=> New_List
(
6935 Make_Integer_Literal
(Loc
, Dim
)));
6936 end Build_Attribute_Reference
;
6938 -- Start of processing for Check_Subscripts
6941 for J
in 1 .. Number_Dimensions
(Typ
) loop
6942 Evolve_And_Then
(Cond
,
6945 Build_Attribute_Reference
6946 (Duplicate_Subexpr_No_Checks
(Obj
),
6949 Build_Attribute_Reference
6950 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
6952 Evolve_And_Then
(Cond
,
6955 Build_Attribute_Reference
6956 (Duplicate_Subexpr_No_Checks
(Obj
),
6959 Build_Attribute_Reference
6960 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
6962 end Check_Subscripts
;
6964 -- These are the cases where constraint checks may be required,
6965 -- e.g. records with possible discriminants
6968 -- Expand the test into a series of discriminant comparisons.
6969 -- The expression that is built is the negation of the one that
6970 -- is used for checking discriminant constraints.
6972 Obj
:= Relocate_Node
(Left_Opnd
(N
));
6974 if Has_Discriminants
(Typ
) then
6975 Cond
:= Make_Op_Not
(Loc
,
6976 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
6978 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
6983 if Check_Null_Exclusion
then
6984 Cond
:= Make_And_Then
(Loc
,
6988 Right_Opnd
=> Make_Null
(Loc
)),
6989 Right_Opnd
=> Cond
);
6991 Cond
:= Make_Or_Else
(Loc
,
6995 Right_Opnd
=> Make_Null
(Loc
)),
6996 Right_Opnd
=> Cond
);
7001 Analyze_And_Resolve
(N
, Restyp
);
7003 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
7004 -- expression of an anonymous access type. This can involve an
7005 -- accessibility test and a tagged type membership test in the
7006 -- case of tagged designated types.
7008 if Ada_Version
>= Ada_2012
7010 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
7013 Expr_Entity
: Entity_Id
:= Empty
;
7015 Param_Level
: Node_Id
;
7016 Type_Level
: Node_Id
;
7019 if Is_Entity_Name
(Lop
) then
7020 Expr_Entity
:= Param_Entity
(Lop
);
7022 if No
(Expr_Entity
) then
7023 Expr_Entity
:= Entity
(Lop
);
7027 -- When restriction No_Dynamic_Accessibility_Checks is in
7028 -- effect, expand the membership test to a static value
7029 -- since we cannot rely on dynamic levels.
7031 if No_Dynamic_Accessibility_Checks_Enabled
(Lop
) then
7032 if Static_Accessibility_Level
7033 (Lop
, Object_Decl_Level
)
7034 > Type_Access_Level
(Rtyp
)
7036 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
7038 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
7040 Analyze_And_Resolve
(N
, Restyp
);
7042 -- If a conversion of the anonymous access value to the
7043 -- tested type would be illegal, then the result is False.
7045 elsif not Valid_Conversion
7046 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
7048 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
7049 Analyze_And_Resolve
(N
, Restyp
);
7051 -- Apply an accessibility check if the access object has an
7052 -- associated access level and when the level of the type is
7053 -- less deep than the level of the access parameter. This
7054 -- can only occur for access parameters and stand-alone
7055 -- objects of an anonymous access type.
7058 Param_Level
:= Accessibility_Level
7059 (Expr_Entity
, Dynamic_Level
);
7062 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
7064 -- Return True only if the accessibility level of the
7065 -- expression entity is not deeper than the level of
7066 -- the tested access type.
7070 Left_Opnd
=> Relocate_Node
(N
),
7071 Right_Opnd
=> Make_Op_Le
(Loc
,
7072 Left_Opnd
=> Param_Level
,
7073 Right_Opnd
=> Type_Level
)));
7075 Analyze_And_Resolve
(N
);
7077 -- If the designated type is tagged, do tagged membership
7080 if Is_Tagged_Type
(Typ
) then
7082 -- No expansion will be performed for VM targets, as
7083 -- the VM back ends will handle the membership tests
7086 if Tagged_Type_Expansion
then
7088 -- Note that we have to pass Original_Node, because
7089 -- the membership test might already have been
7090 -- rewritten by earlier parts of membership test.
7093 (Original_Node
(N
), SCIL_Node
, New_N
);
7095 -- Update decoration of relocated node referenced
7096 -- by the SCIL node.
7098 if Generate_SCIL
and then Present
(SCIL_Node
) then
7099 Set_SCIL_Node
(New_N
, SCIL_Node
);
7104 Left_Opnd
=> Relocate_Node
(N
),
7105 Right_Opnd
=> New_N
));
7107 Analyze_And_Resolve
(N
, Restyp
);
7116 -- At this point, we have done the processing required for the basic
7117 -- membership test, but not yet dealt with the predicate.
7121 -- If a predicate is present, then we do the predicate test, but we
7122 -- most certainly want to omit this if we are within the predicate
7123 -- function itself, since otherwise we have an infinite recursion.
7124 -- The check should also not be emitted when testing against a range
7125 -- (the check is only done when the right operand is a subtype; see
7126 -- RM12-4.5.2 (28.1/3-30/3)).
7128 Predicate_Check
: declare
7129 function In_Range_Check
return Boolean;
7130 -- Within an expanded range check that may raise Constraint_Error do
7131 -- not generate a predicate check as well. It is redundant because
7132 -- the context will add an explicit predicate check, and it will
7133 -- raise the wrong exception if it fails.
7135 --------------------
7136 -- In_Range_Check --
7137 --------------------
7139 function In_Range_Check
return Boolean is
7143 while Present
(P
) loop
7144 if Nkind
(P
) = N_Raise_Constraint_Error
then
7147 elsif Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
7148 or else Nkind
(P
) = N_Procedure_Call_Statement
7149 or else Nkind
(P
) in N_Declaration
7162 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
7165 -- Start of processing for Predicate_Check
7169 and then Current_Scope
/= PFunc
7170 and then Nkind
(Rop
) /= N_Range
7172 -- First apply the transformation that was skipped above
7174 if Is_Scalar_Type
(Rtyp
) then
7178 Make_Attribute_Reference
(Loc
,
7179 Attribute_Name
=> Name_First
,
7180 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
7183 Make_Attribute_Reference
(Loc
,
7184 Attribute_Name
=> Name_Last
,
7185 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
7187 Analyze_And_Resolve
(N
, Restyp
);
7190 if not In_Range_Check
then
7191 -- Indicate via Static_Mem parameter that this predicate
7192 -- evaluation is for a membership test.
7193 R_Op
:= Make_Predicate_Call
(Rtyp
, Lop
, Static_Mem
=> True);
7195 R_Op
:= New_Occurrence_Of
(Standard_True
, Loc
);
7200 Left_Opnd
=> Relocate_Node
(N
),
7201 Right_Opnd
=> R_Op
));
7203 -- Analyze new expression, mark left operand as analyzed to
7204 -- avoid infinite recursion adding predicate calls. Similarly,
7205 -- suppress further range checks on the call.
7207 Set_Analyzed
(Left_Opnd
(N
));
7208 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7210 end Predicate_Check
;
7213 --------------------------------
7214 -- Expand_N_Indexed_Component --
7215 --------------------------------
7217 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
7219 Wild_Reads_May_Have_Bad_Side_Effects
: Boolean
7220 renames Validity_Check_Subscripts
;
7221 -- This Boolean needs to be True if reading from a bad address can
7222 -- have a bad side effect (e.g., a segmentation fault that is not
7223 -- transformed into a Storage_Error exception, or interactions with
7224 -- memory-mapped I/O) that needs to be prevented. This refers to the
7225 -- act of reading itself, not to any damage that might be caused later
7226 -- by making use of whatever value was read. We assume here that
7227 -- Validity_Check_Subscripts meets this requirement, but introduce
7228 -- this declaration in order to document this assumption.
7230 function Is_Renamed_Variable_Name
(N
: Node_Id
) return Boolean;
7231 -- Returns True if the given name occurs as part of the renaming
7232 -- of a variable. In this case, the indexing operation should be
7233 -- treated as a write, rather than a read, with respect to validity
7234 -- checking. This is because the renamed variable can later be
7237 function Type_Requires_Subscript_Validity_Checks_For_Reads
7238 (Typ
: Entity_Id
) return Boolean;
7239 -- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing
7240 -- into an array of characters in order to read an element, it is ok
7241 -- if an invalid index value goes undetected. But if it is an array of
7242 -- pointers or an array of tasks, the consequences of such a read are
7243 -- potentially more severe and so we want to detect an invalid index
7244 -- value. This function captures that distinction; this is intended to
7245 -- be consistent with the "but does not by itself lead to erroneous
7246 -- ... execution" rule of RM 13.9.1(11).
7248 ------------------------------
7249 -- Is_Renamed_Variable_Name --
7250 ------------------------------
7252 function Is_Renamed_Variable_Name
(N
: Node_Id
) return Boolean is
7253 Rover
: Node_Id
:= N
;
7255 if Is_Variable
(N
) then
7258 Rover_Parent
: constant Node_Id
:= Parent
(Rover
);
7260 case Nkind
(Rover_Parent
) is
7261 when N_Object_Renaming_Declaration
=>
7262 return Rover
= Name
(Rover_Parent
);
7264 when N_Indexed_Component
7266 | N_Selected_Component
7268 exit when Rover
/= Prefix
(Rover_Parent
);
7269 Rover
:= Rover_Parent
;
7271 -- No need to check for qualified expressions or type
7272 -- conversions here, mostly because of the Is_Variable
7273 -- test. It is possible to have a view conversion for
7274 -- which Is_Variable yields True and which occurs as
7275 -- part of an object renaming, but only if the type is
7276 -- tagged; in that case this function will not be called.
7285 end Is_Renamed_Variable_Name
;
7287 -------------------------------------------------------
7288 -- Type_Requires_Subscript_Validity_Checks_For_Reads --
7289 -------------------------------------------------------
7291 function Type_Requires_Subscript_Validity_Checks_For_Reads
7292 (Typ
: Entity_Id
) return Boolean
7294 -- a shorter name for recursive calls
7295 function Needs_Check
(Typ
: Entity_Id
) return Boolean renames
7296 Type_Requires_Subscript_Validity_Checks_For_Reads
;
7298 if Is_Access_Type
(Typ
)
7299 or else Is_Tagged_Type
(Typ
)
7300 or else Is_Concurrent_Type
(Typ
)
7301 or else (Is_Array_Type
(Typ
)
7302 and then Needs_Check
(Component_Type
(Typ
)))
7303 or else (Is_Scalar_Type
(Typ
)
7304 and then Has_Aspect
(Typ
, Aspect_Default_Value
))
7309 if Is_Record_Type
(Typ
) then
7311 Comp
: Entity_Id
:= First_Component_Or_Discriminant
(Typ
);
7313 while Present
(Comp
) loop
7314 if Needs_Check
(Etype
(Comp
)) then
7318 Next_Component_Or_Discriminant
(Comp
);
7324 end Type_Requires_Subscript_Validity_Checks_For_Reads
;
7328 Loc
: constant Source_Ptr
:= Sloc
(N
);
7329 Typ
: constant Entity_Id
:= Etype
(N
);
7330 P
: constant Node_Id
:= Prefix
(N
);
7331 T
: constant Entity_Id
:= Etype
(P
);
7333 -- Start of processing for Expand_N_Indexed_Component
7336 -- A special optimization, if we have an indexed component that is
7337 -- selecting from a slice, then we can eliminate the slice, since, for
7338 -- example, x (i .. j)(k) is identical to x(k). The only difference is
7339 -- the range check required by the slice. The range check for the slice
7340 -- itself has already been generated. The range check for the
7341 -- subscripting operation is ensured by converting the subject to
7342 -- the subtype of the slice.
7344 -- This optimization not only generates better code, avoiding slice
7345 -- messing especially in the packed case, but more importantly bypasses
7346 -- some problems in handling this peculiar case, for example, the issue
7347 -- of dealing specially with object renamings.
7349 if Nkind
(P
) = N_Slice
7351 -- This optimization is disabled for CodePeer because it can transform
7352 -- an index-check constraint_error into a range-check constraint_error
7353 -- and CodePeer cares about that distinction.
7355 and then not CodePeer_Mode
7358 Make_Indexed_Component
(Loc
,
7359 Prefix
=> Prefix
(P
),
7360 Expressions
=> New_List
(
7362 (Etype
(First_Index
(Etype
(P
))),
7363 First
(Expressions
(N
))))));
7364 Analyze_And_Resolve
(N
, Typ
);
7368 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7369 -- function, then additional actuals must be passed.
7371 if Is_Build_In_Place_Function_Call
(P
) then
7372 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
7374 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
7375 -- containing build-in-place function calls whose returned object covers
7378 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
7379 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
7382 -- Generate index and validity checks
7385 Dims_Checked
: Dimension_Set
(Dimensions
=>
7386 (if Is_Array_Type
(T
)
7387 then Number_Dimensions
(T
)
7389 -- Dims_Checked is used to avoid generating two checks (one in
7390 -- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks)
7391 -- for the same index value in cases where the index check eliminates
7392 -- the need for the validity check. The Is_Array_Type test avoids
7393 -- cascading errors.
7396 Generate_Index_Checks
(N
, Checks_Generated
=> Dims_Checked
);
7398 if Validity_Checks_On
7399 and then (Validity_Check_Subscripts
7400 or else Wild_Reads_May_Have_Bad_Side_Effects
7401 or else Type_Requires_Subscript_Validity_Checks_For_Reads
7403 or else Is_Renamed_Variable_Name
(N
))
7405 if Validity_Check_Subscripts
then
7406 -- If we index into an array with an uninitialized variable
7407 -- and we generate an index check that passes at run time,
7408 -- passing that check does not ensure that the variable is
7409 -- valid (although it does in the common case where the
7410 -- object's subtype matches the index subtype).
7411 -- Consider an uninitialized variable with subtype 1 .. 10
7412 -- used to index into an array with bounds 1 .. 20 when the
7413 -- value of the uninitialized variable happens to be 15.
7414 -- The index check will succeed but the variable is invalid.
7415 -- If Validity_Check_Subscripts is True then we need to
7416 -- ensure validity, so we adjust Dims_Checked accordingly.
7417 Dims_Checked
.Elements
:= (others => False);
7419 elsif Is_Array_Type
(T
) then
7420 -- We are only adding extra validity checks here to
7421 -- deal with uninitialized variables (but this includes
7422 -- assigning one uninitialized variable to another). Other
7423 -- ways of producing invalid objects imply erroneousness, so
7424 -- the compiler can do whatever it wants for those cases.
7425 -- If an index type has the Default_Value aspect specified,
7426 -- then we don't have to worry about the possibility of an
7427 -- uninitialized variable, so no need for these extra
7431 Idx
: Node_Id
:= First_Index
(T
);
7433 for No_Check_Needed
of Dims_Checked
.Elements
loop
7434 No_Check_Needed
:= No_Check_Needed
7435 or else Has_Aspect
(Etype
(Idx
), Aspect_Default_Value
);
7441 Apply_Subscript_Validity_Checks
7442 (N
, No_Check_Needed
=> Dims_Checked
);
7446 -- If selecting from an array with atomic components, and atomic sync
7447 -- is not suppressed for this array type, set atomic sync flag.
7449 if (Has_Atomic_Components
(T
)
7450 and then not Atomic_Synchronization_Disabled
(T
))
7451 or else (Is_Atomic
(Typ
)
7452 and then not Atomic_Synchronization_Disabled
(Typ
))
7453 or else (Is_Entity_Name
(P
)
7454 and then Has_Atomic_Components
(Entity
(P
))
7455 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
7457 Activate_Atomic_Synchronization
(N
);
7460 -- All done if the prefix is not a packed array implemented specially
7462 if not (Is_Packed
(Etype
(Prefix
(N
)))
7463 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(N
)))))
7468 -- For packed arrays that are not bit-packed (i.e. the case of an array
7469 -- with one or more index types with a non-contiguous enumeration type),
7470 -- we can always use the normal packed element get circuit.
7472 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
7473 Expand_Packed_Element_Reference
(N
);
7477 -- For a reference to a component of a bit packed array, we convert it
7478 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
7479 -- want to do this for simple references, and not for:
7481 -- Left side of assignment, or prefix of left side of assignment, or
7482 -- prefix of the prefix, to handle packed arrays of packed arrays,
7483 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
7485 -- Renaming objects in renaming associations
7486 -- This case is handled when a use of the renamed variable occurs
7488 -- Actual parameters for a subprogram call
7489 -- This case is handled in Exp_Ch6.Expand_Actuals
7491 -- The second expression in a 'Read attribute reference
7493 -- The prefix of an address or bit or size attribute reference
7495 -- The following circuit detects these exceptions. Note that we need to
7496 -- deal with implicit dereferences when climbing up the parent chain,
7497 -- with the additional difficulty that the type of parents may have yet
7498 -- to be resolved since prefixes are usually resolved first.
7501 Child
: Node_Id
:= N
;
7502 Parnt
: Node_Id
:= Parent
(N
);
7506 if Nkind
(Parnt
) = N_Unchecked_Expression
then
7509 elsif Nkind
(Parnt
) = N_Object_Renaming_Declaration
then
7512 elsif Nkind
(Parnt
) in N_Subprogram_Call
7513 or else (Nkind
(Parnt
) = N_Parameter_Association
7514 and then Nkind
(Parent
(Parnt
)) in N_Subprogram_Call
)
7518 elsif Nkind
(Parnt
) = N_Attribute_Reference
7519 and then Attribute_Name
(Parnt
) in Name_Address
7522 and then Prefix
(Parnt
) = Child
7526 elsif Nkind
(Parnt
) = N_Assignment_Statement
7527 and then Name
(Parnt
) = Child
7531 -- If the expression is an index of an indexed component, it must
7532 -- be expanded regardless of context.
7534 elsif Nkind
(Parnt
) = N_Indexed_Component
7535 and then Child
/= Prefix
(Parnt
)
7537 Expand_Packed_Element_Reference
(N
);
7540 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
7541 and then Name
(Parent
(Parnt
)) = Parnt
7545 elsif Nkind
(Parnt
) = N_Attribute_Reference
7546 and then Attribute_Name
(Parnt
) = Name_Read
7547 and then Next
(First
(Expressions
(Parnt
))) = Child
7551 elsif Nkind
(Parnt
) = N_Indexed_Component
7552 and then Prefix
(Parnt
) = Child
7556 elsif Nkind
(Parnt
) = N_Selected_Component
7557 and then Prefix
(Parnt
) = Child
7558 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
7560 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
7564 -- If the parent is a dereference, either implicit or explicit,
7565 -- then the packed reference needs to be expanded.
7568 Expand_Packed_Element_Reference
(N
);
7572 -- Keep looking up tree for unchecked expression, or if we are the
7573 -- prefix of a possible assignment left side.
7576 Parnt
:= Parent
(Child
);
7579 end Expand_N_Indexed_Component
;
7581 ---------------------
7582 -- Expand_N_Not_In --
7583 ---------------------
7585 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7586 -- can be done. This avoids needing to duplicate this expansion code.
7588 procedure Expand_N_Not_In
(N
: Node_Id
) is
7589 Loc
: constant Source_Ptr
:= Sloc
(N
);
7590 Typ
: constant Entity_Id
:= Etype
(N
);
7591 Cfs
: constant Boolean := Comes_From_Source
(N
);
7598 Left_Opnd
=> Left_Opnd
(N
),
7599 Right_Opnd
=> Right_Opnd
(N
))));
7601 -- If this is a set membership, preserve list of alternatives
7603 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
7605 -- We want this to appear as coming from source if original does (see
7606 -- transformations in Expand_N_In).
7608 Set_Comes_From_Source
(N
, Cfs
);
7609 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
7611 -- Now analyze transformed node
7613 Analyze_And_Resolve
(N
, Typ
);
7614 end Expand_N_Not_In
;
7620 -- The only replacement required is for the case of a null of a type that
7621 -- is an access to protected subprogram, or a subtype thereof. We represent
7622 -- such access values as a record, and so we must replace the occurrence of
7623 -- null by the equivalent record (with a null address and a null pointer in
7624 -- it), so that the back end creates the proper value.
7626 procedure Expand_N_Null
(N
: Node_Id
) is
7627 Loc
: constant Source_Ptr
:= Sloc
(N
);
7628 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
7632 if Is_Access_Protected_Subprogram_Type
(Typ
) then
7634 Make_Aggregate
(Loc
,
7635 Expressions
=> New_List
(
7636 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
7640 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
7642 -- For subsequent semantic analysis, the node must retain its type.
7643 -- Gigi in any case replaces this type by the corresponding record
7644 -- type before processing the node.
7650 when RE_Not_Available
=>
7654 ---------------------
7655 -- Expand_N_Op_Abs --
7656 ---------------------
7658 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
7659 Loc
: constant Source_Ptr
:= Sloc
(N
);
7660 Expr
: constant Node_Id
:= Right_Opnd
(N
);
7661 Typ
: constant Entity_Id
:= Etype
(N
);
7664 Unary_Op_Validity_Checks
(N
);
7666 -- Check for MINIMIZED/ELIMINATED overflow mode
7668 if Minimized_Eliminated_Overflow_Check
(N
) then
7669 Apply_Arithmetic_Overflow_Check
(N
);
7673 -- Try to narrow the operation
7675 if Typ
= Universal_Integer
then
7676 Narrow_Large_Operation
(N
);
7678 if Nkind
(N
) /= N_Op_Abs
then
7683 -- Deal with software overflow checking
7685 if Is_Signed_Integer_Type
(Typ
)
7686 and then Do_Overflow_Check
(N
)
7688 -- The only case to worry about is when the argument is equal to the
7689 -- largest negative number, so what we do is to insert the check:
7691 -- [constraint_error when Expr = typ'Base'First]
7693 -- with the usual Duplicate_Subexpr use coding for expr
7696 Make_Raise_Constraint_Error
(Loc
,
7699 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
7701 Make_Attribute_Reference
(Loc
,
7703 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
7704 Attribute_Name
=> Name_First
)),
7705 Reason
=> CE_Overflow_Check_Failed
));
7707 Set_Do_Overflow_Check
(N
, False);
7709 end Expand_N_Op_Abs
;
7711 ---------------------
7712 -- Expand_N_Op_Add --
7713 ---------------------
7715 procedure Expand_N_Op_Add
(N
: Node_Id
) is
7716 Typ
: constant Entity_Id
:= Etype
(N
);
7719 Binary_Op_Validity_Checks
(N
);
7721 -- Check for MINIMIZED/ELIMINATED overflow mode
7723 if Minimized_Eliminated_Overflow_Check
(N
) then
7724 Apply_Arithmetic_Overflow_Check
(N
);
7728 -- N + 0 = 0 + N = N for integer types
7730 if Is_Integer_Type
(Typ
) then
7731 if Compile_Time_Known_Value
(Right_Opnd
(N
))
7732 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
7734 Rewrite
(N
, Left_Opnd
(N
));
7737 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
7738 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
7740 Rewrite
(N
, Right_Opnd
(N
));
7745 -- Try to narrow the operation
7747 if Typ
= Universal_Integer
then
7748 Narrow_Large_Operation
(N
);
7750 if Nkind
(N
) /= N_Op_Add
then
7755 -- Arithmetic overflow checks for signed integer/fixed point types
7757 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
7758 Apply_Arithmetic_Overflow_Check
(N
);
7762 -- Overflow checks for floating-point if -gnateF mode active
7764 Check_Float_Op_Overflow
(N
);
7766 Expand_Nonbinary_Modular_Op
(N
);
7767 end Expand_N_Op_Add
;
7769 ---------------------
7770 -- Expand_N_Op_And --
7771 ---------------------
7773 procedure Expand_N_Op_And
(N
: Node_Id
) is
7774 Typ
: constant Entity_Id
:= Etype
(N
);
7777 Binary_Op_Validity_Checks
(N
);
7779 if Is_Array_Type
(Etype
(N
)) then
7780 Expand_Boolean_Operator
(N
);
7782 elsif Is_Boolean_Type
(Etype
(N
)) then
7783 Adjust_Condition
(Left_Opnd
(N
));
7784 Adjust_Condition
(Right_Opnd
(N
));
7785 Set_Etype
(N
, Standard_Boolean
);
7786 Adjust_Result_Type
(N
, Typ
);
7788 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
7789 Expand_Intrinsic_Call
(N
, Entity
(N
));
7792 Expand_Nonbinary_Modular_Op
(N
);
7793 end Expand_N_Op_And
;
7795 ------------------------
7796 -- Expand_N_Op_Concat --
7797 ------------------------
7799 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
7801 -- List of operands to be concatenated
7804 -- Node which is to be replaced by the result of concatenating the nodes
7805 -- in the list Opnds.
7808 -- Ensure validity of both operands
7810 Binary_Op_Validity_Checks
(N
);
7812 -- If we are the left operand of a concatenation higher up the tree,
7813 -- then do nothing for now, since we want to deal with a series of
7814 -- concatenations as a unit.
7816 if Nkind
(Parent
(N
)) = N_Op_Concat
7817 and then N
= Left_Opnd
(Parent
(N
))
7822 -- We get here with a concatenation whose left operand may be a
7823 -- concatenation itself with a consistent type. We need to process
7824 -- these concatenation operands from left to right, which means
7825 -- from the deepest node in the tree to the highest node.
7828 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
7829 Cnode
:= Left_Opnd
(Cnode
);
7832 -- Now Cnode is the deepest concatenation, and its parents are the
7833 -- concatenation nodes above, so now we process bottom up, doing the
7836 -- The outer loop runs more than once if more than one concatenation
7837 -- type is involved.
7840 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
7841 Set_Parent
(Opnds
, N
);
7843 -- The inner loop gathers concatenation operands
7845 Inner
: while Cnode
/= N
7846 and then Base_Type
(Etype
(Cnode
)) =
7847 Base_Type
(Etype
(Parent
(Cnode
)))
7849 Cnode
:= Parent
(Cnode
);
7850 Append
(Right_Opnd
(Cnode
), Opnds
);
7853 -- Note: The following code is a temporary workaround for N731-034
7854 -- and N829-028 and will be kept until the general issue of internal
7855 -- symbol serialization is addressed. The workaround is kept under a
7856 -- debug switch to avoid permiating into the general case.
7858 -- Wrap the node to concatenate into an expression actions node to
7859 -- keep it nicely packaged. This is useful in the case of an assert
7860 -- pragma with a concatenation where we want to be able to delete
7861 -- the concatenation and all its expansion stuff.
7863 if Debug_Flag_Dot_H
then
7865 Cnod
: constant Node_Id
:= New_Copy_Tree
(Cnode
);
7866 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
7869 -- Note: use Rewrite rather than Replace here, so that for
7870 -- example Why_Not_Static can find the original concatenation
7874 Make_Expression_With_Actions
(Sloc
(Cnode
),
7875 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
7876 Expression
=> Cnod
));
7878 Expand_Concatenate
(Cnod
, Opnds
);
7879 Analyze_And_Resolve
(Cnode
, Typ
);
7885 Expand_Concatenate
(Cnode
, Opnds
);
7888 exit Outer
when Cnode
= N
;
7889 Cnode
:= Parent
(Cnode
);
7891 end Expand_N_Op_Concat
;
7893 ------------------------
7894 -- Expand_N_Op_Divide --
7895 ------------------------
7897 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
7898 Loc
: constant Source_Ptr
:= Sloc
(N
);
7899 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
7900 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
7901 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
7902 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
7903 Typ
: Entity_Id
:= Etype
(N
);
7904 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
7906 Compile_Time_Known_Value
(Ropnd
);
7910 Binary_Op_Validity_Checks
(N
);
7912 -- Check for MINIMIZED/ELIMINATED overflow mode
7914 if Minimized_Eliminated_Overflow_Check
(N
) then
7915 Apply_Arithmetic_Overflow_Check
(N
);
7919 -- Otherwise proceed with expansion of division
7922 Rval
:= Expr_Value
(Ropnd
);
7925 -- N / 1 = N for integer types
7927 if Rknow
and then Rval
= Uint_1
then
7932 -- Try to narrow the operation
7934 if Typ
= Universal_Integer
then
7935 Narrow_Large_Operation
(N
);
7937 if Nkind
(N
) /= N_Op_Divide
then
7942 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7943 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7944 -- operand is an unsigned integer, as required for this to work.
7946 if Nkind
(Ropnd
) = N_Op_Expon
7947 and then Is_Power_Of_2_For_Shift
(Ropnd
)
7949 -- We cannot do this transformation in configurable run time mode if we
7950 -- have 64-bit integers and long shifts are not available.
7952 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
7955 Make_Op_Shift_Right
(Loc
,
7958 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
7959 Analyze_And_Resolve
(N
, Typ
);
7963 -- Do required fixup of universal fixed operation
7965 if Typ
= Universal_Fixed
then
7966 Fixup_Universal_Fixed_Operation
(N
);
7970 -- Divisions with fixed-point results
7972 if Is_Fixed_Point_Type
(Typ
) then
7974 if Is_Integer_Type
(Rtyp
) then
7975 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
7977 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
7980 -- Deal with divide-by-zero check if back end cannot handle them
7981 -- and the flag is set indicating that we need such a check. Note
7982 -- that we don't need to bother here with the case of mixed-mode
7983 -- (Right operand an integer type), since these will be rewritten
7984 -- with conversions to a divide with a fixed-point right operand.
7986 if Nkind
(N
) = N_Op_Divide
7987 and then Do_Division_Check
(N
)
7988 and then not Backend_Divide_Checks_On_Target
7989 and then not Is_Integer_Type
(Rtyp
)
7991 Set_Do_Division_Check
(N
, False);
7993 Make_Raise_Constraint_Error
(Loc
,
7996 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
7997 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
7998 Reason
=> CE_Divide_By_Zero
));
8001 -- Other cases of division of fixed-point operands
8003 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
8004 if Is_Integer_Type
(Typ
) then
8005 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
8007 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8008 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
8011 -- Mixed-mode operations can appear in a non-static universal context,
8012 -- in which case the integer argument must be converted explicitly.
8014 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
8016 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
8018 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
8020 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
8022 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
8024 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
8026 -- Non-fixed point cases, do integer zero divide and overflow checks
8028 elsif Is_Integer_Type
(Typ
) then
8029 Apply_Divide_Checks
(N
);
8032 -- Overflow checks for floating-point if -gnateF mode active
8034 Check_Float_Op_Overflow
(N
);
8036 Expand_Nonbinary_Modular_Op
(N
);
8037 end Expand_N_Op_Divide
;
8039 --------------------
8040 -- Expand_N_Op_Eq --
8041 --------------------
8043 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
8044 Loc
: constant Source_Ptr
:= Sloc
(N
);
8045 Typ
: constant Entity_Id
:= Etype
(N
);
8046 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
8047 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
8048 Bodies
: constant List_Id
:= New_List
;
8049 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
8051 procedure Build_Equality_Call
(Eq
: Entity_Id
);
8052 -- If a constructed equality exists for the type or for its parent,
8053 -- build and analyze call, adding conversions if the operation is
8056 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
;
8057 -- Find a primitive equality function within primitive operation list
8060 function Has_Unconstrained_UU_Component
(Typ
: Entity_Id
) return Boolean;
8061 -- Determines whether a type has a subcomponent of an unconstrained
8062 -- Unchecked_Union subtype. Typ is a record type.
8064 -------------------------
8065 -- Build_Equality_Call --
8066 -------------------------
8068 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
8069 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
8070 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
8071 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
8074 -- Adjust operands if necessary to comparison type
8076 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
8077 and then not Is_Class_Wide_Type
(A_Typ
)
8079 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
8080 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
8083 -- If we have an Unchecked_Union, we need to add the inferred
8084 -- discriminant values as actuals in the function call. At this
8085 -- point, the expansion has determined that both operands have
8086 -- inferable discriminants.
8088 if Is_Unchecked_Union
(Op_Type
) then
8090 Lhs_Type
: constant Entity_Id
:= Etype
(L_Exp
);
8091 Rhs_Type
: constant Entity_Id
:= Etype
(R_Exp
);
8093 Lhs_Discr_Vals
: Elist_Id
;
8094 -- List of inferred discriminant values for left operand.
8096 Rhs_Discr_Vals
: Elist_Id
;
8097 -- List of inferred discriminant values for right operand.
8102 Lhs_Discr_Vals
:= New_Elmt_List
;
8103 Rhs_Discr_Vals
:= New_Elmt_List
;
8105 -- Per-object constrained selected components require special
8106 -- attention. If the enclosing scope of the component is an
8107 -- Unchecked_Union, we cannot reference its discriminants
8108 -- directly. This is why we use the extra parameters of the
8109 -- equality function of the enclosing Unchecked_Union.
8111 -- type UU_Type (Discr : Integer := 0) is
8114 -- pragma Unchecked_Union (UU_Type);
8116 -- 1. Unchecked_Union enclosing record:
8118 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
8120 -- Comp : UU_Type (Discr);
8122 -- end Enclosing_UU_Type;
8123 -- pragma Unchecked_Union (Enclosing_UU_Type);
8125 -- Obj1 : Enclosing_UU_Type;
8126 -- Obj2 : Enclosing_UU_Type (1);
8128 -- [. . .] Obj1 = Obj2 [. . .]
8132 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
8134 -- A and B are the formal parameters of the equality function
8135 -- of Enclosing_UU_Type. The function always has two extra
8136 -- formals to capture the inferred discriminant values for
8137 -- each discriminant of the type.
8139 -- 2. Non-Unchecked_Union enclosing record:
8142 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
8145 -- Comp : UU_Type (Discr);
8147 -- end Enclosing_Non_UU_Type;
8149 -- Obj1 : Enclosing_Non_UU_Type;
8150 -- Obj2 : Enclosing_Non_UU_Type (1);
8152 -- ... Obj1 = Obj2 ...
8156 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
8157 -- obj1.discr, obj2.discr)) then
8159 -- In this case we can directly reference the discriminants of
8160 -- the enclosing record.
8162 -- Process left operand of equality
8164 if Nkind
(Lhs
) = N_Selected_Component
8166 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
8168 -- If enclosing record is an Unchecked_Union, use formals
8169 -- corresponding to each discriminant. The name of the
8170 -- formal is that of the discriminant, with added suffix,
8171 -- see Exp_Ch3.Build_Record_Equality for details.
8173 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Lhs
))))
8177 (Scope
(Entity
(Selector_Name
(Lhs
))));
8178 while Present
(Discr
) loop
8180 (Make_Identifier
(Loc
,
8181 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
8182 To
=> Lhs_Discr_Vals
);
8183 Next_Discriminant
(Discr
);
8186 -- If enclosing record is of a non-Unchecked_Union type, it
8187 -- is possible to reference its discriminants directly.
8190 Discr
:= First_Discriminant
(Lhs_Type
);
8191 while Present
(Discr
) loop
8193 (Make_Selected_Component
(Loc
,
8194 Prefix
=> Prefix
(Lhs
),
8197 (Get_Discriminant_Value
(Discr
,
8199 Stored_Constraint
(Lhs_Type
)))),
8200 To
=> Lhs_Discr_Vals
);
8201 Next_Discriminant
(Discr
);
8205 -- Otherwise operand is on object with a constrained type.
8206 -- Infer the discriminant values from the constraint.
8209 Discr
:= First_Discriminant
(Lhs_Type
);
8210 while Present
(Discr
) loop
8213 (Get_Discriminant_Value
(Discr
,
8215 Stored_Constraint
(Lhs_Type
))),
8216 To
=> Lhs_Discr_Vals
);
8217 Next_Discriminant
(Discr
);
8221 -- Similar processing for right operand of equality
8223 if Nkind
(Rhs
) = N_Selected_Component
8225 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
8227 if Is_Unchecked_Union
8228 (Scope
(Entity
(Selector_Name
(Rhs
))))
8232 (Scope
(Entity
(Selector_Name
(Rhs
))));
8233 while Present
(Discr
) loop
8235 (Make_Identifier
(Loc
,
8236 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
8237 To
=> Rhs_Discr_Vals
);
8238 Next_Discriminant
(Discr
);
8242 Discr
:= First_Discriminant
(Rhs_Type
);
8243 while Present
(Discr
) loop
8245 (Make_Selected_Component
(Loc
,
8246 Prefix
=> Prefix
(Rhs
),
8248 New_Copy
(Get_Discriminant_Value
8251 Stored_Constraint
(Rhs_Type
)))),
8252 To
=> Rhs_Discr_Vals
);
8253 Next_Discriminant
(Discr
);
8258 Discr
:= First_Discriminant
(Rhs_Type
);
8259 while Present
(Discr
) loop
8261 (New_Copy
(Get_Discriminant_Value
8264 Stored_Constraint
(Rhs_Type
))),
8265 To
=> Rhs_Discr_Vals
);
8266 Next_Discriminant
(Discr
);
8270 -- Now merge the list of discriminant values so that values
8271 -- of corresponding discriminants are adjacent.
8279 Params
:= New_List
(L_Exp
, R_Exp
);
8280 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
8281 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
8282 while Present
(L_Elmt
) loop
8283 Append_To
(Params
, Node
(L_Elmt
));
8284 Append_To
(Params
, Node
(R_Elmt
));
8290 Make_Function_Call
(Loc
,
8291 Name
=> New_Occurrence_Of
(Eq
, Loc
),
8292 Parameter_Associations
=> Params
));
8296 -- Normal case, not an unchecked union
8300 Make_Function_Call
(Loc
,
8301 Name
=> New_Occurrence_Of
(Eq
, Loc
),
8302 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
8305 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8306 end Build_Equality_Call
;
8312 function Find_Equality
(Prims
: Elist_Id
) return Entity_Id
is
8313 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
;
8314 -- Find an equality in a possible alias chain starting from primitive
8317 ---------------------------
8318 -- Find_Aliased_Equality --
8319 ---------------------------
8321 function Find_Aliased_Equality
(Prim
: Entity_Id
) return Entity_Id
is
8325 -- Inspect each candidate in the alias chain, checking whether it
8326 -- denotes an equality.
8329 while Present
(Candid
) loop
8330 if Is_User_Defined_Equality
(Candid
) then
8334 Candid
:= Alias
(Candid
);
8338 end Find_Aliased_Equality
;
8342 Eq_Prim
: Entity_Id
;
8343 Prim_Elmt
: Elmt_Id
;
8345 -- Start of processing for Find_Equality
8348 -- Assume that the tagged type lacks an equality
8352 -- Inspect the list of primitives looking for a suitable equality
8353 -- within a possible chain of aliases.
8355 Prim_Elmt
:= First_Elmt
(Prims
);
8356 while Present
(Prim_Elmt
) and then No
(Eq_Prim
) loop
8357 Eq_Prim
:= Find_Aliased_Equality
(Node
(Prim_Elmt
));
8359 Next_Elmt
(Prim_Elmt
);
8362 -- A tagged type should always have an equality
8364 pragma Assert
(Present
(Eq_Prim
));
8369 ------------------------------------
8370 -- Has_Unconstrained_UU_Component --
8371 ------------------------------------
8373 function Has_Unconstrained_UU_Component
8374 (Typ
: Entity_Id
) return Boolean
8376 function Unconstrained_UU_In_Component_Declaration
8377 (N
: Node_Id
) return Boolean;
8379 function Unconstrained_UU_In_Component_Items
8380 (L
: List_Id
) return Boolean;
8382 function Unconstrained_UU_In_Component_List
8383 (N
: Node_Id
) return Boolean;
8385 function Unconstrained_UU_In_Variant_Part
8386 (N
: Node_Id
) return Boolean;
8387 -- A family of routines that determine whether a particular construct
8388 -- of a record type definition contains a subcomponent of an
8389 -- unchecked union type whose nominal subtype is unconstrained.
8391 -- Individual routines correspond to the production rules of the Ada
8392 -- grammar, as described in the Ada RM (P).
8394 -----------------------------------------------
8395 -- Unconstrained_UU_In_Component_Declaration --
8396 -----------------------------------------------
8398 function Unconstrained_UU_In_Component_Declaration
8399 (N
: Node_Id
) return Boolean
8401 pragma Assert
(Nkind
(N
) = N_Component_Declaration
);
8403 Sindic
: constant Node_Id
:=
8404 Subtype_Indication
(Component_Definition
(N
));
8406 -- If the component declaration includes a subtype indication
8407 -- it is not an unchecked_union. Otherwise verify that it carries
8408 -- the Unchecked_Union flag and is either a record or a private
8409 -- type. A Record_Subtype declared elsewhere does not qualify,
8410 -- even if its parent type carries the flag.
8412 return Nkind
(Sindic
) in N_Expanded_Name | N_Identifier
8413 and then Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)))
8414 and then (Ekind
(Entity
(Sindic
)) in
8415 E_Private_Type | E_Record_Type
);
8416 end Unconstrained_UU_In_Component_Declaration
;
8418 -----------------------------------------
8419 -- Unconstrained_UU_In_Component_Items --
8420 -----------------------------------------
8422 function Unconstrained_UU_In_Component_Items
8423 (L
: List_Id
) return Boolean
8425 N
: Node_Id
:= First
(L
);
8427 while Present
(N
) loop
8428 if Nkind
(N
) = N_Component_Declaration
8429 and then Unconstrained_UU_In_Component_Declaration
(N
)
8438 end Unconstrained_UU_In_Component_Items
;
8440 ----------------------------------------
8441 -- Unconstrained_UU_In_Component_List --
8442 ----------------------------------------
8444 function Unconstrained_UU_In_Component_List
8445 (N
: Node_Id
) return Boolean
8447 pragma Assert
(Nkind
(N
) = N_Component_List
);
8449 Optional_Variant_Part
: Node_Id
;
8451 if Unconstrained_UU_In_Component_Items
(Component_Items
(N
)) then
8455 Optional_Variant_Part
:= Variant_Part
(N
);
8458 Present
(Optional_Variant_Part
)
8460 Unconstrained_UU_In_Variant_Part
(Optional_Variant_Part
);
8461 end Unconstrained_UU_In_Component_List
;
8463 --------------------------------------
8464 -- Unconstrained_UU_In_Variant_Part --
8465 --------------------------------------
8467 function Unconstrained_UU_In_Variant_Part
8468 (N
: Node_Id
) return Boolean
8470 pragma Assert
(Nkind
(N
) = N_Variant_Part
);
8472 Variant
: Node_Id
:= First
(Variants
(N
));
8475 if Unconstrained_UU_In_Component_List
(Component_List
(Variant
))
8481 exit when No
(Variant
);
8485 end Unconstrained_UU_In_Variant_Part
;
8487 Typ_Def
: constant Node_Id
:=
8488 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
8490 Optional_Component_List
: constant Node_Id
:=
8491 Component_List
(Typ_Def
);
8493 -- Start of processing for Has_Unconstrained_UU_Component
8496 return Present
(Optional_Component_List
)
8498 Unconstrained_UU_In_Component_List
(Optional_Component_List
);
8499 end Has_Unconstrained_UU_Component
;
8505 -- Start of processing for Expand_N_Op_Eq
8508 Binary_Op_Validity_Checks
(N
);
8510 -- Deal with private types
8512 Typl
:= Underlying_Type
(A_Typ
);
8514 -- It may happen in error situations that the underlying type is not
8515 -- set. The error will be detected later, here we just defend the
8522 -- Now get the implementation base type (note that plain Base_Type here
8523 -- might lead us back to the private type, which is not what we want!)
8525 Typl
:= Implementation_Base_Type
(Typl
);
8527 -- Equality between variant records results in a call to a routine
8528 -- that has conditional tests of the discriminant value(s), and hence
8529 -- violates the No_Implicit_Conditionals restriction.
8531 if Has_Variant_Part
(Typl
) then
8536 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
8540 ("\comparison of variant records tests discriminants", N
);
8546 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8547 -- means we no longer have a comparison operation, we are all done.
8549 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
)) then
8550 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8553 if Nkind
(N
) /= N_Op_Eq
then
8557 -- Boolean types (requiring handling of non-standard case)
8559 if Is_Boolean_Type
(Typl
) then
8560 Adjust_Condition
(Left_Opnd
(N
));
8561 Adjust_Condition
(Right_Opnd
(N
));
8562 Set_Etype
(N
, Standard_Boolean
);
8563 Adjust_Result_Type
(N
, Typ
);
8567 elsif Is_Array_Type
(Typl
) then
8569 -- If we are doing full validity checking, and it is possible for the
8570 -- array elements to be invalid then expand out array comparisons to
8571 -- make sure that we check the array elements.
8573 if Validity_Check_Operands
8574 and then not Is_Known_Valid
(Component_Type
(Typl
))
8577 Save_Force_Validity_Checks
: constant Boolean :=
8578 Force_Validity_Checks
;
8580 Force_Validity_Checks
:= True;
8582 Expand_Array_Equality
8584 Relocate_Node
(Lhs
),
8585 Relocate_Node
(Rhs
),
8588 Insert_Actions
(N
, Bodies
);
8589 Analyze_And_Resolve
(N
, Standard_Boolean
);
8590 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
8593 -- Packed case where both operands are known aligned
8595 elsif Is_Bit_Packed_Array
(Typl
)
8596 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8597 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8599 Expand_Packed_Eq
(N
);
8601 -- Where the component type is elementary we can use a block bit
8602 -- comparison (if supported on the target) exception in the case
8603 -- of floating-point (negative zero issues require element by
8604 -- element comparison), and full access types (where we must be sure
8605 -- to load elements independently) and possibly unaligned arrays.
8607 elsif Is_Elementary_Type
(Component_Type
(Typl
))
8608 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
8609 and then not Is_Full_Access
(Component_Type
(Typl
))
8610 and then not Is_Possibly_Unaligned_Object
(Lhs
)
8611 and then not Is_Possibly_Unaligned_Slice
(Lhs
)
8612 and then not Is_Possibly_Unaligned_Object
(Rhs
)
8613 and then not Is_Possibly_Unaligned_Slice
(Rhs
)
8614 and then Support_Composite_Compare_On_Target
8618 -- For composite and floating-point cases, expand equality loop to
8619 -- make sure of using proper comparisons for tagged types, and
8620 -- correctly handling the floating-point case.
8624 Expand_Array_Equality
8626 Relocate_Node
(Lhs
),
8627 Relocate_Node
(Rhs
),
8630 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
8631 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8636 elsif Is_Record_Type
(Typl
) then
8638 -- For tagged types, use the primitive "="
8640 if Is_Tagged_Type
(Typl
) then
8642 -- No need to do anything else compiling under restriction
8643 -- No_Dispatching_Calls. During the semantic analysis we
8644 -- already notified such violation.
8646 if Restriction_Active
(No_Dispatching_Calls
) then
8650 -- If this is an untagged private type completed with a derivation
8651 -- of an untagged private type whose full view is a tagged type,
8652 -- we use the primitive operations of the private type (since it
8653 -- does not have a full view, and also because its equality
8654 -- primitive may have been overridden in its untagged full view).
8656 if Inherits_From_Tagged_Full_View
(A_Typ
) then
8658 (Find_Equality
(Collect_Primitive_Operations
(A_Typ
)));
8660 -- Find the type's predefined equality or an overriding
8661 -- user-defined equality. The reason for not simply calling
8662 -- Find_Prim_Op here is that there may be a user-defined
8663 -- overloaded equality op that precedes the equality that we
8664 -- want, so we have to explicitly search (e.g., there could be
8665 -- an equality with two different parameter types).
8668 if Is_Class_Wide_Type
(Typl
) then
8669 Typl
:= Find_Specific_Type
(Typl
);
8673 (Find_Equality
(Primitive_Operations
(Typl
)));
8676 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8677 -- predefined equality operator for a type which has a subcomponent
8678 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
8680 elsif Has_Unconstrained_UU_Component
(Typl
) then
8682 Make_Raise_Program_Error
(Loc
,
8683 Reason
=> PE_Unchecked_Union_Restriction
));
8685 -- Prevent Gigi from generating incorrect code by rewriting the
8686 -- equality as a standard False. (is this documented somewhere???)
8689 New_Occurrence_Of
(Standard_False
, Loc
));
8691 elsif Is_Unchecked_Union
(Typl
) then
8693 -- If we can infer the discriminants of the operands, we make a
8694 -- call to the TSS equality function.
8696 if Has_Inferable_Discriminants
(Lhs
)
8698 Has_Inferable_Discriminants
(Rhs
)
8701 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8704 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
8705 -- the predefined equality operator for an Unchecked_Union type
8706 -- if either of the operands lack inferable discriminants.
8709 Make_Raise_Program_Error
(Loc
,
8710 Reason
=> PE_Unchecked_Union_Restriction
));
8712 -- Emit a warning on source equalities only, otherwise the
8713 -- message may appear out of place due to internal use. The
8714 -- warning is unconditional because it is required by the
8717 if Comes_From_Source
(N
) then
8719 ("Unchecked_Union discriminants cannot be determined??",
8722 ("\Program_Error will be raised for equality operation??",
8726 -- Prevent Gigi from generating incorrect code by rewriting
8727 -- the equality as a standard False (documented where???).
8730 New_Occurrence_Of
(Standard_False
, Loc
));
8733 -- If a type support function is present (for complex cases), use it
8735 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
8737 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
8739 -- When comparing two Bounded_Strings, use the primitive equality of
8740 -- the root Super_String type.
8742 elsif Is_Bounded_String
(Typl
) then
8745 (Collect_Primitive_Operations
(Root_Type
(Typl
))));
8747 -- Otherwise expand the component by component equality. Note that
8748 -- we never use block-bit comparisons for records, because of the
8749 -- problems with gaps. The back end will often be able to recombine
8750 -- the separate comparisons that we generate here.
8753 Remove_Side_Effects
(Lhs
);
8754 Remove_Side_Effects
(Rhs
);
8755 Rewrite
(N
, Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
));
8757 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8760 -- If unnesting, handle elementary types whose Equivalent_Types are
8761 -- records because there may be padding or undefined fields.
8763 elsif Unnest_Subprogram_Mode
8764 and then Ekind
(Typl
) in E_Class_Wide_Type
8765 | E_Class_Wide_Subtype
8766 | E_Access_Subprogram_Type
8767 | E_Access_Protected_Subprogram_Type
8768 | E_Anonymous_Access_Protected_Subprogram_Type
8770 and then Present
(Equivalent_Type
(Typl
))
8771 and then Is_Record_Type
(Equivalent_Type
(Typl
))
8773 Typl
:= Equivalent_Type
(Typl
);
8774 Remove_Side_Effects
(Lhs
);
8775 Remove_Side_Effects
(Rhs
);
8777 Expand_Record_Equality
(N
, Typl
,
8778 Unchecked_Convert_To
(Typl
, Lhs
),
8779 Unchecked_Convert_To
(Typl
, Rhs
)));
8781 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
8784 -- Test if result is known at compile time
8786 Rewrite_Comparison
(N
);
8788 -- Try to narrow the operation
8790 if Typl
= Universal_Integer
and then Nkind
(N
) = N_Op_Eq
then
8791 Narrow_Large_Operation
(N
);
8794 -- Special optimization of length comparison
8796 Optimize_Length_Comparison
(N
);
8798 -- One more special case: if we have a comparison of X'Result = expr
8799 -- in floating-point, then if not already there, change expr to be
8800 -- f'Machine (expr) to eliminate surprise from extra precision.
8802 if Is_Floating_Point_Type
(Typl
)
8803 and then Is_Attribute_Result
(Original_Node
(Lhs
))
8805 -- Stick in the Typ'Machine call if not already there
8807 if Nkind
(Rhs
) /= N_Attribute_Reference
8808 or else Attribute_Name
(Rhs
) /= Name_Machine
8811 Make_Attribute_Reference
(Loc
,
8812 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
8813 Attribute_Name
=> Name_Machine
,
8814 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
8815 Analyze_And_Resolve
(Rhs
, Typl
);
8820 -----------------------
8821 -- Expand_N_Op_Expon --
8822 -----------------------
8824 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
8825 Loc
: constant Source_Ptr
:= Sloc
(N
);
8826 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
8827 Typ
: constant Entity_Id
:= Etype
(N
);
8828 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
8832 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
8833 -- Given an expression Exp, if the root type is Float or Long_Float,
8834 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8835 -- extra precision. This is done to ensure that X**A = X**B when A is
8836 -- a static constant and B is a variable with the same value. For any
8837 -- other type, the node Exp is returned unchanged.
8843 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
8844 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
8847 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
8849 Make_Attribute_Reference
(Loc
,
8850 Attribute_Name
=> Name_Machine
,
8851 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
8852 Expressions
=> New_List
(Relocate_Node
(Exp
)));
8870 -- Start of processing for Expand_N_Op_Expon
8873 Binary_Op_Validity_Checks
(N
);
8875 -- CodePeer wants to see the unexpanded N_Op_Expon node
8877 if CodePeer_Mode
then
8881 -- Relocation of left and right operands must be done after performing
8882 -- the validity checks since the generation of validation checks may
8883 -- remove side effects.
8885 Base
:= Relocate_Node
(Left_Opnd
(N
));
8886 Bastyp
:= Etype
(Base
);
8887 Exp
:= Relocate_Node
(Right_Opnd
(N
));
8888 Exptyp
:= Etype
(Exp
);
8890 -- If either operand is of a private type, then we have the use of an
8891 -- intrinsic operator, and we get rid of the privateness, by using root
8892 -- types of underlying types for the actual operation. Otherwise the
8893 -- private types will cause trouble if we expand multiplications or
8894 -- shifts etc. We also do this transformation if the result type is
8895 -- different from the base type.
8897 if Is_Private_Type
(Etype
(Base
))
8898 or else Is_Private_Type
(Typ
)
8899 or else Is_Private_Type
(Exptyp
)
8900 or else Rtyp
/= Root_Type
(Bastyp
)
8903 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
8904 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
8907 Unchecked_Convert_To
(Typ
,
8909 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
8910 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
8911 Analyze_And_Resolve
(N
, Typ
);
8916 -- Check for MINIMIZED/ELIMINATED overflow mode
8918 if Minimized_Eliminated_Overflow_Check
(N
) then
8919 Apply_Arithmetic_Overflow_Check
(N
);
8923 -- Test for case of known right argument where we can replace the
8924 -- exponentiation by an equivalent expression using multiplication.
8926 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8927 -- configurable run-time mode, we may not have the exponentiation
8928 -- routine available, and we don't want the legality of the program
8929 -- to depend on how clever the compiler is in knowing values.
8931 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
8932 Expv
:= Expr_Value
(Exp
);
8934 -- We only fold small non-negative exponents. You might think we
8935 -- could fold small negative exponents for the real case, but we
8936 -- can't because we are required to raise Constraint_Error for
8937 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8938 -- See ACVC test C4A012B, and it is not worth generating the test.
8940 -- For small negative exponents, we return the reciprocal of
8941 -- the folding of the exponentiation for the opposite (positive)
8942 -- exponent, as required by Ada RM 4.5.6(11/3).
8944 if abs Expv
<= 4 then
8946 -- X ** 0 = 1 (or 1.0)
8950 -- Call Remove_Side_Effects to ensure that any side effects
8951 -- in the ignored left operand (in particular function calls
8952 -- to user defined functions) are properly executed.
8954 Remove_Side_Effects
(Base
);
8956 if Ekind
(Typ
) in Integer_Kind
then
8957 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
8959 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
8972 Make_Op_Multiply
(Loc
,
8973 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8974 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8976 -- X ** 3 = X * X * X
8981 Make_Op_Multiply
(Loc
,
8983 Make_Op_Multiply
(Loc
,
8984 Left_Opnd
=> Duplicate_Subexpr
(Base
),
8985 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
8986 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
8991 -- En : constant base'type := base * base;
8996 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
8999 Make_Expression_With_Actions
(Loc
,
9000 Actions
=> New_List
(
9001 Make_Object_Declaration
(Loc
,
9002 Defining_Identifier
=> Temp
,
9003 Constant_Present
=> True,
9004 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9007 Make_Op_Multiply
(Loc
,
9009 Duplicate_Subexpr
(Base
),
9011 Duplicate_Subexpr_No_Checks
(Base
))))),
9015 Make_Op_Multiply
(Loc
,
9016 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
9017 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
9019 -- X ** N = 1.0 / X ** (-N)
9024 (Expv
= -1 or Expv
= -2 or Expv
= -3 or Expv
= -4);
9027 Make_Op_Divide
(Loc
,
9029 Make_Float_Literal
(Loc
,
9031 Significand
=> Uint_1
,
9032 Exponent
=> Uint_0
),
9035 Left_Opnd
=> Duplicate_Subexpr
(Base
),
9037 Make_Integer_Literal
(Loc
,
9042 Analyze_And_Resolve
(N
, Typ
);
9047 -- Deal with optimizing 2 ** expression to shift where possible
9049 -- Note: we used to check that Exptyp was an unsigned type. But that is
9050 -- an unnecessary check, since if Exp is negative, we have a run-time
9051 -- error that is either caught (so we get the right result) or we have
9052 -- suppressed the check, in which case the code is erroneous anyway.
9054 if Is_Integer_Type
(Rtyp
)
9056 -- The base value must be "safe compile-time known", and exactly 2
9058 and then Nkind
(Base
) = N_Integer_Literal
9059 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
9060 and then Expr_Value
(Base
) = Uint_2
9062 -- We only handle cases where the right type is a integer
9064 and then Is_Integer_Type
(Root_Type
(Exptyp
))
9065 and then Esize
(Root_Type
(Exptyp
)) <= Standard_Integer_Size
9067 -- This transformation is not applicable for a modular type with a
9068 -- nonbinary modulus because we do not handle modular reduction in
9069 -- a correct manner if we attempt this transformation in this case.
9071 and then not Non_Binary_Modulus
(Typ
)
9073 -- Handle the cases where our parent is a division or multiplication
9074 -- specially. In these cases we can convert to using a shift at the
9075 -- parent level if we are not doing overflow checking, since it is
9076 -- too tricky to combine the overflow check at the parent level.
9079 and then Nkind
(Parent
(N
)) in N_Op_Divide | N_Op_Multiply
9082 P
: constant Node_Id
:= Parent
(N
);
9083 L
: constant Node_Id
:= Left_Opnd
(P
);
9084 R
: constant Node_Id
:= Right_Opnd
(P
);
9087 if (Nkind
(P
) = N_Op_Multiply
9089 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
9091 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
9092 and then not Do_Overflow_Check
(P
))
9095 (Nkind
(P
) = N_Op_Divide
9096 and then Is_Integer_Type
(Etype
(L
))
9097 and then Is_Unsigned_Type
(Etype
(L
))
9099 and then not Do_Overflow_Check
(P
))
9101 Set_Is_Power_Of_2_For_Shift
(N
);
9106 -- Here we just have 2 ** N on its own, so we can convert this to a
9107 -- shift node. We are prepared to deal with overflow here, and we
9108 -- also have to handle proper modular reduction for binary modular.
9117 -- Maximum shift count with no overflow
9120 -- Set True if we must test the shift count
9123 -- Node for test against TestS
9126 -- Compute maximum shift based on the underlying size. For a
9127 -- modular type this is one less than the size.
9129 if Is_Modular_Integer_Type
(Typ
) then
9131 -- For modular integer types, this is the size of the value
9132 -- being shifted minus one. Any larger values will cause
9133 -- modular reduction to a result of zero. Note that we do
9134 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
9135 -- of 6, since 2**7 should be reduced to zero).
9137 MaxS
:= RM_Size
(Rtyp
) - 1;
9139 -- For signed integer types, we use the size of the value
9140 -- being shifted minus 2. Larger values cause overflow.
9143 MaxS
:= Esize
(Rtyp
) - 2;
9146 -- Determine range to see if it can be larger than MaxS
9148 Determine_Range
(Exp
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9149 TestS
:= (not OK
) or else Hi
> MaxS
;
9151 -- Signed integer case
9153 if Is_Signed_Integer_Type
(Typ
) then
9155 -- Generate overflow check if overflow is active. Note that
9156 -- we can simply ignore the possibility of overflow if the
9157 -- flag is not set (means that overflow cannot happen or
9158 -- that overflow checks are suppressed).
9160 if Ovflo
and TestS
then
9162 Make_Raise_Constraint_Error
(Loc
,
9165 Left_Opnd
=> Duplicate_Subexpr
(Exp
),
9166 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
9167 Reason
=> CE_Overflow_Check_Failed
));
9170 -- Now rewrite node as Shift_Left (1, right-operand)
9173 Make_Op_Shift_Left
(Loc
,
9174 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
9175 Right_Opnd
=> Exp
));
9177 -- Modular integer case
9179 else pragma Assert
(Is_Modular_Integer_Type
(Typ
));
9181 -- If shift count can be greater than MaxS, we need to wrap
9182 -- the shift in a test that will reduce the result value to
9183 -- zero if this shift count is exceeded.
9187 -- Note: build node for the comparison first, before we
9188 -- reuse the Right_Opnd, so that we have proper parents
9189 -- in place for the Duplicate_Subexpr call.
9193 Left_Opnd
=> Duplicate_Subexpr
(Exp
),
9194 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
));
9197 Make_If_Expression
(Loc
,
9198 Expressions
=> New_List
(
9200 Make_Integer_Literal
(Loc
, Uint_0
),
9201 Make_Op_Shift_Left
(Loc
,
9202 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
9203 Right_Opnd
=> Exp
))));
9205 -- If we know shift count cannot be greater than MaxS, then
9206 -- it is safe to just rewrite as a shift with no test.
9210 Make_Op_Shift_Left
(Loc
,
9211 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
9212 Right_Opnd
=> Exp
));
9216 Analyze_And_Resolve
(N
, Typ
);
9222 -- Fall through if exponentiation must be done using a runtime routine
9224 -- First deal with modular case
9226 if Is_Modular_Integer_Type
(Rtyp
) then
9228 -- Nonbinary modular case, we call the special exponentiation
9229 -- routine for the nonbinary case, converting the argument to
9230 -- Long_Long_Integer and passing the modulus value. Then the
9231 -- result is converted back to the base type.
9233 if Non_Binary_Modulus
(Rtyp
) then
9236 Make_Function_Call
(Loc
,
9238 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
9239 Parameter_Associations
=> New_List
(
9240 Convert_To
(RTE
(RE_Unsigned
), Base
),
9241 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
9244 -- Binary modular case, in this case, we call one of three routines,
9245 -- either the unsigned integer case, or the unsigned long long
9246 -- integer case, or the unsigned long long long integer case, with a
9247 -- final "and" operation to do the required mod.
9250 if Esize
(Rtyp
) <= Standard_Integer_Size
then
9251 Ent
:= RTE
(RE_Exp_Unsigned
);
9252 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
9253 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
9255 Ent
:= RTE
(RE_Exp_Long_Long_Long_Unsigned
);
9262 Make_Function_Call
(Loc
,
9263 Name
=> New_Occurrence_Of
(Ent
, Loc
),
9264 Parameter_Associations
=> New_List
(
9265 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
9268 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
9272 -- Common exit point for modular type case
9274 Analyze_And_Resolve
(N
, Typ
);
9277 -- Signed integer cases, using either Integer, Long_Long_Integer or
9278 -- Long_Long_Long_Integer. It is not worth also having routines for
9279 -- Short_[Short_]Integer, since for most machines it would not help,
9280 -- and it would generate more code that might need certification when
9281 -- a certified run time is required.
9283 -- In the integer cases, we have two routines, one for when overflow
9284 -- checks are required, and one when they are not required, since there
9285 -- is a real gain in omitting checks on many machines.
9287 elsif Is_Signed_Integer_Type
(Rtyp
) then
9288 if Esize
(Rtyp
) <= Standard_Integer_Size
then
9289 Etyp
:= Standard_Integer
;
9292 Rent
:= RE_Exp_Integer
;
9294 Rent
:= RE_Exn_Integer
;
9297 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
9298 Etyp
:= Standard_Long_Long_Integer
;
9301 Rent
:= RE_Exp_Long_Long_Integer
;
9303 Rent
:= RE_Exn_Long_Long_Integer
;
9307 Etyp
:= Standard_Long_Long_Long_Integer
;
9310 Rent
:= RE_Exp_Long_Long_Long_Integer
;
9312 Rent
:= RE_Exn_Long_Long_Long_Integer
;
9316 -- Floating-point cases. We do not need separate routines for the
9317 -- overflow case here, since in the case of floating-point, we generate
9318 -- infinities anyway as a rule (either that or we automatically trap
9319 -- overflow), and if there is an infinity generated and a range check
9320 -- is required, the check will fail anyway.
9323 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
9325 -- Short_Float and Float are the same type for GNAT
9327 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
9328 Etyp
:= Standard_Float
;
9329 Rent
:= RE_Exn_Float
;
9331 elsif Rtyp
= Standard_Long_Float
then
9332 Etyp
:= Standard_Long_Float
;
9333 Rent
:= RE_Exn_Long_Float
;
9336 Etyp
:= Standard_Long_Long_Float
;
9337 Rent
:= RE_Exn_Long_Long_Float
;
9341 -- Common processing for integer cases and floating-point cases.
9342 -- If we are in the right type, we can call runtime routine directly
9345 and then not Is_Universal_Numeric_Type
(Rtyp
)
9349 Make_Function_Call
(Loc
,
9350 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
9351 Parameter_Associations
=> New_List
(Base
, Exp
))));
9353 -- Otherwise we have to introduce conversions (conversions are also
9354 -- required in the universal cases, since the runtime routine is
9355 -- typed using one of the standard types).
9360 Make_Function_Call
(Loc
,
9361 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
9362 Parameter_Associations
=> New_List
(
9363 Convert_To
(Etyp
, Base
),
9367 Analyze_And_Resolve
(N
, Typ
);
9371 when RE_Not_Available
=>
9373 end Expand_N_Op_Expon
;
9375 --------------------
9376 -- Expand_N_Op_Ge --
9377 --------------------
9379 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
9380 Typ
: constant Entity_Id
:= Etype
(N
);
9381 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9382 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9383 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9386 Binary_Op_Validity_Checks
(N
);
9388 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9389 -- means we no longer have a comparison operation, we are all done.
9391 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9392 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9395 if Nkind
(N
) /= N_Op_Ge
then
9401 if Is_Array_Type
(Typ1
) then
9402 Expand_Array_Comparison
(N
);
9406 -- Deal with boolean operands
9408 if Is_Boolean_Type
(Typ1
) then
9409 Adjust_Condition
(Op1
);
9410 Adjust_Condition
(Op2
);
9411 Set_Etype
(N
, Standard_Boolean
);
9412 Adjust_Result_Type
(N
, Typ
);
9415 Rewrite_Comparison
(N
);
9417 -- Try to narrow the operation
9419 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Ge
then
9420 Narrow_Large_Operation
(N
);
9423 Optimize_Length_Comparison
(N
);
9426 --------------------
9427 -- Expand_N_Op_Gt --
9428 --------------------
9430 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
9431 Typ
: constant Entity_Id
:= Etype
(N
);
9432 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9433 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9434 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9437 Binary_Op_Validity_Checks
(N
);
9439 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9440 -- means we no longer have a comparison operation, we are all done.
9442 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9443 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9446 if Nkind
(N
) /= N_Op_Gt
then
9450 -- Deal with array type operands
9452 if Is_Array_Type
(Typ1
) then
9453 Expand_Array_Comparison
(N
);
9457 -- Deal with boolean type operands
9459 if Is_Boolean_Type
(Typ1
) then
9460 Adjust_Condition
(Op1
);
9461 Adjust_Condition
(Op2
);
9462 Set_Etype
(N
, Standard_Boolean
);
9463 Adjust_Result_Type
(N
, Typ
);
9466 Rewrite_Comparison
(N
);
9468 -- Try to narrow the operation
9470 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Gt
then
9471 Narrow_Large_Operation
(N
);
9474 Optimize_Length_Comparison
(N
);
9477 --------------------
9478 -- Expand_N_Op_Le --
9479 --------------------
9481 procedure Expand_N_Op_Le
(N
: Node_Id
) is
9482 Typ
: constant Entity_Id
:= Etype
(N
);
9483 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9484 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9485 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9488 Binary_Op_Validity_Checks
(N
);
9490 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9491 -- means we no longer have a comparison operation, we are all done.
9493 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9494 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9497 if Nkind
(N
) /= N_Op_Le
then
9501 -- Deal with array type operands
9503 if Is_Array_Type
(Typ1
) then
9504 Expand_Array_Comparison
(N
);
9508 -- Deal with Boolean type operands
9510 if Is_Boolean_Type
(Typ1
) then
9511 Adjust_Condition
(Op1
);
9512 Adjust_Condition
(Op2
);
9513 Set_Etype
(N
, Standard_Boolean
);
9514 Adjust_Result_Type
(N
, Typ
);
9517 Rewrite_Comparison
(N
);
9519 -- Try to narrow the operation
9521 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Le
then
9522 Narrow_Large_Operation
(N
);
9525 Optimize_Length_Comparison
(N
);
9528 --------------------
9529 -- Expand_N_Op_Lt --
9530 --------------------
9532 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
9533 Typ
: constant Entity_Id
:= Etype
(N
);
9534 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9535 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9536 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
9539 Binary_Op_Validity_Checks
(N
);
9541 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9542 -- means we no longer have a comparison operation, we are all done.
9544 if Minimized_Eliminated_Overflow_Check
(Op1
) then
9545 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
9548 if Nkind
(N
) /= N_Op_Lt
then
9552 -- Deal with array type operands
9554 if Is_Array_Type
(Typ1
) then
9555 Expand_Array_Comparison
(N
);
9559 -- Deal with Boolean type operands
9561 if Is_Boolean_Type
(Typ1
) then
9562 Adjust_Condition
(Op1
);
9563 Adjust_Condition
(Op2
);
9564 Set_Etype
(N
, Standard_Boolean
);
9565 Adjust_Result_Type
(N
, Typ
);
9568 Rewrite_Comparison
(N
);
9570 -- Try to narrow the operation
9572 if Typ1
= Universal_Integer
and then Nkind
(N
) = N_Op_Lt
then
9573 Narrow_Large_Operation
(N
);
9576 Optimize_Length_Comparison
(N
);
9579 -----------------------
9580 -- Expand_N_Op_Minus --
9581 -----------------------
9583 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
9584 Loc
: constant Source_Ptr
:= Sloc
(N
);
9585 Typ
: constant Entity_Id
:= Etype
(N
);
9588 Unary_Op_Validity_Checks
(N
);
9590 -- Check for MINIMIZED/ELIMINATED overflow mode
9592 if Minimized_Eliminated_Overflow_Check
(N
) then
9593 Apply_Arithmetic_Overflow_Check
(N
);
9597 -- Try to narrow the operation
9599 if Typ
= Universal_Integer
then
9600 Narrow_Large_Operation
(N
);
9602 if Nkind
(N
) /= N_Op_Minus
then
9607 if not Backend_Overflow_Checks_On_Target
9608 and then Is_Signed_Integer_Type
(Typ
)
9609 and then Do_Overflow_Check
(N
)
9611 -- Software overflow checking expands -expr into (0 - expr)
9614 Make_Op_Subtract
(Loc
,
9615 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
9616 Right_Opnd
=> Right_Opnd
(N
)));
9618 Analyze_And_Resolve
(N
, Typ
);
9621 Expand_Nonbinary_Modular_Op
(N
);
9622 end Expand_N_Op_Minus
;
9624 ---------------------
9625 -- Expand_N_Op_Mod --
9626 ---------------------
9628 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
9629 Loc
: constant Source_Ptr
:= Sloc
(N
);
9630 Typ
: constant Entity_Id
:= Etype
(N
);
9631 DDC
: constant Boolean := Do_Division_Check
(N
);
9644 pragma Warnings
(Off
, Lhi
);
9647 Binary_Op_Validity_Checks
(N
);
9649 -- Check for MINIMIZED/ELIMINATED overflow mode
9651 if Minimized_Eliminated_Overflow_Check
(N
) then
9652 Apply_Arithmetic_Overflow_Check
(N
);
9656 -- Try to narrow the operation
9658 if Typ
= Universal_Integer
then
9659 Narrow_Large_Operation
(N
);
9661 if Nkind
(N
) /= N_Op_Mod
then
9666 if Is_Integer_Type
(Typ
) then
9667 Apply_Divide_Checks
(N
);
9669 -- All done if we don't have a MOD any more, which can happen as a
9670 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9672 if Nkind
(N
) /= N_Op_Mod
then
9677 -- Proceed with expansion of mod operator
9679 Left
:= Left_Opnd
(N
);
9680 Right
:= Right_Opnd
(N
);
9682 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
9683 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
9685 -- Convert mod to rem if operands are both known to be non-negative, or
9686 -- both known to be non-positive (these are the cases in which rem and
9687 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9688 -- likely that this will improve the quality of code, (the operation now
9689 -- corresponds to the hardware remainder), and it does not seem likely
9690 -- that it could be harmful. It also avoids some cases of the elaborate
9691 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9694 and then ((Llo
>= 0 and then Rlo
>= 0)
9696 (Lhi
<= 0 and then Rhi
<= 0))
9699 Make_Op_Rem
(Sloc
(N
),
9700 Left_Opnd
=> Left_Opnd
(N
),
9701 Right_Opnd
=> Right_Opnd
(N
)));
9703 -- Instead of reanalyzing the node we do the analysis manually. This
9704 -- avoids anomalies when the replacement is done in an instance and
9705 -- is epsilon more efficient.
9707 pragma Assert
(Entity
(N
) = Standard_Op_Rem
);
9709 Set_Do_Division_Check
(N
, DDC
);
9710 Expand_N_Op_Rem
(N
);
9714 -- Otherwise, normal mod processing
9717 -- Apply optimization x mod 1 = 0. We don't really need that with
9718 -- gcc, but it is useful with other back ends and is certainly
9721 if Is_Integer_Type
(Etype
(N
))
9722 and then Compile_Time_Known_Value
(Right
)
9723 and then Expr_Value
(Right
) = Uint_1
9725 -- Call Remove_Side_Effects to ensure that any side effects in
9726 -- the ignored left operand (in particular function calls to
9727 -- user defined functions) are properly executed.
9729 Remove_Side_Effects
(Left
);
9731 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9732 Analyze_And_Resolve
(N
, Typ
);
9736 -- If we still have a mod operator and we are in Modify_Tree_For_C
9737 -- mode, and we have a signed integer type, then here is where we do
9738 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9739 -- for the special handling of the annoying case of largest negative
9740 -- number mod minus one.
9742 if Nkind
(N
) = N_Op_Mod
9743 and then Is_Signed_Integer_Type
(Typ
)
9744 and then Modify_Tree_For_C
9746 -- In the general case, we expand A mod B as
9748 -- Tnn : constant typ := A rem B;
9750 -- (if (A >= 0) = (B >= 0) then Tnn
9751 -- elsif Tnn = 0 then 0
9754 -- The comparison can be written simply as A >= 0 if we know that
9755 -- B >= 0 which is a very common case.
9757 -- An important optimization is when B is known at compile time
9758 -- to be 2**K for some constant. In this case we can simply AND
9759 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9760 -- and that works for both the positive and negative cases.
9763 P2
: constant Nat
:= Power_Of_Two
(Right
);
9768 Unchecked_Convert_To
(Typ
,
9771 Unchecked_Convert_To
9772 (Corresponding_Unsigned_Type
(Typ
), Left
),
9774 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
9775 Analyze_And_Resolve
(N
, Typ
);
9780 -- Here for the full rewrite
9783 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
9789 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9790 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
9792 if not LOK
or else Rlo
< 0 then
9798 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
9799 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
9803 Make_Object_Declaration
(Loc
,
9804 Defining_Identifier
=> Tnn
,
9805 Constant_Present
=> True,
9806 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
9810 Right_Opnd
=> Right
)));
9813 Make_If_Expression
(Loc
,
9814 Expressions
=> New_List
(
9816 New_Occurrence_Of
(Tnn
, Loc
),
9817 Make_If_Expression
(Loc
,
9819 Expressions
=> New_List
(
9821 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9822 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
9823 Make_Integer_Literal
(Loc
, 0),
9825 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
9827 Duplicate_Subexpr_No_Checks
(Right
)))))));
9829 Analyze_And_Resolve
(N
, Typ
);
9834 -- Deal with annoying case of largest negative number mod minus one.
9835 -- Gigi may not handle this case correctly, because on some targets,
9836 -- the mod value is computed using a divide instruction which gives
9837 -- an overflow trap for this case.
9839 -- It would be a bit more efficient to figure out which targets
9840 -- this is really needed for, but in practice it is reasonable
9841 -- to do the following special check in all cases, since it means
9842 -- we get a clearer message, and also the overhead is minimal given
9843 -- that division is expensive in any case.
9845 -- In fact the check is quite easy, if the right operand is -1, then
9846 -- the mod value is always 0, and we can just ignore the left operand
9847 -- completely in this case.
9849 -- This only applies if we still have a mod operator. Skip if we
9850 -- have already rewritten this (e.g. in the case of eliminated
9851 -- overflow checks which have driven us into bignum mode).
9853 if Nkind
(N
) = N_Op_Mod
then
9855 -- The operand type may be private (e.g. in the expansion of an
9856 -- intrinsic operation) so we must use the underlying type to get
9857 -- the bounds, and convert the literals explicitly.
9861 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
9863 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
9864 and then ((not LOK
) or else (Llo
= LLB
))
9865 and then not CodePeer_Mode
9868 Make_If_Expression
(Loc
,
9869 Expressions
=> New_List
(
9871 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9873 Unchecked_Convert_To
(Typ
,
9874 Make_Integer_Literal
(Loc
, -1))),
9875 Unchecked_Convert_To
(Typ
,
9876 Make_Integer_Literal
(Loc
, Uint_0
)),
9877 Relocate_Node
(N
))));
9879 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9880 Analyze_And_Resolve
(N
, Typ
);
9884 end Expand_N_Op_Mod
;
9886 --------------------------
9887 -- Expand_N_Op_Multiply --
9888 --------------------------
9890 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
9891 Loc
: constant Source_Ptr
:= Sloc
(N
);
9892 Lop
: constant Node_Id
:= Left_Opnd
(N
);
9893 Rop
: constant Node_Id
:= Right_Opnd
(N
);
9895 Lp2
: constant Boolean :=
9896 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
9897 Rp2
: constant Boolean :=
9898 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
9900 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
9901 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
9902 Typ
: Entity_Id
:= Etype
(N
);
9905 Binary_Op_Validity_Checks
(N
);
9907 -- Check for MINIMIZED/ELIMINATED overflow mode
9909 if Minimized_Eliminated_Overflow_Check
(N
) then
9910 Apply_Arithmetic_Overflow_Check
(N
);
9914 -- Special optimizations for integer types
9916 if Is_Integer_Type
(Typ
) then
9918 -- N * 0 = 0 for integer types
9920 if Compile_Time_Known_Value
(Rop
)
9921 and then Expr_Value
(Rop
) = Uint_0
9923 -- Call Remove_Side_Effects to ensure that any side effects in
9924 -- the ignored left operand (in particular function calls to
9925 -- user defined functions) are properly executed.
9927 Remove_Side_Effects
(Lop
);
9929 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9930 Analyze_And_Resolve
(N
, Typ
);
9934 -- Similar handling for 0 * N = 0
9936 if Compile_Time_Known_Value
(Lop
)
9937 and then Expr_Value
(Lop
) = Uint_0
9939 Remove_Side_Effects
(Rop
);
9940 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
9941 Analyze_And_Resolve
(N
, Typ
);
9945 -- N * 1 = 1 * N = N for integer types
9947 -- This optimisation is not done if we are going to
9948 -- rewrite the product 1 * 2 ** N to a shift.
9950 if Compile_Time_Known_Value
(Rop
)
9951 and then Expr_Value
(Rop
) = Uint_1
9957 elsif Compile_Time_Known_Value
(Lop
)
9958 and then Expr_Value
(Lop
) = Uint_1
9966 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9967 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9968 -- operand is an integer, as required for this to work.
9973 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9977 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
9980 Left_Opnd
=> Right_Opnd
(Lop
),
9981 Right_Opnd
=> Right_Opnd
(Rop
))));
9982 Analyze_And_Resolve
(N
, Typ
);
9986 -- If the result is modular, perform the reduction of the result
9989 if Is_Modular_Integer_Type
(Typ
)
9990 and then not Non_Binary_Modulus
(Typ
)
9995 Make_Op_Shift_Left
(Loc
,
9998 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
10000 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
10004 Make_Op_Shift_Left
(Loc
,
10007 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
10010 Analyze_And_Resolve
(N
, Typ
);
10014 -- Same processing for the operands the other way round
10017 if Is_Modular_Integer_Type
(Typ
)
10018 and then not Non_Binary_Modulus
(Typ
)
10023 Make_Op_Shift_Left
(Loc
,
10026 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
10028 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
10032 Make_Op_Shift_Left
(Loc
,
10035 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
10038 Analyze_And_Resolve
(N
, Typ
);
10042 -- Try to narrow the operation
10044 if Typ
= Universal_Integer
then
10045 Narrow_Large_Operation
(N
);
10047 if Nkind
(N
) /= N_Op_Multiply
then
10052 -- Do required fixup of universal fixed operation
10054 if Typ
= Universal_Fixed
then
10055 Fixup_Universal_Fixed_Operation
(N
);
10059 -- Multiplications with fixed-point results
10061 if Is_Fixed_Point_Type
(Typ
) then
10063 -- Case of fixed * integer => fixed
10065 if Is_Integer_Type
(Rtyp
) then
10066 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
10068 -- Case of integer * fixed => fixed
10070 elsif Is_Integer_Type
(Ltyp
) then
10071 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
10073 -- Case of fixed * fixed => fixed
10076 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
10079 -- Other cases of multiplication of fixed-point operands
10081 elsif Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
) then
10082 if Is_Integer_Type
(Typ
) then
10083 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
10085 pragma Assert
(Is_Floating_Point_Type
(Typ
));
10086 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
10089 -- Mixed-mode operations can appear in a non-static universal context,
10090 -- in which case the integer argument must be converted explicitly.
10092 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
10093 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
10094 Analyze_And_Resolve
(Rop
, Universal_Real
);
10096 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
10097 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
10098 Analyze_And_Resolve
(Lop
, Universal_Real
);
10100 -- Non-fixed point cases, check software overflow checking required
10102 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
10103 Apply_Arithmetic_Overflow_Check
(N
);
10106 -- Overflow checks for floating-point if -gnateF mode active
10108 Check_Float_Op_Overflow
(N
);
10110 Expand_Nonbinary_Modular_Op
(N
);
10111 end Expand_N_Op_Multiply
;
10113 --------------------
10114 -- Expand_N_Op_Ne --
10115 --------------------
10117 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
10118 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
10121 -- Case of elementary type with standard operator. But if unnesting,
10122 -- handle elementary types whose Equivalent_Types are records because
10123 -- there may be padding or undefined fields.
10125 if Is_Elementary_Type
(Typ
)
10126 and then Sloc
(Entity
(N
)) = Standard_Location
10127 and then not (Ekind
(Typ
) in E_Class_Wide_Type
10128 | E_Class_Wide_Subtype
10129 | E_Access_Subprogram_Type
10130 | E_Access_Protected_Subprogram_Type
10131 | E_Anonymous_Access_Protected_Subprogram_Type
10133 and then Present
(Equivalent_Type
(Typ
))
10134 and then Is_Record_Type
(Equivalent_Type
(Typ
)))
10136 Binary_Op_Validity_Checks
(N
);
10138 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
10139 -- means we no longer have a /= operation, we are all done.
10141 if Minimized_Eliminated_Overflow_Check
(Left_Opnd
(N
)) then
10142 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
10145 if Nkind
(N
) /= N_Op_Ne
then
10149 -- Boolean types (requiring handling of non-standard case)
10151 if Is_Boolean_Type
(Typ
) then
10152 Adjust_Condition
(Left_Opnd
(N
));
10153 Adjust_Condition
(Right_Opnd
(N
));
10154 Set_Etype
(N
, Standard_Boolean
);
10155 Adjust_Result_Type
(N
, Typ
);
10158 Rewrite_Comparison
(N
);
10160 -- Try to narrow the operation
10162 if Typ
= Universal_Integer
and then Nkind
(N
) = N_Op_Ne
then
10163 Narrow_Large_Operation
(N
);
10166 -- For all cases other than elementary types, we rewrite node as the
10167 -- negation of an equality operation, and reanalyze. The equality to be
10168 -- used is defined in the same scope and has the same signature. This
10169 -- signature must be set explicitly since in an instance it may not have
10170 -- the same visibility as in the generic unit. This avoids duplicating
10171 -- or factoring the complex code for record/array equality tests etc.
10173 -- This case is also used for the minimal expansion performed in
10178 Loc
: constant Source_Ptr
:= Sloc
(N
);
10180 Ne
: constant Entity_Id
:= Entity
(N
);
10183 Binary_Op_Validity_Checks
(N
);
10189 Left_Opnd
=> Left_Opnd
(N
),
10190 Right_Opnd
=> Right_Opnd
(N
)));
10192 -- The level of parentheses is useless in GNATprove mode, and
10193 -- bumping its level here leads to wrong columns being used in
10194 -- check messages, hence skip it in this mode.
10196 if not GNATprove_Mode
then
10197 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
10200 if Scope
(Ne
) /= Standard_Standard
then
10201 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
10204 -- For navigation purposes, we want to treat the inequality as an
10205 -- implicit reference to the corresponding equality. Preserve the
10206 -- Comes_From_ source flag to generate proper Xref entries.
10208 Preserve_Comes_From_Source
(Neg
, N
);
10209 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
10211 Analyze_And_Resolve
(N
, Standard_Boolean
);
10215 -- No need for optimization in GNATprove mode, where we would rather see
10216 -- the original source expression.
10218 if not GNATprove_Mode
then
10219 Optimize_Length_Comparison
(N
);
10221 end Expand_N_Op_Ne
;
10223 ---------------------
10224 -- Expand_N_Op_Not --
10225 ---------------------
10227 -- If the argument is other than a Boolean array type, there is no special
10228 -- expansion required, except for dealing with validity checks, and non-
10229 -- standard boolean representations.
10231 -- For the packed array case, we call the special routine in Exp_Pakd,
10232 -- except that if the component size is greater than one, we use the
10233 -- standard routine generating a gruesome loop (it is so peculiar to have
10234 -- packed arrays with non-standard Boolean representations anyway, so it
10235 -- does not matter that we do not handle this case efficiently).
10237 -- For the unpacked array case (and for the special packed case where we
10238 -- have non standard Booleans, as discussed above), we generate and insert
10239 -- into the tree the following function definition:
10241 -- function Nnnn (A : arr) is
10244 -- for J in a'range loop
10245 -- B (J) := not A (J);
10250 -- or in the case of Transform_Function_Array:
10252 -- procedure Nnnn (A : arr; RESULT : out arr) is
10254 -- for J in a'range loop
10255 -- RESULT (J) := not A (J);
10259 -- Here arr is the actual subtype of the parameter (and hence always
10260 -- constrained). Then we replace the not with a call to this subprogram.
10262 procedure Expand_N_Op_Not
(N
: Node_Id
) is
10263 Loc
: constant Source_Ptr
:= Sloc
(N
);
10264 Typ
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10273 Func_Name
: Entity_Id
;
10274 Loop_Statement
: Node_Id
;
10277 Unary_Op_Validity_Checks
(N
);
10279 -- For boolean operand, deal with non-standard booleans
10281 if Is_Boolean_Type
(Typ
) then
10282 Adjust_Condition
(Right_Opnd
(N
));
10283 Set_Etype
(N
, Standard_Boolean
);
10284 Adjust_Result_Type
(N
, Typ
);
10288 -- Only array types need any other processing
10290 if not Is_Array_Type
(Typ
) then
10294 -- Case of array operand. If bit packed with a component size of 1,
10295 -- handle it in Exp_Pakd if the operand is known to be aligned.
10297 if Is_Bit_Packed_Array
(Typ
)
10298 and then Component_Size
(Typ
) = 1
10299 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
10301 Expand_Packed_Not
(N
);
10305 -- Case of array operand which is not bit-packed. If the context is
10306 -- a safe assignment, call in-place operation, If context is a larger
10307 -- boolean expression in the context of a safe assignment, expansion is
10308 -- done by enclosing operation.
10310 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
10311 Convert_To_Actual_Subtype
(Opnd
);
10312 Arr
:= Etype
(Opnd
);
10313 Ensure_Defined
(Arr
, N
);
10314 Silly_Boolean_Array_Not_Test
(N
, Arr
);
10316 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
10317 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
10318 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
10321 -- Special case the negation of a binary operation
10323 elsif Nkind
(Opnd
) in N_Op_And | N_Op_Or | N_Op_Xor
10324 and then Safe_In_Place_Array_Op
10325 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
10327 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
10331 elsif Nkind
(Parent
(N
)) in N_Binary_Op
10332 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
10335 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
10336 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
10337 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
10340 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
10342 -- (not A) op (not B) can be reduced to a single call
10344 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
10347 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
10350 -- A xor (not B) can also be special-cased
10352 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
10359 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
10361 if Transform_Function_Array
then
10362 B
:= Make_Defining_Identifier
(Loc
, Name_UP_RESULT
);
10364 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
10367 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
10370 Make_Indexed_Component
(Loc
,
10371 Prefix
=> New_Occurrence_Of
(A
, Loc
),
10372 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
10375 Make_Indexed_Component
(Loc
,
10376 Prefix
=> New_Occurrence_Of
(B
, Loc
),
10377 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
10380 Make_Implicit_Loop_Statement
(N
,
10381 Identifier
=> Empty
,
10383 Iteration_Scheme
=>
10384 Make_Iteration_Scheme
(Loc
,
10385 Loop_Parameter_Specification
=>
10386 Make_Loop_Parameter_Specification
(Loc
,
10387 Defining_Identifier
=> J
,
10388 Discrete_Subtype_Definition
=>
10389 Make_Attribute_Reference
(Loc
,
10390 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
10391 Attribute_Name
=> Name_Range
))),
10393 Statements
=> New_List
(
10394 Make_Assignment_Statement
(Loc
,
10396 Expression
=> Make_Op_Not
(Loc
, A_J
))));
10398 Func_Name
:= Make_Temporary
(Loc
, 'N');
10399 Set_Is_Inlined
(Func_Name
);
10401 if Transform_Function_Array
then
10403 Make_Subprogram_Body
(Loc
,
10405 Make_Procedure_Specification
(Loc
,
10406 Defining_Unit_Name
=> Func_Name
,
10407 Parameter_Specifications
=> New_List
(
10408 Make_Parameter_Specification
(Loc
,
10409 Defining_Identifier
=> A
,
10410 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
10411 Make_Parameter_Specification
(Loc
,
10412 Defining_Identifier
=> B
,
10413 Out_Present
=> True,
10414 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)))),
10416 Declarations
=> New_List
,
10418 Handled_Statement_Sequence
=>
10419 Make_Handled_Sequence_Of_Statements
(Loc
,
10420 Statements
=> New_List
(Loop_Statement
))));
10423 Temp_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
10432 Make_Object_Declaration
(Loc
,
10433 Defining_Identifier
=> Temp_Id
,
10434 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10437 -- Proc_Call (Opnd, Temp);
10440 Make_Procedure_Call_Statement
(Loc
,
10441 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
10442 Parameter_Associations
=>
10443 New_List
(Opnd
, New_Occurrence_Of
(Temp_Id
, Loc
)));
10445 Insert_Actions
(Parent
(N
), New_List
(Decl
, Call
));
10446 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
10450 Make_Subprogram_Body
(Loc
,
10452 Make_Function_Specification
(Loc
,
10453 Defining_Unit_Name
=> Func_Name
,
10454 Parameter_Specifications
=> New_List
(
10455 Make_Parameter_Specification
(Loc
,
10456 Defining_Identifier
=> A
,
10457 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
10458 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
10460 Declarations
=> New_List
(
10461 Make_Object_Declaration
(Loc
,
10462 Defining_Identifier
=> B
,
10463 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
10465 Handled_Statement_Sequence
=>
10466 Make_Handled_Sequence_Of_Statements
(Loc
,
10467 Statements
=> New_List
(
10469 Make_Simple_Return_Statement
(Loc
,
10470 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
10473 Make_Function_Call
(Loc
,
10474 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
10475 Parameter_Associations
=> New_List
(Opnd
)));
10478 Analyze_And_Resolve
(N
, Typ
);
10479 end Expand_N_Op_Not
;
10481 --------------------
10482 -- Expand_N_Op_Or --
10483 --------------------
10485 procedure Expand_N_Op_Or
(N
: Node_Id
) is
10486 Typ
: constant Entity_Id
:= Etype
(N
);
10489 Binary_Op_Validity_Checks
(N
);
10491 if Is_Array_Type
(Etype
(N
)) then
10492 Expand_Boolean_Operator
(N
);
10494 elsif Is_Boolean_Type
(Etype
(N
)) then
10495 Adjust_Condition
(Left_Opnd
(N
));
10496 Adjust_Condition
(Right_Opnd
(N
));
10497 Set_Etype
(N
, Standard_Boolean
);
10498 Adjust_Result_Type
(N
, Typ
);
10500 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
10501 Expand_Intrinsic_Call
(N
, Entity
(N
));
10504 Expand_Nonbinary_Modular_Op
(N
);
10505 end Expand_N_Op_Or
;
10507 ----------------------
10508 -- Expand_N_Op_Plus --
10509 ----------------------
10511 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
10512 Typ
: constant Entity_Id
:= Etype
(N
);
10515 Unary_Op_Validity_Checks
(N
);
10517 -- Check for MINIMIZED/ELIMINATED overflow mode
10519 if Minimized_Eliminated_Overflow_Check
(N
) then
10520 Apply_Arithmetic_Overflow_Check
(N
);
10524 -- Try to narrow the operation
10526 if Typ
= Universal_Integer
then
10527 Narrow_Large_Operation
(N
);
10529 end Expand_N_Op_Plus
;
10531 ---------------------
10532 -- Expand_N_Op_Rem --
10533 ---------------------
10535 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
10536 Loc
: constant Source_Ptr
:= Sloc
(N
);
10537 Typ
: constant Entity_Id
:= Etype
(N
);
10548 -- Set if corresponding operand can be negative
10551 Binary_Op_Validity_Checks
(N
);
10553 -- Check for MINIMIZED/ELIMINATED overflow mode
10555 if Minimized_Eliminated_Overflow_Check
(N
) then
10556 Apply_Arithmetic_Overflow_Check
(N
);
10560 -- Try to narrow the operation
10562 if Typ
= Universal_Integer
then
10563 Narrow_Large_Operation
(N
);
10565 if Nkind
(N
) /= N_Op_Rem
then
10570 if Is_Integer_Type
(Etype
(N
)) then
10571 Apply_Divide_Checks
(N
);
10573 -- All done if we don't have a REM any more, which can happen as a
10574 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
10576 if Nkind
(N
) /= N_Op_Rem
then
10581 -- Proceed with expansion of REM
10583 Left
:= Left_Opnd
(N
);
10584 Right
:= Right_Opnd
(N
);
10586 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
10587 -- but it is useful with other back ends, and is certainly harmless.
10589 if Is_Integer_Type
(Etype
(N
))
10590 and then Compile_Time_Known_Value
(Right
)
10591 and then Expr_Value
(Right
) = Uint_1
10593 -- Call Remove_Side_Effects to ensure that any side effects in the
10594 -- ignored left operand (in particular function calls to user defined
10595 -- functions) are properly executed.
10597 Remove_Side_Effects
(Left
);
10599 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10600 Analyze_And_Resolve
(N
, Typ
);
10604 -- Deal with annoying case of largest negative number remainder minus
10605 -- one. Gigi may not handle this case correctly, because on some
10606 -- targets, the mod value is computed using a divide instruction
10607 -- which gives an overflow trap for this case.
10609 -- It would be a bit more efficient to figure out which targets this
10610 -- is really needed for, but in practice it is reasonable to do the
10611 -- following special check in all cases, since it means we get a clearer
10612 -- message, and also the overhead is minimal given that division is
10613 -- expensive in any case.
10615 -- In fact the check is quite easy, if the right operand is -1, then
10616 -- the remainder is always 0, and we can just ignore the left operand
10617 -- completely in this case.
10619 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10620 Lneg
:= (not OK
) or else Lo
< 0;
10622 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10623 Rneg
:= (not OK
) or else Lo
< 0;
10625 -- We won't mess with trying to find out if the left operand can really
10626 -- be the largest negative number (that's a pain in the case of private
10627 -- types and this is really marginal). We will just assume that we need
10628 -- the test if the left operand can be negative at all.
10631 and then not CodePeer_Mode
10634 Make_If_Expression
(Loc
,
10635 Expressions
=> New_List
(
10637 Left_Opnd
=> Duplicate_Subexpr
(Right
),
10639 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
10641 Unchecked_Convert_To
(Typ
,
10642 Make_Integer_Literal
(Loc
, Uint_0
)),
10644 Relocate_Node
(N
))));
10646 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
10647 Analyze_And_Resolve
(N
, Typ
);
10649 end Expand_N_Op_Rem
;
10651 -----------------------------
10652 -- Expand_N_Op_Rotate_Left --
10653 -----------------------------
10655 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
10657 Binary_Op_Validity_Checks
(N
);
10659 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10660 -- so we rewrite in terms of logical shifts
10662 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10664 -- where Bits is the shift count mod Esize (the mod operation here
10665 -- deals with ludicrous large shift counts, which are apparently OK).
10667 if Modify_Tree_For_C
then
10669 Loc
: constant Source_Ptr
:= Sloc
(N
);
10670 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10671 Typ
: constant Entity_Id
:= Etype
(N
);
10674 -- Sem_Intr should prevent getting there with a non binary modulus
10676 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10678 Rewrite
(Right_Opnd
(N
),
10680 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10681 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10683 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10688 Make_Op_Shift_Left
(Loc
,
10689 Left_Opnd
=> Left_Opnd
(N
),
10690 Right_Opnd
=> Right_Opnd
(N
)),
10693 Make_Op_Shift_Right
(Loc
,
10694 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10696 Make_Op_Subtract
(Loc
,
10697 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10699 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10701 Analyze_And_Resolve
(N
, Typ
);
10704 end Expand_N_Op_Rotate_Left
;
10706 ------------------------------
10707 -- Expand_N_Op_Rotate_Right --
10708 ------------------------------
10710 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
10712 Binary_Op_Validity_Checks
(N
);
10714 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10715 -- so we rewrite in terms of logical shifts
10717 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10719 -- where Bits is the shift count mod Esize (the mod operation here
10720 -- deals with ludicrous large shift counts, which are apparently OK).
10722 if Modify_Tree_For_C
then
10724 Loc
: constant Source_Ptr
:= Sloc
(N
);
10725 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
10726 Typ
: constant Entity_Id
:= Etype
(N
);
10729 -- Sem_Intr should prevent getting there with a non binary modulus
10731 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10733 Rewrite
(Right_Opnd
(N
),
10735 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
10736 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
10738 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
10743 Make_Op_Shift_Right
(Loc
,
10744 Left_Opnd
=> Left_Opnd
(N
),
10745 Right_Opnd
=> Right_Opnd
(N
)),
10748 Make_Op_Shift_Left
(Loc
,
10749 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
10751 Make_Op_Subtract
(Loc
,
10752 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
10754 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
10756 Analyze_And_Resolve
(N
, Typ
);
10759 end Expand_N_Op_Rotate_Right
;
10761 ----------------------------
10762 -- Expand_N_Op_Shift_Left --
10763 ----------------------------
10765 -- Note: nothing in this routine depends on left as opposed to right shifts
10766 -- so we share the routine for expanding shift right operations.
10768 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
10770 Binary_Op_Validity_Checks
(N
);
10772 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10773 -- operand is not greater than the word size (since that would not
10774 -- be defined properly by the corresponding C shift operator).
10776 if Modify_Tree_For_C
then
10778 Right
: constant Node_Id
:= Right_Opnd
(N
);
10779 Loc
: constant Source_Ptr
:= Sloc
(Right
);
10780 Typ
: constant Entity_Id
:= Etype
(N
);
10781 Siz
: constant Uint
:= Esize
(Typ
);
10788 -- Sem_Intr should prevent getting there with a non binary modulus
10790 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10792 if Compile_Time_Known_Value
(Right
) then
10793 if Expr_Value
(Right
) >= Siz
then
10794 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
10795 Analyze_And_Resolve
(N
, Typ
);
10798 -- Not compile time known, find range
10801 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
10803 -- Nothing to do if known to be OK range, otherwise expand
10805 if not OK
or else Hi
>= Siz
then
10807 -- Prevent recursion on copy of shift node
10809 Orig
:= Relocate_Node
(N
);
10810 Set_Analyzed
(Orig
);
10812 -- Now do the rewrite
10815 Make_If_Expression
(Loc
,
10816 Expressions
=> New_List
(
10818 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
10819 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
10820 Make_Integer_Literal
(Loc
, 0),
10822 Analyze_And_Resolve
(N
, Typ
);
10827 end Expand_N_Op_Shift_Left
;
10829 -----------------------------
10830 -- Expand_N_Op_Shift_Right --
10831 -----------------------------
10833 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
10835 -- Share shift left circuit
10837 Expand_N_Op_Shift_Left
(N
);
10838 end Expand_N_Op_Shift_Right
;
10840 ----------------------------------------
10841 -- Expand_N_Op_Shift_Right_Arithmetic --
10842 ----------------------------------------
10844 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
10846 Binary_Op_Validity_Checks
(N
);
10848 -- If we are in Modify_Tree_For_C mode, there is no shift right
10849 -- arithmetic in C, so we rewrite in terms of logical shifts for
10850 -- modular integers, and keep the Shift_Right intrinsic for signed
10851 -- integers: even though doing a shift on a signed integer is not
10852 -- fully guaranteed by the C standard, this is what C compilers
10853 -- implement in practice.
10854 -- Consider also taking advantage of this for modular integers by first
10855 -- performing an unchecked conversion of the modular integer to a signed
10856 -- integer of the same sign, and then convert back.
10858 -- Shift_Right (Num, Bits) or
10860 -- then not (Shift_Right (Mask, bits))
10863 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10865 -- Note: the above works fine for shift counts greater than or equal
10866 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10867 -- generates all 1'bits.
10869 if Modify_Tree_For_C
and then Is_Modular_Integer_Type
(Etype
(N
)) then
10871 Loc
: constant Source_Ptr
:= Sloc
(N
);
10872 Typ
: constant Entity_Id
:= Etype
(N
);
10873 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
10874 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
10875 Left
: constant Node_Id
:= Left_Opnd
(N
);
10876 Right
: constant Node_Id
:= Right_Opnd
(N
);
10880 -- Sem_Intr should prevent getting there with a non binary modulus
10882 pragma Assert
(not Non_Binary_Modulus
(Typ
));
10884 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10885 -- compile time as a single constant.
10887 if Compile_Time_Known_Value
(Right
) then
10889 Val
: constant Uint
:= Expr_Value
(Right
);
10892 if Val
>= Esize
(Typ
) then
10893 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
10897 Make_Integer_Literal
(Loc
,
10898 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
10906 Make_Op_Shift_Right
(Loc
,
10907 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
10908 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
10911 -- Now do the rewrite
10916 Make_Op_Shift_Right
(Loc
,
10918 Right_Opnd
=> Right
),
10920 Make_If_Expression
(Loc
,
10921 Expressions
=> New_List
(
10923 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
10924 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
10926 Make_Integer_Literal
(Loc
, 0)))));
10927 Analyze_And_Resolve
(N
, Typ
);
10930 end Expand_N_Op_Shift_Right_Arithmetic
;
10932 --------------------------
10933 -- Expand_N_Op_Subtract --
10934 --------------------------
10936 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
10937 Typ
: constant Entity_Id
:= Etype
(N
);
10940 Binary_Op_Validity_Checks
(N
);
10942 -- Check for MINIMIZED/ELIMINATED overflow mode
10944 if Minimized_Eliminated_Overflow_Check
(N
) then
10945 Apply_Arithmetic_Overflow_Check
(N
);
10949 -- Try to narrow the operation
10951 if Typ
= Universal_Integer
then
10952 Narrow_Large_Operation
(N
);
10954 if Nkind
(N
) /= N_Op_Subtract
then
10959 -- N - 0 = N for integer types
10961 if Is_Integer_Type
(Typ
)
10962 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
10963 and then Expr_Value
(Right_Opnd
(N
)) = 0
10965 Rewrite
(N
, Left_Opnd
(N
));
10969 -- Arithmetic overflow checks for signed integer/fixed point types
10971 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
10972 Apply_Arithmetic_Overflow_Check
(N
);
10975 -- Overflow checks for floating-point if -gnateF mode active
10977 Check_Float_Op_Overflow
(N
);
10979 Expand_Nonbinary_Modular_Op
(N
);
10980 end Expand_N_Op_Subtract
;
10982 ---------------------
10983 -- Expand_N_Op_Xor --
10984 ---------------------
10986 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
10987 Typ
: constant Entity_Id
:= Etype
(N
);
10990 Binary_Op_Validity_Checks
(N
);
10992 if Is_Array_Type
(Etype
(N
)) then
10993 Expand_Boolean_Operator
(N
);
10995 elsif Is_Boolean_Type
(Etype
(N
)) then
10996 Adjust_Condition
(Left_Opnd
(N
));
10997 Adjust_Condition
(Right_Opnd
(N
));
10998 Set_Etype
(N
, Standard_Boolean
);
10999 Adjust_Result_Type
(N
, Typ
);
11001 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
11002 Expand_Intrinsic_Call
(N
, Entity
(N
));
11005 Expand_Nonbinary_Modular_Op
(N
);
11006 end Expand_N_Op_Xor
;
11008 ----------------------
11009 -- Expand_N_Or_Else --
11010 ----------------------
11012 procedure Expand_N_Or_Else
(N
: Node_Id
)
11013 renames Expand_Short_Circuit_Operator
;
11015 -----------------------------------
11016 -- Expand_N_Qualified_Expression --
11017 -----------------------------------
11019 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
11020 Operand
: constant Node_Id
:= Expression
(N
);
11021 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
11024 -- Do validity check if validity checking operands
11026 if Validity_Checks_On
and Validity_Check_Operands
then
11027 Ensure_Valid
(Operand
);
11030 Freeze_Before
(Operand
, Target_Type
);
11032 -- Apply possible constraint check
11034 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
11036 -- Apply possible predicate check
11038 Apply_Predicate_Check
(Operand
, Target_Type
);
11040 if Do_Range_Check
(Operand
) then
11041 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
11043 end Expand_N_Qualified_Expression
;
11045 ------------------------------------
11046 -- Expand_N_Quantified_Expression --
11047 ------------------------------------
11051 -- for all X in range => Cond
11056 -- for X in range loop
11057 -- if not Cond then
11063 -- Similarly, an existentially quantified expression:
11065 -- for some X in range => Cond
11070 -- for X in range loop
11077 -- In both cases, the iteration may be over a container in which case it is
11078 -- given by an iterator specification, not a loop parameter specification.
11080 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
11081 Actions
: constant List_Id
:= New_List
;
11082 For_All
: constant Boolean := All_Present
(N
);
11083 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
11084 Loc
: constant Source_Ptr
:= Sloc
(N
);
11085 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
11093 -- Ensure that the bound variable as well as the type of Name of the
11094 -- Iter_Spec if present are properly frozen. We must do this before
11095 -- expansion because the expression is about to be converted into a
11096 -- loop, and resulting freeze nodes may end up in the wrong place in the
11099 if Present
(Iter_Spec
) then
11100 Var
:= Defining_Identifier
(Iter_Spec
);
11102 Var
:= Defining_Identifier
(Loop_Spec
);
11106 P
: Node_Id
:= Parent
(N
);
11108 while Nkind
(P
) in N_Subexpr
loop
11112 if Present
(Iter_Spec
) then
11113 Freeze_Before
(P
, Etype
(Name
(Iter_Spec
)));
11116 Freeze_Before
(P
, Etype
(Var
));
11119 -- Create the declaration of the flag which tracks the status of the
11120 -- quantified expression. Generate:
11122 -- Flag : Boolean := (True | False);
11124 Flag
:= Make_Temporary
(Loc
, 'T', N
);
11126 Append_To
(Actions
,
11127 Make_Object_Declaration
(Loc
,
11128 Defining_Identifier
=> Flag
,
11129 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
11131 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
11133 -- Construct the circuitry which tracks the status of the quantified
11134 -- expression. Generate:
11136 -- if [not] Cond then
11137 -- Flag := (False | True);
11141 Cond
:= Relocate_Node
(Condition
(N
));
11144 Cond
:= Make_Op_Not
(Loc
, Cond
);
11147 Stmts
:= New_List
(
11148 Make_Implicit_If_Statement
(N
,
11150 Then_Statements
=> New_List
(
11151 Make_Assignment_Statement
(Loc
,
11152 Name
=> New_Occurrence_Of
(Flag
, Loc
),
11154 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
11155 Make_Exit_Statement
(Loc
))));
11157 -- Build the loop equivalent of the quantified expression
11159 if Present
(Iter_Spec
) then
11161 Make_Iteration_Scheme
(Loc
,
11162 Iterator_Specification
=> Iter_Spec
);
11165 Make_Iteration_Scheme
(Loc
,
11166 Loop_Parameter_Specification
=> Loop_Spec
);
11169 Append_To
(Actions
,
11170 Make_Loop_Statement
(Loc
,
11171 Iteration_Scheme
=> Scheme
,
11172 Statements
=> Stmts
,
11173 End_Label
=> Empty
));
11175 -- Transform the quantified expression
11178 Make_Expression_With_Actions
(Loc
,
11179 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
11180 Actions
=> Actions
));
11181 Analyze_And_Resolve
(N
, Standard_Boolean
);
11182 end Expand_N_Quantified_Expression
;
11184 ---------------------------------
11185 -- Expand_N_Selected_Component --
11186 ---------------------------------
11188 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
11189 Loc
: constant Source_Ptr
:= Sloc
(N
);
11190 Par
: constant Node_Id
:= Parent
(N
);
11191 P
: constant Node_Id
:= Prefix
(N
);
11192 S
: constant Node_Id
:= Selector_Name
(N
);
11193 Ptyp
: constant Entity_Id
:= Underlying_Type
(Etype
(P
));
11199 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
11200 -- Gigi needs a temporary for prefixes that depend on a discriminant,
11201 -- unless the context of an assignment can provide size information.
11202 -- Don't we have a general routine that does this???
11204 function Is_Subtype_Declaration
return Boolean;
11205 -- The replacement of a discriminant reference by its value is required
11206 -- if this is part of the initialization of an temporary generated by a
11207 -- change of representation. This shows up as the construction of a
11208 -- discriminant constraint for a subtype declared at the same point as
11209 -- the entity in the prefix of the selected component. We recognize this
11210 -- case when the context of the reference is:
11211 -- subtype ST is T(Obj.D);
11212 -- where the entity for Obj comes from source, and ST has the same sloc.
11214 -----------------------
11215 -- In_Left_Hand_Side --
11216 -----------------------
11218 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
11220 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
11221 and then Comp
= Name
(Parent
(Comp
)))
11222 or else (Present
(Parent
(Comp
))
11223 and then Nkind
(Parent
(Comp
)) in N_Subexpr
11224 and then In_Left_Hand_Side
(Parent
(Comp
)));
11225 end In_Left_Hand_Side
;
11227 -----------------------------
11228 -- Is_Subtype_Declaration --
11229 -----------------------------
11231 function Is_Subtype_Declaration
return Boolean is
11232 Par
: constant Node_Id
:= Parent
(N
);
11235 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
11236 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
11237 and then Comes_From_Source
(Entity
(Prefix
(N
)))
11238 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
11239 end Is_Subtype_Declaration
;
11241 -- Start of processing for Expand_N_Selected_Component
11244 -- Deal with discriminant check required
11246 if Do_Discriminant_Check
(N
) then
11247 if Present
(Discriminant_Checking_Func
11248 (Original_Record_Component
(Entity
(S
))))
11250 -- Present the discriminant checking function to the backend, so
11251 -- that it can inline the call to the function.
11254 (Discriminant_Checking_Func
11255 (Original_Record_Component
(Entity
(S
))),
11258 -- Now reset the flag and generate the call
11260 Set_Do_Discriminant_Check
(N
, False);
11261 Generate_Discriminant_Check
(N
);
11263 -- In the case of Unchecked_Union, no discriminant checking is
11264 -- actually performed.
11267 if (not Is_Unchecked_Union
11268 (Implementation_Base_Type
(Etype
(Prefix
(N
)))))
11269 and then not Is_Predefined_Unit
(Get_Source_Unit
(N
))
11272 ("sorry - unable to generate discriminant check for" &
11273 " reference to variant component &",
11274 Selector_Name
(N
));
11277 Set_Do_Discriminant_Check
(N
, False);
11281 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11282 -- function, then additional actuals must be passed.
11284 if Is_Build_In_Place_Function_Call
(P
) then
11285 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
11287 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11288 -- containing build-in-place function calls whose returned object covers
11289 -- interface types.
11291 elsif Present
(Unqual_BIP_Iface_Function_Call
(P
)) then
11292 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(P
);
11295 -- Gigi cannot handle unchecked conversions that are the prefix of a
11296 -- selected component with discriminants. This must be checked during
11297 -- expansion, because during analysis the type of the selector is not
11298 -- known at the point the prefix is analyzed. If the conversion is the
11299 -- target of an assignment, then we cannot force the evaluation.
11301 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
11302 and then Has_Discriminants
(Etype
(N
))
11303 and then not In_Left_Hand_Side
(N
)
11305 Force_Evaluation
(Prefix
(N
));
11308 -- Remaining processing applies only if selector is a discriminant
11310 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
11312 -- If the selector is a discriminant of a constrained record type,
11313 -- we may be able to rewrite the expression with the actual value
11314 -- of the discriminant, a useful optimization in some cases.
11316 if Is_Record_Type
(Ptyp
)
11317 and then Has_Discriminants
(Ptyp
)
11318 and then Is_Constrained
(Ptyp
)
11320 -- Do this optimization for discrete types only, and not for
11321 -- access types (access discriminants get us into trouble).
11323 if not Is_Discrete_Type
(Etype
(N
)) then
11326 -- Don't do this on the left-hand side of an assignment statement.
11327 -- Normally one would think that references like this would not
11328 -- occur, but they do in generated code, and mean that we really
11329 -- do want to assign the discriminant.
11331 elsif Nkind
(Par
) = N_Assignment_Statement
11332 and then Name
(Par
) = N
11336 -- Don't do this optimization for the prefix of an attribute or
11337 -- the name of an object renaming declaration since these are
11338 -- contexts where we do not want the value anyway.
11340 elsif (Nkind
(Par
) = N_Attribute_Reference
11341 and then Prefix
(Par
) = N
)
11342 or else Is_Renamed_Object
(N
)
11346 -- Don't do this optimization if we are within the code for a
11347 -- discriminant check, since the whole point of such a check may
11348 -- be to verify the condition on which the code below depends.
11350 elsif Is_In_Discriminant_Check
(N
) then
11353 -- Green light to see if we can do the optimization. There is
11354 -- still one condition that inhibits the optimization below but
11355 -- now is the time to check the particular discriminant.
11358 -- Loop through discriminants to find the matching discriminant
11359 -- constraint to see if we can copy it.
11361 Disc
:= First_Discriminant
(Ptyp
);
11362 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
11363 Discr_Loop
: while Present
(Dcon
) loop
11364 Dval
:= Node
(Dcon
);
11366 -- Check if this is the matching discriminant and if the
11367 -- discriminant value is simple enough to make sense to
11368 -- copy. We don't want to copy complex expressions, and
11369 -- indeed to do so can cause trouble (before we put in
11370 -- this guard, a discriminant expression containing an
11371 -- AND THEN was copied, causing problems for coverage
11372 -- analysis tools).
11374 -- However, if the reference is part of the initialization
11375 -- code generated for an object declaration, we must use
11376 -- the discriminant value from the subtype constraint,
11377 -- because the selected component may be a reference to the
11378 -- object being initialized, whose discriminant is not yet
11379 -- set. This only happens in complex cases involving changes
11380 -- of representation.
11382 if Disc
= Entity
(Selector_Name
(N
))
11383 and then (Is_Entity_Name
(Dval
)
11384 or else Compile_Time_Known_Value
(Dval
)
11385 or else Is_Subtype_Declaration
)
11387 -- Here we have the matching discriminant. Check for
11388 -- the case of a discriminant of a component that is
11389 -- constrained by an outer discriminant, which cannot
11390 -- be optimized away.
11392 if Denotes_Discriminant
(Dval
, Check_Concurrent
=> True)
11396 -- Do not retrieve value if constraint is not static. It
11397 -- is generally not useful, and the constraint may be a
11398 -- rewritten outer discriminant in which case it is in
11401 elsif Is_Entity_Name
(Dval
)
11403 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
11404 and then Present
(Expression
(Parent
(Entity
(Dval
))))
11406 Is_OK_Static_Expression
11407 (Expression
(Parent
(Entity
(Dval
))))
11411 -- In the context of a case statement, the expression may
11412 -- have the base type of the discriminant, and we need to
11413 -- preserve the constraint to avoid spurious errors on
11416 elsif Nkind
(Parent
(N
)) = N_Case_Statement
11417 and then Etype
(Dval
) /= Etype
(Disc
)
11420 Make_Qualified_Expression
(Loc
,
11422 New_Occurrence_Of
(Etype
(Disc
), Loc
),
11424 New_Copy_Tree
(Dval
)));
11425 Analyze_And_Resolve
(N
, Etype
(Disc
));
11427 -- In case that comes out as a static expression,
11428 -- reset it (a selected component is never static).
11430 Set_Is_Static_Expression
(N
, False);
11433 -- Otherwise we can just copy the constraint, but the
11434 -- result is certainly not static. In some cases the
11435 -- discriminant constraint has been analyzed in the
11436 -- context of the original subtype indication, but for
11437 -- itypes the constraint might not have been analyzed
11438 -- yet, and this must be done now.
11441 Rewrite
(N
, New_Copy_Tree
(Dval
));
11442 Analyze_And_Resolve
(N
);
11443 Set_Is_Static_Expression
(N
, False);
11449 Next_Discriminant
(Disc
);
11450 end loop Discr_Loop
;
11452 -- Note: the above loop should always find a matching
11453 -- discriminant, but if it does not, we just missed an
11454 -- optimization due to some glitch (perhaps a previous
11455 -- error), so ignore.
11460 -- The only remaining processing is in the case of a discriminant of
11461 -- a concurrent object, where we rewrite the prefix to denote the
11462 -- corresponding record type. If the type is derived and has renamed
11463 -- discriminants, use corresponding discriminant, which is the one
11464 -- that appears in the corresponding record.
11466 if not Is_Concurrent_Type
(Ptyp
) then
11470 Disc
:= Entity
(Selector_Name
(N
));
11472 if Is_Derived_Type
(Ptyp
)
11473 and then Present
(Corresponding_Discriminant
(Disc
))
11475 Disc
:= Corresponding_Discriminant
(Disc
);
11479 Make_Selected_Component
(Loc
,
11481 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
11482 New_Copy_Tree
(P
)),
11483 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
11485 Rewrite
(N
, New_N
);
11489 -- Set Atomic_Sync_Required if necessary for atomic component
11491 if Nkind
(N
) = N_Selected_Component
then
11493 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
11497 -- If component is atomic, but type is not, setting depends on
11498 -- disable/enable state for the component.
11500 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
11501 Set
:= not Atomic_Synchronization_Disabled
(E
);
11503 -- If component is not atomic, but its type is atomic, setting
11504 -- depends on disable/enable state for the type.
11506 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
11507 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
11509 -- If both component and type are atomic, we disable if either
11510 -- component or its type have sync disabled.
11512 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
11513 Set
:= (not Atomic_Synchronization_Disabled
(E
))
11515 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
11521 -- Set flag if required
11524 Activate_Atomic_Synchronization
(N
);
11528 end Expand_N_Selected_Component
;
11530 --------------------
11531 -- Expand_N_Slice --
11532 --------------------
11534 procedure Expand_N_Slice
(N
: Node_Id
) is
11535 Loc
: constant Source_Ptr
:= Sloc
(N
);
11536 Typ
: constant Entity_Id
:= Etype
(N
);
11538 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
11539 -- Check whether the argument is an actual for a procedure call, in
11540 -- which case the expansion of a bit-packed slice is deferred until the
11541 -- call itself is expanded. The reason this is required is that we might
11542 -- have an IN OUT or OUT parameter, and the copy out is essential, and
11543 -- that copy out would be missed if we created a temporary here in
11544 -- Expand_N_Slice. Note that we don't bother to test specifically for an
11545 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
11546 -- is harmless to defer expansion in the IN case, since the call
11547 -- processing will still generate the appropriate copy in operation,
11548 -- which will take care of the slice.
11550 procedure Make_Temporary_For_Slice
;
11551 -- Create a named variable for the value of the slice, in cases where
11552 -- the back end cannot handle it properly, e.g. when packed types or
11553 -- unaligned slices are involved.
11555 -------------------------
11556 -- Is_Procedure_Actual --
11557 -------------------------
11559 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
11560 Par
: Node_Id
:= Parent
(N
);
11564 -- If our parent is a procedure call we can return
11566 if Nkind
(Par
) = N_Procedure_Call_Statement
then
11569 -- If our parent is a type conversion, keep climbing the tree,
11570 -- since a type conversion can be a procedure actual. Also keep
11571 -- climbing if parameter association or a qualified expression,
11572 -- since these are additional cases that do can appear on
11573 -- procedure actuals.
11575 elsif Nkind
(Par
) in N_Type_Conversion
11576 | N_Parameter_Association
11577 | N_Qualified_Expression
11579 Par
:= Parent
(Par
);
11581 -- Any other case is not what we are looking for
11587 end Is_Procedure_Actual
;
11589 ------------------------------
11590 -- Make_Temporary_For_Slice --
11591 ------------------------------
11593 procedure Make_Temporary_For_Slice
is
11594 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
11599 Make_Object_Declaration
(Loc
,
11600 Defining_Identifier
=> Ent
,
11601 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
11603 Set_No_Initialization
(Decl
);
11605 Insert_Actions
(N
, New_List
(
11607 Make_Assignment_Statement
(Loc
,
11608 Name
=> New_Occurrence_Of
(Ent
, Loc
),
11609 Expression
=> Relocate_Node
(N
))));
11611 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
11612 Analyze_And_Resolve
(N
, Typ
);
11613 end Make_Temporary_For_Slice
;
11617 Pref
: constant Node_Id
:= Prefix
(N
);
11619 -- Start of processing for Expand_N_Slice
11622 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11623 -- function, then additional actuals must be passed.
11625 if Is_Build_In_Place_Function_Call
(Pref
) then
11626 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
11628 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11629 -- containing build-in-place function calls whose returned object covers
11630 -- interface types.
11632 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
11633 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
11636 -- The remaining case to be handled is packed slices. We can leave
11637 -- packed slices as they are in the following situations:
11639 -- 1. Right or left side of an assignment (we can handle this
11640 -- situation correctly in the assignment statement expansion).
11642 -- 2. Prefix of indexed component (the slide is optimized away in this
11643 -- case, see the start of Expand_N_Indexed_Component.)
11645 -- 3. Object renaming declaration, since we want the name of the
11646 -- slice, not the value.
11648 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11649 -- be required, and this is handled in the expansion of call
11652 -- 5. Prefix of an address attribute (this is an error which is caught
11653 -- elsewhere, and the expansion would interfere with generating the
11654 -- error message) or of a size attribute (because 'Size may change
11655 -- when applied to the temporary instead of the slice directly).
11657 if not Is_Packed
(Typ
) then
11659 -- Apply transformation for actuals of a function call, where
11660 -- Expand_Actuals is not used.
11662 if Nkind
(Parent
(N
)) = N_Function_Call
11663 and then Is_Possibly_Unaligned_Slice
(N
)
11665 Make_Temporary_For_Slice
;
11668 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
11669 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
11670 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
11674 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
11675 or else Is_Renamed_Object
(N
)
11676 or else Is_Procedure_Actual
(N
)
11680 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
11681 and then (Attribute_Name
(Parent
(N
)) = Name_Address
11682 or else Attribute_Name
(Parent
(N
)) = Name_Size
)
11687 Make_Temporary_For_Slice
;
11689 end Expand_N_Slice
;
11691 ------------------------------
11692 -- Expand_N_Type_Conversion --
11693 ------------------------------
11695 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
11696 Loc
: constant Source_Ptr
:= Sloc
(N
);
11697 Operand
: constant Node_Id
:= Expression
(N
);
11698 Operand_Acc
: Node_Id
:= Operand
;
11699 Target_Type
: Entity_Id
:= Etype
(N
);
11700 Operand_Type
: Entity_Id
:= Etype
(Operand
);
11702 procedure Discrete_Range_Check
;
11703 -- Handles generation of range check for discrete target value
11705 procedure Handle_Changed_Representation
;
11706 -- This is called in the case of record and array type conversions to
11707 -- see if there is a change of representation to be handled. Change of
11708 -- representation is actually handled at the assignment statement level,
11709 -- and what this procedure does is rewrite node N conversion as an
11710 -- assignment to temporary. If there is no change of representation,
11711 -- then the conversion node is unchanged.
11713 procedure Raise_Accessibility_Error
;
11714 -- Called when we know that an accessibility check will fail. Rewrites
11715 -- node N to an appropriate raise statement and outputs warning msgs.
11716 -- The Etype of the raise node is set to Target_Type. Note that in this
11717 -- case the rest of the processing should be skipped (i.e. the call to
11718 -- this procedure will be followed by "goto Done").
11720 procedure Real_Range_Check
;
11721 -- Handles generation of range check for real target value
11723 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
11724 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11725 -- evaluates to True.
11727 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
11729 -- Given a target type for a conversion, determine whether the
11730 -- statically deeper accessibility rules apply to it.
11732 --------------------------
11733 -- Discrete_Range_Check --
11734 --------------------------
11736 -- Case of conversions to a discrete type. We let Generate_Range_Check
11737 -- do the heavy lifting, after converting a fixed-point operand to an
11738 -- appropriate integer type.
11740 procedure Discrete_Range_Check
is
11744 procedure Generate_Temporary
;
11745 -- Generate a temporary to facilitate in the C backend the code
11746 -- generation of the unchecked conversion since the size of the
11747 -- source type may differ from the size of the target type.
11749 ------------------------
11750 -- Generate_Temporary --
11751 ------------------------
11753 procedure Generate_Temporary
is
11755 if Esize
(Etype
(Expr
)) < Esize
(Etype
(Ityp
)) then
11757 Exp_Type
: constant Entity_Id
:= Ityp
;
11758 Def_Id
: constant Entity_Id
:=
11759 Make_Temporary
(Loc
, 'R', Expr
);
11764 Set_Is_Internal
(Def_Id
);
11765 Set_Etype
(Def_Id
, Exp_Type
);
11766 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
11769 Make_Object_Declaration
(Loc
,
11770 Defining_Identifier
=> Def_Id
,
11771 Object_Definition
=> New_Occurrence_Of
11773 Constant_Present
=> True,
11774 Expression
=> Relocate_Node
(Expr
));
11776 Set_Assignment_OK
(E
);
11777 Insert_Action
(Expr
, E
);
11779 Set_Assignment_OK
(Res
, Assignment_OK
(Expr
));
11781 Rewrite
(Expr
, Res
);
11782 Analyze_And_Resolve
(Expr
, Exp_Type
);
11785 end Generate_Temporary
;
11787 -- Start of processing for Discrete_Range_Check
11790 -- Nothing more to do if conversion was rewritten
11792 if Nkind
(N
) /= N_Type_Conversion
then
11796 Expr
:= Expression
(N
);
11798 -- Clear the Do_Range_Check flag on Expr
11800 Set_Do_Range_Check
(Expr
, False);
11802 -- Nothing to do if range checks suppressed
11804 if Range_Checks_Suppressed
(Target_Type
) then
11808 -- Nothing to do if expression is an entity on which checks have been
11811 if Is_Entity_Name
(Expr
)
11812 and then Range_Checks_Suppressed
(Entity
(Expr
))
11817 -- Before we do a range check, we have to deal with treating
11818 -- a fixed-point operand as an integer. The way we do this
11819 -- is simply to do an unchecked conversion to an appropriate
11820 -- integer type with the smallest size, so that we can suppress
11823 if Is_Fixed_Point_Type
(Etype
(Expr
)) then
11824 Ityp
:= Small_Integer_Type_For
11825 (Esize
(Base_Type
(Etype
(Expr
))), Uns
=> False);
11827 -- Generate a temporary with the integer type to facilitate in the
11828 -- C backend the code generation for the unchecked conversion.
11830 if Modify_Tree_For_C
then
11831 Generate_Temporary
;
11834 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11837 -- Reset overflow flag, since the range check will include
11838 -- dealing with possible overflow, and generate the check.
11840 Set_Do_Overflow_Check
(N
, False);
11842 Generate_Range_Check
(Expr
, Target_Type
, CE_Range_Check_Failed
);
11843 end Discrete_Range_Check
;
11845 -----------------------------------
11846 -- Handle_Changed_Representation --
11847 -----------------------------------
11849 procedure Handle_Changed_Representation
is
11857 -- Nothing else to do if no change of representation
11859 if Has_Compatible_Representation
(Target_Type
, Operand_Type
) then
11862 -- The real change of representation work is done by the assignment
11863 -- statement processing. So if this type conversion is appearing as
11864 -- the expression of an assignment statement, nothing needs to be
11865 -- done to the conversion.
11867 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
11870 -- Otherwise we need to generate a temporary variable, and do the
11871 -- change of representation assignment into that temporary variable.
11872 -- The conversion is then replaced by a reference to this variable.
11877 -- If type is unconstrained we have to add a constraint, copied
11878 -- from the actual value of the left-hand side.
11880 if not Is_Constrained
(Target_Type
) then
11881 if Has_Discriminants
(Operand_Type
) then
11883 -- A change of representation can only apply to untagged
11884 -- types. We need to build the constraint that applies to
11885 -- the target type, using the constraints of the operand.
11886 -- The analysis is complicated if there are both inherited
11887 -- discriminants and constrained discriminants.
11888 -- We iterate over the discriminants of the target, and
11889 -- find the discriminant of the same name:
11891 -- a) If there is a corresponding discriminant in the object
11892 -- then the value is a selected component of the operand.
11894 -- b) Otherwise the value of a constrained discriminant is
11895 -- found in the stored constraint of the operand.
11898 Stored
: constant Elist_Id
:=
11899 Stored_Constraint
(Operand_Type
);
11900 -- Stored constraints of the operand. If present, they
11901 -- correspond to the discriminants of the parent type.
11903 Disc_O
: Entity_Id
;
11904 -- Discriminant of the operand type. Its value in the
11905 -- object is captured in a selected component.
11907 Disc_T
: Entity_Id
;
11908 -- Discriminant of the target type
11913 Disc_O
:= First_Discriminant
(Operand_Type
);
11914 Disc_T
:= First_Discriminant
(Target_Type
);
11915 Elmt
:= (if Present
(Stored
)
11916 then First_Elmt
(Stored
)
11920 while Present
(Disc_T
) loop
11921 if Present
(Disc_O
)
11922 and then Chars
(Disc_T
) = Chars
(Disc_O
)
11925 Make_Selected_Component
(Loc
,
11927 Duplicate_Subexpr_Move_Checks
(Operand
),
11929 Make_Identifier
(Loc
, Chars
(Disc_O
))));
11930 Next_Discriminant
(Disc_O
);
11932 elsif Present
(Elmt
) then
11933 Append_To
(Cons
, New_Copy_Tree
(Node
(Elmt
)));
11936 if Present
(Elmt
) then
11940 Next_Discriminant
(Disc_T
);
11944 elsif Is_Array_Type
(Operand_Type
) then
11945 N_Ix
:= First_Index
(Target_Type
);
11948 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
11950 -- We convert the bounds explicitly. We use an unchecked
11951 -- conversion because bounds checks are done elsewhere.
11956 Unchecked_Convert_To
(Etype
(N_Ix
),
11957 Make_Attribute_Reference
(Loc
,
11959 Duplicate_Subexpr_No_Checks
11960 (Operand
, Name_Req
=> True),
11961 Attribute_Name
=> Name_First
,
11962 Expressions
=> New_List
(
11963 Make_Integer_Literal
(Loc
, J
)))),
11966 Unchecked_Convert_To
(Etype
(N_Ix
),
11967 Make_Attribute_Reference
(Loc
,
11969 Duplicate_Subexpr_No_Checks
11970 (Operand
, Name_Req
=> True),
11971 Attribute_Name
=> Name_Last
,
11972 Expressions
=> New_List
(
11973 Make_Integer_Literal
(Loc
, J
))))));
11980 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
11982 if Present
(Cons
) then
11984 Make_Subtype_Indication
(Loc
,
11985 Subtype_Mark
=> Odef
,
11987 Make_Index_Or_Discriminant_Constraint
(Loc
,
11988 Constraints
=> Cons
));
11991 Temp
:= Make_Temporary
(Loc
, 'C');
11993 Make_Object_Declaration
(Loc
,
11994 Defining_Identifier
=> Temp
,
11995 Object_Definition
=> Odef
);
11997 Set_No_Initialization
(Decl
, True);
11999 -- Insert required actions. It is essential to suppress checks
12000 -- since we have suppressed default initialization, which means
12001 -- that the variable we create may have no discriminants.
12006 Make_Assignment_Statement
(Loc
,
12007 Name
=> New_Occurrence_Of
(Temp
, Loc
),
12008 Expression
=> Relocate_Node
(N
))),
12009 Suppress
=> All_Checks
);
12011 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
12014 end Handle_Changed_Representation
;
12016 -------------------------------
12017 -- Raise_Accessibility_Error --
12018 -------------------------------
12020 procedure Raise_Accessibility_Error
is
12022 Error_Msg_Warn
:= SPARK_Mode
/= On
;
12024 Make_Raise_Program_Error
(Sloc
(N
),
12025 Reason
=> PE_Accessibility_Check_Failed
));
12026 Set_Etype
(N
, Target_Type
);
12028 Error_Msg_N
("accessibility check failure<<", N
);
12029 Error_Msg_N
("\Program_Error [<<", N
);
12030 end Raise_Accessibility_Error
;
12032 ----------------------
12033 -- Real_Range_Check --
12034 ----------------------
12036 -- Case of conversions to floating-point or fixed-point. If range checks
12037 -- are enabled and the target type has a range constraint, we convert:
12043 -- Tnn : typ'Base := typ'Base (x);
12044 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
12047 -- This is necessary when there is a conversion of integer to float or
12048 -- to fixed-point to ensure that the correct checks are made. It is not
12049 -- necessary for the float-to-float case where it is enough to just set
12050 -- the Do_Range_Check flag on the expression.
12052 procedure Real_Range_Check
is
12053 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
12054 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
12055 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
12066 -- Nothing more to do if conversion was rewritten
12068 if Nkind
(N
) /= N_Type_Conversion
then
12072 Expr
:= Expression
(N
);
12074 -- Clear the Do_Range_Check flag on Expr
12076 Set_Do_Range_Check
(Expr
, False);
12078 -- Nothing to do if range checks suppressed, or target has the same
12079 -- range as the base type (or is the base type).
12081 if Range_Checks_Suppressed
(Target_Type
)
12082 or else (Lo
= Type_Low_Bound
(Btyp
)
12084 Hi
= Type_High_Bound
(Btyp
))
12089 -- Nothing to do if expression is an entity on which checks have been
12092 if Is_Entity_Name
(Expr
)
12093 and then Range_Checks_Suppressed
(Entity
(Expr
))
12098 -- Nothing to do if expression was rewritten into a float-to-float
12099 -- conversion, since this kind of conversion is handled elsewhere.
12101 if Is_Floating_Point_Type
(Etype
(Expr
))
12102 and then Is_Floating_Point_Type
(Target_Type
)
12107 -- Nothing to do if bounds are all static and we can tell that the
12108 -- expression is within the bounds of the target. Note that if the
12109 -- operand is of an unconstrained floating-point type, then we do
12110 -- not trust it to be in range (might be infinite)
12113 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Expr
));
12114 S_Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Expr
));
12117 if (not Is_Floating_Point_Type
(Etype
(Expr
))
12118 or else Is_Constrained
(Etype
(Expr
)))
12119 and then Compile_Time_Known_Value
(S_Lo
)
12120 and then Compile_Time_Known_Value
(S_Hi
)
12121 and then Compile_Time_Known_Value
(Hi
)
12122 and then Compile_Time_Known_Value
(Lo
)
12125 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
12126 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
12131 if Is_Real_Type
(Etype
(Expr
)) then
12132 S_Lov
:= Expr_Value_R
(S_Lo
);
12133 S_Hiv
:= Expr_Value_R
(S_Hi
);
12135 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
12136 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
12140 and then S_Lov
>= D_Lov
12141 and then S_Hiv
<= D_Hiv
12149 -- Otherwise rewrite the conversion as described above
12151 Conv
:= Convert_To
(Btyp
, Expr
);
12153 -- If a conversion is necessary, then copy the specific flags from
12154 -- the original one and also move the Do_Overflow_Check flag since
12155 -- this new conversion is to the base type.
12157 if Nkind
(Conv
) = N_Type_Conversion
then
12158 Set_Conversion_OK
(Conv
, Conversion_OK
(N
));
12159 Set_Float_Truncate
(Conv
, Float_Truncate
(N
));
12160 Set_Rounded_Result
(Conv
, Rounded_Result
(N
));
12162 if Do_Overflow_Check
(N
) then
12163 Set_Do_Overflow_Check
(Conv
);
12164 Set_Do_Overflow_Check
(N
, False);
12168 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
12170 -- For a conversion from Float to Fixed where the bounds of the
12171 -- fixed-point type are static, we can obtain a more accurate
12172 -- fixed-point value by converting the result of the floating-
12173 -- point expression to an appropriate integer type, and then
12174 -- performing an unchecked conversion to the target fixed-point
12175 -- type. The range check can then use the corresponding integer
12176 -- value of the bounds instead of requiring further conversions.
12177 -- This preserves the identity:
12179 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
12181 -- which used to fail when Fix_Val was a bound of the type and
12182 -- the 'Small was not a representable number.
12183 -- This transformation requires an integer type large enough to
12184 -- accommodate a fixed-point value.
12186 if Is_Ordinary_Fixed_Point_Type
(Target_Type
)
12187 and then Is_Floating_Point_Type
(Etype
(Expr
))
12188 and then RM_Size
(Btyp
) <= System_Max_Integer_Size
12189 and then Nkind
(Lo
) = N_Real_Literal
12190 and then Nkind
(Hi
) = N_Real_Literal
12193 Expr_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Conv
);
12194 Int_Typ
: constant Entity_Id
:=
12195 Small_Integer_Type_For
(RM_Size
(Btyp
), Uns
=> False);
12198 -- Generate a temporary with the integer value. Required in the
12199 -- CCG compiler to ensure that run-time checks reference this
12200 -- integer expression (instead of the resulting fixed-point
12201 -- value because fixed-point values are handled by means of
12202 -- unsigned integer types).
12205 Make_Object_Declaration
(Loc
,
12206 Defining_Identifier
=> Expr_Id
,
12207 Object_Definition
=> New_Occurrence_Of
(Int_Typ
, Loc
),
12208 Constant_Present
=> True,
12210 Convert_To
(Int_Typ
, Expression
(Conv
))));
12212 -- Create integer objects for range checking of result.
12215 Unchecked_Convert_To
12216 (Int_Typ
, New_Occurrence_Of
(Expr_Id
, Loc
));
12219 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Lo
));
12222 Unchecked_Convert_To
12223 (Int_Typ
, New_Occurrence_Of
(Expr_Id
, Loc
));
12226 Make_Integer_Literal
(Loc
, Corresponding_Integer_Value
(Hi
));
12228 -- Rewrite conversion as an integer conversion of the
12229 -- original floating-point expression, followed by an
12230 -- unchecked conversion to the target fixed-point type.
12233 Unchecked_Convert_To
12234 (Target_Type
, New_Occurrence_Of
(Expr_Id
, Loc
));
12237 -- All other conversions
12240 Lo_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
12242 Make_Attribute_Reference
(Loc
,
12243 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
12244 Attribute_Name
=> Name_First
);
12246 Hi_Arg
:= New_Occurrence_Of
(Tnn
, Loc
);
12248 Make_Attribute_Reference
(Loc
,
12249 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
12250 Attribute_Name
=> Name_Last
);
12253 -- Build code for range checking. Note that checks are suppressed
12254 -- here since we don't want a recursive range check popping up.
12256 Insert_Actions
(N
, New_List
(
12257 Make_Object_Declaration
(Loc
,
12258 Defining_Identifier
=> Tnn
,
12259 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
12260 Constant_Present
=> True,
12261 Expression
=> Conv
),
12263 Make_Raise_Constraint_Error
(Loc
,
12268 Left_Opnd
=> Lo_Arg
,
12269 Right_Opnd
=> Lo_Val
),
12273 Left_Opnd
=> Hi_Arg
,
12274 Right_Opnd
=> Hi_Val
)),
12275 Reason
=> CE_Range_Check_Failed
)),
12276 Suppress
=> All_Checks
);
12278 Rewrite
(Expr
, New_Occurrence_Of
(Tnn
, Loc
));
12279 end Real_Range_Check
;
12281 -----------------------------
12282 -- Has_Extra_Accessibility --
12283 -----------------------------
12285 -- Returns true for a formal of an anonymous access type or for an Ada
12286 -- 2012-style stand-alone object of an anonymous access type.
12288 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
12290 if Is_Formal
(Id
) or else Ekind
(Id
) in E_Constant | E_Variable
then
12291 return Present
(Effective_Extra_Accessibility
(Id
));
12295 end Has_Extra_Accessibility
;
12297 ----------------------------------------
12298 -- Statically_Deeper_Relation_Applies --
12299 ----------------------------------------
12301 function Statically_Deeper_Relation_Applies
(Targ_Typ
: Entity_Id
)
12305 -- The case where the target type is an anonymous access type is
12306 -- ignored since they have different semantics and get covered by
12307 -- various runtime checks depending on context.
12309 -- Note, the current implementation of this predicate is incomplete
12310 -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
12313 return Ekind
(Targ_Typ
) /= E_Anonymous_Access_Type
;
12314 end Statically_Deeper_Relation_Applies
;
12316 -- Start of processing for Expand_N_Type_Conversion
12319 -- First remove check marks put by the semantic analysis on the type
12320 -- conversion between array types. We need these checks, and they will
12321 -- be generated by this expansion routine, but we do not depend on these
12322 -- flags being set, and since we do intend to expand the checks in the
12323 -- front end, we don't want them on the tree passed to the back end.
12325 if Is_Array_Type
(Target_Type
) then
12326 if Is_Constrained
(Target_Type
) then
12327 Set_Do_Length_Check
(N
, False);
12329 Set_Do_Range_Check
(Operand
, False);
12333 -- Nothing at all to do if conversion is to the identical type so remove
12334 -- the conversion completely, it is useless, except that it may carry
12335 -- an Assignment_OK attribute, which must be propagated to the operand
12336 -- and the Do_Range_Check flag on the operand must be cleared, if any.
12338 if Operand_Type
= Target_Type
then
12339 if Assignment_OK
(N
) then
12340 Set_Assignment_OK
(Operand
);
12343 Set_Do_Range_Check
(Operand
, False);
12345 Rewrite
(N
, Relocate_Node
(Operand
));
12350 -- Nothing to do if this is the second argument of read. This is a
12351 -- "backwards" conversion that will be handled by the specialized code
12352 -- in attribute processing.
12354 if Nkind
(Parent
(N
)) = N_Attribute_Reference
12355 and then Attribute_Name
(Parent
(N
)) = Name_Read
12356 and then Next
(First
(Expressions
(Parent
(N
)))) = N
12361 -- Check for case of converting to a type that has an invariant
12362 -- associated with it. This requires an invariant check. We insert
12365 -- invariant_check (typ (expr))
12367 -- in the code, after removing side effects from the expression.
12368 -- This is clearer than replacing the conversion into an expression
12369 -- with actions, because the context may impose additional actions
12370 -- (tag checks, membership tests, etc.) that conflict with this
12371 -- rewriting (used previously).
12373 -- Note: the Comes_From_Source check, and then the resetting of this
12374 -- flag prevents what would otherwise be an infinite recursion.
12376 if Has_Invariants
(Target_Type
)
12377 and then Present
(Invariant_Procedure
(Target_Type
))
12378 and then Comes_From_Source
(N
)
12380 Set_Comes_From_Source
(N
, False);
12381 Remove_Side_Effects
(N
);
12382 Insert_Action
(N
, Make_Invariant_Call
(Duplicate_Subexpr
(N
)));
12385 -- AI12-0042: For a view conversion to a class-wide type occurring
12386 -- within the immediate scope of T, from a specific type that is
12387 -- a descendant of T (including T itself), an invariant check is
12388 -- performed on the part of the object that is of type T. (We don't
12389 -- need to explicitly check for the operand type being a descendant,
12390 -- just that it's a specific type, because the conversion would be
12391 -- illegal if it's specific and not a descendant -- downward conversion
12392 -- is not allowed).
12394 elsif Is_Class_Wide_Type
(Target_Type
)
12395 and then not Is_Class_Wide_Type
(Etype
(Expression
(N
)))
12396 and then Present
(Invariant_Procedure
(Root_Type
(Target_Type
)))
12397 and then Comes_From_Source
(N
)
12398 and then Within_Scope
(Find_Enclosing_Scope
(N
), Scope
(Target_Type
))
12400 Remove_Side_Effects
(N
);
12402 -- Perform the invariant check on a conversion to the class-wide
12403 -- type's root type.
12406 Root_Conv
: constant Node_Id
:=
12407 Make_Type_Conversion
(Loc
,
12409 New_Occurrence_Of
(Root_Type
(Target_Type
), Loc
),
12410 Expression
=> Duplicate_Subexpr
(Expression
(N
)));
12412 Set_Etype
(Root_Conv
, Root_Type
(Target_Type
));
12414 Insert_Action
(N
, Make_Invariant_Call
(Root_Conv
));
12419 -- Here if we may need to expand conversion
12421 -- If the operand of the type conversion is an arithmetic operation on
12422 -- signed integers, and the based type of the signed integer type in
12423 -- question is smaller than Standard.Integer, we promote both of the
12424 -- operands to type Integer.
12426 -- For example, if we have
12428 -- target-type (opnd1 + opnd2)
12430 -- and opnd1 and opnd2 are of type short integer, then we rewrite
12433 -- target-type (integer(opnd1) + integer(opnd2))
12435 -- We do this because we are always allowed to compute in a larger type
12436 -- if we do the right thing with the result, and in this case we are
12437 -- going to do a conversion which will do an appropriate check to make
12438 -- sure that things are in range of the target type in any case. This
12439 -- avoids some unnecessary intermediate overflows.
12441 -- We might consider a similar transformation in the case where the
12442 -- target is a real type or a 64-bit integer type, and the operand
12443 -- is an arithmetic operation using a 32-bit integer type. However,
12444 -- we do not bother with this case, because it could cause significant
12445 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
12446 -- much cheaper, but we don't want different behavior on 32-bit and
12447 -- 64-bit machines. Note that the exclusion of the 64-bit case also
12448 -- handles the configurable run-time cases where 64-bit arithmetic
12449 -- may simply be unavailable.
12451 -- Note: this circuit is partially redundant with respect to the circuit
12452 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
12453 -- the processing here. Also we still need the Checks circuit, since we
12454 -- have to be sure not to generate junk overflow checks in the first
12455 -- place, since it would be tricky to remove them here.
12457 if Integer_Promotion_Possible
(N
) then
12459 -- All conditions met, go ahead with transformation
12466 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
12468 R
:= Convert_To
(Standard_Integer
, Right_Opnd
(Operand
));
12469 Set_Right_Opnd
(Opnd
, R
);
12471 if Nkind
(Operand
) in N_Binary_Op
then
12472 L
:= Convert_To
(Standard_Integer
, Left_Opnd
(Operand
));
12473 Set_Left_Opnd
(Opnd
, L
);
12477 Make_Type_Conversion
(Loc
,
12478 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
12479 Expression
=> Opnd
));
12481 Analyze_And_Resolve
(N
, Target_Type
);
12486 -- If the conversion is from Universal_Integer and requires an overflow
12487 -- check, try to do an intermediate conversion to a narrower type first
12488 -- without overflow check, in order to avoid doing the overflow check
12489 -- in Universal_Integer, which can be a very large type.
12491 if Operand_Type
= Universal_Integer
and then Do_Overflow_Check
(N
) then
12493 Lo
, Hi
, Siz
: Uint
;
12498 Determine_Range
(Operand
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12501 Siz
:= Get_Size_For_Range
(Lo
, Hi
);
12503 -- We use the base type instead of the first subtype because
12504 -- overflow checks are done in the base type, so this avoids
12505 -- the need for useless conversions.
12507 if Siz
< System_Max_Integer_Size
then
12508 Typ
:= Etype
(Integer_Type_For
(Siz
, Uns
=> False));
12510 Convert_To_And_Rewrite
(Typ
, Operand
);
12511 Analyze_And_Resolve
12512 (Operand
, Typ
, Suppress
=> Overflow_Check
);
12514 Analyze_And_Resolve
(N
, Target_Type
);
12521 -- Do validity check if validity checking operands
12523 if Validity_Checks_On
and Validity_Check_Operands
then
12524 Ensure_Valid
(Operand
);
12527 -- Special case of converting from non-standard boolean type
12529 if Is_Boolean_Type
(Operand_Type
)
12530 and then (Nonzero_Is_True
(Operand_Type
))
12532 Adjust_Condition
(Operand
);
12533 Set_Etype
(Operand
, Standard_Boolean
);
12534 Operand_Type
:= Standard_Boolean
;
12537 -- Case of converting to an access type
12539 if Is_Access_Type
(Target_Type
) then
12540 -- In terms of accessibility rules, an anonymous access discriminant
12541 -- is not considered separate from its parent object.
12543 if Nkind
(Operand
) = N_Selected_Component
12544 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
12545 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
12547 Operand_Acc
:= Original_Node
(Prefix
(Operand
));
12550 -- If this type conversion was internally generated by the front end
12551 -- to displace the pointer to the object to reference an interface
12552 -- type and the original node was an Unrestricted_Access attribute,
12553 -- then skip applying accessibility checks (because, according to the
12554 -- GNAT Reference Manual, this attribute is similar to 'Access except
12555 -- that all accessibility and aliased view checks are omitted).
12557 if not Comes_From_Source
(N
)
12558 and then Is_Interface
(Designated_Type
(Target_Type
))
12559 and then Nkind
(Original_Node
(N
)) = N_Attribute_Reference
12560 and then Attribute_Name
(Original_Node
(N
)) =
12561 Name_Unrestricted_Access
12565 -- Apply an accessibility check when the conversion operand is an
12566 -- access parameter (or a renaming thereof), unless conversion was
12567 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
12568 -- or for the actual of a class-wide interface parameter. Note that
12569 -- other checks may still need to be applied below (such as tagged
12572 elsif Is_Entity_Name
(Operand_Acc
)
12573 and then Has_Extra_Accessibility
(Entity
(Operand_Acc
))
12574 and then Ekind
(Etype
(Operand_Acc
)) = E_Anonymous_Access_Type
12575 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
12576 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
12577 and then not No_Dynamic_Accessibility_Checks_Enabled
(N
)
12579 if not Comes_From_Source
(N
)
12580 and then Nkind
(Parent
(N
)) in N_Function_Call
12581 | N_Parameter_Association
12582 | N_Procedure_Call_Statement
12583 and then Is_Interface
(Designated_Type
(Target_Type
))
12584 and then Is_Class_Wide_Type
(Designated_Type
(Target_Type
))
12589 Apply_Accessibility_Check
12590 (Operand
, Target_Type
, Insert_Node
=> Operand
);
12593 -- If the level of the operand type is statically deeper than the
12594 -- level of the target type, then force Program_Error. Note that this
12595 -- can only occur for cases where the attribute is within the body of
12596 -- an instantiation, otherwise the conversion will already have been
12597 -- rejected as illegal.
12599 -- Note: warnings are issued by the analyzer for the instance cases,
12600 -- and, since we are late in expansion, a check is performed to
12601 -- verify that neither the target type nor the operand type are
12602 -- internally generated - as this can lead to spurious errors when,
12603 -- for example, the operand type is a result of BIP expansion.
12605 elsif In_Instance_Body
12606 and then Statically_Deeper_Relation_Applies
(Target_Type
)
12607 and then not Is_Internal
(Target_Type
)
12608 and then not Is_Internal
(Operand_Type
)
12610 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
12612 Raise_Accessibility_Error
;
12615 -- When the operand is a selected access discriminant the check needs
12616 -- to be made against the level of the object denoted by the prefix
12617 -- of the selected name. Force Program_Error for this case as well
12618 -- (this accessibility violation can only happen if within the body
12619 -- of an instantiation).
12621 elsif In_Instance_Body
12622 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
12623 and then Nkind
(Operand
) = N_Selected_Component
12624 and then Ekind
(Entity
(Selector_Name
(Operand
))) = E_Discriminant
12625 and then Static_Accessibility_Level
(Operand
, Zero_On_Dynamic_Level
)
12626 > Type_Access_Level
(Target_Type
)
12628 Raise_Accessibility_Error
;
12633 -- Case of conversions of tagged types and access to tagged types
12635 -- When needed, that is to say when the expression is class-wide, Add
12636 -- runtime a tag check for (strict) downward conversion by using the
12637 -- membership test, generating:
12639 -- [constraint_error when Operand not in Target_Type'Class]
12641 -- or in the access type case
12643 -- [constraint_error
12644 -- when Operand /= null
12645 -- and then Operand.all not in
12646 -- Designated_Type (Target_Type)'Class]
12648 if (Is_Access_Type
(Target_Type
)
12649 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
12650 or else Is_Tagged_Type
(Target_Type
)
12652 -- Do not do any expansion in the access type case if the parent is a
12653 -- renaming, since this is an error situation which will be caught by
12654 -- Sem_Ch8, and the expansion can interfere with this error check.
12656 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
12660 -- Otherwise, proceed with processing tagged conversion
12662 Tagged_Conversion
: declare
12663 Actual_Op_Typ
: Entity_Id
;
12664 Actual_Targ_Typ
: Entity_Id
;
12665 Root_Op_Typ
: Entity_Id
;
12667 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
12668 -- Create a membership check to test whether Operand is a member
12669 -- of Targ_Typ. If the original Target_Type is an access, include
12670 -- a test for null value. The check is inserted at N.
12672 --------------------
12673 -- Make_Tag_Check --
12674 --------------------
12676 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
12681 -- [Constraint_Error
12682 -- when Operand /= null
12683 -- and then Operand.all not in Targ_Typ]
12685 if Is_Access_Type
(Target_Type
) then
12687 Make_And_Then
(Loc
,
12690 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12691 Right_Opnd
=> Make_Null
(Loc
)),
12696 Make_Explicit_Dereference
(Loc
,
12697 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
12698 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
12701 -- [Constraint_Error when Operand not in Targ_Typ]
12706 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
12707 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
12711 Make_Raise_Constraint_Error
(Loc
,
12713 Reason
=> CE_Tag_Check_Failed
),
12714 Suppress
=> All_Checks
);
12715 end Make_Tag_Check
;
12717 -- Start of processing for Tagged_Conversion
12720 -- Handle entities from the limited view
12722 if Is_Access_Type
(Operand_Type
) then
12724 Available_View
(Designated_Type
(Operand_Type
));
12726 Actual_Op_Typ
:= Operand_Type
;
12729 if Is_Access_Type
(Target_Type
) then
12731 Available_View
(Designated_Type
(Target_Type
));
12733 Actual_Targ_Typ
:= Target_Type
;
12736 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
12738 -- Ada 2005 (AI-251): Handle interface type conversion
12740 if Is_Interface
(Actual_Op_Typ
)
12742 Is_Interface
(Actual_Targ_Typ
)
12744 Expand_Interface_Conversion
(N
);
12748 -- Create a runtime tag check for a downward CW type conversion
12750 if Is_Class_Wide_Type
(Actual_Op_Typ
)
12751 and then Actual_Op_Typ
/= Actual_Targ_Typ
12752 and then Root_Op_Typ
/= Actual_Targ_Typ
12753 and then Is_Ancestor
12754 (Root_Op_Typ
, Actual_Targ_Typ
, Use_Full_View
=> True)
12755 and then not Tag_Checks_Suppressed
(Actual_Targ_Typ
)
12760 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
12761 Conv
:= Unchecked_Convert_To
(Target_Type
, Expression
(N
));
12763 Analyze_And_Resolve
(N
, Target_Type
);
12766 end Tagged_Conversion
;
12768 -- Case of other access type conversions
12770 elsif Is_Access_Type
(Target_Type
) then
12771 Apply_Constraint_Check
(Operand
, Target_Type
);
12773 -- Case of conversions from a fixed-point type
12775 -- These conversions require special expansion and processing, found in
12776 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12777 -- since from a semantic point of view, these are simple integer
12778 -- conversions, which do not need further processing except for the
12779 -- generation of range checks, which is performed at the end of this
12782 elsif Is_Fixed_Point_Type
(Operand_Type
)
12783 and then not Conversion_OK
(N
)
12785 -- We should never see universal fixed at this case, since the
12786 -- expansion of the constituent divide or multiply should have
12787 -- eliminated the explicit mention of universal fixed.
12789 pragma Assert
(Operand_Type
/= Universal_Fixed
);
12791 -- Check for special case of the conversion to universal real that
12792 -- occurs as a result of the use of a round attribute. In this case,
12793 -- the real type for the conversion is taken from the target type of
12794 -- the Round attribute and the result must be marked as rounded.
12796 if Target_Type
= Universal_Real
12797 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
12798 and then Attribute_Name
(Parent
(N
)) = Name_Round
12800 Set_Etype
(N
, Etype
(Parent
(N
)));
12801 Target_Type
:= Etype
(N
);
12802 Set_Rounded_Result
(N
);
12805 if Is_Fixed_Point_Type
(Target_Type
) then
12806 Expand_Convert_Fixed_To_Fixed
(N
);
12807 elsif Is_Integer_Type
(Target_Type
) then
12808 Expand_Convert_Fixed_To_Integer
(N
);
12810 pragma Assert
(Is_Floating_Point_Type
(Target_Type
));
12811 Expand_Convert_Fixed_To_Float
(N
);
12814 -- Case of conversions to a fixed-point type
12816 -- These conversions require special expansion and processing, found in
12817 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12818 -- since from a semantic point of view, these are simple integer
12819 -- conversions, which do not need further processing.
12821 elsif Is_Fixed_Point_Type
(Target_Type
)
12822 and then not Conversion_OK
(N
)
12824 if Is_Integer_Type
(Operand_Type
) then
12825 Expand_Convert_Integer_To_Fixed
(N
);
12827 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
12828 Expand_Convert_Float_To_Fixed
(N
);
12831 -- Case of array conversions
12833 -- Expansion of array conversions, add required length/range checks but
12834 -- only do this if there is no change of representation. For handling of
12835 -- this case, see Handle_Changed_Representation.
12837 elsif Is_Array_Type
(Target_Type
) then
12838 if Is_Constrained
(Target_Type
) then
12839 Apply_Length_Check
(Operand
, Target_Type
);
12841 -- If the object has an unconstrained array subtype with fixed
12842 -- lower bound, then sliding to that bound may be needed.
12844 if Is_Fixed_Lower_Bound_Array_Subtype
(Target_Type
) then
12845 Expand_Sliding_Conversion
(Operand
, Target_Type
);
12848 Apply_Range_Check
(Operand
, Target_Type
);
12851 Handle_Changed_Representation
;
12853 -- Case of conversions of discriminated types
12855 -- Add required discriminant checks if target is constrained. Again this
12856 -- change is skipped if we have a change of representation.
12858 elsif Has_Discriminants
(Target_Type
)
12859 and then Is_Constrained
(Target_Type
)
12861 Apply_Discriminant_Check
(Operand
, Target_Type
);
12862 Handle_Changed_Representation
;
12864 -- Case of all other record conversions. The only processing required
12865 -- is to check for a change of representation requiring the special
12866 -- assignment processing.
12868 elsif Is_Record_Type
(Target_Type
) then
12870 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12871 -- a derived Unchecked_Union type to an unconstrained type that is
12872 -- not Unchecked_Union if the operand lacks inferable discriminants.
12874 if Is_Derived_Type
(Operand_Type
)
12875 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
12876 and then not Is_Constrained
(Target_Type
)
12877 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
12878 and then not Has_Inferable_Discriminants
(Operand
)
12880 -- To prevent Gigi from generating illegal code, we generate a
12881 -- Program_Error node, but we give it the target type of the
12882 -- conversion (is this requirement documented somewhere ???)
12885 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
12886 Reason
=> PE_Unchecked_Union_Restriction
);
12889 Set_Etype
(PE
, Target_Type
);
12894 Handle_Changed_Representation
;
12897 -- Case of conversions of enumeration types
12899 elsif Is_Enumeration_Type
(Target_Type
) then
12901 -- Special processing is required if there is a change of
12902 -- representation (from enumeration representation clauses).
12904 if not Has_Compatible_Representation
(Target_Type
, Operand_Type
)
12905 and then not Conversion_OK
(N
)
12907 if Optimization_Level
> 0
12908 and then Is_Boolean_Type
(Target_Type
)
12910 -- Convert x(y) to (if y then x'(True) else x'(False)).
12911 -- Use literals, instead of indexing x'val, to enable
12912 -- further optimizations in the middle-end.
12915 Make_If_Expression
(Loc
,
12916 Expressions
=> New_List
(
12918 Convert_To
(Target_Type
,
12919 New_Occurrence_Of
(Standard_True
, Loc
)),
12920 Convert_To
(Target_Type
,
12921 New_Occurrence_Of
(Standard_False
, Loc
)))));
12924 -- Convert: x(y) to x'val (ytyp'pos (y))
12927 Make_Attribute_Reference
(Loc
,
12928 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
12929 Attribute_Name
=> Name_Val
,
12930 Expressions
=> New_List
(
12931 Make_Attribute_Reference
(Loc
,
12932 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
12933 Attribute_Name
=> Name_Pos
,
12934 Expressions
=> New_List
(Operand
)))));
12937 Analyze_And_Resolve
(N
, Target_Type
);
12941 -- At this stage, either the conversion node has been transformed into
12942 -- some other equivalent expression, or left as a conversion that can be
12943 -- handled by Gigi.
12945 -- The only remaining step is to generate a range check if we still have
12946 -- a type conversion at this stage and Do_Range_Check is set. Note that
12947 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12948 -- conversions here, because the float-to-integer case is entirely dealt
12949 -- with by Apply_Float_Conversion_Check.
12951 if Nkind
(N
) = N_Type_Conversion
12952 and then Do_Range_Check
(Expression
(N
))
12954 -- Float-to-float conversions
12956 if Is_Floating_Point_Type
(Target_Type
)
12957 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
12959 -- Reset overflow flag, since the range check will include
12960 -- dealing with possible overflow, and generate the check.
12962 Set_Do_Overflow_Check
(N
, False);
12964 Generate_Range_Check
12965 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
12967 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12968 -- conversions when Conversion_OK is set.
12970 elsif Is_Discrete_Type
(Target_Type
)
12971 and then (Is_Discrete_Type
(Etype
(Expression
(N
)))
12972 or else (Is_Fixed_Point_Type
(Etype
(Expression
(N
)))
12973 and then Conversion_OK
(N
)))
12975 -- If Address is either a source type or target type,
12976 -- suppress range check to avoid typing anomalies when
12977 -- it is a visible integer type.
12979 if Is_Descendant_Of_Address
(Etype
(Expression
(N
)))
12980 or else Is_Descendant_Of_Address
(Target_Type
)
12982 Set_Do_Range_Check
(Expression
(N
), False);
12984 Discrete_Range_Check
;
12987 -- Conversions to floating- or fixed-point when Conversion_OK is set
12989 elsif Is_Floating_Point_Type
(Target_Type
)
12990 or else (Is_Fixed_Point_Type
(Target_Type
)
12991 and then Conversion_OK
(N
))
12996 pragma Assert
(not Do_Range_Check
(Expression
(N
)));
12999 -- Here at end of processing
13002 -- Apply predicate check if required. Note that we can't just call
13003 -- Apply_Predicate_Check here, because the type looks right after
13004 -- the conversion and it would omit the check. The Comes_From_Source
13005 -- guard is necessary to prevent infinite recursions when we generate
13006 -- internal conversions for the purpose of checking predicates.
13008 -- A view conversion of a tagged object is an object and can appear
13009 -- in an assignment context, in which case no predicate check applies
13010 -- to the now-dead value.
13012 if Nkind
(Parent
(N
)) = N_Assignment_Statement
13013 and then N
= Name
(Parent
(N
))
13017 elsif Predicate_Enabled
(Target_Type
)
13018 and then Target_Type
/= Operand_Type
13019 and then Comes_From_Source
(N
)
13022 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
13025 -- Avoid infinite recursion on the subsequent expansion of the
13026 -- copy of the original type conversion. When needed, a range
13027 -- check has already been applied to the expression.
13029 Set_Comes_From_Source
(New_Expr
, False);
13031 Make_Predicate_Check
(Target_Type
, New_Expr
),
13032 Suppress
=> Range_Check
);
13035 end Expand_N_Type_Conversion
;
13037 -----------------------------------
13038 -- Expand_N_Unchecked_Expression --
13039 -----------------------------------
13041 -- Remove the unchecked expression node from the tree. Its job was simply
13042 -- to make sure that its constituent expression was handled with checks
13043 -- off, and now that is done, we can remove it from the tree, and indeed
13044 -- must, since Gigi does not expect to see these nodes.
13046 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
13047 Exp
: constant Node_Id
:= Expression
(N
);
13049 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
13051 end Expand_N_Unchecked_Expression
;
13053 ----------------------------------------
13054 -- Expand_N_Unchecked_Type_Conversion --
13055 ----------------------------------------
13057 -- If this cannot be handled by Gigi and we haven't already made a
13058 -- temporary for it, do it now.
13060 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
13061 Target_Type
: constant Entity_Id
:= Etype
(N
);
13062 Operand
: constant Node_Id
:= Expression
(N
);
13063 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
13066 -- Nothing at all to do if conversion is to the identical type so remove
13067 -- the conversion completely, it is useless, except that it may carry
13068 -- an Assignment_OK indication which must be propagated to the operand.
13070 if Operand_Type
= Target_Type
then
13071 Expand_N_Unchecked_Expression
(N
);
13075 -- Generate an extra temporary for cases unsupported by the C backend
13077 if Modify_Tree_For_C
then
13079 Source
: constant Node_Id
:= Unqual_Conv
(Expression
(N
));
13080 Source_Typ
: Entity_Id
:= Get_Full_View
(Etype
(Source
));
13083 if Is_Packed_Array
(Source_Typ
) then
13084 Source_Typ
:= Packed_Array_Impl_Type
(Source_Typ
);
13087 if Nkind
(Source
) = N_Function_Call
13088 and then (Is_Composite_Type
(Etype
(Source
))
13089 or else Is_Composite_Type
(Target_Type
))
13091 Force_Evaluation
(Source
);
13096 -- Nothing to do if conversion is safe
13098 if Safe_Unchecked_Type_Conversion
(N
) then
13102 if Assignment_OK
(N
) then
13105 Force_Evaluation
(N
);
13107 end Expand_N_Unchecked_Type_Conversion
;
13109 ----------------------------
13110 -- Expand_Record_Equality --
13111 ----------------------------
13113 -- For non-variant records, Equality is expanded when needed into:
13115 -- and then Lhs.Discr1 = Rhs.Discr1
13117 -- and then Lhs.Discrn = Rhs.Discrn
13118 -- and then Lhs.Cmp1 = Rhs.Cmp1
13120 -- and then Lhs.Cmpn = Rhs.Cmpn
13122 -- The expression is folded by the back end for adjacent fields. This
13123 -- function is called for tagged record in only one occasion: for imple-
13124 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
13125 -- otherwise the primitive "=" is used directly.
13127 function Expand_Record_Equality
13131 Rhs
: Node_Id
) return Node_Id
13133 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
13138 First_Time
: Boolean := True;
13140 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
13141 -- Return the next discriminant or component to compare, starting with
13142 -- C, skipping inherited components.
13144 ------------------------
13145 -- Element_To_Compare --
13146 ------------------------
13148 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
13149 Comp
: Entity_Id
:= C
;
13152 while Present
(Comp
) loop
13153 -- Skip inherited components
13155 -- Note: for a tagged type, we always generate the "=" primitive
13156 -- for the base type (not on the first subtype), so the test for
13157 -- Comp /= Original_Record_Component (Comp) is True for inherited
13158 -- components only.
13160 if (Is_Tagged_Type
(Typ
)
13161 and then Comp
/= Original_Record_Component
(Comp
))
13165 or else Chars
(Comp
) = Name_uTag
13167 -- Skip interface elements (secondary tags???)
13169 or else Is_Interface
(Etype
(Comp
))
13171 Next_Component_Or_Discriminant
(Comp
);
13178 end Element_To_Compare
;
13180 -- Start of processing for Expand_Record_Equality
13183 -- Generates the following code: (assuming that Typ has one Discr and
13184 -- component C2 is also a record)
13186 -- Lhs.Discr1 = Rhs.Discr1
13187 -- and then Lhs.C1 = Rhs.C1
13188 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
13190 -- and then Lhs.Cmpn = Rhs.Cmpn
13192 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
13193 C
:= Element_To_Compare
(First_Component_Or_Discriminant
(Typ
));
13194 while Present
(C
) loop
13205 New_Lhs
:= New_Copy_Tree
(Lhs
);
13206 New_Rhs
:= New_Copy_Tree
(Rhs
);
13210 Expand_Composite_Equality
13211 (Outer_Type
=> Typ
, Nod
=> Nod
, Comp_Type
=> Etype
(C
),
13213 Make_Selected_Component
(Loc
,
13215 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
13217 Make_Selected_Component
(Loc
,
13219 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)));
13221 -- If some (sub)component is an unchecked_union, the whole
13222 -- operation will raise program error.
13224 if Nkind
(Check
) = N_Raise_Program_Error
then
13226 Set_Etype
(Result
, Standard_Boolean
);
13232 -- Generate logical "and" for CodePeer to simplify the
13233 -- generated code and analysis.
13235 elsif CodePeer_Mode
then
13238 Left_Opnd
=> Result
,
13239 Right_Opnd
=> Check
);
13243 Make_And_Then
(Loc
,
13244 Left_Opnd
=> Result
,
13245 Right_Opnd
=> Check
);
13250 First_Time
:= False;
13251 C
:= Element_To_Compare
(Next_Component_Or_Discriminant
(C
));
13255 end Expand_Record_Equality
;
13257 ---------------------------
13258 -- Expand_Set_Membership --
13259 ---------------------------
13261 procedure Expand_Set_Membership
(N
: Node_Id
) is
13262 Lop
: constant Node_Id
:= Left_Opnd
(N
);
13266 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
13267 -- If the alternative is a subtype mark, create a simple membership
13268 -- test. Otherwise create an equality test for it.
13274 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
13276 L
: constant Node_Id
:= New_Copy_Tree
(Lop
);
13277 R
: constant Node_Id
:= Relocate_Node
(Alt
);
13280 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
13281 or else Nkind
(Alt
) = N_Range
13283 Cond
:= Make_In
(Sloc
(Alt
), Left_Opnd
=> L
, Right_Opnd
=> R
);
13286 Cond
:= Make_Op_Eq
(Sloc
(Alt
), Left_Opnd
=> L
, Right_Opnd
=> R
);
13287 Resolve_Membership_Equality
(Cond
, Etype
(Alt
));
13293 -- Start of processing for Expand_Set_Membership
13296 Remove_Side_Effects
(Lop
);
13298 Alt
:= First
(Alternatives
(N
));
13299 Res
:= Make_Cond
(Alt
);
13302 -- We use left associativity as in the equivalent boolean case. This
13303 -- kind of canonicalization helps the optimizer of the code generator.
13305 while Present
(Alt
) loop
13307 Make_Or_Else
(Sloc
(Alt
),
13309 Right_Opnd
=> Make_Cond
(Alt
));
13314 Analyze_And_Resolve
(N
, Standard_Boolean
);
13315 end Expand_Set_Membership
;
13317 -----------------------------------
13318 -- Expand_Short_Circuit_Operator --
13319 -----------------------------------
13321 -- Deal with special expansion if actions are present for the right operand
13322 -- and deal with optimizing case of arguments being True or False. We also
13323 -- deal with the special case of non-standard boolean values.
13325 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
13326 Loc
: constant Source_Ptr
:= Sloc
(N
);
13327 Typ
: constant Entity_Id
:= Etype
(N
);
13328 Left
: constant Node_Id
:= Left_Opnd
(N
);
13329 Right
: constant Node_Id
:= Right_Opnd
(N
);
13330 LocR
: constant Source_Ptr
:= Sloc
(Right
);
13333 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
13334 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
13335 -- If Left = Shortcut_Value then Right need not be evaluated
13337 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
13338 -- For Opnd a boolean expression, return a Boolean expression equivalent
13339 -- to Opnd /= Shortcut_Value.
13341 function Useful
(Actions
: List_Id
) return Boolean;
13342 -- Return True if Actions is not empty and contains useful nodes to
13345 --------------------
13346 -- Make_Test_Expr --
13347 --------------------
13349 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
13351 if Shortcut_Value
then
13352 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
13356 end Make_Test_Expr
;
13362 function Useful
(Actions
: List_Id
) return Boolean is
13365 if Present
(Actions
) then
13366 L
:= First
(Actions
);
13368 -- For now "useful" means not N_Variable_Reference_Marker.
13369 -- Consider stripping other nodes in the future.
13371 while Present
(L
) loop
13372 if Nkind
(L
) /= N_Variable_Reference_Marker
then
13385 Op_Var
: Entity_Id
;
13386 -- Entity for a temporary variable holding the value of the operator,
13387 -- used for expansion in the case where actions are present.
13389 -- Start of processing for Expand_Short_Circuit_Operator
13392 -- Deal with non-standard booleans
13394 if Is_Boolean_Type
(Typ
) then
13395 Adjust_Condition
(Left
);
13396 Adjust_Condition
(Right
);
13397 Set_Etype
(N
, Standard_Boolean
);
13400 -- Check for cases where left argument is known to be True or False
13402 if Compile_Time_Known_Value
(Left
) then
13404 -- Mark SCO for left condition as compile time known
13406 if Generate_SCO
and then Comes_From_Source
(Left
) then
13407 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
13410 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
13411 -- Any actions associated with Right will be executed unconditionally
13412 -- and can thus be inserted into the tree unconditionally.
13414 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
13415 if Present
(Actions
(N
)) then
13416 Insert_Actions
(N
, Actions
(N
));
13419 Rewrite
(N
, Right
);
13421 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
13422 -- In this case we can forget the actions associated with Right,
13423 -- since they will never be executed.
13426 Kill_Dead_Code
(Right
);
13427 Kill_Dead_Code
(Actions
(N
));
13428 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
13431 Adjust_Result_Type
(N
, Typ
);
13435 -- If Actions are present for the right operand, we have to do some
13436 -- special processing. We can't just let these actions filter back into
13437 -- code preceding the short circuit (which is what would have happened
13438 -- if we had not trapped them in the short-circuit form), since they
13439 -- must only be executed if the right operand of the short circuit is
13440 -- executed and not otherwise.
13442 if Useful
(Actions
(N
)) then
13443 Actlist
:= Actions
(N
);
13445 -- The old approach is to expand:
13447 -- left AND THEN right
13451 -- C : Boolean := False;
13459 -- and finally rewrite the operator into a reference to C. Similarly
13460 -- for left OR ELSE right, with negated values. Note that this
13461 -- rewrite causes some difficulties for coverage analysis because
13462 -- of the introduction of the new variable C, which obscures the
13463 -- structure of the test.
13465 -- We use this "old approach" if Minimize_Expression_With_Actions
13468 if Minimize_Expression_With_Actions
then
13469 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
13472 Make_Object_Declaration
(Loc
,
13473 Defining_Identifier
=> Op_Var
,
13474 Object_Definition
=>
13475 New_Occurrence_Of
(Standard_Boolean
, Loc
),
13477 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
13479 Append_To
(Actlist
,
13480 Make_Implicit_If_Statement
(Right
,
13481 Condition
=> Make_Test_Expr
(Right
),
13482 Then_Statements
=> New_List
(
13483 Make_Assignment_Statement
(LocR
,
13484 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
13487 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
13490 Make_Implicit_If_Statement
(Left
,
13491 Condition
=> Make_Test_Expr
(Left
),
13492 Then_Statements
=> Actlist
));
13494 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
13495 Analyze_And_Resolve
(N
, Standard_Boolean
);
13497 -- The new approach (the default) is to use an
13498 -- Expression_With_Actions node for the right operand of the
13499 -- short-circuit form. Note that this solves the traceability
13500 -- problems for coverage analysis.
13504 Make_Expression_With_Actions
(LocR
,
13505 Expression
=> Relocate_Node
(Right
),
13506 Actions
=> Actlist
));
13508 Set_Actions
(N
, No_List
);
13509 Analyze_And_Resolve
(Right
, Standard_Boolean
);
13512 Adjust_Result_Type
(N
, Typ
);
13516 -- No actions present, check for cases of right argument True/False
13518 if Compile_Time_Known_Value
(Right
) then
13520 -- Mark SCO for left condition as compile time known
13522 if Generate_SCO
and then Comes_From_Source
(Right
) then
13523 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
13526 -- Change (Left and then True), (Left or else False) to Left. Note
13527 -- that we know there are no actions associated with the right
13528 -- operand, since we just checked for this case above.
13530 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
13533 -- Change (Left and then False), (Left or else True) to Right,
13534 -- making sure to preserve any side effects associated with the Left
13538 Remove_Side_Effects
(Left
);
13539 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
13543 Adjust_Result_Type
(N
, Typ
);
13544 end Expand_Short_Circuit_Operator
;
13546 ------------------------------------
13547 -- Fixup_Universal_Fixed_Operation --
13548 -------------------------------------
13550 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
13551 Conv
: constant Node_Id
:= Parent
(N
);
13554 -- We must have a type conversion immediately above us
13556 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
13558 -- Normally the type conversion gives our target type. The exception
13559 -- occurs in the case of the Round attribute, where the conversion
13560 -- will be to universal real, and our real type comes from the Round
13561 -- attribute (as well as an indication that we must round the result)
13563 if Etype
(Conv
) = Universal_Real
13564 and then Nkind
(Parent
(Conv
)) = N_Attribute_Reference
13565 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
13567 Set_Etype
(N
, Base_Type
(Etype
(Parent
(Conv
))));
13568 Set_Rounded_Result
(N
);
13570 -- Normal case where type comes from conversion above us
13573 Set_Etype
(N
, Base_Type
(Etype
(Conv
)));
13575 end Fixup_Universal_Fixed_Operation
;
13577 ----------------------------
13578 -- Get_First_Index_Bounds --
13579 ----------------------------
13581 procedure Get_First_Index_Bounds
(T
: Entity_Id
; Lo
, Hi
: out Uint
) is
13585 pragma Assert
(Is_Array_Type
(T
));
13587 -- This follows Sem_Eval.Compile_Time_Known_Bounds
13589 if Ekind
(T
) = E_String_Literal_Subtype
then
13590 Lo
:= Expr_Value
(String_Literal_Low_Bound
(T
));
13591 Hi
:= Lo
+ String_Literal_Length
(T
) - 1;
13594 Typ
:= Underlying_Type
(Etype
(First_Index
(T
)));
13596 Lo
:= Expr_Value
(Type_Low_Bound
(Typ
));
13597 Hi
:= Expr_Value
(Type_High_Bound
(Typ
));
13599 end Get_First_Index_Bounds
;
13601 ------------------------
13602 -- Get_Size_For_Range --
13603 ------------------------
13605 function Get_Size_For_Range
(Lo
, Hi
: Uint
) return Uint
is
13607 function Is_OK_For_Range
(Siz
: Uint
) return Boolean;
13608 -- Return True if a signed integer with given size can cover Lo .. Hi
13610 --------------------------
13611 -- Is_OK_For_Range --
13612 --------------------------
13614 function Is_OK_For_Range
(Siz
: Uint
) return Boolean is
13615 B
: constant Uint
:= Uint_2
** (Siz
- 1);
13618 -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
13620 return Lo
>= -B
and then Hi
>= -B
and then Lo
< B
and then Hi
< B
;
13621 end Is_OK_For_Range
;
13624 -- This is (almost always) the size of Integer
13626 if Is_OK_For_Range
(Uint_32
) then
13631 elsif Is_OK_For_Range
(Uint_63
) then
13634 -- This is (almost always) the size of Long_Long_Integer
13636 elsif Is_OK_For_Range
(Uint_64
) then
13641 elsif Is_OK_For_Range
(Uint_127
) then
13647 end Get_Size_For_Range
;
13649 -------------------------------
13650 -- Insert_Dereference_Action --
13651 -------------------------------
13653 procedure Insert_Dereference_Action
(N
: Node_Id
) is
13654 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
13655 -- Return true if type of P is derived from Checked_Pool;
13657 -----------------------------
13658 -- Is_Checked_Storage_Pool --
13659 -----------------------------
13661 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
13670 while T
/= Etype
(T
) loop
13671 if Is_RTE
(T
, RE_Checked_Pool
) then
13679 end Is_Checked_Storage_Pool
;
13683 Context
: constant Node_Id
:= Parent
(N
);
13684 Ptr_Typ
: constant Entity_Id
:= Etype
(N
);
13685 Desig_Typ
: constant Entity_Id
:=
13686 Available_View
(Designated_Type
(Ptr_Typ
));
13687 Loc
: constant Source_Ptr
:= Sloc
(N
);
13688 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
13694 Size_Bits
: Node_Id
;
13697 -- Start of processing for Insert_Dereference_Action
13700 pragma Assert
(Nkind
(Context
) = N_Explicit_Dereference
);
13702 -- Do not re-expand a dereference which has already been processed by
13705 if Has_Dereference_Action
(Context
) then
13708 -- Do not perform this type of expansion for internally-generated
13711 elsif not Comes_From_Source
(Original_Node
(Context
)) then
13714 -- A dereference action is only applicable to objects which have been
13715 -- allocated on a checked pool.
13717 elsif not Is_Checked_Storage_Pool
(Pool
) then
13721 -- Extract the address of the dereferenced object. Generate:
13723 -- Addr : System.Address := <N>'Pool_Address;
13725 Addr
:= Make_Temporary
(Loc
, 'P');
13728 Make_Object_Declaration
(Loc
,
13729 Defining_Identifier
=> Addr
,
13730 Object_Definition
=>
13731 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
13733 Make_Attribute_Reference
(Loc
,
13734 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
13735 Attribute_Name
=> Name_Pool_Address
)));
13737 -- Calculate the size of the dereferenced object. Generate:
13739 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13742 Make_Explicit_Dereference
(Loc
,
13743 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13744 Set_Has_Dereference_Action
(Deref
);
13747 Make_Attribute_Reference
(Loc
,
13749 Attribute_Name
=> Name_Size
);
13751 -- Special case of an unconstrained array: need to add descriptor size
13753 if Is_Array_Type
(Desig_Typ
)
13754 and then not Is_Constrained
(First_Subtype
(Desig_Typ
))
13759 Make_Attribute_Reference
(Loc
,
13761 New_Occurrence_Of
(First_Subtype
(Desig_Typ
), Loc
),
13762 Attribute_Name
=> Name_Descriptor_Size
),
13763 Right_Opnd
=> Size_Bits
);
13766 Size
:= Make_Temporary
(Loc
, 'S');
13768 Make_Object_Declaration
(Loc
,
13769 Defining_Identifier
=> Size
,
13770 Object_Definition
=>
13771 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13773 Make_Op_Divide
(Loc
,
13774 Left_Opnd
=> Size_Bits
,
13775 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
13777 -- Calculate the alignment of the dereferenced object. Generate:
13778 -- Alig : constant Storage_Count := <N>.all'Alignment;
13781 Make_Explicit_Dereference
(Loc
,
13782 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13783 Set_Has_Dereference_Action
(Deref
);
13785 Alig
:= Make_Temporary
(Loc
, 'A');
13787 Make_Object_Declaration
(Loc
,
13788 Defining_Identifier
=> Alig
,
13789 Object_Definition
=>
13790 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
13792 Make_Attribute_Reference
(Loc
,
13794 Attribute_Name
=> Name_Alignment
)));
13796 -- A dereference of a controlled object requires special processing. The
13797 -- finalization machinery requests additional space from the underlying
13798 -- pool to allocate and hide two pointers. As a result, a checked pool
13799 -- may mark the wrong memory as valid. Since checked pools do not have
13800 -- knowledge of hidden pointers, we have to bring the two pointers back
13801 -- in view in order to restore the original state of the object.
13803 -- The address manipulation is not performed for access types that are
13804 -- subject to pragma No_Heap_Finalization because the two pointers do
13805 -- not exist in the first place.
13807 if No_Heap_Finalization
(Ptr_Typ
) then
13810 elsif Needs_Finalization
(Desig_Typ
) then
13812 -- Adjust the address and size of the dereferenced object. Generate:
13813 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13816 Make_Procedure_Call_Statement
(Loc
,
13818 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
13819 Parameter_Associations
=> New_List
(
13820 New_Occurrence_Of
(Addr
, Loc
),
13821 New_Occurrence_Of
(Size
, Loc
),
13822 New_Occurrence_Of
(Alig
, Loc
)));
13824 -- Class-wide types complicate things because we cannot determine
13825 -- statically whether the actual object is truly controlled. We must
13826 -- generate a runtime check to detect this property. Generate:
13828 -- if Needs_Finalization (<N>.all'Tag) then
13832 if Is_Class_Wide_Type
(Desig_Typ
) then
13834 Make_Explicit_Dereference
(Loc
,
13835 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
13836 Set_Has_Dereference_Action
(Deref
);
13839 Make_Implicit_If_Statement
(N
,
13841 Make_Function_Call
(Loc
,
13843 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
13844 Parameter_Associations
=> New_List
(
13845 Make_Attribute_Reference
(Loc
,
13847 Attribute_Name
=> Name_Tag
))),
13848 Then_Statements
=> New_List
(Stmt
));
13851 Insert_Action
(N
, Stmt
);
13855 -- Dereference (Pool, Addr, Size, Alig);
13858 Make_Procedure_Call_Statement
(Loc
,
13861 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
13862 Parameter_Associations
=> New_List
(
13863 New_Occurrence_Of
(Pool
, Loc
),
13864 New_Occurrence_Of
(Addr
, Loc
),
13865 New_Occurrence_Of
(Size
, Loc
),
13866 New_Occurrence_Of
(Alig
, Loc
))));
13868 -- Mark the explicit dereference as processed to avoid potential
13869 -- infinite expansion.
13871 Set_Has_Dereference_Action
(Context
);
13874 when RE_Not_Available
=>
13876 end Insert_Dereference_Action
;
13878 --------------------------------
13879 -- Integer_Promotion_Possible --
13880 --------------------------------
13882 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
13883 Operand
: constant Node_Id
:= Expression
(N
);
13884 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
13885 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
13888 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
13892 -- We only do the transformation for source constructs. We assume
13893 -- that the expander knows what it is doing when it generates code.
13895 Comes_From_Source
(N
)
13897 -- If the operand type is Short_Integer or Short_Short_Integer,
13898 -- then we will promote to Integer, which is available on all
13899 -- targets, and is sufficient to ensure no intermediate overflow.
13900 -- Furthermore it is likely to be as efficient or more efficient
13901 -- than using the smaller type for the computation so we do this
13902 -- unconditionally.
13905 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
13907 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
13909 -- Test for interesting operation, which includes addition,
13910 -- division, exponentiation, multiplication, subtraction, absolute
13911 -- value and unary negation. Unary "+" is omitted since it is a
13912 -- no-op and thus can't overflow.
13914 and then Nkind
(Operand
) in
13915 N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
13916 N_Op_Minus | N_Op_Multiply | N_Op_Subtract
;
13917 end Integer_Promotion_Possible
;
13919 ------------------------------
13920 -- Make_Array_Comparison_Op --
13921 ------------------------------
13923 -- This is a hand-coded expansion of the following generic function:
13926 -- type elem is (<>);
13927 -- type index is (<>);
13928 -- type a is array (index range <>) of elem;
13930 -- function Gnnn (X : a; Y: a) return boolean is
13931 -- J : index := Y'first;
13934 -- if X'length = 0 then
13937 -- elsif Y'length = 0 then
13941 -- for I in X'range loop
13942 -- if X (I) = Y (J) then
13943 -- if J = Y'last then
13946 -- J := index'succ (J);
13950 -- return X (I) > Y (J);
13954 -- return X'length > Y'length;
13958 -- Note that since we are essentially doing this expansion by hand, we
13959 -- do not need to generate an actual or formal generic part, just the
13960 -- instantiated function itself.
13962 function Make_Array_Comparison_Op
13964 Nod
: Node_Id
) return Node_Id
13966 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
13968 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
13969 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
13970 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
13971 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
13973 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
13975 Loop_Statement
: Node_Id
;
13976 Loop_Body
: Node_Id
;
13978 Inner_If
: Node_Id
;
13979 Final_Expr
: Node_Id
;
13980 Func_Body
: Node_Id
;
13981 Func_Name
: Entity_Id
;
13987 -- if J = Y'last then
13990 -- J := index'succ (J);
13994 Make_Implicit_If_Statement
(Nod
,
13997 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
13999 Make_Attribute_Reference
(Loc
,
14000 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
14001 Attribute_Name
=> Name_Last
)),
14003 Then_Statements
=> New_List
(
14004 Make_Exit_Statement
(Loc
)),
14008 Make_Assignment_Statement
(Loc
,
14009 Name
=> New_Occurrence_Of
(J
, Loc
),
14011 Make_Attribute_Reference
(Loc
,
14012 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
14013 Attribute_Name
=> Name_Succ
,
14014 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
14016 -- if X (I) = Y (J) then
14019 -- return X (I) > Y (J);
14023 Make_Implicit_If_Statement
(Nod
,
14027 Make_Indexed_Component
(Loc
,
14028 Prefix
=> New_Occurrence_Of
(X
, Loc
),
14029 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
14032 Make_Indexed_Component
(Loc
,
14033 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
14034 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
14036 Then_Statements
=> New_List
(Inner_If
),
14038 Else_Statements
=> New_List
(
14039 Make_Simple_Return_Statement
(Loc
,
14043 Make_Indexed_Component
(Loc
,
14044 Prefix
=> New_Occurrence_Of
(X
, Loc
),
14045 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
14048 Make_Indexed_Component
(Loc
,
14049 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
14050 Expressions
=> New_List
(
14051 New_Occurrence_Of
(J
, Loc
)))))));
14053 -- for I in X'range loop
14058 Make_Implicit_Loop_Statement
(Nod
,
14059 Identifier
=> Empty
,
14061 Iteration_Scheme
=>
14062 Make_Iteration_Scheme
(Loc
,
14063 Loop_Parameter_Specification
=>
14064 Make_Loop_Parameter_Specification
(Loc
,
14065 Defining_Identifier
=> I
,
14066 Discrete_Subtype_Definition
=>
14067 Make_Attribute_Reference
(Loc
,
14068 Prefix
=> New_Occurrence_Of
(X
, Loc
),
14069 Attribute_Name
=> Name_Range
))),
14071 Statements
=> New_List
(Loop_Body
));
14073 -- if X'length = 0 then
14075 -- elsif Y'length = 0 then
14078 -- for ... loop ... end loop;
14079 -- return X'length > Y'length;
14083 Make_Attribute_Reference
(Loc
,
14084 Prefix
=> New_Occurrence_Of
(X
, Loc
),
14085 Attribute_Name
=> Name_Length
);
14088 Make_Attribute_Reference
(Loc
,
14089 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
14090 Attribute_Name
=> Name_Length
);
14094 Left_Opnd
=> Length1
,
14095 Right_Opnd
=> Length2
);
14098 Make_Implicit_If_Statement
(Nod
,
14102 Make_Attribute_Reference
(Loc
,
14103 Prefix
=> New_Occurrence_Of
(X
, Loc
),
14104 Attribute_Name
=> Name_Length
),
14106 Make_Integer_Literal
(Loc
, 0)),
14110 Make_Simple_Return_Statement
(Loc
,
14111 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
14113 Elsif_Parts
=> New_List
(
14114 Make_Elsif_Part
(Loc
,
14118 Make_Attribute_Reference
(Loc
,
14119 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
14120 Attribute_Name
=> Name_Length
),
14122 Make_Integer_Literal
(Loc
, 0)),
14126 Make_Simple_Return_Statement
(Loc
,
14127 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
14129 Else_Statements
=> New_List
(
14131 Make_Simple_Return_Statement
(Loc
,
14132 Expression
=> Final_Expr
)));
14136 Formals
:= New_List
(
14137 Make_Parameter_Specification
(Loc
,
14138 Defining_Identifier
=> X
,
14139 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
14141 Make_Parameter_Specification
(Loc
,
14142 Defining_Identifier
=> Y
,
14143 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
14145 -- function Gnnn (...) return boolean is
14146 -- J : index := Y'first;
14151 Func_Name
:= Make_Temporary
(Loc
, 'G');
14154 Make_Subprogram_Body
(Loc
,
14156 Make_Function_Specification
(Loc
,
14157 Defining_Unit_Name
=> Func_Name
,
14158 Parameter_Specifications
=> Formals
,
14159 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
14161 Declarations
=> New_List
(
14162 Make_Object_Declaration
(Loc
,
14163 Defining_Identifier
=> J
,
14164 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
14166 Make_Attribute_Reference
(Loc
,
14167 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
14168 Attribute_Name
=> Name_First
))),
14170 Handled_Statement_Sequence
=>
14171 Make_Handled_Sequence_Of_Statements
(Loc
,
14172 Statements
=> New_List
(If_Stat
)));
14175 end Make_Array_Comparison_Op
;
14177 ---------------------------
14178 -- Make_Boolean_Array_Op --
14179 ---------------------------
14181 -- For logical operations on boolean arrays, expand in line the following,
14182 -- replacing 'and' with 'or' or 'xor' where needed:
14184 -- function Annn (A : typ; B: typ) return typ is
14187 -- for J in A'range loop
14188 -- C (J) := A (J) op B (J);
14193 -- or in the case of Transform_Function_Array:
14195 -- procedure Annn (A : typ; B: typ; RESULT: out typ) is
14197 -- for J in A'range loop
14198 -- RESULT (J) := A (J) op B (J);
14202 -- Here typ is the boolean array type
14204 function Make_Boolean_Array_Op
14206 N
: Node_Id
) return Node_Id
14208 Loc
: constant Source_Ptr
:= Sloc
(N
);
14210 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
14211 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
14212 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
14222 Func_Name
: Entity_Id
;
14223 Func_Body
: Node_Id
;
14224 Loop_Statement
: Node_Id
;
14227 if Transform_Function_Array
then
14228 C
:= Make_Defining_Identifier
(Loc
, Name_UP_RESULT
);
14230 C
:= Make_Defining_Identifier
(Loc
, Name_uC
);
14234 Make_Indexed_Component
(Loc
,
14235 Prefix
=> New_Occurrence_Of
(A
, Loc
),
14236 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14239 Make_Indexed_Component
(Loc
,
14240 Prefix
=> New_Occurrence_Of
(B
, Loc
),
14241 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14244 Make_Indexed_Component
(Loc
,
14245 Prefix
=> New_Occurrence_Of
(C
, Loc
),
14246 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
14248 if Nkind
(N
) = N_Op_And
then
14252 Right_Opnd
=> B_J
);
14254 elsif Nkind
(N
) = N_Op_Or
then
14258 Right_Opnd
=> B_J
);
14264 Right_Opnd
=> B_J
);
14268 Make_Implicit_Loop_Statement
(N
,
14269 Identifier
=> Empty
,
14271 Iteration_Scheme
=>
14272 Make_Iteration_Scheme
(Loc
,
14273 Loop_Parameter_Specification
=>
14274 Make_Loop_Parameter_Specification
(Loc
,
14275 Defining_Identifier
=> J
,
14276 Discrete_Subtype_Definition
=>
14277 Make_Attribute_Reference
(Loc
,
14278 Prefix
=> New_Occurrence_Of
(A
, Loc
),
14279 Attribute_Name
=> Name_Range
))),
14281 Statements
=> New_List
(
14282 Make_Assignment_Statement
(Loc
,
14284 Expression
=> Op
)));
14286 Formals
:= New_List
(
14287 Make_Parameter_Specification
(Loc
,
14288 Defining_Identifier
=> A
,
14289 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
14291 Make_Parameter_Specification
(Loc
,
14292 Defining_Identifier
=> B
,
14293 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
14295 if Transform_Function_Array
then
14296 Append_To
(Formals
,
14297 Make_Parameter_Specification
(Loc
,
14298 Defining_Identifier
=> C
,
14299 Out_Present
=> True,
14300 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
14303 Func_Name
:= Make_Temporary
(Loc
, 'A');
14304 Set_Is_Inlined
(Func_Name
);
14306 if Transform_Function_Array
then
14308 Make_Subprogram_Body
(Loc
,
14310 Make_Procedure_Specification
(Loc
,
14311 Defining_Unit_Name
=> Func_Name
,
14312 Parameter_Specifications
=> Formals
),
14314 Declarations
=> New_List
,
14316 Handled_Statement_Sequence
=>
14317 Make_Handled_Sequence_Of_Statements
(Loc
,
14318 Statements
=> New_List
(Loop_Statement
)));
14322 Make_Subprogram_Body
(Loc
,
14324 Make_Function_Specification
(Loc
,
14325 Defining_Unit_Name
=> Func_Name
,
14326 Parameter_Specifications
=> Formals
,
14327 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
14329 Declarations
=> New_List
(
14330 Make_Object_Declaration
(Loc
,
14331 Defining_Identifier
=> C
,
14332 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
14334 Handled_Statement_Sequence
=>
14335 Make_Handled_Sequence_Of_Statements
(Loc
,
14336 Statements
=> New_List
(
14338 Make_Simple_Return_Statement
(Loc
,
14339 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
14343 end Make_Boolean_Array_Op
;
14345 -----------------------------------------
14346 -- Minimized_Eliminated_Overflow_Check --
14347 -----------------------------------------
14349 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
14351 -- The MINIMIZED mode operates in Long_Long_Integer so we cannot use it
14352 -- if the type of the expression is already larger.
14355 Is_Signed_Integer_Type
(Etype
(N
))
14356 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
14357 and then not (Overflow_Check_Mode
= Minimized
14359 Esize
(Etype
(N
)) > Standard_Long_Long_Integer_Size
);
14360 end Minimized_Eliminated_Overflow_Check
;
14362 ----------------------------
14363 -- Narrow_Large_Operation --
14364 ----------------------------
14366 procedure Narrow_Large_Operation
(N
: Node_Id
) is
14367 Kind
: constant Node_Kind
:= Nkind
(N
);
14368 Otyp
: constant Entity_Id
:= Etype
(N
);
14369 In_Rng
: constant Boolean := Kind
= N_In
;
14370 Binary
: constant Boolean := Kind
in N_Binary_Op
or else In_Rng
;
14371 Compar
: constant Boolean := Kind
in N_Op_Compare
or else In_Rng
;
14372 R
: constant Node_Id
:= Right_Opnd
(N
);
14373 Typ
: constant Entity_Id
:= Etype
(R
);
14374 Tsiz
: constant Uint
:= RM_Size
(Typ
);
14388 -- Start of processing for Narrow_Large_Operation
14391 -- First, determine the range of the left operand, if any
14394 L
:= Left_Opnd
(N
);
14395 Determine_Range
(L
, OK
, Llo
, Lhi
, Assume_Valid
=> True);
14406 -- Second, determine the range of the right operand, which can itself
14407 -- be a range, in which case we take the lower bound of the low bound
14408 -- and the upper bound of the high bound.
14416 (Low_Bound
(R
), OK
, Rlo
, Zhi
, Assume_Valid
=> True);
14422 (High_Bound
(R
), OK
, Zlo
, Rhi
, Assume_Valid
=> True);
14429 Determine_Range
(R
, OK
, Rlo
, Rhi
, Assume_Valid
=> True);
14435 -- Then compute a size suitable for each range
14438 Lsiz
:= Get_Size_For_Range
(Llo
, Lhi
);
14443 Rsiz
:= Get_Size_For_Range
(Rlo
, Rhi
);
14445 -- Now compute the size of the narrower type
14448 -- The type must be able to accommodate the operands
14450 Nsiz
:= UI_Max
(Lsiz
, Rsiz
);
14453 -- The type must be able to accommodate the operand(s) and result.
14455 -- Note that Determine_Range typically does not report the bounds of
14456 -- the value as being larger than those of the base type, which means
14457 -- that it does not report overflow (see also Enable_Overflow_Check).
14459 Determine_Range
(N
, OK
, Nlo
, Nhi
, Assume_Valid
=> True);
14464 -- Therefore, if Nsiz is not lower than the size of the original type
14465 -- here, we cannot be sure that the operation does not overflow.
14467 Nsiz
:= Get_Size_For_Range
(Nlo
, Nhi
);
14468 Nsiz
:= UI_Max
(Nsiz
, Lsiz
);
14469 Nsiz
:= UI_Max
(Nsiz
, Rsiz
);
14472 -- If the size is not lower than the size of the original type, then
14473 -- there is no point in changing the type, except in the case where
14474 -- we can remove a conversion to the original type from an operand.
14477 and then not (Binary
14478 and then Nkind
(L
) = N_Type_Conversion
14479 and then Entity
(Subtype_Mark
(L
)) = Typ
)
14480 and then not (Nkind
(R
) = N_Type_Conversion
14481 and then Entity
(Subtype_Mark
(R
)) = Typ
)
14486 -- Now pick the narrower type according to the size. We use the base
14487 -- type instead of the first subtype because operations are done in
14488 -- the base type, so this avoids the need for useless conversions.
14490 if Nsiz
<= System_Max_Integer_Size
then
14491 Ntyp
:= Etype
(Integer_Type_For
(Nsiz
, Uns
=> False));
14496 -- Finally, rewrite the operation in the narrower type, but make sure
14497 -- not to perform name resolution for the operator again.
14499 Nop
:= New_Op_Node
(Kind
, Sloc
(N
));
14500 if Nkind
(N
) in N_Has_Entity
then
14501 Set_Entity
(Nop
, Entity
(N
));
14505 Set_Left_Opnd
(Nop
, Convert_To
(Ntyp
, L
));
14509 Set_Right_Opnd
(Nop
,
14510 Make_Range
(Sloc
(N
),
14511 Convert_To
(Ntyp
, Low_Bound
(R
)),
14512 Convert_To
(Ntyp
, High_Bound
(R
))));
14514 Set_Right_Opnd
(Nop
, Convert_To
(Ntyp
, R
));
14520 -- Analyze it with the comparison type and checks suppressed since
14521 -- the conversions of the operands cannot overflow.
14523 Analyze_And_Resolve
(N
, Otyp
, Suppress
=> Overflow_Check
);
14526 -- Analyze it with the narrower type and checks suppressed, but only
14527 -- when we are sure that the operation does not overflow, see above.
14529 if Nsiz
< Tsiz
then
14530 Analyze_And_Resolve
(N
, Ntyp
, Suppress
=> Overflow_Check
);
14532 Analyze_And_Resolve
(N
, Ntyp
);
14535 -- Put back a conversion to the original type
14537 Convert_To_And_Rewrite
(Typ
, N
);
14539 end Narrow_Large_Operation
;
14541 --------------------------------
14542 -- Optimize_Length_Comparison --
14543 --------------------------------
14545 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
14546 Loc
: constant Source_Ptr
:= Sloc
(N
);
14547 Typ
: constant Entity_Id
:= Etype
(N
);
14552 -- First and Last attribute reference nodes, which end up as left and
14553 -- right operands of the optimized result.
14556 -- True for comparison operand of zero
14558 Maybe_Superflat
: Boolean;
14559 -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set
14560 -- to false but the comparison operand can be zero at run time. In this
14561 -- case, we normally cannot do anything because the canonical formula of
14562 -- the length is not valid, but there is one exception: when the operand
14563 -- is itself the length of an array with the same bounds as the array on
14564 -- the LHS, we can entirely optimize away the comparison.
14567 -- Comparison operand, set only if Is_Zero is false
14569 Ent
: array (Pos
range 1 .. 2) of Entity_Id
:= (Empty
, Empty
);
14570 -- Entities whose length is being compared
14572 Index
: array (Pos
range 1 .. 2) of Node_Id
:= (Empty
, Empty
);
14573 -- Integer_Literal nodes for length attribute expressions, or Empty
14574 -- if there is no such expression present.
14576 Op
: Node_Kind
:= Nkind
(N
);
14577 -- Kind of comparison operator, gets flipped if operands backwards
14579 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
;
14580 -- Given a discrete expression, returns a Long_Long_Integer typed
14581 -- expression representing the underlying value of the expression.
14582 -- This is done with an unchecked conversion to Long_Long_Integer.
14583 -- We use unchecked conversion to handle the enumeration type case.
14585 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean;
14586 -- Tests if N is a length attribute applied to a simple entity. If so,
14587 -- returns True, and sets Ent to the entity, and Index to the integer
14588 -- literal provided as an attribute expression, or to Empty if none.
14589 -- Num is the index designating the relevant slot in Ent and Index.
14590 -- Also returns True if the expression is a generated type conversion
14591 -- whose expression is of the desired form. This latter case arises
14592 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
14593 -- to check for being in range, which is not needed in this context.
14594 -- Returns False if neither condition holds.
14596 function Is_Optimizable
(N
: Node_Id
) return Boolean;
14597 -- Tests N to see if it is an optimizable comparison value (defined as
14598 -- constant zero or one, or something else where the value is known to
14599 -- be nonnegative and in the 32-bit range and where the corresponding
14600 -- Length value is also known to be 32 bits). If result is true, sets
14601 -- Is_Zero, Maybe_Superflat and Comp accordingly.
14603 procedure Rewrite_For_Equal_Lengths
;
14604 -- Rewrite the comparison of two equal lengths into either True or False
14606 ----------------------------------
14607 -- Convert_To_Long_Long_Integer --
14608 ----------------------------------
14610 function Convert_To_Long_Long_Integer
(N
: Node_Id
) return Node_Id
is
14612 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
14613 end Convert_To_Long_Long_Integer
;
14615 ----------------------
14616 -- Is_Entity_Length --
14617 ----------------------
14619 function Is_Entity_Length
(N
: Node_Id
; Num
: Pos
) return Boolean is
14621 if Nkind
(N
) = N_Attribute_Reference
14622 and then Attribute_Name
(N
) = Name_Length
14623 and then Is_Entity_Name
(Prefix
(N
))
14625 Ent
(Num
) := Entity
(Prefix
(N
));
14627 if Present
(Expressions
(N
)) then
14628 Index
(Num
) := First
(Expressions
(N
));
14630 Index
(Num
) := Empty
;
14635 elsif Nkind
(N
) = N_Type_Conversion
14636 and then not Comes_From_Source
(N
)
14638 return Is_Entity_Length
(Expression
(N
), Num
);
14643 end Is_Entity_Length
;
14645 --------------------
14646 -- Is_Optimizable --
14647 --------------------
14649 function Is_Optimizable
(N
: Node_Id
) return Boolean is
14659 if Compile_Time_Known_Value
(N
) then
14660 Val
:= Expr_Value
(N
);
14662 if Val
= Uint_0
then
14664 Maybe_Superflat
:= False;
14668 elsif Val
= Uint_1
then
14670 Maybe_Superflat
:= False;
14676 -- Here we have to make sure of being within a 32-bit range (take the
14677 -- full unsigned range so the length of 32-bit arrays is accepted).
14679 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
14682 or else Lo
< Uint_0
14683 or else Hi
> Uint_2
** 32
14688 Maybe_Superflat
:= (Lo
= Uint_0
);
14690 -- Tests if N is also a length attribute applied to a simple entity
14692 Dbl
:= Is_Entity_Length
(N
, 2);
14694 -- We can deal with the superflat case only if N is also a length
14696 if Maybe_Superflat
and then not Dbl
then
14700 -- Comparison value was within range, so now we must check the index
14701 -- value to make sure it is also within 32 bits.
14703 for K
in Pos
range 1 .. 2 loop
14704 Indx
:= First_Index
(Etype
(Ent
(K
)));
14706 if Present
(Index
(K
)) then
14707 for J
in 2 .. UI_To_Int
(Intval
(Index
(K
))) loop
14712 Ityp
:= Etype
(Indx
);
14714 if Esize
(Ityp
) > 32 then
14724 end Is_Optimizable
;
14726 -------------------------------
14727 -- Rewrite_For_Equal_Lengths --
14728 -------------------------------
14730 procedure Rewrite_For_Equal_Lengths
is
14739 New_Occurrence_Of
(Standard_True
, Sloc
(N
))));
14747 New_Occurrence_Of
(Standard_False
, Sloc
(N
))));
14750 raise Program_Error
;
14753 Analyze_And_Resolve
(N
, Typ
);
14754 end Rewrite_For_Equal_Lengths
;
14756 -- Start of processing for Optimize_Length_Comparison
14759 -- Nothing to do if not a comparison
14761 if Op
not in N_Op_Compare
then
14765 -- Nothing to do if special -gnatd.P debug flag set.
14767 if Debug_Flag_Dot_PP
then
14771 -- Ent'Length op 0/1
14773 if Is_Entity_Length
(Left_Opnd
(N
), 1)
14774 and then Is_Optimizable
(Right_Opnd
(N
))
14778 -- 0/1 op Ent'Length
14780 elsif Is_Entity_Length
(Right_Opnd
(N
), 1)
14781 and then Is_Optimizable
(Left_Opnd
(N
))
14783 -- Flip comparison to opposite sense
14786 when N_Op_Lt
=> Op
:= N_Op_Gt
;
14787 when N_Op_Le
=> Op
:= N_Op_Ge
;
14788 when N_Op_Gt
=> Op
:= N_Op_Lt
;
14789 when N_Op_Ge
=> Op
:= N_Op_Le
;
14790 when others => null;
14793 -- Else optimization not possible
14799 -- Fall through if we will do the optimization
14801 -- Cases to handle:
14803 -- X'Length = 0 => X'First > X'Last
14804 -- X'Length = 1 => X'First = X'Last
14805 -- X'Length = n => X'First + (n - 1) = X'Last
14807 -- X'Length /= 0 => X'First <= X'Last
14808 -- X'Length /= 1 => X'First /= X'Last
14809 -- X'Length /= n => X'First + (n - 1) /= X'Last
14811 -- X'Length >= 0 => always true, warn
14812 -- X'Length >= 1 => X'First <= X'Last
14813 -- X'Length >= n => X'First + (n - 1) <= X'Last
14815 -- X'Length > 0 => X'First <= X'Last
14816 -- X'Length > 1 => X'First < X'Last
14817 -- X'Length > n => X'First + (n - 1) < X'Last
14819 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
14820 -- X'Length <= 1 => X'First >= X'Last
14821 -- X'Length <= n => X'First + (n - 1) >= X'Last
14823 -- X'Length < 0 => always false (warn)
14824 -- X'Length < 1 => X'First > X'Last
14825 -- X'Length < n => X'First + (n - 1) > X'Last
14827 -- Note: for the cases of n (not constant 0,1), we require that the
14828 -- corresponding index type be integer or shorter (i.e. not 64-bit),
14829 -- and the same for the comparison value. Then we do the comparison
14830 -- using 64-bit arithmetic (actually long long integer), so that we
14831 -- cannot have overflow intefering with the result.
14833 -- First deal with warning cases
14842 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
14843 Analyze_And_Resolve
(N
, Typ
);
14844 Warn_On_Known_Condition
(N
);
14851 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
14852 Analyze_And_Resolve
(N
, Typ
);
14853 Warn_On_Known_Condition
(N
);
14857 if Constant_Condition_Warnings
14858 and then Comes_From_Source
(Original_Node
(N
))
14860 Error_Msg_N
("could replace by ""'=""?c?", N
);
14870 -- Build the First reference we will use
14873 Make_Attribute_Reference
(Loc
,
14874 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14875 Attribute_Name
=> Name_First
);
14877 if Present
(Index
(1)) then
14878 Set_Expressions
(Left
, New_List
(New_Copy
(Index
(1))));
14881 -- Build the Last reference we will use
14884 Make_Attribute_Reference
(Loc
,
14885 Prefix
=> New_Occurrence_Of
(Ent
(1), Loc
),
14886 Attribute_Name
=> Name_Last
);
14888 if Present
(Index
(1)) then
14889 Set_Expressions
(Right
, New_List
(New_Copy
(Index
(1))));
14892 -- If general value case, then do the addition of (n - 1), and
14893 -- also add the needed conversions to type Long_Long_Integer.
14895 -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into:
14897 -- Y'Last + (X'First - Y'First) op X'Last
14899 -- in the hope that X'First - Y'First can be computed statically.
14901 if Present
(Comp
) then
14902 if Present
(Ent
(2)) then
14904 Y_First
: constant Node_Id
:=
14905 Make_Attribute_Reference
(Loc
,
14906 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14907 Attribute_Name
=> Name_First
);
14908 Y_Last
: constant Node_Id
:=
14909 Make_Attribute_Reference
(Loc
,
14910 Prefix
=> New_Occurrence_Of
(Ent
(2), Loc
),
14911 Attribute_Name
=> Name_Last
);
14912 R
: Compare_Result
;
14915 if Present
(Index
(2)) then
14916 Set_Expressions
(Y_First
, New_List
(New_Copy
(Index
(2))));
14917 Set_Expressions
(Y_Last
, New_List
(New_Copy
(Index
(2))));
14923 -- If X'First = Y'First, simplify the above formula into a
14924 -- direct comparison of Y'Last and X'Last.
14926 R
:= Compile_Time_Compare
(Left
, Y_First
, Assume_Valid
=> True);
14932 R
:= Compile_Time_Compare
14933 (Right
, Y_Last
, Assume_Valid
=> True);
14935 -- If the pairs of attributes are equal, we are done
14938 Rewrite_For_Equal_Lengths
;
14942 -- If the base types are different, convert both operands to
14943 -- Long_Long_Integer, else compare them directly.
14945 if Base_Type
(Etype
(Right
)) /= Base_Type
(Etype
(Y_Last
))
14947 Left
:= Convert_To_Long_Long_Integer
(Y_Last
);
14953 -- Otherwise, use the above formula as-is
14959 Convert_To_Long_Long_Integer
(Y_Last
),
14961 Make_Op_Subtract
(Loc
,
14963 Convert_To_Long_Long_Integer
(Left
),
14965 Convert_To_Long_Long_Integer
(Y_First
)));
14969 -- General value case
14974 Left_Opnd
=> Convert_To_Long_Long_Integer
(Left
),
14976 Make_Op_Subtract
(Loc
,
14977 Left_Opnd
=> Convert_To_Long_Long_Integer
(Comp
),
14978 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
14982 -- We cannot do anything in the superflat case past this point
14984 if Maybe_Superflat
then
14988 -- If general operand, convert Last reference to Long_Long_Integer
14990 if Present
(Comp
) then
14991 Right
:= Convert_To_Long_Long_Integer
(Right
);
14994 -- Check for cases to optimize
14996 -- X'Length = 0 => X'First > X'Last
14997 -- X'Length < 1 => X'First > X'Last
14998 -- X'Length < n => X'First + (n - 1) > X'Last
15000 if (Is_Zero
and then Op
= N_Op_Eq
)
15001 or else (not Is_Zero
and then Op
= N_Op_Lt
)
15006 Right_Opnd
=> Right
);
15008 -- X'Length = 1 => X'First = X'Last
15009 -- X'Length = n => X'First + (n - 1) = X'Last
15011 elsif not Is_Zero
and then Op
= N_Op_Eq
then
15015 Right_Opnd
=> Right
);
15017 -- X'Length /= 0 => X'First <= X'Last
15018 -- X'Length > 0 => X'First <= X'Last
15020 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
15024 Right_Opnd
=> Right
);
15026 -- X'Length /= 1 => X'First /= X'Last
15027 -- X'Length /= n => X'First + (n - 1) /= X'Last
15029 elsif not Is_Zero
and then Op
= N_Op_Ne
then
15033 Right_Opnd
=> Right
);
15035 -- X'Length >= 1 => X'First <= X'Last
15036 -- X'Length >= n => X'First + (n - 1) <= X'Last
15038 elsif not Is_Zero
and then Op
= N_Op_Ge
then
15042 Right_Opnd
=> Right
);
15044 -- X'Length > 1 => X'First < X'Last
15045 -- X'Length > n => X'First + (n = 1) < X'Last
15047 elsif not Is_Zero
and then Op
= N_Op_Gt
then
15051 Right_Opnd
=> Right
);
15053 -- X'Length <= 1 => X'First >= X'Last
15054 -- X'Length <= n => X'First + (n - 1) >= X'Last
15056 elsif not Is_Zero
and then Op
= N_Op_Le
then
15060 Right_Opnd
=> Right
);
15062 -- Should not happen at this stage
15065 raise Program_Error
;
15068 -- Rewrite and finish up (we can suppress overflow checks, see above)
15070 Rewrite
(N
, Result
);
15071 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Overflow_Check
);
15072 end Optimize_Length_Comparison
;
15074 --------------------------------
15075 -- Process_If_Case_Statements --
15076 --------------------------------
15078 procedure Process_If_Case_Statements
(N
: Node_Id
; Stmts
: List_Id
) is
15082 Decl
:= First
(Stmts
);
15083 while Present
(Decl
) loop
15084 if Nkind
(Decl
) = N_Object_Declaration
15085 and then Is_Finalizable_Transient
(Decl
, N
)
15087 Process_Transient_In_Expression
(Decl
, N
, Stmts
);
15092 end Process_If_Case_Statements
;
15094 -------------------------------------
15095 -- Process_Transient_In_Expression --
15096 -------------------------------------
15098 procedure Process_Transient_In_Expression
15099 (Obj_Decl
: Node_Id
;
15103 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
15104 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Obj_Decl
);
15106 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Expr
);
15107 -- The node on which to insert the hook as an action. This is usually
15108 -- the innermost enclosing non-transient construct.
15110 Fin_Call
: Node_Id
;
15111 Hook_Assign
: Node_Id
;
15112 Hook_Clear
: Node_Id
;
15113 Hook_Decl
: Node_Id
;
15114 Hook_Insert
: Node_Id
;
15115 Ptr_Decl
: Node_Id
;
15117 Fin_Context
: Node_Id
;
15118 -- The node after which to insert the finalization actions of the
15119 -- transient object.
15122 pragma Assert
(Nkind
(Expr
) in N_Case_Expression
15123 | N_Expression_With_Actions
15124 | N_If_Expression
);
15126 -- When the context is a Boolean evaluation, all three nodes capture the
15127 -- result of their computation in a local temporary:
15130 -- Trans_Id : Ctrl_Typ := ...;
15131 -- Result : constant Boolean := ... Trans_Id ...;
15132 -- <finalize Trans_Id>
15135 -- As a result, the finalization of any transient objects can safely
15136 -- take place after the result capture.
15138 -- ??? could this be extended to elementary types?
15140 if Is_Boolean_Type
(Etype
(Expr
)) then
15141 Fin_Context
:= Last
(Stmts
);
15143 -- Otherwise the immediate context may not be safe enough to carry
15144 -- out transient object finalization due to aliasing and nesting of
15145 -- constructs. Insert calls to [Deep_]Finalize after the innermost
15146 -- enclosing non-transient construct.
15149 Fin_Context
:= Hook_Context
;
15152 -- Mark the transient object as successfully processed to avoid double
15155 Set_Is_Finalized_Transient
(Obj_Id
);
15157 -- Construct all the pieces necessary to hook and finalize a transient
15160 Build_Transient_Object_Statements
15161 (Obj_Decl
=> Obj_Decl
,
15162 Fin_Call
=> Fin_Call
,
15163 Hook_Assign
=> Hook_Assign
,
15164 Hook_Clear
=> Hook_Clear
,
15165 Hook_Decl
=> Hook_Decl
,
15166 Ptr_Decl
=> Ptr_Decl
,
15167 Finalize_Obj
=> False);
15169 -- Add the access type which provides a reference to the transient
15170 -- object. Generate:
15172 -- type Ptr_Typ is access all Desig_Typ;
15174 Insert_Action
(Hook_Context
, Ptr_Decl
);
15176 -- Add the temporary which acts as a hook to the transient object.
15179 -- Hook : Ptr_Id := null;
15181 Insert_Action
(Hook_Context
, Hook_Decl
);
15183 -- When the transient object is initialized by an aggregate, the hook
15184 -- must capture the object after the last aggregate assignment takes
15185 -- place. Only then is the object considered initialized. Generate:
15187 -- Hook := Ptr_Typ (Obj_Id);
15189 -- Hook := Obj_Id'Unrestricted_Access;
15191 if Ekind
(Obj_Id
) in E_Constant | E_Variable
15192 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
15194 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
15196 -- Otherwise the hook seizes the related object immediately
15199 Hook_Insert
:= Obj_Decl
;
15202 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
15204 -- When the node is part of a return statement, there is no need to
15205 -- insert a finalization call, as the general finalization mechanism
15206 -- (see Build_Finalizer) would take care of the transient object on
15207 -- subprogram exit. Note that it would also be impossible to insert the
15208 -- finalization code after the return statement as this will render it
15211 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
15214 -- Finalize the hook after the context has been evaluated. Generate:
15216 -- if Hook /= null then
15217 -- [Deep_]Finalize (Hook.all);
15221 -- Note that the value returned by Find_Hook_Context may be an operator
15222 -- node, which is not a list member. We must locate the proper node in
15223 -- in the tree after which to insert the finalization code.
15226 while not Is_List_Member
(Fin_Context
) loop
15227 Fin_Context
:= Parent
(Fin_Context
);
15230 pragma Assert
(Present
(Fin_Context
));
15232 Insert_Action_After
(Fin_Context
,
15233 Make_Implicit_If_Statement
(Obj_Decl
,
15237 New_Occurrence_Of
(Defining_Entity
(Hook_Decl
), Loc
),
15238 Right_Opnd
=> Make_Null
(Loc
)),
15240 Then_Statements
=> New_List
(
15244 end Process_Transient_In_Expression
;
15246 ------------------------
15247 -- Rewrite_Comparison --
15248 ------------------------
15250 procedure Rewrite_Comparison
(N
: Node_Id
) is
15251 Typ
: constant Entity_Id
:= Etype
(N
);
15253 False_Result
: Boolean;
15254 True_Result
: Boolean;
15257 if Nkind
(N
) = N_Type_Conversion
then
15258 Rewrite_Comparison
(Expression
(N
));
15261 elsif Nkind
(N
) not in N_Op_Compare
then
15265 -- If both operands are static, then the comparison has been already
15266 -- folded in evaluation.
15269 (not Is_Static_Expression
(Left_Opnd
(N
))
15271 not Is_Static_Expression
(Right_Opnd
(N
)));
15273 -- Determine the potential outcome of the comparison assuming that the
15274 -- operands are valid and emit a warning when the comparison evaluates
15275 -- to True or False only in the presence of invalid values.
15277 Warn_On_Constant_Valid_Condition
(N
);
15279 -- Determine the potential outcome of the comparison assuming that the
15280 -- operands are not valid.
15284 Assume_Valid
=> False,
15285 True_Result
=> True_Result
,
15286 False_Result
=> False_Result
);
15288 -- The outcome is a decisive False or True, rewrite the operator into a
15289 -- non-static literal.
15291 if False_Result
or True_Result
then
15294 New_Occurrence_Of
(Boolean_Literals
(True_Result
), Sloc
(N
))));
15296 Analyze_And_Resolve
(N
, Typ
);
15297 Set_Is_Static_Expression
(N
, False);
15298 Warn_On_Known_Condition
(N
);
15300 end Rewrite_Comparison
;
15302 ----------------------------
15303 -- Safe_In_Place_Array_Op --
15304 ----------------------------
15306 function Safe_In_Place_Array_Op
15309 Op2
: Node_Id
) return Boolean
15311 Target
: Entity_Id
;
15313 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
15314 -- Operand is safe if it cannot overlap part of the target of the
15315 -- operation. If the operand and the target are identical, the operand
15316 -- is safe. The operand can be empty in the case of negation.
15318 function Is_Unaliased
(N
: Node_Id
) return Boolean;
15319 -- Check that N is a stand-alone entity
15325 function Is_Unaliased
(N
: Node_Id
) return Boolean is
15329 and then No
(Address_Clause
(Entity
(N
)))
15330 and then No
(Renamed_Object
(Entity
(N
)));
15333 ---------------------
15334 -- Is_Safe_Operand --
15335 ---------------------
15337 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
15342 elsif Is_Entity_Name
(Op
) then
15343 return Is_Unaliased
(Op
);
15345 elsif Nkind
(Op
) in N_Indexed_Component | N_Selected_Component
then
15346 return Is_Unaliased
(Prefix
(Op
));
15348 elsif Nkind
(Op
) = N_Slice
then
15350 Is_Unaliased
(Prefix
(Op
))
15351 and then Entity
(Prefix
(Op
)) /= Target
;
15353 elsif Nkind
(Op
) = N_Op_Not
then
15354 return Is_Safe_Operand
(Right_Opnd
(Op
));
15359 end Is_Safe_Operand
;
15361 -- Start of processing for Safe_In_Place_Array_Op
15364 -- Skip this processing if the component size is different from system
15365 -- storage unit (since at least for NOT this would cause problems).
15367 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
15370 -- Cannot do in place stuff if non-standard Boolean representation
15372 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
15375 elsif not Is_Unaliased
(Lhs
) then
15379 Target
:= Entity
(Lhs
);
15380 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
15382 end Safe_In_Place_Array_Op
;
15384 -----------------------
15385 -- Tagged_Membership --
15386 -----------------------
15388 -- There are two different cases to consider depending on whether the right
15389 -- operand is a class-wide type or not. If not we just compare the actual
15390 -- tag of the left expr to the target type tag:
15392 -- Left_Expr.Tag = Right_Type'Tag;
15394 -- If it is a class-wide type we use the RT function CW_Membership which is
15395 -- usually implemented by looking in the ancestor tables contained in the
15396 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
15398 -- In both cases if Left_Expr is an access type, we first check whether it
15401 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
15402 -- function IW_Membership which is usually implemented by looking in the
15403 -- table of abstract interface types plus the ancestor table contained in
15404 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
15406 procedure Tagged_Membership
15408 SCIL_Node
: out Node_Id
;
15409 Result
: out Node_Id
)
15411 Left
: constant Node_Id
:= Left_Opnd
(N
);
15412 Right
: constant Node_Id
:= Right_Opnd
(N
);
15413 Loc
: constant Source_Ptr
:= Sloc
(N
);
15415 -- Handle entities from the limited view
15417 Orig_Right_Type
: constant Entity_Id
:= Available_View
(Etype
(Right
));
15419 Full_R_Typ
: Entity_Id
;
15420 Left_Type
: Entity_Id
:= Available_View
(Etype
(Left
));
15421 Right_Type
: Entity_Id
:= Orig_Right_Type
;
15425 SCIL_Node
:= Empty
;
15427 -- We have to examine the corresponding record type when dealing with
15428 -- protected types instead of the original, unexpanded, type.
15430 if Ekind
(Right_Type
) = E_Protected_Type
then
15431 Right_Type
:= Corresponding_Record_Type
(Right_Type
);
15434 if Ekind
(Left_Type
) = E_Protected_Type
then
15435 Left_Type
:= Corresponding_Record_Type
(Left_Type
);
15438 -- In the case where the type is an access type, the test is applied
15439 -- using the designated types (needed in Ada 2012 for implicit anonymous
15440 -- access conversions, for AI05-0149).
15442 if Is_Access_Type
(Right_Type
) then
15443 Left_Type
:= Designated_Type
(Left_Type
);
15444 Right_Type
:= Designated_Type
(Right_Type
);
15447 if Is_Class_Wide_Type
(Left_Type
) then
15448 Left_Type
:= Root_Type
(Left_Type
);
15451 if Is_Class_Wide_Type
(Right_Type
) then
15452 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
15454 Full_R_Typ
:= Underlying_Type
(Right_Type
);
15458 Make_Selected_Component
(Loc
,
15459 Prefix
=> Relocate_Node
(Left
),
15461 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
15463 if Is_Class_Wide_Type
(Right_Type
) then
15465 -- No need to issue a run-time check if we statically know that the
15466 -- result of this membership test is always true. For example,
15467 -- considering the following declarations:
15469 -- type Iface is interface;
15470 -- type T is tagged null record;
15471 -- type DT is new T and Iface with null record;
15476 -- These membership tests are always true:
15479 -- Obj2 in T'Class;
15480 -- Obj2 in Iface'Class;
15482 -- We do not need to handle cases where the membership is illegal.
15485 -- Obj1 in DT'Class; -- Compile time error
15486 -- Obj1 in Iface'Class; -- Compile time error
15488 if not Is_Interface
(Left_Type
)
15489 and then not Is_Class_Wide_Type
(Left_Type
)
15490 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
15491 Use_Full_View
=> True)
15492 or else (Is_Interface
(Etype
(Right_Type
))
15493 and then Interface_Present_In_Ancestor
15495 Iface
=> Etype
(Right_Type
))))
15497 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
15501 -- Ada 2005 (AI-251): Class-wide applied to interfaces
15503 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
15505 -- Support to: "Iface_CW_Typ in Typ'Class"
15507 or else Is_Interface
(Left_Type
)
15509 -- Issue error if IW_Membership operation not available in a
15510 -- configurable run-time setting.
15512 if not RTE_Available
(RE_IW_Membership
) then
15514 ("dynamic membership test on interface types", N
);
15520 Make_Function_Call
(Loc
,
15521 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
15522 Parameter_Associations
=> New_List
(
15523 Make_Attribute_Reference
(Loc
,
15525 Attribute_Name
=> Name_Address
),
15526 New_Occurrence_Of
(
15527 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15530 -- Ada 95: Normal case
15533 -- Issue error if CW_Membership operation not available in a
15534 -- configurable run-time setting.
15536 if not RTE_Available
(RE_CW_Membership
) then
15538 ("dynamic membership test on tagged types", N
);
15544 Make_Function_Call
(Loc
,
15545 Name
=> New_Occurrence_Of
(RTE
(RE_CW_Membership
), Loc
),
15546 Parameter_Associations
=> New_List
(
15548 New_Occurrence_Of
(
15549 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
15552 -- Generate the SCIL node for this class-wide membership test.
15554 if Generate_SCIL
then
15555 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
15556 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
15557 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
15561 -- Right_Type is not a class-wide type
15564 -- No need to check the tag of the object if Right_Typ is abstract
15566 if Is_Abstract_Type
(Right_Type
) then
15567 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
15572 Left_Opnd
=> Obj_Tag
,
15575 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
15579 -- if Left is an access object then generate test of the form:
15580 -- * if Right_Type excludes null: Left /= null and then ...
15581 -- * if Right_Type includes null: Left = null or else ...
15583 if Is_Access_Type
(Orig_Right_Type
) then
15584 if Can_Never_Be_Null
(Orig_Right_Type
) then
15585 Result
:= Make_And_Then
(Loc
,
15589 Right_Opnd
=> Make_Null
(Loc
)),
15590 Right_Opnd
=> Result
);
15593 Result
:= Make_Or_Else
(Loc
,
15597 Right_Opnd
=> Make_Null
(Loc
)),
15598 Right_Opnd
=> Result
);
15601 end Tagged_Membership
;
15603 ------------------------------
15604 -- Unary_Op_Validity_Checks --
15605 ------------------------------
15607 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
15609 if Validity_Checks_On
and Validity_Check_Operands
then
15610 Ensure_Valid
(Right_Opnd
(N
));
15612 end Unary_Op_Validity_Checks
;