1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Aggr
; use Exp_Aggr
;
33 with Exp_Atag
; use Exp_Atag
;
34 with Exp_Ch2
; use Exp_Ch2
;
35 with Exp_Ch3
; use Exp_Ch3
;
36 with Exp_Ch6
; use Exp_Ch6
;
37 with Exp_Ch7
; use Exp_Ch7
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Disp
; use Exp_Disp
;
40 with Exp_Fixd
; use Exp_Fixd
;
41 with Exp_Intr
; use Exp_Intr
;
42 with Exp_Pakd
; use Exp_Pakd
;
43 with Exp_Tss
; use Exp_Tss
;
44 with Exp_Util
; use Exp_Util
;
45 with Freeze
; use Freeze
;
46 with Inline
; use Inline
;
47 with Namet
; use Namet
;
48 with Nlists
; use Nlists
;
49 with Nmake
; use Nmake
;
51 with Par_SCO
; use Par_SCO
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Cat
; use Sem_Cat
;
58 with Sem_Ch3
; use Sem_Ch3
;
59 with Sem_Ch13
; use Sem_Ch13
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Res
; use Sem_Res
;
62 with Sem_Type
; use Sem_Type
;
63 with Sem_Util
; use Sem_Util
;
64 with Sem_Warn
; use Sem_Warn
;
65 with Sinfo
; use Sinfo
;
66 with Snames
; use Snames
;
67 with Stand
; use Stand
;
68 with SCIL_LL
; use SCIL_LL
;
69 with Targparm
; use Targparm
;
70 with Tbuild
; use Tbuild
;
71 with Ttypes
; use Ttypes
;
72 with Uintp
; use Uintp
;
73 with Urealp
; use Urealp
;
74 with Validsw
; use Validsw
;
76 package body Exp_Ch4
is
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
83 pragma Inline
(Binary_Op_Validity_Checks
);
84 -- Performs validity checks for a binary operator
86 procedure Build_Boolean_Array_Proc_Call
90 -- If a boolean array assignment can be done in place, build call to
91 -- corresponding library procedure.
93 procedure Displace_Allocator_Pointer
(N
: Node_Id
);
94 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
95 -- Expand_Allocator_Expression. Allocating class-wide interface objects
96 -- this routine displaces the pointer to the allocated object to reference
97 -- the component referencing the corresponding secondary dispatch table.
99 procedure Expand_Allocator_Expression
(N
: Node_Id
);
100 -- Subsidiary to Expand_N_Allocator, for the case when the expression
101 -- is a qualified expression or an aggregate.
103 procedure Expand_Array_Comparison
(N
: Node_Id
);
104 -- This routine handles expansion of the comparison operators (N_Op_Lt,
105 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
106 -- code for these operators is similar, differing only in the details of
107 -- the actual comparison call that is made. Special processing (call a
110 function Expand_Array_Equality
115 Typ
: Entity_Id
) return Node_Id
;
116 -- Expand an array equality into a call to a function implementing this
117 -- equality, and a call to it. Loc is the location for the generated nodes.
118 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
119 -- on which to attach bodies of local functions that are created in the
120 -- process. It is the responsibility of the caller to insert those bodies
121 -- at the right place. Nod provides the Sloc value for the generated code.
122 -- Normally the types used for the generated equality routine are taken
123 -- from Lhs and Rhs. However, in some situations of generated code, the
124 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
125 -- the type to be used for the formal parameters.
127 procedure Expand_Boolean_Operator
(N
: Node_Id
);
128 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
129 -- case of array type arguments.
131 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
);
132 -- Common expansion processing for short-circuit boolean operators
134 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
);
135 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
136 -- where we allow comparison of "out of range" values.
138 function Expand_Composite_Equality
143 Bodies
: List_Id
) return Node_Id
;
144 -- Local recursive function used to expand equality for nested composite
145 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
146 -- to attach bodies of local functions that are created in the process. It
147 -- is the responsibility of the caller to insert those bodies at the right
148 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
149 -- the left and right sides for the comparison, and Typ is the type of the
150 -- objects to compare.
152 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
153 -- Routine to expand concatenation of a sequence of two or more operands
154 -- (in the list Operands) and replace node Cnode with the result of the
155 -- concatenation. The operands can be of any appropriate type, and can
156 -- include both arrays and singleton elements.
158 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
);
159 -- N is an N_In membership test mode, with the overflow check mode set to
160 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
161 -- integer type. This is a case where top level processing is required to
162 -- handle overflow checks in subtrees.
164 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
165 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
166 -- fixed. We do not have such a type at runtime, so the purpose of this
167 -- routine is to find the real type by looking up the tree. We also
168 -- determine if the operation must be rounded.
170 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
171 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
172 -- discriminants if it has a constrained nominal type, unless the object
173 -- is a component of an enclosing Unchecked_Union object that is subject
174 -- to a per-object constraint and the enclosing object lacks inferable
177 -- An expression of an Unchecked_Union type has inferable discriminants
178 -- if it is either a name of an object with inferable discriminants or a
179 -- qualified expression whose subtype mark denotes a constrained subtype.
181 procedure Insert_Dereference_Action
(N
: Node_Id
);
182 -- N is an expression whose type is an access. When the type of the
183 -- associated storage pool is derived from Checked_Pool, generate a
184 -- call to the 'Dereference' primitive operation.
186 function Make_Array_Comparison_Op
188 Nod
: Node_Id
) return Node_Id
;
189 -- Comparisons between arrays are expanded in line. This function produces
190 -- the body of the implementation of (a > b), where a and b are one-
191 -- dimensional arrays of some discrete type. The original node is then
192 -- expanded into the appropriate call to this function. Nod provides the
193 -- Sloc value for the generated code.
195 function Make_Boolean_Array_Op
197 N
: Node_Id
) return Node_Id
;
198 -- Boolean operations on boolean arrays are expanded in line. This function
199 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
200 -- b). It is used only the normal case and not the packed case. The type
201 -- involved, Typ, is the Boolean array type, and the logical operations in
202 -- the body are simple boolean operations. Note that Typ is always a
203 -- constrained type (the caller has ensured this by using
204 -- Convert_To_Actual_Subtype if necessary).
206 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean;
207 -- For signed arithmetic operations when the current overflow mode is
208 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
209 -- as the first thing we do. We then return. We count on the recursive
210 -- apparatus for overflow checks to call us back with an equivalent
211 -- operation that is in CHECKED mode, avoiding a recursive entry into this
212 -- routine, and that is when we will proceed with the expansion of the
213 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
214 -- these optimizations without first making this check, since there may be
215 -- operands further down the tree that are relying on the recursive calls
216 -- triggered by the top level nodes to properly process overflow checking
217 -- and remaining expansion on these nodes. Note that this call back may be
218 -- skipped if the operation is done in Bignum mode but that's fine, since
219 -- the Bignum call takes care of everything.
221 procedure Optimize_Length_Comparison
(N
: Node_Id
);
222 -- Given an expression, if it is of the form X'Length op N (or the other
223 -- way round), where N is known at compile time to be 0 or 1, and X is a
224 -- simple entity, and op is a comparison operator, optimizes it into a
225 -- comparison of First and Last.
227 procedure Process_Transient_Object
230 -- Subsidiary routine to the expansion of expression_with_actions and if
231 -- expressions. Generate all the necessary code to finalize a transient
232 -- controlled object when the enclosing context is elaborated or evaluated.
233 -- Decl denotes the declaration of the transient controlled object which is
234 -- usually the result of a controlled function call. Rel_Node denotes the
235 -- context, either an expression_with_actions or an if expression.
237 procedure Rewrite_Comparison
(N
: Node_Id
);
238 -- If N is the node for a comparison whose outcome can be determined at
239 -- compile time, then the node N can be rewritten with True or False. If
240 -- the outcome cannot be determined at compile time, the call has no
241 -- effect. If N is a type conversion, then this processing is applied to
242 -- its expression. If N is neither comparison nor a type conversion, the
243 -- call has no effect.
245 procedure Tagged_Membership
247 SCIL_Node
: out Node_Id
;
248 Result
: out Node_Id
);
249 -- Construct the expression corresponding to the tagged membership test.
250 -- Deals with a second operand being (or not) a class-wide type.
252 function Safe_In_Place_Array_Op
255 Op2
: Node_Id
) return Boolean;
256 -- In the context of an assignment, where the right-hand side is a boolean
257 -- operation on arrays, check whether operation can be performed in place.
259 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
260 pragma Inline
(Unary_Op_Validity_Checks
);
261 -- Performs validity checks for a unary operator
263 -------------------------------
264 -- Binary_Op_Validity_Checks --
265 -------------------------------
267 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
269 if Validity_Checks_On
and Validity_Check_Operands
then
270 Ensure_Valid
(Left_Opnd
(N
));
271 Ensure_Valid
(Right_Opnd
(N
));
273 end Binary_Op_Validity_Checks
;
275 ------------------------------------
276 -- Build_Boolean_Array_Proc_Call --
277 ------------------------------------
279 procedure Build_Boolean_Array_Proc_Call
284 Loc
: constant Source_Ptr
:= Sloc
(N
);
285 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
286 Target
: constant Node_Id
:=
287 Make_Attribute_Reference
(Loc
,
289 Attribute_Name
=> Name_Address
);
291 Arg1
: Node_Id
:= Op1
;
292 Arg2
: Node_Id
:= Op2
;
294 Proc_Name
: Entity_Id
;
297 if Kind
= N_Op_Not
then
298 if Nkind
(Op1
) in N_Binary_Op
then
300 -- Use negated version of the binary operators
302 if Nkind
(Op1
) = N_Op_And
then
303 Proc_Name
:= RTE
(RE_Vector_Nand
);
305 elsif Nkind
(Op1
) = N_Op_Or
then
306 Proc_Name
:= RTE
(RE_Vector_Nor
);
308 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
309 Proc_Name
:= RTE
(RE_Vector_Xor
);
313 Make_Procedure_Call_Statement
(Loc
,
314 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
316 Parameter_Associations
=> New_List
(
318 Make_Attribute_Reference
(Loc
,
319 Prefix
=> Left_Opnd
(Op1
),
320 Attribute_Name
=> Name_Address
),
322 Make_Attribute_Reference
(Loc
,
323 Prefix
=> Right_Opnd
(Op1
),
324 Attribute_Name
=> Name_Address
),
326 Make_Attribute_Reference
(Loc
,
327 Prefix
=> Left_Opnd
(Op1
),
328 Attribute_Name
=> Name_Length
)));
331 Proc_Name
:= RTE
(RE_Vector_Not
);
334 Make_Procedure_Call_Statement
(Loc
,
335 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
336 Parameter_Associations
=> New_List
(
339 Make_Attribute_Reference
(Loc
,
341 Attribute_Name
=> Name_Address
),
343 Make_Attribute_Reference
(Loc
,
345 Attribute_Name
=> Name_Length
)));
349 -- We use the following equivalences:
351 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
352 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
353 -- (not X) xor (not Y) = X xor Y
354 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
356 if Nkind
(Op1
) = N_Op_Not
then
357 Arg1
:= Right_Opnd
(Op1
);
358 Arg2
:= Right_Opnd
(Op2
);
360 if Kind
= N_Op_And
then
361 Proc_Name
:= RTE
(RE_Vector_Nor
);
362 elsif Kind
= N_Op_Or
then
363 Proc_Name
:= RTE
(RE_Vector_Nand
);
365 Proc_Name
:= RTE
(RE_Vector_Xor
);
369 if Kind
= N_Op_And
then
370 Proc_Name
:= RTE
(RE_Vector_And
);
371 elsif Kind
= N_Op_Or
then
372 Proc_Name
:= RTE
(RE_Vector_Or
);
373 elsif Nkind
(Op2
) = N_Op_Not
then
374 Proc_Name
:= RTE
(RE_Vector_Nxor
);
375 Arg2
:= Right_Opnd
(Op2
);
377 Proc_Name
:= RTE
(RE_Vector_Xor
);
382 Make_Procedure_Call_Statement
(Loc
,
383 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
384 Parameter_Associations
=> New_List
(
386 Make_Attribute_Reference
(Loc
,
388 Attribute_Name
=> Name_Address
),
389 Make_Attribute_Reference
(Loc
,
391 Attribute_Name
=> Name_Address
),
392 Make_Attribute_Reference
(Loc
,
394 Attribute_Name
=> Name_Length
)));
397 Rewrite
(N
, Call_Node
);
401 when RE_Not_Available
=>
403 end Build_Boolean_Array_Proc_Call
;
405 --------------------------------
406 -- Displace_Allocator_Pointer --
407 --------------------------------
409 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
410 Loc
: constant Source_Ptr
:= Sloc
(N
);
411 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
417 -- Do nothing in case of VM targets: the virtual machine will handle
418 -- interfaces directly.
420 if not Tagged_Type_Expansion
then
424 pragma Assert
(Nkind
(N
) = N_Identifier
425 and then Nkind
(Orig_Node
) = N_Allocator
);
427 PtrT
:= Etype
(Orig_Node
);
428 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
429 Etyp
:= Etype
(Expression
(Orig_Node
));
431 if Is_Class_Wide_Type
(Dtyp
) and then Is_Interface
(Dtyp
) then
433 -- If the type of the allocator expression is not an interface type
434 -- we can generate code to reference the record component containing
435 -- the pointer to the secondary dispatch table.
437 if not Is_Interface
(Etyp
) then
439 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
442 -- 1) Get access to the allocated object
445 Make_Explicit_Dereference
(Loc
, Relocate_Node
(N
)));
449 -- 2) Add the conversion to displace the pointer to reference
450 -- the secondary dispatch table.
452 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
453 Analyze_And_Resolve
(N
, Dtyp
);
455 -- 3) The 'access to the secondary dispatch table will be used
456 -- as the value returned by the allocator.
459 Make_Attribute_Reference
(Loc
,
460 Prefix
=> Relocate_Node
(N
),
461 Attribute_Name
=> Name_Access
));
462 Set_Etype
(N
, Saved_Typ
);
466 -- If the type of the allocator expression is an interface type we
467 -- generate a run-time call to displace "this" to reference the
468 -- component containing the pointer to the secondary dispatch table
469 -- or else raise Constraint_Error if the actual object does not
470 -- implement the target interface. This case corresponds to the
471 -- following example:
473 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
475 -- return new Iface_2'Class'(Obj);
480 Unchecked_Convert_To
(PtrT
,
481 Make_Function_Call
(Loc
,
482 Name
=> New_Occurrence_Of
(RTE
(RE_Displace
), Loc
),
483 Parameter_Associations
=> New_List
(
484 Unchecked_Convert_To
(RTE
(RE_Address
),
490 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
492 Analyze_And_Resolve
(N
, PtrT
);
495 end Displace_Allocator_Pointer
;
497 ---------------------------------
498 -- Expand_Allocator_Expression --
499 ---------------------------------
501 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
502 Loc
: constant Source_Ptr
:= Sloc
(N
);
503 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
504 PtrT
: constant Entity_Id
:= Etype
(N
);
505 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
507 procedure Apply_Accessibility_Check
509 Built_In_Place
: Boolean := False);
510 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
511 -- type, generate an accessibility check to verify that the level of the
512 -- type of the created object is not deeper than the level of the access
513 -- type. If the type of the qualified expression is class-wide, then
514 -- always generate the check (except in the case where it is known to be
515 -- unnecessary, see comment below). Otherwise, only generate the check
516 -- if the level of the qualified expression type is statically deeper
517 -- than the access type.
519 -- Although the static accessibility will generally have been performed
520 -- as a legality check, it won't have been done in cases where the
521 -- allocator appears in generic body, so a run-time check is needed in
522 -- general. One special case is when the access type is declared in the
523 -- same scope as the class-wide allocator, in which case the check can
524 -- never fail, so it need not be generated.
526 -- As an open issue, there seem to be cases where the static level
527 -- associated with the class-wide object's underlying type is not
528 -- sufficient to perform the proper accessibility check, such as for
529 -- allocators in nested subprograms or accept statements initialized by
530 -- class-wide formals when the actual originates outside at a deeper
531 -- static level. The nested subprogram case might require passing
532 -- accessibility levels along with class-wide parameters, and the task
533 -- case seems to be an actual gap in the language rules that needs to
534 -- be fixed by the ARG. ???
536 -------------------------------
537 -- Apply_Accessibility_Check --
538 -------------------------------
540 procedure Apply_Accessibility_Check
542 Built_In_Place
: Boolean := False)
544 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
552 if Ada_Version
>= Ada_2005
553 and then Is_Class_Wide_Type
(DesigT
)
554 and then Tagged_Type_Expansion
555 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
557 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
559 (Is_Class_Wide_Type
(Etype
(Exp
))
560 and then Scope
(PtrT
) /= Current_Scope
))
562 -- If the allocator was built in place, Ref is already a reference
563 -- to the access object initialized to the result of the allocator
564 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
565 -- Remove_Side_Effects for cases where the build-in-place call may
566 -- still be the prefix of the reference (to avoid generating
567 -- duplicate calls). Otherwise, it is the entity associated with
568 -- the object containing the address of the allocated object.
570 if Built_In_Place
then
571 Remove_Side_Effects
(Ref
);
572 Obj_Ref
:= New_Copy_Tree
(Ref
);
574 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
577 -- For access to interface types we must generate code to displace
578 -- the pointer to the base of the object since the subsequent code
579 -- references components located in the TSD of the object (which
580 -- is associated with the primary dispatch table --see a-tags.ads)
581 -- and also generates code invoking Free, which requires also a
582 -- reference to the base of the unallocated object.
584 if Is_Interface
(DesigT
) and then Tagged_Type_Expansion
then
586 Unchecked_Convert_To
(Etype
(Obj_Ref
),
587 Make_Function_Call
(Loc
,
589 New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
590 Parameter_Associations
=> New_List
(
591 Unchecked_Convert_To
(RTE
(RE_Address
),
592 New_Copy_Tree
(Obj_Ref
)))));
595 -- Step 1: Create the object clean up code
599 -- Deallocate the object if the accessibility check fails. This
600 -- is done only on targets or profiles that support deallocation.
604 if RTE_Available
(RE_Free
) then
605 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
606 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
608 Append_To
(Stmts
, Free_Stmt
);
610 -- The target or profile cannot deallocate objects
616 -- Finalize the object if applicable. Generate:
618 -- [Deep_]Finalize (Obj_Ref.all);
620 if Needs_Finalization
(DesigT
) then
624 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
627 -- When the target or profile supports deallocation, wrap the
628 -- finalization call in a block to ensure proper deallocation
629 -- even if finalization fails. Generate:
639 if Present
(Free_Stmt
) then
641 Make_Block_Statement
(Loc
,
642 Handled_Statement_Sequence
=>
643 Make_Handled_Sequence_Of_Statements
(Loc
,
644 Statements
=> New_List
(Fin_Call
),
646 Exception_Handlers
=> New_List
(
647 Make_Exception_Handler
(Loc
,
648 Exception_Choices
=> New_List
(
649 Make_Others_Choice
(Loc
)),
650 Statements
=> New_List
(
651 New_Copy_Tree
(Free_Stmt
),
652 Make_Raise_Statement
(Loc
))))));
655 Prepend_To
(Stmts
, Fin_Call
);
658 -- Signal the accessibility failure through a Program_Error
661 Make_Raise_Program_Error
(Loc
,
662 Condition
=> New_Occurrence_Of
(Standard_True
, Loc
),
663 Reason
=> PE_Accessibility_Check_Failed
));
665 -- Step 2: Create the accessibility comparison
671 Make_Attribute_Reference
(Loc
,
673 Attribute_Name
=> Name_Tag
);
675 -- For tagged types, determine the accessibility level by looking
676 -- at the type specific data of the dispatch table. Generate:
678 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
680 if Tagged_Type_Expansion
then
681 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
683 -- Use a runtime call to determine the accessibility level when
684 -- compiling on virtual machine targets. Generate:
686 -- Get_Access_Level (Ref'Tag)
690 Make_Function_Call
(Loc
,
692 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
693 Parameter_Associations
=> New_List
(Obj_Ref
));
700 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
)));
702 -- Due to the complexity and side effects of the check, utilize an
703 -- if statement instead of the regular Program_Error circuitry.
706 Make_Implicit_If_Statement
(N
,
708 Then_Statements
=> Stmts
));
710 end Apply_Accessibility_Check
;
714 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
715 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
716 T
: constant Entity_Id
:= Entity
(Indic
);
718 Tag_Assign
: Node_Id
;
722 TagT
: Entity_Id
:= Empty
;
723 -- Type used as source for tag assignment
725 TagR
: Node_Id
:= Empty
;
726 -- Target reference for tag assignment
728 -- Start of processing for Expand_Allocator_Expression
731 -- Handle call to C++ constructor
733 if Is_CPP_Constructor_Call
(Exp
) then
734 Make_CPP_Constructor_Call_In_Allocator
736 Function_Call
=> Exp
);
740 -- In the case of an Ada 2012 allocator whose initial value comes from a
741 -- function call, pass "the accessibility level determined by the point
742 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
743 -- Expand_Call but it couldn't be done there (because the Etype of the
744 -- allocator wasn't set then) so we generate the parameter here. See
745 -- the Boolean variable Defer in (a block within) Expand_Call.
747 if Ada_Version
>= Ada_2012
and then Nkind
(Exp
) = N_Function_Call
then
752 if Nkind
(Name
(Exp
)) = N_Explicit_Dereference
then
753 Subp
:= Designated_Type
(Etype
(Prefix
(Name
(Exp
))));
755 Subp
:= Entity
(Name
(Exp
));
758 Subp
:= Ultimate_Alias
(Subp
);
760 if Present
(Extra_Accessibility_Of_Result
(Subp
)) then
761 Add_Extra_Actual_To_Call
762 (Subprogram_Call
=> Exp
,
763 Extra_Formal
=> Extra_Accessibility_Of_Result
(Subp
),
764 Extra_Actual
=> Dynamic_Accessibility_Level
(PtrT
));
769 -- Case of tagged type or type requiring finalization
771 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
773 -- Ada 2005 (AI-318-02): If the initialization expression is a call
774 -- to a build-in-place function, then access to the allocated object
775 -- must be passed to the function. Currently we limit such functions
776 -- to those with constrained limited result subtypes, but eventually
777 -- we plan to expand the allowed forms of functions that are treated
778 -- as build-in-place.
780 if Ada_Version
>= Ada_2005
781 and then Is_Build_In_Place_Function_Call
(Exp
)
783 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
784 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
788 -- Actions inserted before:
789 -- Temp : constant ptr_T := new T'(Expression);
790 -- Temp._tag = T'tag; -- when not class-wide
791 -- [Deep_]Adjust (Temp.all);
793 -- We analyze by hand the new internal allocator to avoid any
794 -- recursion and inappropriate call to Initialize.
796 -- We don't want to remove side effects when the expression must be
797 -- built in place. In the case of a build-in-place function call,
798 -- that could lead to a duplication of the call, which was already
799 -- substituted for the allocator.
801 if not Aggr_In_Place
then
802 Remove_Side_Effects
(Exp
);
805 Temp
:= Make_Temporary
(Loc
, 'P', N
);
807 -- For a class wide allocation generate the following code:
809 -- type Equiv_Record is record ... end record;
810 -- implicit subtype CW is <Class_Wide_Subytpe>;
811 -- temp : PtrT := new CW'(CW!(expr));
813 if Is_Class_Wide_Type
(T
) then
814 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
816 -- Ada 2005 (AI-251): If the expression is a class-wide interface
817 -- object we generate code to move up "this" to reference the
818 -- base of the object before allocating the new object.
820 -- Note that Exp'Address is recursively expanded into a call
821 -- to Base_Address (Exp.Tag)
823 if Is_Class_Wide_Type
(Etype
(Exp
))
824 and then Is_Interface
(Etype
(Exp
))
825 and then Tagged_Type_Expansion
829 Unchecked_Convert_To
(Entity
(Indic
),
830 Make_Explicit_Dereference
(Loc
,
831 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
832 Make_Attribute_Reference
(Loc
,
834 Attribute_Name
=> Name_Address
)))));
838 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
841 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
844 -- Processing for allocators returning non-interface types
846 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
847 if Aggr_In_Place
then
849 Make_Object_Declaration
(Loc
,
850 Defining_Identifier
=> Temp
,
851 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
855 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
857 -- Copy the Comes_From_Source flag for the allocator we just
858 -- built, since logically this allocator is a replacement of
859 -- the original allocator node. This is for proper handling of
860 -- restriction No_Implicit_Heap_Allocations.
862 Set_Comes_From_Source
863 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
865 Set_No_Initialization
(Expression
(Temp_Decl
));
866 Insert_Action
(N
, Temp_Decl
);
868 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
869 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
872 Node
:= Relocate_Node
(N
);
876 Make_Object_Declaration
(Loc
,
877 Defining_Identifier
=> Temp
,
878 Constant_Present
=> True,
879 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
882 Insert_Action
(N
, Temp_Decl
);
883 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
886 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
887 -- interface type. In this case we use the type of the qualified
888 -- expression to allocate the object.
892 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
897 Make_Full_Type_Declaration
(Loc
,
898 Defining_Identifier
=> Def_Id
,
900 Make_Access_To_Object_Definition
(Loc
,
902 Null_Exclusion_Present
=> False,
904 Is_Access_Constant
(Etype
(N
)),
905 Subtype_Indication
=>
906 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
908 Insert_Action
(N
, New_Decl
);
910 -- Inherit the allocation-related attributes from the original
913 Set_Finalization_Master
914 (Def_Id
, Finalization_Master
(PtrT
));
916 Set_Associated_Storage_Pool
917 (Def_Id
, Associated_Storage_Pool
(PtrT
));
919 -- Declare the object using the previous type declaration
921 if Aggr_In_Place
then
923 Make_Object_Declaration
(Loc
,
924 Defining_Identifier
=> Temp
,
925 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
928 New_Occurrence_Of
(Etype
(Exp
), Loc
)));
930 -- Copy the Comes_From_Source flag for the allocator we just
931 -- built, since logically this allocator is a replacement of
932 -- the original allocator node. This is for proper handling
933 -- of restriction No_Implicit_Heap_Allocations.
935 Set_Comes_From_Source
936 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
938 Set_No_Initialization
(Expression
(Temp_Decl
));
939 Insert_Action
(N
, Temp_Decl
);
941 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
942 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
945 Node
:= Relocate_Node
(N
);
949 Make_Object_Declaration
(Loc
,
950 Defining_Identifier
=> Temp
,
951 Constant_Present
=> True,
952 Object_Definition
=> New_Occurrence_Of
(Def_Id
, Loc
),
955 Insert_Action
(N
, Temp_Decl
);
956 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
959 -- Generate an additional object containing the address of the
960 -- returned object. The type of this second object declaration
961 -- is the correct type required for the common processing that
962 -- is still performed by this subprogram. The displacement of
963 -- this pointer to reference the component associated with the
964 -- interface type will be done at the end of common processing.
967 Make_Object_Declaration
(Loc
,
968 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
969 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
971 Unchecked_Convert_To
(PtrT
,
972 New_Occurrence_Of
(Temp
, Loc
)));
974 Insert_Action
(N
, New_Decl
);
976 Temp_Decl
:= New_Decl
;
977 Temp
:= Defining_Identifier
(New_Decl
);
981 -- Generate the tag assignment
983 -- Suppress the tag assignment for VM targets because VM tags are
984 -- represented implicitly in objects.
986 if not Tagged_Type_Expansion
then
989 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
990 -- interface objects because in this case the tag does not change.
992 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
993 pragma Assert
(Is_Class_Wide_Type
994 (Directly_Designated_Type
(Etype
(N
))));
997 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
999 TagR
:= New_Occurrence_Of
(Temp
, Loc
);
1001 elsif Is_Private_Type
(T
)
1002 and then Is_Tagged_Type
(Underlying_Type
(T
))
1004 TagT
:= Underlying_Type
(T
);
1006 Unchecked_Convert_To
(Underlying_Type
(T
),
1007 Make_Explicit_Dereference
(Loc
,
1008 Prefix
=> New_Occurrence_Of
(Temp
, Loc
)));
1011 if Present
(TagT
) then
1013 Full_T
: constant Entity_Id
:= Underlying_Type
(TagT
);
1017 Make_Assignment_Statement
(Loc
,
1019 Make_Selected_Component
(Loc
,
1023 (First_Tag_Component
(Full_T
), Loc
)),
1026 Unchecked_Convert_To
(RTE
(RE_Tag
),
1029 (First_Elmt
(Access_Disp_Table
(Full_T
))), Loc
)));
1032 -- The previous assignment has to be done in any case
1034 Set_Assignment_OK
(Name
(Tag_Assign
));
1035 Insert_Action
(N
, Tag_Assign
);
1038 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1039 -- the object may be inherently limited, in which case there is no
1040 -- Adjust procedure, and the object is built in place. In Ada 95, the
1041 -- object can be limited but not inherently limited if this allocator
1042 -- came from a return statement (we're allocating the result on the
1043 -- secondary stack). In that case, the object will be moved, so we do
1046 if Needs_Finalization
(DesigT
)
1047 and then Needs_Finalization
(T
)
1048 and then not Aggr_In_Place
1049 and then not Is_Limited_View
(T
)
1051 -- An unchecked conversion is needed in the classwide case because
1052 -- the designated type can be an ancestor of the subtype mark of
1058 Unchecked_Convert_To
(T
,
1059 Make_Explicit_Dereference
(Loc
,
1060 Prefix
=> New_Occurrence_Of
(Temp
, Loc
))),
1064 -- Note: the accessibility check must be inserted after the call to
1065 -- [Deep_]Adjust to ensure proper completion of the assignment.
1067 Apply_Accessibility_Check
(Temp
);
1069 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1070 Analyze_And_Resolve
(N
, PtrT
);
1072 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1073 -- component containing the secondary dispatch table of the interface
1076 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
1077 Displace_Allocator_Pointer
(N
);
1080 -- Always force the generation of a temporary for aggregates when
1081 -- generating C code, to simplify the work in the code generator.
1084 or else (Generate_C_Code
and then Nkind
(Exp
) = N_Aggregate
)
1086 Temp
:= Make_Temporary
(Loc
, 'P', N
);
1088 Make_Object_Declaration
(Loc
,
1089 Defining_Identifier
=> Temp
,
1090 Object_Definition
=> New_Occurrence_Of
(PtrT
, Loc
),
1092 Make_Allocator
(Loc
,
1093 Expression
=> New_Occurrence_Of
(Etype
(Exp
), Loc
)));
1095 -- Copy the Comes_From_Source flag for the allocator we just built,
1096 -- since logically this allocator is a replacement of the original
1097 -- allocator node. This is for proper handling of restriction
1098 -- No_Implicit_Heap_Allocations.
1100 Set_Comes_From_Source
1101 (Expression
(Temp_Decl
), Comes_From_Source
(N
));
1103 Set_No_Initialization
(Expression
(Temp_Decl
));
1104 Insert_Action
(N
, Temp_Decl
);
1106 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
1107 Convert_Aggr_In_Allocator
(N
, Temp_Decl
, Exp
);
1109 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1110 Analyze_And_Resolve
(N
, PtrT
);
1112 elsif Is_Access_Type
(T
) and then Can_Never_Be_Null
(T
) then
1113 Install_Null_Excluding_Check
(Exp
);
1115 elsif Is_Access_Type
(DesigT
)
1116 and then Nkind
(Exp
) = N_Allocator
1117 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1119 -- Apply constraint to designated subtype indication
1121 Apply_Constraint_Check
1122 (Expression
(Exp
), Designated_Type
(DesigT
), No_Sliding
=> True);
1124 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1126 -- Propagate constraint_error to enclosing allocator
1128 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1132 Build_Allocate_Deallocate_Proc
(N
, True);
1135 -- type A is access T1;
1136 -- X : A := new T2'(...);
1137 -- T1 and T2 can be different subtypes, and we might need to check
1138 -- both constraints. First check against the type of the qualified
1141 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1143 if Do_Range_Check
(Exp
) then
1144 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1147 -- A check is also needed in cases where the designated subtype is
1148 -- constrained and differs from the subtype given in the qualified
1149 -- expression. Note that the check on the qualified expression does
1150 -- not allow sliding, but this check does (a relaxation from Ada 83).
1152 if Is_Constrained
(DesigT
)
1153 and then not Subtypes_Statically_Match
(T
, DesigT
)
1155 Apply_Constraint_Check
1156 (Exp
, DesigT
, No_Sliding
=> False);
1158 if Do_Range_Check
(Exp
) then
1159 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1163 -- For an access to unconstrained packed array, GIGI needs to see an
1164 -- expression with a constrained subtype in order to compute the
1165 -- proper size for the allocator.
1167 if Is_Array_Type
(T
)
1168 and then not Is_Constrained
(T
)
1169 and then Is_Packed
(T
)
1172 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1173 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1176 Make_Subtype_Declaration
(Loc
,
1177 Defining_Identifier
=> ConstrT
,
1178 Subtype_Indication
=>
1179 Make_Subtype_From_Expr
(Internal_Exp
, T
)));
1180 Freeze_Itype
(ConstrT
, Exp
);
1181 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1185 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1186 -- to a build-in-place function, then access to the allocated object
1187 -- must be passed to the function. Currently we limit such functions
1188 -- to those with constrained limited result subtypes, but eventually
1189 -- we plan to expand the allowed forms of functions that are treated
1190 -- as build-in-place.
1192 if Ada_Version
>= Ada_2005
1193 and then Is_Build_In_Place_Function_Call
(Exp
)
1195 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1200 when RE_Not_Available
=>
1202 end Expand_Allocator_Expression
;
1204 -----------------------------
1205 -- Expand_Array_Comparison --
1206 -----------------------------
1208 -- Expansion is only required in the case of array types. For the unpacked
1209 -- case, an appropriate runtime routine is called. For packed cases, and
1210 -- also in some other cases where a runtime routine cannot be called, the
1211 -- form of the expansion is:
1213 -- [body for greater_nn; boolean_expression]
1215 -- The body is built by Make_Array_Comparison_Op, and the form of the
1216 -- Boolean expression depends on the operator involved.
1218 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1219 Loc
: constant Source_Ptr
:= Sloc
(N
);
1220 Op1
: Node_Id
:= Left_Opnd
(N
);
1221 Op2
: Node_Id
:= Right_Opnd
(N
);
1222 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1223 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1226 Func_Body
: Node_Id
;
1227 Func_Name
: Entity_Id
;
1231 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1232 -- True for byte addressable target
1234 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1235 -- Returns True if the length of the given operand is known to be less
1236 -- than 4. Returns False if this length is known to be four or greater
1237 -- or is not known at compile time.
1239 ------------------------
1240 -- Length_Less_Than_4 --
1241 ------------------------
1243 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1244 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1247 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1248 return String_Literal_Length
(Otyp
) < 4;
1252 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1253 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1254 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1259 if Compile_Time_Known_Value
(Lo
) then
1260 Lov
:= Expr_Value
(Lo
);
1265 if Compile_Time_Known_Value
(Hi
) then
1266 Hiv
:= Expr_Value
(Hi
);
1271 return Hiv
< Lov
+ 3;
1274 end Length_Less_Than_4
;
1276 -- Start of processing for Expand_Array_Comparison
1279 -- Deal first with unpacked case, where we can call a runtime routine
1280 -- except that we avoid this for targets for which are not addressable
1283 if not Is_Bit_Packed_Array
(Typ1
)
1284 and then Byte_Addressable
1286 -- The call we generate is:
1288 -- Compare_Array_xn[_Unaligned]
1289 -- (left'address, right'address, left'length, right'length) <op> 0
1291 -- x = U for unsigned, S for signed
1292 -- n = 8,16,32,64 for component size
1293 -- Add _Unaligned if length < 4 and component size is 8.
1294 -- <op> is the standard comparison operator
1296 if Component_Size
(Typ1
) = 8 then
1297 if Length_Less_Than_4
(Op1
)
1299 Length_Less_Than_4
(Op2
)
1301 if Is_Unsigned_Type
(Ctyp
) then
1302 Comp
:= RE_Compare_Array_U8_Unaligned
;
1304 Comp
:= RE_Compare_Array_S8_Unaligned
;
1308 if Is_Unsigned_Type
(Ctyp
) then
1309 Comp
:= RE_Compare_Array_U8
;
1311 Comp
:= RE_Compare_Array_S8
;
1315 elsif Component_Size
(Typ1
) = 16 then
1316 if Is_Unsigned_Type
(Ctyp
) then
1317 Comp
:= RE_Compare_Array_U16
;
1319 Comp
:= RE_Compare_Array_S16
;
1322 elsif Component_Size
(Typ1
) = 32 then
1323 if Is_Unsigned_Type
(Ctyp
) then
1324 Comp
:= RE_Compare_Array_U32
;
1326 Comp
:= RE_Compare_Array_S32
;
1329 else pragma Assert
(Component_Size
(Typ1
) = 64);
1330 if Is_Unsigned_Type
(Ctyp
) then
1331 Comp
:= RE_Compare_Array_U64
;
1333 Comp
:= RE_Compare_Array_S64
;
1337 if RTE_Available
(Comp
) then
1339 -- Expand to a call only if the runtime function is available,
1340 -- otherwise fall back to inline code.
1342 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1343 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1346 Make_Function_Call
(Sloc
(Op1
),
1347 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1349 Parameter_Associations
=> New_List
(
1350 Make_Attribute_Reference
(Loc
,
1351 Prefix
=> Relocate_Node
(Op1
),
1352 Attribute_Name
=> Name_Address
),
1354 Make_Attribute_Reference
(Loc
,
1355 Prefix
=> Relocate_Node
(Op2
),
1356 Attribute_Name
=> Name_Address
),
1358 Make_Attribute_Reference
(Loc
,
1359 Prefix
=> Relocate_Node
(Op1
),
1360 Attribute_Name
=> Name_Length
),
1362 Make_Attribute_Reference
(Loc
,
1363 Prefix
=> Relocate_Node
(Op2
),
1364 Attribute_Name
=> Name_Length
))));
1367 Make_Integer_Literal
(Sloc
(Op2
),
1370 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1371 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1376 -- Cases where we cannot make runtime call
1378 -- For (a <= b) we convert to not (a > b)
1380 if Chars
(N
) = Name_Op_Le
then
1386 Right_Opnd
=> Op2
)));
1387 Analyze_And_Resolve
(N
, Standard_Boolean
);
1390 -- For < the Boolean expression is
1391 -- greater__nn (op2, op1)
1393 elsif Chars
(N
) = Name_Op_Lt
then
1394 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1398 Op1
:= Right_Opnd
(N
);
1399 Op2
:= Left_Opnd
(N
);
1401 -- For (a >= b) we convert to not (a < b)
1403 elsif Chars
(N
) = Name_Op_Ge
then
1409 Right_Opnd
=> Op2
)));
1410 Analyze_And_Resolve
(N
, Standard_Boolean
);
1413 -- For > the Boolean expression is
1414 -- greater__nn (op1, op2)
1417 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1418 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1421 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1423 Make_Function_Call
(Loc
,
1424 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1425 Parameter_Associations
=> New_List
(Op1
, Op2
));
1427 Insert_Action
(N
, Func_Body
);
1429 Analyze_And_Resolve
(N
, Standard_Boolean
);
1430 end Expand_Array_Comparison
;
1432 ---------------------------
1433 -- Expand_Array_Equality --
1434 ---------------------------
1436 -- Expand an equality function for multi-dimensional arrays. Here is an
1437 -- example of such a function for Nb_Dimension = 2
1439 -- function Enn (A : atyp; B : btyp) return boolean is
1441 -- if (A'length (1) = 0 or else A'length (2) = 0)
1443 -- (B'length (1) = 0 or else B'length (2) = 0)
1445 -- return True; -- RM 4.5.2(22)
1448 -- if A'length (1) /= B'length (1)
1450 -- A'length (2) /= B'length (2)
1452 -- return False; -- RM 4.5.2(23)
1456 -- A1 : Index_T1 := A'first (1);
1457 -- B1 : Index_T1 := B'first (1);
1461 -- A2 : Index_T2 := A'first (2);
1462 -- B2 : Index_T2 := B'first (2);
1465 -- if A (A1, A2) /= B (B1, B2) then
1469 -- exit when A2 = A'last (2);
1470 -- A2 := Index_T2'succ (A2);
1471 -- B2 := Index_T2'succ (B2);
1475 -- exit when A1 = A'last (1);
1476 -- A1 := Index_T1'succ (A1);
1477 -- B1 := Index_T1'succ (B1);
1484 -- Note on the formal types used (atyp and btyp). If either of the arrays
1485 -- is of a private type, we use the underlying type, and do an unchecked
1486 -- conversion of the actual. If either of the arrays has a bound depending
1487 -- on a discriminant, then we use the base type since otherwise we have an
1488 -- escaped discriminant in the function.
1490 -- If both arrays are constrained and have the same bounds, we can generate
1491 -- a loop with an explicit iteration scheme using a 'Range attribute over
1494 function Expand_Array_Equality
1499 Typ
: Entity_Id
) return Node_Id
1501 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1502 Decls
: constant List_Id
:= New_List
;
1503 Index_List1
: constant List_Id
:= New_List
;
1504 Index_List2
: constant List_Id
:= New_List
;
1508 Func_Name
: Entity_Id
;
1509 Func_Body
: Node_Id
;
1511 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1512 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1516 -- The parameter types to be used for the formals
1521 Num
: Int
) return Node_Id
;
1522 -- This builds the attribute reference Arr'Nam (Expr)
1524 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1525 -- Create one statement to compare corresponding components, designated
1526 -- by a full set of indexes.
1528 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1529 -- Given one of the arguments, computes the appropriate type to be used
1530 -- for that argument in the corresponding function formal
1532 function Handle_One_Dimension
1534 Index
: Node_Id
) return Node_Id
;
1535 -- This procedure returns the following code
1538 -- Bn : Index_T := B'First (N);
1542 -- exit when An = A'Last (N);
1543 -- An := Index_T'Succ (An)
1544 -- Bn := Index_T'Succ (Bn)
1548 -- If both indexes are constrained and identical, the procedure
1549 -- returns a simpler loop:
1551 -- for An in A'Range (N) loop
1555 -- N is the dimension for which we are generating a loop. Index is the
1556 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1557 -- xxx statement is either the loop or declare for the next dimension
1558 -- or if this is the last dimension the comparison of corresponding
1559 -- components of the arrays.
1561 -- The actual way the code works is to return the comparison of
1562 -- corresponding components for the N+1 call. That's neater.
1564 function Test_Empty_Arrays
return Node_Id
;
1565 -- This function constructs the test for both arrays being empty
1566 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1568 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1570 function Test_Lengths_Correspond
return Node_Id
;
1571 -- This function constructs the test for arrays having different lengths
1572 -- in at least one index position, in which case the resulting code is:
1574 -- A'length (1) /= B'length (1)
1576 -- A'length (2) /= B'length (2)
1587 Num
: Int
) return Node_Id
1591 Make_Attribute_Reference
(Loc
,
1592 Attribute_Name
=> Nam
,
1593 Prefix
=> New_Occurrence_Of
(Arr
, Loc
),
1594 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1597 ------------------------
1598 -- Component_Equality --
1599 ------------------------
1601 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1606 -- if a(i1...) /= b(j1...) then return false; end if;
1609 Make_Indexed_Component
(Loc
,
1610 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1611 Expressions
=> Index_List1
);
1614 Make_Indexed_Component
(Loc
,
1615 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1616 Expressions
=> Index_List2
);
1618 Test
:= Expand_Composite_Equality
1619 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1621 -- If some (sub)component is an unchecked_union, the whole operation
1622 -- will raise program error.
1624 if Nkind
(Test
) = N_Raise_Program_Error
then
1626 -- This node is going to be inserted at a location where a
1627 -- statement is expected: clear its Etype so analysis will set
1628 -- it to the expected Standard_Void_Type.
1630 Set_Etype
(Test
, Empty
);
1635 Make_Implicit_If_Statement
(Nod
,
1636 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1637 Then_Statements
=> New_List
(
1638 Make_Simple_Return_Statement
(Loc
,
1639 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1641 end Component_Equality
;
1647 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1658 T
:= Underlying_Type
(T
);
1660 X
:= First_Index
(T
);
1661 while Present
(X
) loop
1662 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1664 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1677 --------------------------
1678 -- Handle_One_Dimension --
1679 ---------------------------
1681 function Handle_One_Dimension
1683 Index
: Node_Id
) return Node_Id
1685 Need_Separate_Indexes
: constant Boolean :=
1686 Ltyp
/= Rtyp
or else not Is_Constrained
(Ltyp
);
1687 -- If the index types are identical, and we are working with
1688 -- constrained types, then we can use the same index for both
1691 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1694 Index_T
: Entity_Id
;
1699 if N
> Number_Dimensions
(Ltyp
) then
1700 return Component_Equality
(Ltyp
);
1703 -- Case where we generate a loop
1705 Index_T
:= Base_Type
(Etype
(Index
));
1707 if Need_Separate_Indexes
then
1708 Bn
:= Make_Temporary
(Loc
, 'B');
1713 Append
(New_Occurrence_Of
(An
, Loc
), Index_List1
);
1714 Append
(New_Occurrence_Of
(Bn
, Loc
), Index_List2
);
1716 Stm_List
:= New_List
(
1717 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1719 if Need_Separate_Indexes
then
1721 -- Generate guard for loop, followed by increments of indexes
1723 Append_To
(Stm_List
,
1724 Make_Exit_Statement
(Loc
,
1727 Left_Opnd
=> New_Occurrence_Of
(An
, Loc
),
1728 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1730 Append_To
(Stm_List
,
1731 Make_Assignment_Statement
(Loc
,
1732 Name
=> New_Occurrence_Of
(An
, Loc
),
1734 Make_Attribute_Reference
(Loc
,
1735 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1736 Attribute_Name
=> Name_Succ
,
1737 Expressions
=> New_List
(
1738 New_Occurrence_Of
(An
, Loc
)))));
1740 Append_To
(Stm_List
,
1741 Make_Assignment_Statement
(Loc
,
1742 Name
=> New_Occurrence_Of
(Bn
, Loc
),
1744 Make_Attribute_Reference
(Loc
,
1745 Prefix
=> New_Occurrence_Of
(Index_T
, Loc
),
1746 Attribute_Name
=> Name_Succ
,
1747 Expressions
=> New_List
(
1748 New_Occurrence_Of
(Bn
, Loc
)))));
1751 -- If separate indexes, we need a declare block for An and Bn, and a
1752 -- loop without an iteration scheme.
1754 if Need_Separate_Indexes
then
1756 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1759 Make_Block_Statement
(Loc
,
1760 Declarations
=> New_List
(
1761 Make_Object_Declaration
(Loc
,
1762 Defining_Identifier
=> An
,
1763 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1764 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1766 Make_Object_Declaration
(Loc
,
1767 Defining_Identifier
=> Bn
,
1768 Object_Definition
=> New_Occurrence_Of
(Index_T
, Loc
),
1769 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1771 Handled_Statement_Sequence
=>
1772 Make_Handled_Sequence_Of_Statements
(Loc
,
1773 Statements
=> New_List
(Loop_Stm
)));
1775 -- If no separate indexes, return loop statement with explicit
1776 -- iteration scheme on its own
1780 Make_Implicit_Loop_Statement
(Nod
,
1781 Statements
=> Stm_List
,
1783 Make_Iteration_Scheme
(Loc
,
1784 Loop_Parameter_Specification
=>
1785 Make_Loop_Parameter_Specification
(Loc
,
1786 Defining_Identifier
=> An
,
1787 Discrete_Subtype_Definition
=>
1788 Arr_Attr
(A
, Name_Range
, N
))));
1791 end Handle_One_Dimension
;
1793 -----------------------
1794 -- Test_Empty_Arrays --
1795 -----------------------
1797 function Test_Empty_Arrays
return Node_Id
is
1807 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1810 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1811 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1815 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1816 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1825 Left_Opnd
=> Relocate_Node
(Alist
),
1826 Right_Opnd
=> Atest
);
1830 Left_Opnd
=> Relocate_Node
(Blist
),
1831 Right_Opnd
=> Btest
);
1838 Right_Opnd
=> Blist
);
1839 end Test_Empty_Arrays
;
1841 -----------------------------
1842 -- Test_Lengths_Correspond --
1843 -----------------------------
1845 function Test_Lengths_Correspond
return Node_Id
is
1851 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1854 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1855 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
1862 Left_Opnd
=> Relocate_Node
(Result
),
1863 Right_Opnd
=> Rtest
);
1868 end Test_Lengths_Correspond
;
1870 -- Start of processing for Expand_Array_Equality
1873 Ltyp
:= Get_Arg_Type
(Lhs
);
1874 Rtyp
:= Get_Arg_Type
(Rhs
);
1876 -- For now, if the argument types are not the same, go to the base type,
1877 -- since the code assumes that the formals have the same type. This is
1878 -- fixable in future ???
1880 if Ltyp
/= Rtyp
then
1881 Ltyp
:= Base_Type
(Ltyp
);
1882 Rtyp
:= Base_Type
(Rtyp
);
1883 pragma Assert
(Ltyp
= Rtyp
);
1886 -- Build list of formals for function
1888 Formals
:= New_List
(
1889 Make_Parameter_Specification
(Loc
,
1890 Defining_Identifier
=> A
,
1891 Parameter_Type
=> New_Occurrence_Of
(Ltyp
, Loc
)),
1893 Make_Parameter_Specification
(Loc
,
1894 Defining_Identifier
=> B
,
1895 Parameter_Type
=> New_Occurrence_Of
(Rtyp
, Loc
)));
1897 Func_Name
:= Make_Temporary
(Loc
, 'E');
1899 -- Build statement sequence for function
1902 Make_Subprogram_Body
(Loc
,
1904 Make_Function_Specification
(Loc
,
1905 Defining_Unit_Name
=> Func_Name
,
1906 Parameter_Specifications
=> Formals
,
1907 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1909 Declarations
=> Decls
,
1911 Handled_Statement_Sequence
=>
1912 Make_Handled_Sequence_Of_Statements
(Loc
,
1913 Statements
=> New_List
(
1915 Make_Implicit_If_Statement
(Nod
,
1916 Condition
=> Test_Empty_Arrays
,
1917 Then_Statements
=> New_List
(
1918 Make_Simple_Return_Statement
(Loc
,
1920 New_Occurrence_Of
(Standard_True
, Loc
)))),
1922 Make_Implicit_If_Statement
(Nod
,
1923 Condition
=> Test_Lengths_Correspond
,
1924 Then_Statements
=> New_List
(
1925 Make_Simple_Return_Statement
(Loc
,
1926 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))),
1928 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
1930 Make_Simple_Return_Statement
(Loc
,
1931 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1933 Set_Has_Completion
(Func_Name
, True);
1934 Set_Is_Inlined
(Func_Name
);
1936 -- If the array type is distinct from the type of the arguments, it
1937 -- is the full view of a private type. Apply an unchecked conversion
1938 -- to insure that analysis of the call succeeds.
1948 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1950 L
:= OK_Convert_To
(Ltyp
, Lhs
);
1954 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1956 R
:= OK_Convert_To
(Rtyp
, Rhs
);
1959 Actuals
:= New_List
(L
, R
);
1962 Append_To
(Bodies
, Func_Body
);
1965 Make_Function_Call
(Loc
,
1966 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
1967 Parameter_Associations
=> Actuals
);
1968 end Expand_Array_Equality
;
1970 -----------------------------
1971 -- Expand_Boolean_Operator --
1972 -----------------------------
1974 -- Note that we first get the actual subtypes of the operands, since we
1975 -- always want to deal with types that have bounds.
1977 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
1978 Typ
: constant Entity_Id
:= Etype
(N
);
1981 -- Special case of bit packed array where both operands are known to be
1982 -- properly aligned. In this case we use an efficient run time routine
1983 -- to carry out the operation (see System.Bit_Ops).
1985 if Is_Bit_Packed_Array
(Typ
)
1986 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
1987 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
1989 Expand_Packed_Boolean_Operator
(N
);
1993 -- For the normal non-packed case, the general expansion is to build
1994 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1995 -- and then inserting it into the tree. The original operator node is
1996 -- then rewritten as a call to this function. We also use this in the
1997 -- packed case if either operand is a possibly unaligned object.
2000 Loc
: constant Source_Ptr
:= Sloc
(N
);
2001 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
2002 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
2003 Func_Body
: Node_Id
;
2004 Func_Name
: Entity_Id
;
2007 Convert_To_Actual_Subtype
(L
);
2008 Convert_To_Actual_Subtype
(R
);
2009 Ensure_Defined
(Etype
(L
), N
);
2010 Ensure_Defined
(Etype
(R
), N
);
2011 Apply_Length_Check
(R
, Etype
(L
));
2013 if Nkind
(N
) = N_Op_Xor
then
2014 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
2017 if Nkind
(Parent
(N
)) = N_Assignment_Statement
2018 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
2020 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
2022 elsif Nkind
(Parent
(N
)) = N_Op_Not
2023 and then Nkind
(N
) = N_Op_And
2024 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
2025 and then Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
2030 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
2031 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
2032 Insert_Action
(N
, Func_Body
);
2034 -- Now rewrite the expression with a call
2037 Make_Function_Call
(Loc
,
2038 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
2039 Parameter_Associations
=>
2042 Make_Type_Conversion
2043 (Loc
, New_Occurrence_Of
(Etype
(L
), Loc
), R
))));
2045 Analyze_And_Resolve
(N
, Typ
);
2048 end Expand_Boolean_Operator
;
2050 ------------------------------------------------
2051 -- Expand_Compare_Minimize_Eliminate_Overflow --
2052 ------------------------------------------------
2054 procedure Expand_Compare_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
2055 Loc
: constant Source_Ptr
:= Sloc
(N
);
2057 Result_Type
: constant Entity_Id
:= Etype
(N
);
2058 -- Capture result type (could be a derived boolean type)
2063 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
2064 -- Entity for Long_Long_Integer'Base
2066 Check
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
2067 -- Current overflow checking mode
2070 procedure Set_False
;
2071 -- These procedures rewrite N with an occurrence of Standard_True or
2072 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2078 procedure Set_False
is
2080 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2081 Warn_On_Known_Condition
(N
);
2088 procedure Set_True
is
2090 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2091 Warn_On_Known_Condition
(N
);
2094 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2097 -- Nothing to do unless we have a comparison operator with operands
2098 -- that are signed integer types, and we are operating in either
2099 -- MINIMIZED or ELIMINATED overflow checking mode.
2101 if Nkind
(N
) not in N_Op_Compare
2102 or else Check
not in Minimized_Or_Eliminated
2103 or else not Is_Signed_Integer_Type
(Etype
(Left_Opnd
(N
)))
2108 -- OK, this is the case we are interested in. First step is to process
2109 -- our operands using the Minimize_Eliminate circuitry which applies
2110 -- this processing to the two operand subtrees.
2112 Minimize_Eliminate_Overflows
2113 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
2114 Minimize_Eliminate_Overflows
2115 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
2117 -- See if the range information decides the result of the comparison.
2118 -- We can only do this if we in fact have full range information (which
2119 -- won't be the case if either operand is bignum at this stage).
2121 if Llo
/= No_Uint
and then Rlo
/= No_Uint
then
2122 case N_Op_Compare
(Nkind
(N
)) is
2124 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2126 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2133 elsif Lhi
< Rlo
then
2140 elsif Lhi
<= Rlo
then
2147 elsif Lhi
<= Rlo
then
2154 elsif Lhi
< Rlo
then
2159 if Llo
= Lhi
and then Rlo
= Rhi
and then Llo
= Rlo
then
2161 elsif Llo
> Rhi
or else Lhi
< Rlo
then
2166 -- All done if we did the rewrite
2168 if Nkind
(N
) not in N_Op_Compare
then
2173 -- Otherwise, time to do the comparison
2176 Ltype
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2177 Rtype
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2180 -- If the two operands have the same signed integer type we are
2181 -- all set, nothing more to do. This is the case where either
2182 -- both operands were unchanged, or we rewrote both of them to
2183 -- be Long_Long_Integer.
2185 -- Note: Entity for the comparison may be wrong, but it's not worth
2186 -- the effort to change it, since the back end does not use it.
2188 if Is_Signed_Integer_Type
(Ltype
)
2189 and then Base_Type
(Ltype
) = Base_Type
(Rtype
)
2193 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2195 elsif Is_RTE
(Ltype
, RE_Bignum
) or else Is_RTE
(Rtype
, RE_Bignum
) then
2197 Left
: Node_Id
:= Left_Opnd
(N
);
2198 Right
: Node_Id
:= Right_Opnd
(N
);
2199 -- Bignum references for left and right operands
2202 if not Is_RTE
(Ltype
, RE_Bignum
) then
2203 Left
:= Convert_To_Bignum
(Left
);
2204 elsif not Is_RTE
(Rtype
, RE_Bignum
) then
2205 Right
:= Convert_To_Bignum
(Right
);
2208 -- We rewrite our node with:
2211 -- Bnn : Result_Type;
2213 -- M : Mark_Id := SS_Mark;
2215 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2223 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
2224 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
2228 case N_Op_Compare
(Nkind
(N
)) is
2229 when N_Op_Eq
=> Ent
:= RE_Big_EQ
;
2230 when N_Op_Ge
=> Ent
:= RE_Big_GE
;
2231 when N_Op_Gt
=> Ent
:= RE_Big_GT
;
2232 when N_Op_Le
=> Ent
:= RE_Big_LE
;
2233 when N_Op_Lt
=> Ent
:= RE_Big_LT
;
2234 when N_Op_Ne
=> Ent
:= RE_Big_NE
;
2237 -- Insert assignment to Bnn into the bignum block
2240 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
2241 Make_Assignment_Statement
(Loc
,
2242 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
2244 Make_Function_Call
(Loc
,
2246 New_Occurrence_Of
(RTE
(Ent
), Loc
),
2247 Parameter_Associations
=> New_List
(Left
, Right
))));
2249 -- Now do the rewrite with expression actions
2252 Make_Expression_With_Actions
(Loc
,
2253 Actions
=> New_List
(
2254 Make_Object_Declaration
(Loc
,
2255 Defining_Identifier
=> Bnn
,
2256 Object_Definition
=>
2257 New_Occurrence_Of
(Result_Type
, Loc
)),
2259 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
2260 Analyze_And_Resolve
(N
, Result_Type
);
2264 -- No bignums involved, but types are different, so we must have
2265 -- rewritten one of the operands as a Long_Long_Integer but not
2268 -- If left operand is Long_Long_Integer, convert right operand
2269 -- and we are done (with a comparison of two Long_Long_Integers).
2271 elsif Ltype
= LLIB
then
2272 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
2273 Analyze_And_Resolve
(Right_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2276 -- If right operand is Long_Long_Integer, convert left operand
2277 -- and we are done (with a comparison of two Long_Long_Integers).
2279 -- This is the only remaining possibility
2281 else pragma Assert
(Rtype
= LLIB
);
2282 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
2283 Analyze_And_Resolve
(Left_Opnd
(N
), LLIB
, Suppress
=> All_Checks
);
2287 end Expand_Compare_Minimize_Eliminate_Overflow
;
2289 -------------------------------
2290 -- Expand_Composite_Equality --
2291 -------------------------------
2293 -- This function is only called for comparing internal fields of composite
2294 -- types when these fields are themselves composites. This is a special
2295 -- case because it is not possible to respect normal Ada visibility rules.
2297 function Expand_Composite_Equality
2302 Bodies
: List_Id
) return Node_Id
2304 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2305 Full_Type
: Entity_Id
;
2309 function Find_Primitive_Eq
return Node_Id
;
2310 -- AI05-0123: Locate primitive equality for type if it exists, and
2311 -- build the corresponding call. If operation is abstract, replace
2312 -- call with an explicit raise. Return Empty if there is no primitive.
2314 -----------------------
2315 -- Find_Primitive_Eq --
2316 -----------------------
2318 function Find_Primitive_Eq
return Node_Id
is
2323 Prim_E
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2324 while Present
(Prim_E
) loop
2325 Prim
:= Node
(Prim_E
);
2327 -- Locate primitive equality with the right signature
2329 if Chars
(Prim
) = Name_Op_Eq
2330 and then Etype
(First_Formal
(Prim
)) =
2331 Etype
(Next_Formal
(First_Formal
(Prim
)))
2332 and then Etype
(Prim
) = Standard_Boolean
2334 if Is_Abstract_Subprogram
(Prim
) then
2336 Make_Raise_Program_Error
(Loc
,
2337 Reason
=> PE_Explicit_Raise
);
2341 Make_Function_Call
(Loc
,
2342 Name
=> New_Occurrence_Of
(Prim
, Loc
),
2343 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2350 -- If not found, predefined operation will be used
2353 end Find_Primitive_Eq
;
2355 -- Start of processing for Expand_Composite_Equality
2358 if Is_Private_Type
(Typ
) then
2359 Full_Type
:= Underlying_Type
(Typ
);
2364 -- If the private type has no completion the context may be the
2365 -- expansion of a composite equality for a composite type with some
2366 -- still incomplete components. The expression will not be analyzed
2367 -- until the enclosing type is completed, at which point this will be
2368 -- properly expanded, unless there is a bona fide completion error.
2370 if No
(Full_Type
) then
2371 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2374 Full_Type
:= Base_Type
(Full_Type
);
2376 -- When the base type itself is private, use the full view to expand
2377 -- the composite equality.
2379 if Is_Private_Type
(Full_Type
) then
2380 Full_Type
:= Underlying_Type
(Full_Type
);
2383 -- Case of array types
2385 if Is_Array_Type
(Full_Type
) then
2387 -- If the operand is an elementary type other than a floating-point
2388 -- type, then we can simply use the built-in block bitwise equality,
2389 -- since the predefined equality operators always apply and bitwise
2390 -- equality is fine for all these cases.
2392 if Is_Elementary_Type
(Component_Type
(Full_Type
))
2393 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
2395 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2397 -- For composite component types, and floating-point types, use the
2398 -- expansion. This deals with tagged component types (where we use
2399 -- the applicable equality routine) and floating-point, (where we
2400 -- need to worry about negative zeroes), and also the case of any
2401 -- composite type recursively containing such fields.
2404 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2407 -- Case of tagged record types
2409 elsif Is_Tagged_Type
(Full_Type
) then
2411 -- Call the primitive operation "=" of this type
2413 if Is_Class_Wide_Type
(Full_Type
) then
2414 Full_Type
:= Root_Type
(Full_Type
);
2417 -- If this is derived from an untagged private type completed with a
2418 -- tagged type, it does not have a full view, so we use the primitive
2419 -- operations of the private type. This check should no longer be
2420 -- necessary when these types receive their full views ???
2422 if Is_Private_Type
(Typ
)
2423 and then not Is_Tagged_Type
(Typ
)
2424 and then not Is_Controlled
(Typ
)
2425 and then Is_Derived_Type
(Typ
)
2426 and then No
(Full_View
(Typ
))
2428 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2430 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2434 Eq_Op
:= Node
(Prim
);
2435 exit when Chars
(Eq_Op
) = Name_Op_Eq
2436 and then Etype
(First_Formal
(Eq_Op
)) =
2437 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2438 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2440 pragma Assert
(Present
(Prim
));
2443 Eq_Op
:= Node
(Prim
);
2446 Make_Function_Call
(Loc
,
2447 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2448 Parameter_Associations
=>
2450 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2451 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2453 -- Case of untagged record types
2455 elsif Is_Record_Type
(Full_Type
) then
2456 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2458 if Present
(Eq_Op
) then
2459 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2461 -- Inherited equality from parent type. Convert the actuals to
2462 -- match signature of operation.
2465 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2469 Make_Function_Call
(Loc
,
2470 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2471 Parameter_Associations
=> New_List
(
2472 OK_Convert_To
(T
, Lhs
),
2473 OK_Convert_To
(T
, Rhs
)));
2477 -- Comparison between Unchecked_Union components
2479 if Is_Unchecked_Union
(Full_Type
) then
2481 Lhs_Type
: Node_Id
:= Full_Type
;
2482 Rhs_Type
: Node_Id
:= Full_Type
;
2483 Lhs_Discr_Val
: Node_Id
;
2484 Rhs_Discr_Val
: Node_Id
;
2489 if Nkind
(Lhs
) = N_Selected_Component
then
2490 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2495 if Nkind
(Rhs
) = N_Selected_Component
then
2496 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2499 -- Lhs of the composite equality
2501 if Is_Constrained
(Lhs_Type
) then
2503 -- Since the enclosing record type can never be an
2504 -- Unchecked_Union (this code is executed for records
2505 -- that do not have variants), we may reference its
2508 if Nkind
(Lhs
) = N_Selected_Component
2509 and then Has_Per_Object_Constraint
2510 (Entity
(Selector_Name
(Lhs
)))
2513 Make_Selected_Component
(Loc
,
2514 Prefix
=> Prefix
(Lhs
),
2517 (Get_Discriminant_Value
2518 (First_Discriminant
(Lhs_Type
),
2520 Stored_Constraint
(Lhs_Type
))));
2525 (Get_Discriminant_Value
2526 (First_Discriminant
(Lhs_Type
),
2528 Stored_Constraint
(Lhs_Type
)));
2532 -- It is not possible to infer the discriminant since
2533 -- the subtype is not constrained.
2536 Make_Raise_Program_Error
(Loc
,
2537 Reason
=> PE_Unchecked_Union_Restriction
);
2540 -- Rhs of the composite equality
2542 if Is_Constrained
(Rhs_Type
) then
2543 if Nkind
(Rhs
) = N_Selected_Component
2544 and then Has_Per_Object_Constraint
2545 (Entity
(Selector_Name
(Rhs
)))
2548 Make_Selected_Component
(Loc
,
2549 Prefix
=> Prefix
(Rhs
),
2552 (Get_Discriminant_Value
2553 (First_Discriminant
(Rhs_Type
),
2555 Stored_Constraint
(Rhs_Type
))));
2560 (Get_Discriminant_Value
2561 (First_Discriminant
(Rhs_Type
),
2563 Stored_Constraint
(Rhs_Type
)));
2568 Make_Raise_Program_Error
(Loc
,
2569 Reason
=> PE_Unchecked_Union_Restriction
);
2572 -- Call the TSS equality function with the inferred
2573 -- discriminant values.
2576 Make_Function_Call
(Loc
,
2577 Name
=> New_Occurrence_Of
(Eq_Op
, Loc
),
2578 Parameter_Associations
=> New_List
(
2585 -- All cases other than comparing Unchecked_Union types
2589 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2592 Make_Function_Call
(Loc
,
2594 New_Occurrence_Of
(Eq_Op
, Loc
),
2595 Parameter_Associations
=> New_List
(
2596 OK_Convert_To
(T
, Lhs
),
2597 OK_Convert_To
(T
, Rhs
)));
2602 -- Equality composes in Ada 2012 for untagged record types. It also
2603 -- composes for bounded strings, because they are part of the
2604 -- predefined environment. We could make it compose for bounded
2605 -- strings by making them tagged, or by making sure all subcomponents
2606 -- are set to the same value, even when not used. Instead, we have
2607 -- this special case in the compiler, because it's more efficient.
2609 elsif Ada_Version
>= Ada_2012
or else Is_Bounded_String
(Typ
) then
2611 -- If no TSS has been created for the type, check whether there is
2612 -- a primitive equality declared for it.
2615 Op
: constant Node_Id
:= Find_Primitive_Eq
;
2618 -- Use user-defined primitive if it exists, otherwise use
2619 -- predefined equality.
2621 if Present
(Op
) then
2624 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2629 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2632 -- Non-composite types (always use predefined equality)
2635 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2637 end Expand_Composite_Equality
;
2639 ------------------------
2640 -- Expand_Concatenate --
2641 ------------------------
2643 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2644 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2646 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2647 -- Result type of concatenation
2649 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2650 -- Component type. Elements of this component type can appear as one
2651 -- of the operands of concatenation as well as arrays.
2653 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2656 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2657 -- Index type. This is the base type of the index subtype, and is used
2658 -- for all computed bounds (which may be out of range of Istyp in the
2659 -- case of null ranges).
2662 -- This is the type we use to do arithmetic to compute the bounds and
2663 -- lengths of operands. The choice of this type is a little subtle and
2664 -- is discussed in a separate section at the start of the body code.
2666 Concatenation_Error
: exception;
2667 -- Raised if concatenation is sure to raise a CE
2669 Result_May_Be_Null
: Boolean := True;
2670 -- Reset to False if at least one operand is encountered which is known
2671 -- at compile time to be non-null. Used for handling the special case
2672 -- of setting the high bound to the last operand high bound for a null
2673 -- result, thus ensuring a proper high bound in the super-flat case.
2675 N
: constant Nat
:= List_Length
(Opnds
);
2676 -- Number of concatenation operands including possibly null operands
2679 -- Number of operands excluding any known to be null, except that the
2680 -- last operand is always retained, in case it provides the bounds for
2684 -- Current operand being processed in the loop through operands. After
2685 -- this loop is complete, always contains the last operand (which is not
2686 -- the same as Operands (NN), since null operands are skipped).
2688 -- Arrays describing the operands, only the first NN entries of each
2689 -- array are set (NN < N when we exclude known null operands).
2691 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2692 -- True if length of corresponding operand known at compile time
2694 Operands
: array (1 .. N
) of Node_Id
;
2695 -- Set to the corresponding entry in the Opnds list (but note that null
2696 -- operands are excluded, so not all entries in the list are stored).
2698 Fixed_Length
: array (1 .. N
) of Uint
;
2699 -- Set to length of operand. Entries in this array are set only if the
2700 -- corresponding entry in Is_Fixed_Length is True.
2702 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2703 -- Set to lower bound of operand. Either an integer literal in the case
2704 -- where the bound is known at compile time, else actual lower bound.
2705 -- The operand low bound is of type Ityp.
2707 Var_Length
: array (1 .. N
) of Entity_Id
;
2708 -- Set to an entity of type Natural that contains the length of an
2709 -- operand whose length is not known at compile time. Entries in this
2710 -- array are set only if the corresponding entry in Is_Fixed_Length
2711 -- is False. The entity is of type Artyp.
2713 Aggr_Length
: array (0 .. N
) of Node_Id
;
2714 -- The J'th entry in an expression node that represents the total length
2715 -- of operands 1 through J. It is either an integer literal node, or a
2716 -- reference to a constant entity with the right value, so it is fine
2717 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2718 -- entry always is set to zero. The length is of type Artyp.
2720 Low_Bound
: Node_Id
;
2721 -- A tree node representing the low bound of the result (of type Ityp).
2722 -- This is either an integer literal node, or an identifier reference to
2723 -- a constant entity initialized to the appropriate value.
2725 Last_Opnd_Low_Bound
: Node_Id
;
2726 -- A tree node representing the low bound of the last operand. This
2727 -- need only be set if the result could be null. It is used for the
2728 -- special case of setting the right low bound for a null result.
2729 -- This is of type Ityp.
2731 Last_Opnd_High_Bound
: Node_Id
;
2732 -- A tree node representing the high bound of the last operand. This
2733 -- need only be set if the result could be null. It is used for the
2734 -- special case of setting the right high bound for a null result.
2735 -- This is of type Ityp.
2737 High_Bound
: Node_Id
;
2738 -- A tree node representing the high bound of the result (of type Ityp)
2741 -- Result of the concatenation (of type Ityp)
2743 Actions
: constant List_Id
:= New_List
;
2744 -- Collect actions to be inserted
2746 Known_Non_Null_Operand_Seen
: Boolean;
2747 -- Set True during generation of the assignments of operands into
2748 -- result once an operand known to be non-null has been seen.
2750 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2751 -- This function makes an N_Integer_Literal node that is returned in
2752 -- analyzed form with the type set to Artyp. Importantly this literal
2753 -- is not flagged as static, so that if we do computations with it that
2754 -- result in statically detected out of range conditions, we will not
2755 -- generate error messages but instead warning messages.
2757 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2758 -- Given a node of type Ityp, returns the corresponding value of type
2759 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2760 -- For enum types, the Pos of the value is returned.
2762 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2763 -- The inverse function (uses Val in the case of enumeration types)
2765 ------------------------
2766 -- Make_Artyp_Literal --
2767 ------------------------
2769 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2770 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2772 Set_Etype
(Result
, Artyp
);
2773 Set_Analyzed
(Result
, True);
2774 Set_Is_Static_Expression
(Result
, False);
2776 end Make_Artyp_Literal
;
2782 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2784 if Ityp
= Base_Type
(Artyp
) then
2787 elsif Is_Enumeration_Type
(Ityp
) then
2789 Make_Attribute_Reference
(Loc
,
2790 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2791 Attribute_Name
=> Name_Pos
,
2792 Expressions
=> New_List
(X
));
2795 return Convert_To
(Artyp
, X
);
2803 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2805 if Is_Enumeration_Type
(Ityp
) then
2807 Make_Attribute_Reference
(Loc
,
2808 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2809 Attribute_Name
=> Name_Val
,
2810 Expressions
=> New_List
(X
));
2812 -- Case where we will do a type conversion
2815 if Ityp
= Base_Type
(Artyp
) then
2818 return Convert_To
(Ityp
, X
);
2823 -- Local Declarations
2825 Lib_Level_Target
: constant Boolean :=
2826 Nkind
(Parent
(Cnode
)) = N_Object_Declaration
2828 Is_Library_Level_Entity
(Defining_Identifier
(Parent
(Cnode
)));
2830 -- If the concatenation declares a library level entity, we call the
2831 -- built-in concatenation routines to prevent code bloat, regardless
2832 -- of optimization level. This is space-efficient, and prevent linking
2833 -- problems when units are compiled with different optimizations.
2835 Opnd_Typ
: Entity_Id
;
2842 -- Start of processing for Expand_Concatenate
2845 -- Choose an appropriate computational type
2847 -- We will be doing calculations of lengths and bounds in this routine
2848 -- and computing one from the other in some cases, e.g. getting the high
2849 -- bound by adding the length-1 to the low bound.
2851 -- We can't just use the index type, or even its base type for this
2852 -- purpose for two reasons. First it might be an enumeration type which
2853 -- is not suitable for computations of any kind, and second it may
2854 -- simply not have enough range. For example if the index type is
2855 -- -128..+127 then lengths can be up to 256, which is out of range of
2858 -- For enumeration types, we can simply use Standard_Integer, this is
2859 -- sufficient since the actual number of enumeration literals cannot
2860 -- possibly exceed the range of integer (remember we will be doing the
2861 -- arithmetic with POS values, not representation values).
2863 if Is_Enumeration_Type
(Ityp
) then
2864 Artyp
:= Standard_Integer
;
2866 -- If index type is Positive, we use the standard unsigned type, to give
2867 -- more room on the top of the range, obviating the need for an overflow
2868 -- check when creating the upper bound. This is needed to avoid junk
2869 -- overflow checks in the common case of String types.
2871 -- ??? Disabled for now
2873 -- elsif Istyp = Standard_Positive then
2874 -- Artyp := Standard_Unsigned;
2876 -- For modular types, we use a 32-bit modular type for types whose size
2877 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2878 -- identity type, and for larger unsigned types we use 64-bits.
2880 elsif Is_Modular_Integer_Type
(Ityp
) then
2881 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
2882 Artyp
:= Standard_Unsigned
;
2883 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
2886 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
2889 -- Similar treatment for signed types
2892 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
2893 Artyp
:= Standard_Integer
;
2894 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
2897 Artyp
:= Standard_Long_Long_Integer
;
2901 -- Supply dummy entry at start of length array
2903 Aggr_Length
(0) := Make_Artyp_Literal
(0);
2905 -- Go through operands setting up the above arrays
2909 Opnd
:= Remove_Head
(Opnds
);
2910 Opnd_Typ
:= Etype
(Opnd
);
2912 -- The parent got messed up when we put the operands in a list,
2913 -- so now put back the proper parent for the saved operand, that
2914 -- is to say the concatenation node, to make sure that each operand
2915 -- is seen as a subexpression, e.g. if actions must be inserted.
2917 Set_Parent
(Opnd
, Cnode
);
2919 -- Set will be True when we have setup one entry in the array
2923 -- Singleton element (or character literal) case
2925 if Base_Type
(Opnd_Typ
) = Ctyp
then
2927 Operands
(NN
) := Opnd
;
2928 Is_Fixed_Length
(NN
) := True;
2929 Fixed_Length
(NN
) := Uint_1
;
2930 Result_May_Be_Null
:= False;
2932 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2933 -- since we know that the result cannot be null).
2935 Opnd_Low_Bound
(NN
) :=
2936 Make_Attribute_Reference
(Loc
,
2937 Prefix
=> New_Occurrence_Of
(Istyp
, Loc
),
2938 Attribute_Name
=> Name_First
);
2942 -- String literal case (can only occur for strings of course)
2944 elsif Nkind
(Opnd
) = N_String_Literal
then
2945 Len
:= String_Literal_Length
(Opnd_Typ
);
2948 Result_May_Be_Null
:= False;
2951 -- Capture last operand low and high bound if result could be null
2953 if J
= N
and then Result_May_Be_Null
then
2954 Last_Opnd_Low_Bound
:=
2955 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2957 Last_Opnd_High_Bound
:=
2958 Make_Op_Subtract
(Loc
,
2960 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
2961 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
2964 -- Skip null string literal
2966 if J
< N
and then Len
= 0 then
2971 Operands
(NN
) := Opnd
;
2972 Is_Fixed_Length
(NN
) := True;
2974 -- Set length and bounds
2976 Fixed_Length
(NN
) := Len
;
2978 Opnd_Low_Bound
(NN
) :=
2979 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2986 -- Check constrained case with known bounds
2988 if Is_Constrained
(Opnd_Typ
) then
2990 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
2991 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
2992 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
2993 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
2996 -- Fixed length constrained array type with known at compile
2997 -- time bounds is last case of fixed length operand.
2999 if Compile_Time_Known_Value
(Lo
)
3001 Compile_Time_Known_Value
(Hi
)
3004 Loval
: constant Uint
:= Expr_Value
(Lo
);
3005 Hival
: constant Uint
:= Expr_Value
(Hi
);
3006 Len
: constant Uint
:=
3007 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
3011 Result_May_Be_Null
:= False;
3014 -- Capture last operand bounds if result could be null
3016 if J
= N
and then Result_May_Be_Null
then
3017 Last_Opnd_Low_Bound
:=
3019 Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3021 Last_Opnd_High_Bound
:=
3023 Make_Integer_Literal
(Loc
, Expr_Value
(Hi
)));
3026 -- Exclude null length case unless last operand
3028 if J
< N
and then Len
= 0 then
3033 Operands
(NN
) := Opnd
;
3034 Is_Fixed_Length
(NN
) := True;
3035 Fixed_Length
(NN
) := Len
;
3037 Opnd_Low_Bound
(NN
) :=
3039 (Make_Integer_Literal
(Loc
, Expr_Value
(Lo
)));
3046 -- All cases where the length is not known at compile time, or the
3047 -- special case of an operand which is known to be null but has a
3048 -- lower bound other than 1 or is other than a string type.
3053 -- Capture operand bounds
3055 Opnd_Low_Bound
(NN
) :=
3056 Make_Attribute_Reference
(Loc
,
3058 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3059 Attribute_Name
=> Name_First
);
3061 -- Capture last operand bounds if result could be null
3063 if J
= N
and Result_May_Be_Null
then
3064 Last_Opnd_Low_Bound
:=
3066 Make_Attribute_Reference
(Loc
,
3068 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3069 Attribute_Name
=> Name_First
));
3071 Last_Opnd_High_Bound
:=
3073 Make_Attribute_Reference
(Loc
,
3075 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3076 Attribute_Name
=> Name_Last
));
3079 -- Capture length of operand in entity
3081 Operands
(NN
) := Opnd
;
3082 Is_Fixed_Length
(NN
) := False;
3084 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
3087 Make_Object_Declaration
(Loc
,
3088 Defining_Identifier
=> Var_Length
(NN
),
3089 Constant_Present
=> True,
3090 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3092 Make_Attribute_Reference
(Loc
,
3094 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
3095 Attribute_Name
=> Name_Length
)));
3099 -- Set next entry in aggregate length array
3101 -- For first entry, make either integer literal for fixed length
3102 -- or a reference to the saved length for variable length.
3105 if Is_Fixed_Length
(1) then
3106 Aggr_Length
(1) := Make_Integer_Literal
(Loc
, Fixed_Length
(1));
3108 Aggr_Length
(1) := New_Occurrence_Of
(Var_Length
(1), Loc
);
3111 -- If entry is fixed length and only fixed lengths so far, make
3112 -- appropriate new integer literal adding new length.
3114 elsif Is_Fixed_Length
(NN
)
3115 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
3118 Make_Integer_Literal
(Loc
,
3119 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
3121 -- All other cases, construct an addition node for the length and
3122 -- create an entity initialized to this length.
3125 Ent
:= Make_Temporary
(Loc
, 'L');
3127 if Is_Fixed_Length
(NN
) then
3128 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
3130 Clen
:= New_Occurrence_Of
(Var_Length
(NN
), Loc
);
3134 Make_Object_Declaration
(Loc
,
3135 Defining_Identifier
=> Ent
,
3136 Constant_Present
=> True,
3137 Object_Definition
=> New_Occurrence_Of
(Artyp
, Loc
),
3140 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
3141 Right_Opnd
=> Clen
)));
3143 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
3150 -- If we have only skipped null operands, return the last operand
3157 -- If we have only one non-null operand, return it and we are done.
3158 -- There is one case in which this cannot be done, and that is when
3159 -- the sole operand is of the element type, in which case it must be
3160 -- converted to an array, and the easiest way of doing that is to go
3161 -- through the normal general circuit.
3163 if NN
= 1 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
then
3164 Result
:= Operands
(1);
3168 -- Cases where we have a real concatenation
3170 -- Next step is to find the low bound for the result array that we
3171 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3173 -- If the ultimate ancestor of the index subtype is a constrained array
3174 -- definition, then the lower bound is that of the index subtype as
3175 -- specified by (RM 4.5.3(6)).
3177 -- The right test here is to go to the root type, and then the ultimate
3178 -- ancestor is the first subtype of this root type.
3180 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
3182 Make_Attribute_Reference
(Loc
,
3184 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
3185 Attribute_Name
=> Name_First
);
3187 -- If the first operand in the list has known length we know that
3188 -- the lower bound of the result is the lower bound of this operand.
3190 elsif Is_Fixed_Length
(1) then
3191 Low_Bound
:= Opnd_Low_Bound
(1);
3193 -- OK, we don't know the lower bound, we have to build a horrible
3194 -- if expression node of the form
3196 -- if Cond1'Length /= 0 then
3199 -- if Opnd2'Length /= 0 then
3204 -- The nesting ends either when we hit an operand whose length is known
3205 -- at compile time, or on reaching the last operand, whose low bound we
3206 -- take unconditionally whether or not it is null. It's easiest to do
3207 -- this with a recursive procedure:
3211 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
3212 -- Returns the lower bound determined by operands J .. NN
3214 ---------------------
3215 -- Get_Known_Bound --
3216 ---------------------
3218 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
3220 if Is_Fixed_Length
(J
) or else J
= NN
then
3221 return New_Copy
(Opnd_Low_Bound
(J
));
3225 Make_If_Expression
(Loc
,
3226 Expressions
=> New_List
(
3230 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3232 Make_Integer_Literal
(Loc
, 0)),
3234 New_Copy
(Opnd_Low_Bound
(J
)),
3235 Get_Known_Bound
(J
+ 1)));
3237 end Get_Known_Bound
;
3240 Ent
:= Make_Temporary
(Loc
, 'L');
3243 Make_Object_Declaration
(Loc
,
3244 Defining_Identifier
=> Ent
,
3245 Constant_Present
=> True,
3246 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
3247 Expression
=> Get_Known_Bound
(1)));
3249 Low_Bound
:= New_Occurrence_Of
(Ent
, Loc
);
3253 -- Now we can safely compute the upper bound, normally
3254 -- Low_Bound + Length - 1.
3259 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3261 Make_Op_Subtract
(Loc
,
3262 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3263 Right_Opnd
=> Make_Artyp_Literal
(1))));
3265 -- Note that calculation of the high bound may cause overflow in some
3266 -- very weird cases, so in the general case we need an overflow check on
3267 -- the high bound. We can avoid this for the common case of string types
3268 -- and other types whose index is Positive, since we chose a wider range
3269 -- for the arithmetic type.
3271 if Istyp
/= Standard_Positive
then
3272 Activate_Overflow_Check
(High_Bound
);
3275 -- Handle the exceptional case where the result is null, in which case
3276 -- case the bounds come from the last operand (so that we get the proper
3277 -- bounds if the last operand is super-flat).
3279 if Result_May_Be_Null
then
3281 Make_If_Expression
(Loc
,
3282 Expressions
=> New_List
(
3284 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3285 Right_Opnd
=> Make_Artyp_Literal
(0)),
3286 Last_Opnd_Low_Bound
,
3290 Make_If_Expression
(Loc
,
3291 Expressions
=> New_List
(
3293 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
3294 Right_Opnd
=> Make_Artyp_Literal
(0)),
3295 Last_Opnd_High_Bound
,
3299 -- Here is where we insert the saved up actions
3301 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
3303 -- Now we construct an array object with appropriate bounds. We mark
3304 -- the target as internal to prevent useless initialization when
3305 -- Initialize_Scalars is enabled. Also since this is the actual result
3306 -- entity, we make sure we have debug information for the result.
3308 Ent
:= Make_Temporary
(Loc
, 'S');
3309 Set_Is_Internal
(Ent
);
3310 Set_Needs_Debug_Info
(Ent
);
3312 -- If the bound is statically known to be out of range, we do not want
3313 -- to abort, we want a warning and a runtime constraint error. Note that
3314 -- we have arranged that the result will not be treated as a static
3315 -- constant, so we won't get an illegality during this insertion.
3317 Insert_Action
(Cnode
,
3318 Make_Object_Declaration
(Loc
,
3319 Defining_Identifier
=> Ent
,
3320 Object_Definition
=>
3321 Make_Subtype_Indication
(Loc
,
3322 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
3324 Make_Index_Or_Discriminant_Constraint
(Loc
,
3325 Constraints
=> New_List
(
3327 Low_Bound
=> Low_Bound
,
3328 High_Bound
=> High_Bound
))))),
3329 Suppress
=> All_Checks
);
3331 -- If the result of the concatenation appears as the initializing
3332 -- expression of an object declaration, we can just rename the
3333 -- result, rather than copying it.
3335 Set_OK_To_Rename
(Ent
);
3337 -- Catch the static out of range case now
3339 if Raises_Constraint_Error
(High_Bound
) then
3340 raise Concatenation_Error
;
3343 -- Now we will generate the assignments to do the actual concatenation
3345 -- There is one case in which we will not do this, namely when all the
3346 -- following conditions are met:
3348 -- The result type is Standard.String
3350 -- There are nine or fewer retained (non-null) operands
3352 -- The optimization level is -O0
3354 -- The corresponding System.Concat_n.Str_Concat_n routine is
3355 -- available in the run time.
3357 -- The debug flag gnatd.c is not set
3359 -- If all these conditions are met then we generate a call to the
3360 -- relevant concatenation routine. The purpose of this is to avoid
3361 -- undesirable code bloat at -O0.
3363 if Atyp
= Standard_String
3364 and then NN
in 2 .. 9
3365 and then (Lib_Level_Target
3366 or else ((Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
3367 and then not Debug_Flag_Dot_C
))
3370 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
3381 if RTE_Available
(RR
(NN
)) then
3383 Opnds
: constant List_Id
:=
3384 New_List
(New_Occurrence_Of
(Ent
, Loc
));
3387 for J
in 1 .. NN
loop
3388 if Is_List_Member
(Operands
(J
)) then
3389 Remove
(Operands
(J
));
3392 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3394 Make_Aggregate
(Loc
,
3395 Component_Associations
=> New_List
(
3396 Make_Component_Association
(Loc
,
3397 Choices
=> New_List
(
3398 Make_Integer_Literal
(Loc
, 1)),
3399 Expression
=> Operands
(J
)))));
3402 Append_To
(Opnds
, Operands
(J
));
3406 Insert_Action
(Cnode
,
3407 Make_Procedure_Call_Statement
(Loc
,
3408 Name
=> New_Occurrence_Of
(RTE
(RR
(NN
)), Loc
),
3409 Parameter_Associations
=> Opnds
));
3411 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3418 -- Not special case so generate the assignments
3420 Known_Non_Null_Operand_Seen
:= False;
3422 for J
in 1 .. NN
loop
3424 Lo
: constant Node_Id
:=
3426 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3427 Right_Opnd
=> Aggr_Length
(J
- 1));
3429 Hi
: constant Node_Id
:=
3431 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
3433 Make_Op_Subtract
(Loc
,
3434 Left_Opnd
=> Aggr_Length
(J
),
3435 Right_Opnd
=> Make_Artyp_Literal
(1)));
3438 -- Singleton case, simple assignment
3440 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
3441 Known_Non_Null_Operand_Seen
:= True;
3442 Insert_Action
(Cnode
,
3443 Make_Assignment_Statement
(Loc
,
3445 Make_Indexed_Component
(Loc
,
3446 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3447 Expressions
=> New_List
(To_Ityp
(Lo
))),
3448 Expression
=> Operands
(J
)),
3449 Suppress
=> All_Checks
);
3451 -- Array case, slice assignment, skipped when argument is fixed
3452 -- length and known to be null.
3454 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3457 Make_Assignment_Statement
(Loc
,
3461 New_Occurrence_Of
(Ent
, Loc
),
3464 Low_Bound
=> To_Ityp
(Lo
),
3465 High_Bound
=> To_Ityp
(Hi
))),
3466 Expression
=> Operands
(J
));
3468 if Is_Fixed_Length
(J
) then
3469 Known_Non_Null_Operand_Seen
:= True;
3471 elsif not Known_Non_Null_Operand_Seen
then
3473 -- Here if operand length is not statically known and no
3474 -- operand known to be non-null has been processed yet.
3475 -- If operand length is 0, we do not need to perform the
3476 -- assignment, and we must avoid the evaluation of the
3477 -- high bound of the slice, since it may underflow if the
3478 -- low bound is Ityp'First.
3481 Make_Implicit_If_Statement
(Cnode
,
3485 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3486 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3487 Then_Statements
=> New_List
(Assign
));
3490 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3496 -- Finally we build the result, which is a reference to the array object
3498 Result
:= New_Occurrence_Of
(Ent
, Loc
);
3501 Rewrite
(Cnode
, Result
);
3502 Analyze_And_Resolve
(Cnode
, Atyp
);
3505 when Concatenation_Error
=>
3507 -- Kill warning generated for the declaration of the static out of
3508 -- range high bound, and instead generate a Constraint_Error with
3509 -- an appropriate specific message.
3511 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3512 Apply_Compile_Time_Constraint_Error
3514 Msg
=> "concatenation result upper bound out of range??",
3515 Reason
=> CE_Range_Check_Failed
);
3516 end Expand_Concatenate
;
3518 ---------------------------------------------------
3519 -- Expand_Membership_Minimize_Eliminate_Overflow --
3520 ---------------------------------------------------
3522 procedure Expand_Membership_Minimize_Eliminate_Overflow
(N
: Node_Id
) is
3523 pragma Assert
(Nkind
(N
) = N_In
);
3524 -- Despite the name, this routine applies only to N_In, not to
3525 -- N_Not_In. The latter is always rewritten as not (X in Y).
3527 Result_Type
: constant Entity_Id
:= Etype
(N
);
3528 -- Capture result type, may be a derived boolean type
3530 Loc
: constant Source_Ptr
:= Sloc
(N
);
3531 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3532 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3534 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3535 -- is thus tempting to capture these values, but due to the rewrites
3536 -- that occur as a result of overflow checking, these values change
3537 -- as we go along, and it is safe just to always use Etype explicitly.
3539 Restype
: constant Entity_Id
:= Etype
(N
);
3543 -- Bounds in Minimize calls, not used currently
3545 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
3546 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3549 Minimize_Eliminate_Overflows
(Lop
, Lo
, Hi
, Top_Level
=> False);
3551 -- If right operand is a subtype name, and the subtype name has no
3552 -- predicate, then we can just replace the right operand with an
3553 -- explicit range T'First .. T'Last, and use the explicit range code.
3555 if Nkind
(Rop
) /= N_Range
3556 and then No
(Predicate_Function
(Etype
(Rop
)))
3559 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3564 Make_Attribute_Reference
(Loc
,
3565 Attribute_Name
=> Name_First
,
3566 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
)),
3568 Make_Attribute_Reference
(Loc
,
3569 Attribute_Name
=> Name_Last
,
3570 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
))));
3571 Analyze_And_Resolve
(Rop
, Rtyp
, Suppress
=> All_Checks
);
3575 -- Here for the explicit range case. Note that the bounds of the range
3576 -- have not been processed for minimized or eliminated checks.
3578 if Nkind
(Rop
) = N_Range
then
3579 Minimize_Eliminate_Overflows
3580 (Low_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3581 Minimize_Eliminate_Overflows
3582 (High_Bound
(Rop
), Lo
, Hi
, Top_Level
=> False);
3584 -- We have A in B .. C, treated as A >= B and then A <= C
3588 if Is_RTE
(Etype
(Lop
), RE_Bignum
)
3589 or else Is_RTE
(Etype
(Low_Bound
(Rop
)), RE_Bignum
)
3590 or else Is_RTE
(Etype
(High_Bound
(Rop
)), RE_Bignum
)
3593 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3594 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3595 L
: constant Entity_Id
:=
3596 Make_Defining_Identifier
(Loc
, Name_uL
);
3597 Lopnd
: constant Node_Id
:= Convert_To_Bignum
(Lop
);
3598 Lbound
: constant Node_Id
:=
3599 Convert_To_Bignum
(Low_Bound
(Rop
));
3600 Hbound
: constant Node_Id
:=
3601 Convert_To_Bignum
(High_Bound
(Rop
));
3603 -- Now we rewrite the membership test node to look like
3606 -- Bnn : Result_Type;
3608 -- M : Mark_Id := SS_Mark;
3609 -- L : Bignum := Lopnd;
3611 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3619 -- Insert declaration of L into declarations of bignum block
3622 (Last
(Declarations
(Blk
)),
3623 Make_Object_Declaration
(Loc
,
3624 Defining_Identifier
=> L
,
3625 Object_Definition
=>
3626 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
),
3627 Expression
=> Lopnd
));
3629 -- Insert assignment to Bnn into expressions of bignum block
3632 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3633 Make_Assignment_Statement
(Loc
,
3634 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3638 Make_Function_Call
(Loc
,
3640 New_Occurrence_Of
(RTE
(RE_Big_GE
), Loc
),
3641 Parameter_Associations
=> New_List
(
3642 New_Occurrence_Of
(L
, Loc
),
3646 Make_Function_Call
(Loc
,
3648 New_Occurrence_Of
(RTE
(RE_Big_LE
), Loc
),
3649 Parameter_Associations
=> New_List
(
3650 New_Occurrence_Of
(L
, Loc
),
3653 -- Now rewrite the node
3656 Make_Expression_With_Actions
(Loc
,
3657 Actions
=> New_List
(
3658 Make_Object_Declaration
(Loc
,
3659 Defining_Identifier
=> Bnn
,
3660 Object_Definition
=>
3661 New_Occurrence_Of
(Result_Type
, Loc
)),
3663 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3664 Analyze_And_Resolve
(N
, Result_Type
);
3668 -- Here if no bignums around
3671 -- Case where types are all the same
3673 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Low_Bound
(Rop
)))
3675 Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(High_Bound
(Rop
)))
3679 -- If types are not all the same, it means that we have rewritten
3680 -- at least one of them to be of type Long_Long_Integer, and we
3681 -- will convert the other operands to Long_Long_Integer.
3684 Convert_To_And_Rewrite
(LLIB
, Lop
);
3685 Set_Analyzed
(Lop
, False);
3686 Analyze_And_Resolve
(Lop
, LLIB
);
3688 -- For the right operand, avoid unnecessary recursion into
3689 -- this routine, we know that overflow is not possible.
3691 Convert_To_And_Rewrite
(LLIB
, Low_Bound
(Rop
));
3692 Convert_To_And_Rewrite
(LLIB
, High_Bound
(Rop
));
3693 Set_Analyzed
(Rop
, False);
3694 Analyze_And_Resolve
(Rop
, LLIB
, Suppress
=> Overflow_Check
);
3697 -- Now the three operands are of the same signed integer type,
3698 -- so we can use the normal expansion routine for membership,
3699 -- setting the flag to prevent recursion into this procedure.
3701 Set_No_Minimize_Eliminate
(N
);
3705 -- Right operand is a subtype name and the subtype has a predicate. We
3706 -- have to make sure the predicate is checked, and for that we need to
3707 -- use the standard N_In circuitry with appropriate types.
3710 pragma Assert
(Present
(Predicate_Function
(Etype
(Rop
))));
3712 -- If types are "right", just call Expand_N_In preventing recursion
3714 if Base_Type
(Etype
(Lop
)) = Base_Type
(Etype
(Rop
)) then
3715 Set_No_Minimize_Eliminate
(N
);
3720 elsif Is_RTE
(Etype
(Lop
), RE_Bignum
) then
3722 -- For X in T, we want to rewrite our node as
3725 -- Bnn : Result_Type;
3728 -- M : Mark_Id := SS_Mark;
3729 -- Lnn : Long_Long_Integer'Base
3735 -- if not Bignum_In_LLI_Range (Nnn) then
3738 -- Lnn := From_Bignum (Nnn);
3740 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3741 -- and then T'Base (Lnn) in T;
3750 -- A bit gruesome, but there doesn't seem to be a simpler way
3753 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
3754 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
3755 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L', N
);
3756 Nnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'N', N
);
3757 T
: constant Entity_Id
:= Etype
(Rop
);
3758 TB
: constant Entity_Id
:= Base_Type
(T
);
3762 -- Mark the last membership operation to prevent recursion
3766 Left_Opnd
=> Convert_To
(TB
, New_Occurrence_Of
(Lnn
, Loc
)),
3767 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3768 Set_No_Minimize_Eliminate
(Nin
);
3770 -- Now decorate the block
3773 (Last
(Declarations
(Blk
)),
3774 Make_Object_Declaration
(Loc
,
3775 Defining_Identifier
=> Lnn
,
3776 Object_Definition
=> New_Occurrence_Of
(LLIB
, Loc
)));
3779 (Last
(Declarations
(Blk
)),
3780 Make_Object_Declaration
(Loc
,
3781 Defining_Identifier
=> Nnn
,
3782 Object_Definition
=>
3783 New_Occurrence_Of
(RTE
(RE_Bignum
), Loc
)));
3786 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
3788 Make_Assignment_Statement
(Loc
,
3789 Name
=> New_Occurrence_Of
(Nnn
, Loc
),
3790 Expression
=> Relocate_Node
(Lop
)),
3792 Make_Implicit_If_Statement
(N
,
3796 Make_Function_Call
(Loc
,
3799 (RTE
(RE_Bignum_In_LLI_Range
), Loc
),
3800 Parameter_Associations
=> New_List
(
3801 New_Occurrence_Of
(Nnn
, Loc
)))),
3803 Then_Statements
=> New_List
(
3804 Make_Assignment_Statement
(Loc
,
3805 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3807 New_Occurrence_Of
(Standard_False
, Loc
))),
3809 Else_Statements
=> New_List
(
3810 Make_Assignment_Statement
(Loc
,
3811 Name
=> New_Occurrence_Of
(Lnn
, Loc
),
3813 Make_Function_Call
(Loc
,
3815 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3816 Parameter_Associations
=> New_List
(
3817 New_Occurrence_Of
(Nnn
, Loc
)))),
3819 Make_Assignment_Statement
(Loc
,
3820 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
3825 Left_Opnd
=> New_Occurrence_Of
(Lnn
, Loc
),
3830 Make_Attribute_Reference
(Loc
,
3831 Attribute_Name
=> Name_First
,
3833 New_Occurrence_Of
(TB
, Loc
))),
3837 Make_Attribute_Reference
(Loc
,
3838 Attribute_Name
=> Name_Last
,
3840 New_Occurrence_Of
(TB
, Loc
))))),
3842 Right_Opnd
=> Nin
))))));
3844 -- Now we can do the rewrite
3847 Make_Expression_With_Actions
(Loc
,
3848 Actions
=> New_List
(
3849 Make_Object_Declaration
(Loc
,
3850 Defining_Identifier
=> Bnn
,
3851 Object_Definition
=>
3852 New_Occurrence_Of
(Result_Type
, Loc
)),
3854 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
3855 Analyze_And_Resolve
(N
, Result_Type
);
3859 -- Not bignum case, but types don't match (this means we rewrote the
3860 -- left operand to be Long_Long_Integer).
3863 pragma Assert
(Base_Type
(Etype
(Lop
)) = LLIB
);
3865 -- We rewrite the membership test as (where T is the type with
3866 -- the predicate, i.e. the type of the right operand)
3868 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3869 -- and then T'Base (Lop) in T
3872 T
: constant Entity_Id
:= Etype
(Rop
);
3873 TB
: constant Entity_Id
:= Base_Type
(T
);
3877 -- The last membership test is marked to prevent recursion
3881 Left_Opnd
=> Convert_To
(TB
, Duplicate_Subexpr
(Lop
)),
3882 Right_Opnd
=> New_Occurrence_Of
(T
, Loc
));
3883 Set_No_Minimize_Eliminate
(Nin
);
3885 -- Now do the rewrite
3896 Make_Attribute_Reference
(Loc
,
3897 Attribute_Name
=> Name_First
,
3899 New_Occurrence_Of
(TB
, Loc
))),
3902 Make_Attribute_Reference
(Loc
,
3903 Attribute_Name
=> Name_Last
,
3905 New_Occurrence_Of
(TB
, Loc
))))),
3906 Right_Opnd
=> Nin
));
3907 Set_Analyzed
(N
, False);
3908 Analyze_And_Resolve
(N
, Restype
);
3912 end Expand_Membership_Minimize_Eliminate_Overflow
;
3914 ------------------------
3915 -- Expand_N_Allocator --
3916 ------------------------
3918 procedure Expand_N_Allocator
(N
: Node_Id
) is
3919 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
3920 Loc
: constant Source_Ptr
:= Sloc
(N
);
3921 PtrT
: constant Entity_Id
:= Etype
(N
);
3923 procedure Rewrite_Coextension
(N
: Node_Id
);
3924 -- Static coextensions have the same lifetime as the entity they
3925 -- constrain. Such occurrences can be rewritten as aliased objects
3926 -- and their unrestricted access used instead of the coextension.
3928 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
3929 -- Given a constrained array type E, returns a node representing the
3930 -- code to compute the size in storage elements for the given type.
3931 -- This is done without using the attribute (which malfunctions for
3934 -------------------------
3935 -- Rewrite_Coextension --
3936 -------------------------
3938 procedure Rewrite_Coextension
(N
: Node_Id
) is
3939 Temp_Id
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
3940 Temp_Decl
: Node_Id
;
3944 -- Cnn : aliased Etyp;
3947 Make_Object_Declaration
(Loc
,
3948 Defining_Identifier
=> Temp_Id
,
3949 Aliased_Present
=> True,
3950 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
));
3952 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
3953 Set_Expression
(Temp_Decl
, Expression
(Expression
(N
)));
3956 Insert_Action
(N
, Temp_Decl
);
3958 Make_Attribute_Reference
(Loc
,
3959 Prefix
=> New_Occurrence_Of
(Temp_Id
, Loc
),
3960 Attribute_Name
=> Name_Unrestricted_Access
));
3962 Analyze_And_Resolve
(N
, PtrT
);
3963 end Rewrite_Coextension
;
3965 ------------------------------
3966 -- Size_In_Storage_Elements --
3967 ------------------------------
3969 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
3971 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3972 -- However, the reason for the existence of this function is
3973 -- to construct a test for sizes too large, which means near the
3974 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3975 -- is that we get overflows when sizes are greater than 2**31.
3977 -- So what we end up doing for array types is to use the expression:
3979 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
3981 -- which avoids this problem. All this is a bit bogus, but it does
3982 -- mean we catch common cases of trying to allocate arrays that
3983 -- are too large, and which in the absence of a check results in
3984 -- undetected chaos ???
3986 -- Note in particular that this is a pessimistic estimate in the
3987 -- case of packed array types, where an array element might occupy
3988 -- just a fraction of a storage element???
3995 for J
in 1 .. Number_Dimensions
(E
) loop
3997 Make_Attribute_Reference
(Loc
,
3998 Prefix
=> New_Occurrence_Of
(E
, Loc
),
3999 Attribute_Name
=> Name_Length
,
4000 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, J
)));
4007 Make_Op_Multiply
(Loc
,
4014 Make_Op_Multiply
(Loc
,
4017 Make_Attribute_Reference
(Loc
,
4018 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
4019 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
4021 end Size_In_Storage_Elements
;
4025 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
4029 Rel_Typ
: Entity_Id
;
4032 -- Start of processing for Expand_N_Allocator
4035 -- RM E.2.3(22). We enforce that the expected type of an allocator
4036 -- shall not be a remote access-to-class-wide-limited-private type
4038 -- Why is this being done at expansion time, seems clearly wrong ???
4040 Validate_Remote_Access_To_Class_Wide_Type
(N
);
4042 -- Processing for anonymous access-to-controlled types. These access
4043 -- types receive a special finalization master which appears in the
4044 -- declarations of the enclosing semantic unit. This expansion is done
4045 -- now to ensure that any additional types generated by this routine or
4046 -- Expand_Allocator_Expression inherit the proper type attributes.
4048 if (Ekind
(PtrT
) = E_Anonymous_Access_Type
4049 or else (Is_Itype
(PtrT
) and then No
(Finalization_Master
(PtrT
))))
4050 and then Needs_Finalization
(Dtyp
)
4052 -- Detect the allocation of an anonymous controlled object where the
4053 -- type of the context is named. For example:
4055 -- procedure Proc (Ptr : Named_Access_Typ);
4056 -- Proc (new Designated_Typ);
4058 -- Regardless of the anonymous-to-named access type conversion, the
4059 -- lifetime of the object must be associated with the named access
4060 -- type. Use the finalization-related attributes of this type.
4062 if Nkind_In
(Parent
(N
), N_Type_Conversion
,
4063 N_Unchecked_Type_Conversion
)
4064 and then Ekind_In
(Etype
(Parent
(N
)), E_Access_Subtype
,
4066 E_General_Access_Type
)
4068 Rel_Typ
:= Etype
(Parent
(N
));
4073 -- Anonymous access-to-controlled types allocate on the global pool.
4074 -- Note that this is a "root type only" attribute.
4076 if No
(Associated_Storage_Pool
(PtrT
)) then
4077 if Present
(Rel_Typ
) then
4078 Set_Associated_Storage_Pool
4079 (Root_Type
(PtrT
), Associated_Storage_Pool
(Rel_Typ
));
4081 Set_Associated_Storage_Pool
4082 (Root_Type
(PtrT
), RTE
(RE_Global_Pool_Object
));
4086 -- The finalization master must be inserted and analyzed as part of
4087 -- the current semantic unit. Note that the master is updated when
4088 -- analysis changes current units. Note that this is a "root type
4091 if Present
(Rel_Typ
) then
4092 Set_Finalization_Master
4093 (Root_Type
(PtrT
), Finalization_Master
(Rel_Typ
));
4095 Build_Anonymous_Master
(Root_Type
(PtrT
));
4099 -- Set the storage pool and find the appropriate version of Allocate to
4100 -- call. Do not overwrite the storage pool if it is already set, which
4101 -- can happen for build-in-place function returns (see
4102 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4104 if No
(Storage_Pool
(N
)) then
4105 Pool
:= Associated_Storage_Pool
(Root_Type
(PtrT
));
4107 if Present
(Pool
) then
4108 Set_Storage_Pool
(N
, Pool
);
4110 if Is_RTE
(Pool
, RE_SS_Pool
) then
4111 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
4113 -- In the case of an allocator for a simple storage pool, locate
4114 -- and save a reference to the pool type's Allocate routine.
4116 elsif Present
(Get_Rep_Pragma
4117 (Etype
(Pool
), Name_Simple_Storage_Pool_Type
))
4120 Pool_Type
: constant Entity_Id
:= Base_Type
(Etype
(Pool
));
4121 Alloc_Op
: Entity_Id
;
4123 Alloc_Op
:= Get_Name_Entity_Id
(Name_Allocate
);
4124 while Present
(Alloc_Op
) loop
4125 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
4126 and then Present
(First_Formal
(Alloc_Op
))
4127 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
4129 Set_Procedure_To_Call
(N
, Alloc_Op
);
4132 Alloc_Op
:= Homonym
(Alloc_Op
);
4137 elsif Is_Class_Wide_Type
(Etype
(Pool
)) then
4138 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
4141 Set_Procedure_To_Call
(N
,
4142 Find_Prim_Op
(Etype
(Pool
), Name_Allocate
));
4147 -- Under certain circumstances we can replace an allocator by an access
4148 -- to statically allocated storage. The conditions, as noted in AARM
4149 -- 3.10 (10c) are as follows:
4151 -- Size and initial value is known at compile time
4152 -- Access type is access-to-constant
4154 -- The allocator is not part of a constraint on a record component,
4155 -- because in that case the inserted actions are delayed until the
4156 -- record declaration is fully analyzed, which is too late for the
4157 -- analysis of the rewritten allocator.
4159 if Is_Access_Constant
(PtrT
)
4160 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
4161 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
4162 and then Size_Known_At_Compile_Time
4163 (Etype
(Expression
(Expression
(N
))))
4164 and then not Is_Record_Type
(Current_Scope
)
4166 -- Here we can do the optimization. For the allocator
4170 -- We insert an object declaration
4172 -- Tnn : aliased x := y;
4174 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4175 -- marked as requiring static allocation.
4177 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
4178 Desig
:= Subtype_Mark
(Expression
(N
));
4180 -- If context is constrained, use constrained subtype directly,
4181 -- so that the constant is not labelled as having a nominally
4182 -- unconstrained subtype.
4184 if Entity
(Desig
) = Base_Type
(Dtyp
) then
4185 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
4189 Make_Object_Declaration
(Loc
,
4190 Defining_Identifier
=> Temp
,
4191 Aliased_Present
=> True,
4192 Constant_Present
=> Is_Access_Constant
(PtrT
),
4193 Object_Definition
=> Desig
,
4194 Expression
=> Expression
(Expression
(N
))));
4197 Make_Attribute_Reference
(Loc
,
4198 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
4199 Attribute_Name
=> Name_Unrestricted_Access
));
4201 Analyze_And_Resolve
(N
, PtrT
);
4203 -- We set the variable as statically allocated, since we don't want
4204 -- it going on the stack of the current procedure.
4206 Set_Is_Statically_Allocated
(Temp
);
4210 -- Same if the allocator is an access discriminant for a local object:
4211 -- instead of an allocator we create a local value and constrain the
4212 -- enclosing object with the corresponding access attribute.
4214 if Is_Static_Coextension
(N
) then
4215 Rewrite_Coextension
(N
);
4219 -- Check for size too large, we do this because the back end misses
4220 -- proper checks here and can generate rubbish allocation calls when
4221 -- we are near the limit. We only do this for the 32-bit address case
4222 -- since that is from a practical point of view where we see a problem.
4224 if System_Address_Size
= 32
4225 and then not Storage_Checks_Suppressed
(PtrT
)
4226 and then not Storage_Checks_Suppressed
(Dtyp
)
4227 and then not Storage_Checks_Suppressed
(Etyp
)
4229 -- The check we want to generate should look like
4231 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4232 -- raise Storage_Error;
4235 -- where 3.5 gigabytes is a constant large enough to accommodate any
4236 -- reasonable request for. But we can't do it this way because at
4237 -- least at the moment we don't compute this attribute right, and
4238 -- can silently give wrong results when the result gets large. Since
4239 -- this is all about large results, that's bad, so instead we only
4240 -- apply the check for constrained arrays, and manually compute the
4241 -- value of the attribute ???
4243 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
4245 Make_Raise_Storage_Error
(Loc
,
4248 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
4250 Make_Integer_Literal
(Loc
, Uint_7
* (Uint_2
** 29))),
4251 Reason
=> SE_Object_Too_Large
));
4255 -- If no storage pool has been specified and we have the restriction
4256 -- No_Standard_Allocators_After_Elaboration is present, then generate
4257 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4259 if Nkind
(N
) = N_Allocator
4260 and then No
(Storage_Pool
(N
))
4261 and then Restriction_Active
(No_Standard_Allocators_After_Elaboration
)
4264 Make_Procedure_Call_Statement
(Loc
,
4266 New_Occurrence_Of
(RTE
(RE_Check_Standard_Allocator
), Loc
)));
4269 -- Handle case of qualified expression (other than optimization above)
4270 -- First apply constraint checks, because the bounds or discriminants
4271 -- in the aggregate might not match the subtype mark in the allocator.
4273 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
4274 Apply_Constraint_Check
4275 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
4277 Expand_Allocator_Expression
(N
);
4281 -- If the allocator is for a type which requires initialization, and
4282 -- there is no initial value (i.e. operand is a subtype indication
4283 -- rather than a qualified expression), then we must generate a call to
4284 -- the initialization routine using an expressions action node:
4286 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4288 -- Here ptr_T is the pointer type for the allocator, and T is the
4289 -- subtype of the allocator. A special case arises if the designated
4290 -- type of the access type is a task or contains tasks. In this case
4291 -- the call to Init (Temp.all ...) is replaced by code that ensures
4292 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4293 -- for details). In addition, if the type T is a task type, then the
4294 -- first argument to Init must be converted to the task record type.
4297 T
: constant Entity_Id
:= Entity
(Expression
(N
));
4303 Init_Arg1
: Node_Id
;
4304 Temp_Decl
: Node_Id
;
4305 Temp_Type
: Entity_Id
;
4308 if No_Initialization
(N
) then
4310 -- Even though this might be a simple allocation, create a custom
4311 -- Allocate if the context requires it.
4313 if Present
(Finalization_Master
(PtrT
)) then
4314 Build_Allocate_Deallocate_Proc
4316 Is_Allocate
=> True);
4319 -- Case of no initialization procedure present
4321 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
4323 -- Case of simple initialization required
4325 if Needs_Simple_Initialization
(T
) then
4326 Check_Restriction
(No_Default_Initialization
, N
);
4327 Rewrite
(Expression
(N
),
4328 Make_Qualified_Expression
(Loc
,
4329 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
4330 Expression
=> Get_Simple_Init_Val
(T
, N
)));
4332 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
4333 Analyze_And_Resolve
(Expression
(N
), T
);
4334 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
4335 Expand_N_Allocator
(N
);
4337 -- No initialization required
4343 -- Case of initialization procedure present, must be called
4346 Check_Restriction
(No_Default_Initialization
, N
);
4348 if not Restriction_Active
(No_Default_Initialization
) then
4349 Init
:= Base_Init_Proc
(T
);
4351 Temp
:= Make_Temporary
(Loc
, 'P');
4353 -- Construct argument list for the initialization routine call
4356 Make_Explicit_Dereference
(Loc
,
4358 New_Occurrence_Of
(Temp
, Loc
));
4360 Set_Assignment_OK
(Init_Arg1
);
4363 -- The initialization procedure expects a specific type. if the
4364 -- context is access to class wide, indicate that the object
4365 -- being allocated has the right specific type.
4367 if Is_Class_Wide_Type
(Dtyp
) then
4368 Init_Arg1
:= Unchecked_Convert_To
(T
, Init_Arg1
);
4371 -- If designated type is a concurrent type or if it is private
4372 -- type whose definition is a concurrent type, the first
4373 -- argument in the Init routine has to be unchecked conversion
4374 -- to the corresponding record type. If the designated type is
4375 -- a derived type, also convert the argument to its root type.
4377 if Is_Concurrent_Type
(T
) then
4379 Unchecked_Convert_To
(
4380 Corresponding_Record_Type
(T
), Init_Arg1
);
4382 elsif Is_Private_Type
(T
)
4383 and then Present
(Full_View
(T
))
4384 and then Is_Concurrent_Type
(Full_View
(T
))
4387 Unchecked_Convert_To
4388 (Corresponding_Record_Type
(Full_View
(T
)), Init_Arg1
);
4390 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
4392 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
4395 Init_Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Init_Arg1
);
4396 Set_Etype
(Init_Arg1
, Ftyp
);
4400 Args
:= New_List
(Init_Arg1
);
4402 -- For the task case, pass the Master_Id of the access type as
4403 -- the value of the _Master parameter, and _Chain as the value
4404 -- of the _Chain parameter (_Chain will be defined as part of
4405 -- the generated code for the allocator).
4407 -- In Ada 2005, the context may be a function that returns an
4408 -- anonymous access type. In that case the Master_Id has been
4409 -- created when expanding the function declaration.
4411 if Has_Task
(T
) then
4412 if No
(Master_Id
(Base_Type
(PtrT
))) then
4414 -- The designated type was an incomplete type, and the
4415 -- access type did not get expanded. Salvage it now.
4417 if not Restriction_Active
(No_Task_Hierarchy
) then
4418 if Present
(Parent
(Base_Type
(PtrT
))) then
4419 Expand_N_Full_Type_Declaration
4420 (Parent
(Base_Type
(PtrT
)));
4422 -- The only other possibility is an itype. For this
4423 -- case, the master must exist in the context. This is
4424 -- the case when the allocator initializes an access
4425 -- component in an init-proc.
4428 pragma Assert
(Is_Itype
(PtrT
));
4429 Build_Master_Renaming
(PtrT
, N
);
4434 -- If the context of the allocator is a declaration or an
4435 -- assignment, we can generate a meaningful image for it,
4436 -- even though subsequent assignments might remove the
4437 -- connection between task and entity. We build this image
4438 -- when the left-hand side is a simple variable, a simple
4439 -- indexed assignment or a simple selected component.
4441 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4443 Nam
: constant Node_Id
:= Name
(Parent
(N
));
4446 if Is_Entity_Name
(Nam
) then
4448 Build_Task_Image_Decls
4451 (Entity
(Nam
), Sloc
(Nam
)), T
);
4453 elsif Nkind_In
(Nam
, N_Indexed_Component
,
4454 N_Selected_Component
)
4455 and then Is_Entity_Name
(Prefix
(Nam
))
4458 Build_Task_Image_Decls
4459 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
4461 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4465 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
4467 Build_Task_Image_Decls
4468 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
4471 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
4474 if Restriction_Active
(No_Task_Hierarchy
) then
4476 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
4480 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
4483 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
4485 Decl
:= Last
(Decls
);
4487 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
4489 -- Has_Task is false, Decls not used
4495 -- Add discriminants if discriminated type
4498 Dis
: Boolean := False;
4502 if Has_Discriminants
(T
) then
4506 -- Type may be a private type with no visible discriminants
4507 -- in which case check full view if in scope, or the
4508 -- underlying_full_view if dealing with a type whose full
4509 -- view may be derived from a private type whose own full
4510 -- view has discriminants.
4512 elsif Is_Private_Type
(T
) then
4513 if Present
(Full_View
(T
))
4514 and then Has_Discriminants
(Full_View
(T
))
4517 Typ
:= Full_View
(T
);
4519 elsif Present
(Underlying_Full_View
(T
))
4520 and then Has_Discriminants
(Underlying_Full_View
(T
))
4523 Typ
:= Underlying_Full_View
(T
);
4529 -- If the allocated object will be constrained by the
4530 -- default values for discriminants, then build a subtype
4531 -- with those defaults, and change the allocated subtype
4532 -- to that. Note that this happens in fewer cases in Ada
4535 if not Is_Constrained
(Typ
)
4536 and then Present
(Discriminant_Default_Value
4537 (First_Discriminant
(Typ
)))
4538 and then (Ada_Version
< Ada_2005
4540 Object_Type_Has_Constrained_Partial_View
4541 (Typ
, Current_Scope
))
4543 Typ
:= Build_Default_Subtype
(Typ
, N
);
4544 Set_Expression
(N
, New_Occurrence_Of
(Typ
, Loc
));
4547 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
4548 while Present
(Discr
) loop
4549 Nod
:= Node
(Discr
);
4550 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
4552 -- AI-416: when the discriminant constraint is an
4553 -- anonymous access type make sure an accessibility
4554 -- check is inserted if necessary (3.10.2(22.q/2))
4556 if Ada_Version
>= Ada_2005
4558 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
4560 Apply_Accessibility_Check
4561 (Nod
, Typ
, Insert_Node
=> Nod
);
4569 -- We set the allocator as analyzed so that when we analyze
4570 -- the if expression node, we do not get an unwanted recursive
4571 -- expansion of the allocator expression.
4573 Set_Analyzed
(N
, True);
4574 Nod
:= Relocate_Node
(N
);
4576 -- Here is the transformation:
4577 -- input: new Ctrl_Typ
4578 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4579 -- Ctrl_TypIP (Temp.all, ...);
4580 -- [Deep_]Initialize (Temp.all);
4582 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4583 -- is the subtype of the allocator.
4586 Make_Object_Declaration
(Loc
,
4587 Defining_Identifier
=> Temp
,
4588 Constant_Present
=> True,
4589 Object_Definition
=> New_Occurrence_Of
(Temp_Type
, Loc
),
4592 Set_Assignment_OK
(Temp_Decl
);
4593 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
4595 Build_Allocate_Deallocate_Proc
(Temp_Decl
, True);
4597 -- If the designated type is a task type or contains tasks,
4598 -- create block to activate created tasks, and insert
4599 -- declaration for Task_Image variable ahead of call.
4601 if Has_Task
(T
) then
4603 L
: constant List_Id
:= New_List
;
4606 Build_Task_Allocate_Block
(L
, Nod
, Args
);
4608 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
4609 Insert_Actions
(N
, L
);
4614 Make_Procedure_Call_Statement
(Loc
,
4615 Name
=> New_Occurrence_Of
(Init
, Loc
),
4616 Parameter_Associations
=> Args
));
4619 if Needs_Finalization
(T
) then
4622 -- [Deep_]Initialize (Init_Arg1);
4626 (Obj_Ref
=> New_Copy_Tree
(Init_Arg1
),
4630 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4631 Analyze_And_Resolve
(N
, PtrT
);
4636 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4637 -- object that has been rewritten as a reference, we displace "this"
4638 -- to reference properly its secondary dispatch table.
4640 if Nkind
(N
) = N_Identifier
and then Is_Interface
(Dtyp
) then
4641 Displace_Allocator_Pointer
(N
);
4645 when RE_Not_Available
=>
4647 end Expand_N_Allocator
;
4649 -----------------------
4650 -- Expand_N_And_Then --
4651 -----------------------
4653 procedure Expand_N_And_Then
(N
: Node_Id
)
4654 renames Expand_Short_Circuit_Operator
;
4656 ------------------------------
4657 -- Expand_N_Case_Expression --
4658 ------------------------------
4660 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
4661 Loc
: constant Source_Ptr
:= Sloc
(N
);
4662 Typ
: constant Entity_Id
:= Etype
(N
);
4665 Case_Stmt
: Node_Id
;
4668 In_Predicate
: Boolean := False;
4669 Optimize_Return_Stmt
: Boolean := False;
4671 Ptr_Typ
: Entity_Id
;
4673 Target_Typ
: Entity_Id
;
4676 -- Check for MINIMIZED/ELIMINATED overflow mode
4678 if Minimized_Eliminated_Overflow_Check
(N
) then
4679 Apply_Arithmetic_Overflow_Check
(N
);
4683 -- If the case expression is a predicate specification, and the type
4684 -- to which it applies has a static predicate aspect, do not expand,
4685 -- because it will be converted to the proper predicate form later.
4687 if Ekind_In
(Current_Scope
, E_Function
, E_Procedure
)
4688 and then Is_Predicate_Function
(Current_Scope
)
4690 In_Predicate
:= True;
4692 if Has_Static_Predicate_Aspect
(Etype
(First_Entity
(Current_Scope
)))
4700 -- case X is when A => AX, when B => BX ...
4715 -- Except when the case expression appears as part of a simple return
4716 -- statement, returning an elementary type, where we expand
4718 -- return (case X is when A => AX, when B => BX ...)
4730 -- Note that this expansion is also triggered for expression functions
4731 -- containing a single case expression since these functions are
4732 -- expanded as above.
4734 -- However, this expansion is wrong for limited types, and also wrong
4735 -- for unconstrained types (since the bounds may not be the same in all
4736 -- branches). Furthermore it involves an extra copy for large objects.
4737 -- So we take care of this by using the following modified expansion for
4738 -- non-elementary types:
4741 -- type Ptr_Typ is access all typ;
4742 -- Target : Ptr_Typ;
4745 -- Target := AX'Unrestricted_Access;
4747 -- Target := BX'Unrestricted_Access;
4750 -- in Target.all end;
4753 Make_Case_Statement
(Loc
,
4754 Expression
=> Expression
(N
),
4755 Alternatives
=> New_List
);
4757 -- Preserve the original context for which the case statement is being
4758 -- generated. This is needed by the finalization machinery to prevent
4759 -- the premature finalization of controlled objects found within the
4762 Set_From_Conditional_Expression
(Case_Stmt
);
4767 if Is_Elementary_Type
(Typ
) then
4770 -- ??? Do not perform the optimization when the return statement is
4771 -- within a predicate function as this causes supurious errors. A
4772 -- possible mismatch in handling this case somewhere else in semantic
4776 and then Nkind
(Parent
(N
)) = N_Simple_Return_Statement
4778 Optimize_Return_Stmt
:= True;
4782 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
4784 Make_Full_Type_Declaration
(Loc
,
4785 Defining_Identifier
=> Ptr_Typ
,
4787 Make_Access_To_Object_Definition
(Loc
,
4788 All_Present
=> True,
4789 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
4790 Target_Typ
:= Ptr_Typ
;
4793 if not Optimize_Return_Stmt
then
4794 Target
:= Make_Temporary
(Loc
, 'T');
4796 -- Create declaration for target of expression, and indicate that it
4797 -- does not require initialization.
4800 Make_Object_Declaration
(Loc
,
4801 Defining_Identifier
=> Target
,
4802 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
));
4803 Set_No_Initialization
(Decl
);
4804 Append_To
(Acts
, Decl
);
4807 -- Now process the alternatives
4809 Alt
:= First
(Alternatives
(N
));
4810 while Present
(Alt
) loop
4812 Alt_Expr
: Node_Id
:= Expression
(Alt
);
4813 Alt_Loc
: constant Source_Ptr
:= Sloc
(Alt_Expr
);
4817 -- As described above, take Unrestricted_Access for case of non-
4818 -- scalar types, to avoid big copies, and special cases.
4820 if not Is_Elementary_Type
(Typ
) then
4822 Make_Attribute_Reference
(Alt_Loc
,
4823 Prefix
=> Relocate_Node
(Alt_Expr
),
4824 Attribute_Name
=> Name_Unrestricted_Access
);
4827 if Optimize_Return_Stmt
then
4829 Make_Simple_Return_Statement
(Alt_Loc
,
4830 Expression
=> Alt_Expr
));
4833 Make_Assignment_Statement
(Alt_Loc
,
4834 Name
=> New_Occurrence_Of
(Target
, Loc
),
4835 Expression
=> Alt_Expr
));
4838 -- Propagate declarations inserted in the node by Insert_Actions
4839 -- (for example, temporaries generated to remove side effects).
4840 -- These actions must remain attached to the alternative, given
4841 -- that they are generated by the corresponding expression.
4843 if Present
(Actions
(Alt
)) then
4844 Prepend_List
(Actions
(Alt
), Stmts
);
4848 (Alternatives
(Case_Stmt
),
4849 Make_Case_Statement_Alternative
(Sloc
(Alt
),
4850 Discrete_Choices
=> Discrete_Choices
(Alt
),
4851 Statements
=> Stmts
));
4857 -- Rewrite parent return statement as a case statement if possible
4859 if Optimize_Return_Stmt
then
4861 Rewrite
(Par
, Case_Stmt
);
4866 Append_To
(Acts
, Case_Stmt
);
4868 -- Construct and return final expression with actions
4870 if Is_Elementary_Type
(Typ
) then
4871 Expr
:= New_Occurrence_Of
(Target
, Loc
);
4874 Make_Explicit_Dereference
(Loc
,
4875 Prefix
=> New_Occurrence_Of
(Target
, Loc
));
4879 Make_Expression_With_Actions
(Loc
,
4883 Analyze_And_Resolve
(N
, Typ
);
4884 end Expand_N_Case_Expression
;
4886 -----------------------------------
4887 -- Expand_N_Explicit_Dereference --
4888 -----------------------------------
4890 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
4892 -- Insert explicit dereference call for the checked storage pool case
4894 Insert_Dereference_Action
(Prefix
(N
));
4896 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
4897 -- we set the atomic sync flag.
4899 if Is_Atomic
(Etype
(N
))
4900 and then not Atomic_Synchronization_Disabled
(Etype
(N
))
4902 Activate_Atomic_Synchronization
(N
);
4904 end Expand_N_Explicit_Dereference
;
4906 --------------------------------------
4907 -- Expand_N_Expression_With_Actions --
4908 --------------------------------------
4910 procedure Expand_N_Expression_With_Actions
(N
: Node_Id
) is
4911 Acts
: constant List_Id
:= Actions
(N
);
4913 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
);
4914 -- Force the evaluation of Boolean expression Expr
4916 function Process_Action
(Act
: Node_Id
) return Traverse_Result
;
4917 -- Inspect and process a single action of an expression_with_actions for
4918 -- transient controlled objects. If such objects are found, the routine
4919 -- generates code to clean them up when the context of the expression is
4920 -- evaluated or elaborated.
4922 ------------------------------
4923 -- Force_Boolean_Evaluation --
4924 ------------------------------
4926 procedure Force_Boolean_Evaluation
(Expr
: Node_Id
) is
4927 Loc
: constant Source_Ptr
:= Sloc
(N
);
4928 Flag_Decl
: Node_Id
;
4929 Flag_Id
: Entity_Id
;
4932 -- Relocate the expression to the actions list by capturing its value
4933 -- in a Boolean flag. Generate:
4934 -- Flag : constant Boolean := Expr;
4936 Flag_Id
:= Make_Temporary
(Loc
, 'F');
4939 Make_Object_Declaration
(Loc
,
4940 Defining_Identifier
=> Flag_Id
,
4941 Constant_Present
=> True,
4942 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4943 Expression
=> Relocate_Node
(Expr
));
4945 Append
(Flag_Decl
, Acts
);
4946 Analyze
(Flag_Decl
);
4948 -- Replace the expression with a reference to the flag
4950 Rewrite
(Expression
(N
), New_Occurrence_Of
(Flag_Id
, Loc
));
4951 Analyze
(Expression
(N
));
4952 end Force_Boolean_Evaluation
;
4954 --------------------
4955 -- Process_Action --
4956 --------------------
4958 function Process_Action
(Act
: Node_Id
) return Traverse_Result
is
4960 if Nkind
(Act
) = N_Object_Declaration
4961 and then Is_Finalizable_Transient
(Act
, N
)
4963 Process_Transient_Object
(Act
, N
);
4966 -- Avoid processing temporary function results multiple times when
4967 -- dealing with nested expression_with_actions.
4969 elsif Nkind
(Act
) = N_Expression_With_Actions
then
4972 -- Do not process temporary function results in loops. This is done
4973 -- by Expand_N_Loop_Statement and Build_Finalizer.
4975 elsif Nkind
(Act
) = N_Loop_Statement
then
4982 procedure Process_Single_Action
is new Traverse_Proc
(Process_Action
);
4988 -- Start of processing for Expand_N_Expression_With_Actions
4991 -- Do not evaluate the expression when it denotes an entity because the
4992 -- expression_with_actions node will be replaced by the reference.
4994 if Is_Entity_Name
(Expression
(N
)) then
4997 -- Do not evaluate the expression when there are no actions because the
4998 -- expression_with_actions node will be replaced by the expression.
5000 elsif No
(Acts
) or else Is_Empty_List
(Acts
) then
5003 -- Force the evaluation of the expression by capturing its value in a
5004 -- temporary. This ensures that aliases of transient controlled objects
5005 -- do not leak to the expression of the expression_with_actions node:
5008 -- Trans_Id : Ctrl_Typ : ...;
5009 -- Alias : ... := Trans_Id;
5010 -- in ... Alias ... end;
5012 -- In the example above, Trans_Id cannot be finalized at the end of the
5013 -- actions list because this may affect the alias and the final value of
5014 -- the expression_with_actions. Forcing the evaluation encapsulates the
5015 -- reference to the Alias within the actions list:
5018 -- Trans_Id : Ctrl_Typ : ...;
5019 -- Alias : ... := Trans_Id;
5020 -- Val : constant Boolean := ... Alias ...;
5021 -- <finalize Trans_Id>
5024 -- Once this transformation is performed, it is safe to finalize the
5025 -- transient controlled object at the end of the actions list.
5027 -- Note that Force_Evaluation does not remove side effects in operators
5028 -- because it assumes that all operands are evaluated and side effect
5029 -- free. This is not the case when an operand depends implicitly on the
5030 -- transient controlled object through the use of access types.
5032 elsif Is_Boolean_Type
(Etype
(Expression
(N
))) then
5033 Force_Boolean_Evaluation
(Expression
(N
));
5035 -- The expression of an expression_with_actions node may not necessarily
5036 -- be Boolean when the node appears in an if expression. In this case do
5037 -- the usual forced evaluation to encapsulate potential aliasing.
5040 Force_Evaluation
(Expression
(N
));
5043 -- Process all transient controlled objects found within the actions of
5046 Act
:= First
(Acts
);
5047 while Present
(Act
) loop
5048 Process_Single_Action
(Act
);
5052 -- Deal with case where there are no actions. In this case we simply
5053 -- rewrite the node with its expression since we don't need the actions
5054 -- and the specification of this node does not allow a null action list.
5056 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5057 -- the expanded tree and relying on being able to retrieve the original
5058 -- tree in cases like this. This raises a whole lot of issues of whether
5059 -- we have problems elsewhere, which will be addressed in the future???
5061 if Is_Empty_List
(Acts
) then
5062 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
5064 end Expand_N_Expression_With_Actions
;
5066 ----------------------------
5067 -- Expand_N_If_Expression --
5068 ----------------------------
5070 -- Deal with limited types and condition actions
5072 procedure Expand_N_If_Expression
(N
: Node_Id
) is
5073 procedure Process_Actions
(Actions
: List_Id
);
5074 -- Inspect and process a single action list of an if expression for
5075 -- transient controlled objects. If such objects are found, the routine
5076 -- generates code to clean them up when the context of the expression is
5077 -- evaluated or elaborated.
5079 ---------------------
5080 -- Process_Actions --
5081 ---------------------
5083 procedure Process_Actions
(Actions
: List_Id
) is
5087 Act
:= First
(Actions
);
5088 while Present
(Act
) loop
5089 if Nkind
(Act
) = N_Object_Declaration
5090 and then Is_Finalizable_Transient
(Act
, N
)
5092 Process_Transient_Object
(Act
, N
);
5097 end Process_Actions
;
5101 Loc
: constant Source_Ptr
:= Sloc
(N
);
5102 Cond
: constant Node_Id
:= First
(Expressions
(N
));
5103 Thenx
: constant Node_Id
:= Next
(Cond
);
5104 Elsex
: constant Node_Id
:= Next
(Thenx
);
5105 Typ
: constant Entity_Id
:= Etype
(N
);
5113 Ptr_Typ
: Entity_Id
;
5115 -- Start of processing for Expand_N_If_Expression
5118 -- Check for MINIMIZED/ELIMINATED overflow mode
5120 if Minimized_Eliminated_Overflow_Check
(N
) then
5121 Apply_Arithmetic_Overflow_Check
(N
);
5125 -- Fold at compile time if condition known. We have already folded
5126 -- static if expressions, but it is possible to fold any case in which
5127 -- the condition is known at compile time, even though the result is
5130 -- Note that we don't do the fold of such cases in Sem_Elab because
5131 -- it can cause infinite loops with the expander adding a conditional
5132 -- expression, and Sem_Elab circuitry removing it repeatedly.
5134 if Compile_Time_Known_Value
(Cond
) then
5136 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean;
5137 -- Fold at compile time. Assumes condition known.
5138 -- Return True if folding occurred, meaning we're done.
5140 ----------------------
5141 -- Fold_Known_Value --
5142 ----------------------
5144 function Fold_Known_Value
(Cond
: Node_Id
) return Boolean is
5146 if Is_True
(Expr_Value
(Cond
)) then
5148 Actions
:= Then_Actions
(N
);
5151 Actions
:= Else_Actions
(N
);
5156 if Present
(Actions
) then
5158 -- To minimize the use of Expression_With_Actions, just skip
5159 -- the optimization as it is not critical for correctness.
5161 if Minimize_Expression_With_Actions
then
5166 Make_Expression_With_Actions
(Loc
,
5167 Expression
=> Relocate_Node
(Expr
),
5168 Actions
=> Actions
));
5169 Analyze_And_Resolve
(N
, Typ
);
5172 Rewrite
(N
, Relocate_Node
(Expr
));
5175 -- Note that the result is never static (legitimate cases of
5176 -- static if expressions were folded in Sem_Eval).
5178 Set_Is_Static_Expression
(N
, False);
5180 end Fold_Known_Value
;
5183 if Fold_Known_Value
(Cond
) then
5189 -- If the type is limited, and the back end does not handle limited
5190 -- types, then we expand as follows to avoid the possibility of
5191 -- improper copying.
5193 -- type Ptr is access all Typ;
5197 -- Cnn := then-expr'Unrestricted_Access;
5200 -- Cnn := else-expr'Unrestricted_Access;
5203 -- and replace the if expression by a reference to Cnn.all.
5205 -- This special case can be skipped if the back end handles limited
5206 -- types properly and ensures that no incorrect copies are made.
5208 if Is_By_Reference_Type
(Typ
)
5209 and then not Back_End_Handles_Limited_Types
5211 -- When the "then" or "else" expressions involve controlled function
5212 -- calls, generated temporaries are chained on the corresponding list
5213 -- of actions. These temporaries need to be finalized after the if
5214 -- expression is evaluated.
5216 Process_Actions
(Then_Actions
(N
));
5217 Process_Actions
(Else_Actions
(N
));
5220 -- type Ann is access all Typ;
5222 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5225 Make_Full_Type_Declaration
(Loc
,
5226 Defining_Identifier
=> Ptr_Typ
,
5228 Make_Access_To_Object_Definition
(Loc
,
5229 All_Present
=> True,
5230 Subtype_Indication
=> New_Occurrence_Of
(Typ
, Loc
))));
5235 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5238 Make_Object_Declaration
(Loc
,
5239 Defining_Identifier
=> Cnn
,
5240 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
));
5244 -- Cnn := <Thenx>'Unrestricted_Access;
5246 -- Cnn := <Elsex>'Unrestricted_Access;
5250 Make_Implicit_If_Statement
(N
,
5251 Condition
=> Relocate_Node
(Cond
),
5252 Then_Statements
=> New_List
(
5253 Make_Assignment_Statement
(Sloc
(Thenx
),
5254 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5256 Make_Attribute_Reference
(Loc
,
5257 Prefix
=> Relocate_Node
(Thenx
),
5258 Attribute_Name
=> Name_Unrestricted_Access
))),
5260 Else_Statements
=> New_List
(
5261 Make_Assignment_Statement
(Sloc
(Elsex
),
5262 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5264 Make_Attribute_Reference
(Loc
,
5265 Prefix
=> Relocate_Node
(Elsex
),
5266 Attribute_Name
=> Name_Unrestricted_Access
))));
5268 -- Preserve the original context for which the if statement is being
5269 -- generated. This is needed by the finalization machinery to prevent
5270 -- the premature finalization of controlled objects found within the
5273 Set_From_Conditional_Expression
(New_If
);
5276 Make_Explicit_Dereference
(Loc
,
5277 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
5279 -- If the result is an unconstrained array and the if expression is in a
5280 -- context other than the initializing expression of the declaration of
5281 -- an object, then we pull out the if expression as follows:
5283 -- Cnn : constant typ := if-expression
5285 -- and then replace the if expression with an occurrence of Cnn. This
5286 -- avoids the need in the back end to create on-the-fly variable length
5287 -- temporaries (which it cannot do!)
5289 -- Note that the test for being in an object declaration avoids doing an
5290 -- unnecessary expansion, and also avoids infinite recursion.
5292 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
)
5293 and then (Nkind
(Parent
(N
)) /= N_Object_Declaration
5294 or else Expression
(Parent
(N
)) /= N
)
5297 Cnn
: constant Node_Id
:= Make_Temporary
(Loc
, 'C', N
);
5300 Make_Object_Declaration
(Loc
,
5301 Defining_Identifier
=> Cnn
,
5302 Constant_Present
=> True,
5303 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5304 Expression
=> Relocate_Node
(N
),
5305 Has_Init_Expression
=> True));
5307 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
5311 -- For other types, we only need to expand if there are other actions
5312 -- associated with either branch.
5314 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
5316 -- We now wrap the actions into the appropriate expression
5318 if Minimize_Expression_With_Actions
5319 and then (Is_Elementary_Type
(Underlying_Type
(Typ
))
5320 or else Is_Constrained
(Underlying_Type
(Typ
)))
5322 -- If we can't use N_Expression_With_Actions nodes, then we insert
5323 -- the following sequence of actions (using Insert_Actions):
5328 -- Cnn := then-expr;
5334 -- and replace the if expression by a reference to Cnn
5336 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
5339 Make_Object_Declaration
(Loc
,
5340 Defining_Identifier
=> Cnn
,
5341 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
5344 Make_Implicit_If_Statement
(N
,
5345 Condition
=> Relocate_Node
(Cond
),
5347 Then_Statements
=> New_List
(
5348 Make_Assignment_Statement
(Sloc
(Thenx
),
5349 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
5350 Expression
=> Relocate_Node
(Thenx
))),
5352 Else_Statements
=> New_List
(
5353 Make_Assignment_Statement
(Sloc
(Elsex
),
5354 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
5355 Expression
=> Relocate_Node
(Elsex
))));
5357 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
5358 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
5360 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
5362 -- Regular path using Expression_With_Actions
5365 if Present
(Then_Actions
(N
)) then
5367 Make_Expression_With_Actions
(Sloc
(Thenx
),
5368 Actions
=> Then_Actions
(N
),
5369 Expression
=> Relocate_Node
(Thenx
)));
5371 Set_Then_Actions
(N
, No_List
);
5372 Analyze_And_Resolve
(Thenx
, Typ
);
5375 if Present
(Else_Actions
(N
)) then
5377 Make_Expression_With_Actions
(Sloc
(Elsex
),
5378 Actions
=> Else_Actions
(N
),
5379 Expression
=> Relocate_Node
(Elsex
)));
5381 Set_Else_Actions
(N
, No_List
);
5382 Analyze_And_Resolve
(Elsex
, Typ
);
5388 -- If no actions then no expansion needed, gigi will handle it using the
5389 -- same approach as a C conditional expression.
5395 -- Fall through here for either the limited expansion, or the case of
5396 -- inserting actions for non-limited types. In both these cases, we must
5397 -- move the SLOC of the parent If statement to the newly created one and
5398 -- change it to the SLOC of the expression which, after expansion, will
5399 -- correspond to what is being evaluated.
5401 if Present
(Parent
(N
)) and then Nkind
(Parent
(N
)) = N_If_Statement
then
5402 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
5403 Set_Sloc
(Parent
(N
), Loc
);
5406 -- Make sure Then_Actions and Else_Actions are appropriately moved
5407 -- to the new if statement.
5409 if Present
(Then_Actions
(N
)) then
5411 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
5414 if Present
(Else_Actions
(N
)) then
5416 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
5419 Insert_Action
(N
, Decl
);
5420 Insert_Action
(N
, New_If
);
5422 Analyze_And_Resolve
(N
, Typ
);
5423 end Expand_N_If_Expression
;
5429 procedure Expand_N_In
(N
: Node_Id
) is
5430 Loc
: constant Source_Ptr
:= Sloc
(N
);
5431 Restyp
: constant Entity_Id
:= Etype
(N
);
5432 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5433 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5434 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
5436 procedure Substitute_Valid_Check
;
5437 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5438 -- test for the left operand being in range of its subtype.
5440 ----------------------------
5441 -- Substitute_Valid_Check --
5442 ----------------------------
5444 procedure Substitute_Valid_Check
is
5445 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean;
5446 -- Determine whether arbitrary node Nod denotes a source object that
5447 -- may safely act as prefix of attribute 'Valid.
5449 ----------------------------
5450 -- Is_OK_Object_Reference --
5451 ----------------------------
5453 function Is_OK_Object_Reference
(Nod
: Node_Id
) return Boolean is
5457 -- Inspect the original operand
5459 Obj_Ref
:= Original_Node
(Nod
);
5461 -- The object reference must be a source construct, otherwise the
5462 -- codefix suggestion may refer to nonexistent code from a user
5465 if Comes_From_Source
(Obj_Ref
) then
5467 -- Recover the actual object reference. There may be more cases
5471 if Nkind_In
(Obj_Ref
, N_Type_Conversion
,
5472 N_Unchecked_Type_Conversion
)
5474 Obj_Ref
:= Expression
(Obj_Ref
);
5480 return Is_Object_Reference
(Obj_Ref
);
5484 end Is_OK_Object_Reference
;
5486 -- Start of processing for Substitute_Valid_Check
5490 Make_Attribute_Reference
(Loc
,
5491 Prefix
=> Relocate_Node
(Lop
),
5492 Attribute_Name
=> Name_Valid
));
5494 Analyze_And_Resolve
(N
, Restyp
);
5496 -- Emit a warning when the left-hand operand of the membership test
5497 -- is a source object, otherwise the use of attribute 'Valid would be
5498 -- illegal. The warning is not given when overflow checking is either
5499 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
5500 -- eliminated above.
5502 if Is_OK_Object_Reference
(Lop
)
5503 and then Overflow_Check_Mode
not in Minimized_Or_Eliminated
5506 ("??explicit membership test may be optimized away", N
);
5507 Error_Msg_N
-- CODEFIX
5508 ("\??use ''Valid attribute instead", N
);
5510 end Substitute_Valid_Check
;
5517 -- Start of processing for Expand_N_In
5520 -- If set membership case, expand with separate procedure
5522 if Present
(Alternatives
(N
)) then
5523 Expand_Set_Membership
(N
);
5527 -- Not set membership, proceed with expansion
5529 Ltyp
:= Etype
(Left_Opnd
(N
));
5530 Rtyp
:= Etype
(Right_Opnd
(N
));
5532 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5533 -- type, then expand with a separate procedure. Note the use of the
5534 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5536 if Overflow_Check_Mode
in Minimized_Or_Eliminated
5537 and then Is_Signed_Integer_Type
(Ltyp
)
5538 and then not No_Minimize_Eliminate
(N
)
5540 Expand_Membership_Minimize_Eliminate_Overflow
(N
);
5544 -- Check case of explicit test for an expression in range of its
5545 -- subtype. This is suspicious usage and we replace it with a 'Valid
5546 -- test and give a warning for scalar types.
5548 if Is_Scalar_Type
(Ltyp
)
5550 -- Only relevant for source comparisons
5552 and then Comes_From_Source
(N
)
5554 -- In floating-point this is a standard way to check for finite values
5555 -- and using 'Valid would typically be a pessimization.
5557 and then not Is_Floating_Point_Type
(Ltyp
)
5559 -- Don't give the message unless right operand is a type entity and
5560 -- the type of the left operand matches this type. Note that this
5561 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5562 -- checks have changed the type of the left operand.
5564 and then Nkind
(Rop
) in N_Has_Entity
5565 and then Ltyp
= Entity
(Rop
)
5567 -- Skip this for predicated types, where such expressions are a
5568 -- reasonable way of testing if something meets the predicate.
5570 and then not Present
(Predicate_Function
(Ltyp
))
5572 Substitute_Valid_Check
;
5576 -- Do validity check on operands
5578 if Validity_Checks_On
and Validity_Check_Operands
then
5579 Ensure_Valid
(Left_Opnd
(N
));
5580 Validity_Check_Range
(Right_Opnd
(N
));
5583 -- Case of explicit range
5585 if Nkind
(Rop
) = N_Range
then
5587 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
5588 Hi
: constant Node_Id
:= High_Bound
(Rop
);
5590 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
5591 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
5593 Lcheck
: Compare_Result
;
5594 Ucheck
: Compare_Result
;
5596 Warn1
: constant Boolean :=
5597 Constant_Condition_Warnings
5598 and then Comes_From_Source
(N
)
5599 and then not In_Instance
;
5600 -- This must be true for any of the optimization warnings, we
5601 -- clearly want to give them only for source with the flag on. We
5602 -- also skip these warnings in an instance since it may be the
5603 -- case that different instantiations have different ranges.
5605 Warn2
: constant Boolean :=
5607 and then Nkind
(Original_Node
(Rop
)) = N_Range
5608 and then Is_Integer_Type
(Etype
(Lo
));
5609 -- For the case where only one bound warning is elided, we also
5610 -- insist on an explicit range and an integer type. The reason is
5611 -- that the use of enumeration ranges including an end point is
5612 -- common, as is the use of a subtype name, one of whose bounds is
5613 -- the same as the type of the expression.
5616 -- If test is explicit x'First .. x'Last, replace by valid check
5618 -- Could use some individual comments for this complex test ???
5620 if Is_Scalar_Type
(Ltyp
)
5622 -- And left operand is X'First where X matches left operand
5623 -- type (this eliminates cases of type mismatch, including
5624 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5625 -- type of the left operand.
5627 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
5628 and then Attribute_Name
(Lo_Orig
) = Name_First
5629 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
5630 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
5632 -- Same tests for right operand
5634 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
5635 and then Attribute_Name
(Hi_Orig
) = Name_Last
5636 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
5637 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
5639 -- Relevant only for source cases
5641 and then Comes_From_Source
(N
)
5643 Substitute_Valid_Check
;
5647 -- If bounds of type are known at compile time, and the end points
5648 -- are known at compile time and identical, this is another case
5649 -- for substituting a valid test. We only do this for discrete
5650 -- types, since it won't arise in practice for float types.
5652 if Comes_From_Source
(N
)
5653 and then Is_Discrete_Type
(Ltyp
)
5654 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
5655 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
5656 and then Compile_Time_Known_Value
(Lo
)
5657 and then Compile_Time_Known_Value
(Hi
)
5658 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
5659 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
5661 -- Kill warnings in instances, since they may be cases where we
5662 -- have a test in the generic that makes sense with some types
5663 -- and not with other types.
5665 and then not In_Instance
5667 Substitute_Valid_Check
;
5671 -- If we have an explicit range, do a bit of optimization based on
5672 -- range analysis (we may be able to kill one or both checks).
5674 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
5675 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
5677 -- If either check is known to fail, replace result by False since
5678 -- the other check does not matter. Preserve the static flag for
5679 -- legality checks, because we are constant-folding beyond RM 4.9.
5681 if Lcheck
= LT
or else Ucheck
= GT
then
5683 Error_Msg_N
("?c?range test optimized away", N
);
5684 Error_Msg_N
("\?c?value is known to be out of range", N
);
5687 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5688 Analyze_And_Resolve
(N
, Restyp
);
5689 Set_Is_Static_Expression
(N
, Static
);
5692 -- If both checks are known to succeed, replace result by True,
5693 -- since we know we are in range.
5695 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5697 Error_Msg_N
("?c?range test optimized away", N
);
5698 Error_Msg_N
("\?c?value is known to be in range", N
);
5701 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5702 Analyze_And_Resolve
(N
, Restyp
);
5703 Set_Is_Static_Expression
(N
, Static
);
5706 -- If lower bound check succeeds and upper bound check is not
5707 -- known to succeed or fail, then replace the range check with
5708 -- a comparison against the upper bound.
5710 elsif Lcheck
in Compare_GE
then
5711 if Warn2
and then not In_Instance
then
5712 Error_Msg_N
("??lower bound test optimized away", Lo
);
5713 Error_Msg_N
("\??value is known to be in range", Lo
);
5719 Right_Opnd
=> High_Bound
(Rop
)));
5720 Analyze_And_Resolve
(N
, Restyp
);
5723 -- If upper bound check succeeds and lower bound check is not
5724 -- known to succeed or fail, then replace the range check with
5725 -- a comparison against the lower bound.
5727 elsif Ucheck
in Compare_LE
then
5728 if Warn2
and then not In_Instance
then
5729 Error_Msg_N
("??upper bound test optimized away", Hi
);
5730 Error_Msg_N
("\??value is known to be in range", Hi
);
5736 Right_Opnd
=> Low_Bound
(Rop
)));
5737 Analyze_And_Resolve
(N
, Restyp
);
5741 -- We couldn't optimize away the range check, but there is one
5742 -- more issue. If we are checking constant conditionals, then we
5743 -- see if we can determine the outcome assuming everything is
5744 -- valid, and if so give an appropriate warning.
5746 if Warn1
and then not Assume_No_Invalid_Values
then
5747 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
5748 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
5750 -- Result is out of range for valid value
5752 if Lcheck
= LT
or else Ucheck
= GT
then
5754 ("?c?value can only be in range if it is invalid", N
);
5756 -- Result is in range for valid value
5758 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
5760 ("?c?value can only be out of range if it is invalid", N
);
5762 -- Lower bound check succeeds if value is valid
5764 elsif Warn2
and then Lcheck
in Compare_GE
then
5766 ("?c?lower bound check only fails if it is invalid", Lo
);
5768 -- Upper bound check succeeds if value is valid
5770 elsif Warn2
and then Ucheck
in Compare_LE
then
5772 ("?c?upper bound check only fails for invalid values", Hi
);
5777 -- For all other cases of an explicit range, nothing to be done
5781 -- Here right operand is a subtype mark
5785 Typ
: Entity_Id
:= Etype
(Rop
);
5786 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
5787 Cond
: Node_Id
:= Empty
;
5789 Obj
: Node_Id
:= Lop
;
5790 SCIL_Node
: Node_Id
;
5793 Remove_Side_Effects
(Obj
);
5795 -- For tagged type, do tagged membership operation
5797 if Is_Tagged_Type
(Typ
) then
5799 -- No expansion will be performed for VM targets, as the VM
5800 -- back-ends will handle the membership tests directly.
5802 if Tagged_Type_Expansion
then
5803 Tagged_Membership
(N
, SCIL_Node
, New_N
);
5805 Analyze_And_Resolve
(N
, Restyp
);
5807 -- Update decoration of relocated node referenced by the
5810 if Generate_SCIL
and then Present
(SCIL_Node
) then
5811 Set_SCIL_Node
(N
, SCIL_Node
);
5817 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5818 -- This reason we do this is that the bounds may have the wrong
5819 -- type if they come from the original type definition. Also this
5820 -- way we get all the processing above for an explicit range.
5822 -- Don't do this for predicated types, since in this case we
5823 -- want to check the predicate.
5825 elsif Is_Scalar_Type
(Typ
) then
5826 if No
(Predicate_Function
(Typ
)) then
5830 Make_Attribute_Reference
(Loc
,
5831 Attribute_Name
=> Name_First
,
5832 Prefix
=> New_Occurrence_Of
(Typ
, Loc
)),
5835 Make_Attribute_Reference
(Loc
,
5836 Attribute_Name
=> Name_Last
,
5837 Prefix
=> New_Occurrence_Of
(Typ
, Loc
))));
5838 Analyze_And_Resolve
(N
, Restyp
);
5843 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5844 -- a membership test if the subtype mark denotes a constrained
5845 -- Unchecked_Union subtype and the expression lacks inferable
5848 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
5849 and then Is_Constrained
(Typ
)
5850 and then not Has_Inferable_Discriminants
(Lop
)
5853 Make_Raise_Program_Error
(Loc
,
5854 Reason
=> PE_Unchecked_Union_Restriction
));
5856 -- Prevent Gigi from generating incorrect code by rewriting the
5857 -- test as False. What is this undocumented thing about ???
5859 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
5863 -- Here we have a non-scalar type
5866 Typ
:= Designated_Type
(Typ
);
5869 if not Is_Constrained
(Typ
) then
5870 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5871 Analyze_And_Resolve
(N
, Restyp
);
5873 -- For the constrained array case, we have to check the subscripts
5874 -- for an exact match if the lengths are non-zero (the lengths
5875 -- must match in any case).
5877 elsif Is_Array_Type
(Typ
) then
5878 Check_Subscripts
: declare
5879 function Build_Attribute_Reference
5882 Dim
: Nat
) return Node_Id
;
5883 -- Build attribute reference E'Nam (Dim)
5885 -------------------------------
5886 -- Build_Attribute_Reference --
5887 -------------------------------
5889 function Build_Attribute_Reference
5892 Dim
: Nat
) return Node_Id
5896 Make_Attribute_Reference
(Loc
,
5898 Attribute_Name
=> Nam
,
5899 Expressions
=> New_List
(
5900 Make_Integer_Literal
(Loc
, Dim
)));
5901 end Build_Attribute_Reference
;
5903 -- Start of processing for Check_Subscripts
5906 for J
in 1 .. Number_Dimensions
(Typ
) loop
5907 Evolve_And_Then
(Cond
,
5910 Build_Attribute_Reference
5911 (Duplicate_Subexpr_No_Checks
(Obj
),
5914 Build_Attribute_Reference
5915 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
5917 Evolve_And_Then
(Cond
,
5920 Build_Attribute_Reference
5921 (Duplicate_Subexpr_No_Checks
(Obj
),
5924 Build_Attribute_Reference
5925 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
5934 Right_Opnd
=> Make_Null
(Loc
)),
5935 Right_Opnd
=> Cond
);
5939 Analyze_And_Resolve
(N
, Restyp
);
5940 end Check_Subscripts
;
5942 -- These are the cases where constraint checks may be required,
5943 -- e.g. records with possible discriminants
5946 -- Expand the test into a series of discriminant comparisons.
5947 -- The expression that is built is the negation of the one that
5948 -- is used for checking discriminant constraints.
5950 Obj
:= Relocate_Node
(Left_Opnd
(N
));
5952 if Has_Discriminants
(Typ
) then
5953 Cond
:= Make_Op_Not
(Loc
,
5954 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
5957 Cond
:= Make_Or_Else
(Loc
,
5961 Right_Opnd
=> Make_Null
(Loc
)),
5962 Right_Opnd
=> Cond
);
5966 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
5970 Analyze_And_Resolve
(N
, Restyp
);
5973 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5974 -- expression of an anonymous access type. This can involve an
5975 -- accessibility test and a tagged type membership test in the
5976 -- case of tagged designated types.
5978 if Ada_Version
>= Ada_2012
5980 and then Ekind
(Ltyp
) = E_Anonymous_Access_Type
5983 Expr_Entity
: Entity_Id
:= Empty
;
5985 Param_Level
: Node_Id
;
5986 Type_Level
: Node_Id
;
5989 if Is_Entity_Name
(Lop
) then
5990 Expr_Entity
:= Param_Entity
(Lop
);
5992 if not Present
(Expr_Entity
) then
5993 Expr_Entity
:= Entity
(Lop
);
5997 -- If a conversion of the anonymous access value to the
5998 -- tested type would be illegal, then the result is False.
6000 if not Valid_Conversion
6001 (Lop
, Rtyp
, Lop
, Report_Errs
=> False)
6003 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
6004 Analyze_And_Resolve
(N
, Restyp
);
6006 -- Apply an accessibility check if the access object has an
6007 -- associated access level and when the level of the type is
6008 -- less deep than the level of the access parameter. This
6009 -- only occur for access parameters and stand-alone objects
6010 -- of an anonymous access type.
6013 if Present
(Expr_Entity
)
6016 (Effective_Extra_Accessibility
(Expr_Entity
))
6017 and then UI_Gt
(Object_Access_Level
(Lop
),
6018 Type_Access_Level
(Rtyp
))
6022 (Effective_Extra_Accessibility
(Expr_Entity
), Loc
);
6025 Make_Integer_Literal
(Loc
, Type_Access_Level
(Rtyp
));
6027 -- Return True only if the accessibility level of the
6028 -- expression entity is not deeper than the level of
6029 -- the tested access type.
6033 Left_Opnd
=> Relocate_Node
(N
),
6034 Right_Opnd
=> Make_Op_Le
(Loc
,
6035 Left_Opnd
=> Param_Level
,
6036 Right_Opnd
=> Type_Level
)));
6038 Analyze_And_Resolve
(N
);
6041 -- If the designated type is tagged, do tagged membership
6044 -- *** NOTE: we have to check not null before doing the
6045 -- tagged membership test (but maybe that can be done
6046 -- inside Tagged_Membership?).
6048 if Is_Tagged_Type
(Typ
) then
6051 Left_Opnd
=> Relocate_Node
(N
),
6055 Right_Opnd
=> Make_Null
(Loc
))));
6057 -- No expansion will be performed for VM targets, as
6058 -- the VM back-ends will handle the membership tests
6061 if Tagged_Type_Expansion
then
6063 -- Note that we have to pass Original_Node, because
6064 -- the membership test might already have been
6065 -- rewritten by earlier parts of membership test.
6068 (Original_Node
(N
), SCIL_Node
, New_N
);
6070 -- Update decoration of relocated node referenced
6071 -- by the SCIL node.
6073 if Generate_SCIL
and then Present
(SCIL_Node
) then
6074 Set_SCIL_Node
(New_N
, SCIL_Node
);
6079 Left_Opnd
=> Relocate_Node
(N
),
6080 Right_Opnd
=> New_N
));
6082 Analyze_And_Resolve
(N
, Restyp
);
6091 -- At this point, we have done the processing required for the basic
6092 -- membership test, but not yet dealt with the predicate.
6096 -- If a predicate is present, then we do the predicate test, but we
6097 -- most certainly want to omit this if we are within the predicate
6098 -- function itself, since otherwise we have an infinite recursion.
6099 -- The check should also not be emitted when testing against a range
6100 -- (the check is only done when the right operand is a subtype; see
6101 -- RM12-4.5.2 (28.1/3-30/3)).
6104 PFunc
: constant Entity_Id
:= Predicate_Function
(Rtyp
);
6108 and then Current_Scope
/= PFunc
6109 and then Nkind
(Rop
) /= N_Range
6113 Left_Opnd
=> Relocate_Node
(N
),
6114 Right_Opnd
=> Make_Predicate_Call
(Rtyp
, Lop
, Mem
=> True)));
6116 -- Analyze new expression, mark left operand as analyzed to
6117 -- avoid infinite recursion adding predicate calls. Similarly,
6118 -- suppress further range checks on the call.
6120 Set_Analyzed
(Left_Opnd
(N
));
6121 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
6123 -- All done, skip attempt at compile time determination of result
6130 --------------------------------
6131 -- Expand_N_Indexed_Component --
6132 --------------------------------
6134 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
6135 Loc
: constant Source_Ptr
:= Sloc
(N
);
6136 Typ
: constant Entity_Id
:= Etype
(N
);
6137 P
: constant Node_Id
:= Prefix
(N
);
6138 T
: constant Entity_Id
:= Etype
(P
);
6142 -- A special optimization, if we have an indexed component that is
6143 -- selecting from a slice, then we can eliminate the slice, since, for
6144 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6145 -- the range check required by the slice. The range check for the slice
6146 -- itself has already been generated. The range check for the
6147 -- subscripting operation is ensured by converting the subject to
6148 -- the subtype of the slice.
6150 -- This optimization not only generates better code, avoiding slice
6151 -- messing especially in the packed case, but more importantly bypasses
6152 -- some problems in handling this peculiar case, for example, the issue
6153 -- of dealing specially with object renamings.
6155 if Nkind
(P
) = N_Slice
6157 -- This optimization is disabled for CodePeer because it can transform
6158 -- an index-check constraint_error into a range-check constraint_error
6159 -- and CodePeer cares about that distinction.
6161 and then not CodePeer_Mode
6164 Make_Indexed_Component
(Loc
,
6165 Prefix
=> Prefix
(P
),
6166 Expressions
=> New_List
(
6168 (Etype
(First_Index
(Etype
(P
))),
6169 First
(Expressions
(N
))))));
6170 Analyze_And_Resolve
(N
, Typ
);
6174 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6175 -- function, then additional actuals must be passed.
6177 if Ada_Version
>= Ada_2005
6178 and then Is_Build_In_Place_Function_Call
(P
)
6180 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
6183 -- If the prefix is an access type, then we unconditionally rewrite if
6184 -- as an explicit dereference. This simplifies processing for several
6185 -- cases, including packed array cases and certain cases in which checks
6186 -- must be generated. We used to try to do this only when it was
6187 -- necessary, but it cleans up the code to do it all the time.
6189 if Is_Access_Type
(T
) then
6190 Insert_Explicit_Dereference
(P
);
6191 Analyze_And_Resolve
(P
, Designated_Type
(T
));
6192 Atp
:= Designated_Type
(T
);
6197 -- Generate index and validity checks
6199 Generate_Index_Checks
(N
);
6201 if Validity_Checks_On
and then Validity_Check_Subscripts
then
6202 Apply_Subscript_Validity_Checks
(N
);
6205 -- If selecting from an array with atomic components, and atomic sync
6206 -- is not suppressed for this array type, set atomic sync flag.
6208 if (Has_Atomic_Components
(Atp
)
6209 and then not Atomic_Synchronization_Disabled
(Atp
))
6210 or else (Is_Atomic
(Typ
)
6211 and then not Atomic_Synchronization_Disabled
(Typ
))
6212 or else (Is_Entity_Name
(P
)
6213 and then Has_Atomic_Components
(Entity
(P
))
6214 and then not Atomic_Synchronization_Disabled
(Entity
(P
)))
6216 Activate_Atomic_Synchronization
(N
);
6219 -- All done for the non-packed case
6221 if not Is_Packed
(Etype
(Prefix
(N
))) then
6225 -- For packed arrays that are not bit-packed (i.e. the case of an array
6226 -- with one or more index types with a non-contiguous enumeration type),
6227 -- we can always use the normal packed element get circuit.
6229 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
6230 Expand_Packed_Element_Reference
(N
);
6234 -- For a reference to a component of a bit packed array, we convert it
6235 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6236 -- want to do this for simple references, and not for:
6238 -- Left side of assignment, or prefix of left side of assignment, or
6239 -- prefix of the prefix, to handle packed arrays of packed arrays,
6240 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6242 -- Renaming objects in renaming associations
6243 -- This case is handled when a use of the renamed variable occurs
6245 -- Actual parameters for a procedure call
6246 -- This case is handled in Exp_Ch6.Expand_Actuals
6248 -- The second expression in a 'Read attribute reference
6250 -- The prefix of an address or bit or size attribute reference
6252 -- The following circuit detects these exceptions. Note that we need to
6253 -- deal with implicit dereferences when climbing up the parent chain,
6254 -- with the additional difficulty that the type of parents may have yet
6255 -- to be resolved since prefixes are usually resolved first.
6258 Child
: Node_Id
:= N
;
6259 Parnt
: Node_Id
:= Parent
(N
);
6263 if Nkind
(Parnt
) = N_Unchecked_Expression
then
6266 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
6267 N_Procedure_Call_Statement
)
6268 or else (Nkind
(Parnt
) = N_Parameter_Association
6270 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
6274 elsif Nkind
(Parnt
) = N_Attribute_Reference
6275 and then Nam_In
(Attribute_Name
(Parnt
), Name_Address
,
6278 and then Prefix
(Parnt
) = Child
6282 elsif Nkind
(Parnt
) = N_Assignment_Statement
6283 and then Name
(Parnt
) = Child
6287 -- If the expression is an index of an indexed component, it must
6288 -- be expanded regardless of context.
6290 elsif Nkind
(Parnt
) = N_Indexed_Component
6291 and then Child
/= Prefix
(Parnt
)
6293 Expand_Packed_Element_Reference
(N
);
6296 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
6297 and then Name
(Parent
(Parnt
)) = Parnt
6301 elsif Nkind
(Parnt
) = N_Attribute_Reference
6302 and then Attribute_Name
(Parnt
) = Name_Read
6303 and then Next
(First
(Expressions
(Parnt
))) = Child
6307 elsif Nkind
(Parnt
) = N_Indexed_Component
6308 and then Prefix
(Parnt
) = Child
6312 elsif Nkind
(Parnt
) = N_Selected_Component
6313 and then Prefix
(Parnt
) = Child
6314 and then not (Present
(Etype
(Selector_Name
(Parnt
)))
6316 Is_Access_Type
(Etype
(Selector_Name
(Parnt
))))
6320 -- If the parent is a dereference, either implicit or explicit,
6321 -- then the packed reference needs to be expanded.
6324 Expand_Packed_Element_Reference
(N
);
6328 -- Keep looking up tree for unchecked expression, or if we are the
6329 -- prefix of a possible assignment left side.
6332 Parnt
:= Parent
(Child
);
6335 end Expand_N_Indexed_Component
;
6337 ---------------------
6338 -- Expand_N_Not_In --
6339 ---------------------
6341 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6342 -- can be done. This avoids needing to duplicate this expansion code.
6344 procedure Expand_N_Not_In
(N
: Node_Id
) is
6345 Loc
: constant Source_Ptr
:= Sloc
(N
);
6346 Typ
: constant Entity_Id
:= Etype
(N
);
6347 Cfs
: constant Boolean := Comes_From_Source
(N
);
6354 Left_Opnd
=> Left_Opnd
(N
),
6355 Right_Opnd
=> Right_Opnd
(N
))));
6357 -- If this is a set membership, preserve list of alternatives
6359 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
6361 -- We want this to appear as coming from source if original does (see
6362 -- transformations in Expand_N_In).
6364 Set_Comes_From_Source
(N
, Cfs
);
6365 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
6367 -- Now analyze transformed node
6369 Analyze_And_Resolve
(N
, Typ
);
6370 end Expand_N_Not_In
;
6376 -- The only replacement required is for the case of a null of a type that
6377 -- is an access to protected subprogram, or a subtype thereof. We represent
6378 -- such access values as a record, and so we must replace the occurrence of
6379 -- null by the equivalent record (with a null address and a null pointer in
6380 -- it), so that the backend creates the proper value.
6382 procedure Expand_N_Null
(N
: Node_Id
) is
6383 Loc
: constant Source_Ptr
:= Sloc
(N
);
6384 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
6388 if Is_Access_Protected_Subprogram_Type
(Typ
) then
6390 Make_Aggregate
(Loc
,
6391 Expressions
=> New_List
(
6392 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
6396 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
6398 -- For subsequent semantic analysis, the node must retain its type.
6399 -- Gigi in any case replaces this type by the corresponding record
6400 -- type before processing the node.
6406 when RE_Not_Available
=>
6410 ---------------------
6411 -- Expand_N_Op_Abs --
6412 ---------------------
6414 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
6415 Loc
: constant Source_Ptr
:= Sloc
(N
);
6416 Expr
: constant Node_Id
:= Right_Opnd
(N
);
6419 Unary_Op_Validity_Checks
(N
);
6421 -- Check for MINIMIZED/ELIMINATED overflow mode
6423 if Minimized_Eliminated_Overflow_Check
(N
) then
6424 Apply_Arithmetic_Overflow_Check
(N
);
6428 -- Deal with software overflow checking
6430 if not Backend_Overflow_Checks_On_Target
6431 and then Is_Signed_Integer_Type
(Etype
(N
))
6432 and then Do_Overflow_Check
(N
)
6434 -- The only case to worry about is when the argument is equal to the
6435 -- largest negative number, so what we do is to insert the check:
6437 -- [constraint_error when Expr = typ'Base'First]
6439 -- with the usual Duplicate_Subexpr use coding for expr
6442 Make_Raise_Constraint_Error
(Loc
,
6445 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
6447 Make_Attribute_Reference
(Loc
,
6449 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
6450 Attribute_Name
=> Name_First
)),
6451 Reason
=> CE_Overflow_Check_Failed
));
6453 end Expand_N_Op_Abs
;
6455 ---------------------
6456 -- Expand_N_Op_Add --
6457 ---------------------
6459 procedure Expand_N_Op_Add
(N
: Node_Id
) is
6460 Typ
: constant Entity_Id
:= Etype
(N
);
6463 Binary_Op_Validity_Checks
(N
);
6465 -- Check for MINIMIZED/ELIMINATED overflow mode
6467 if Minimized_Eliminated_Overflow_Check
(N
) then
6468 Apply_Arithmetic_Overflow_Check
(N
);
6472 -- N + 0 = 0 + N = N for integer types
6474 if Is_Integer_Type
(Typ
) then
6475 if Compile_Time_Known_Value
(Right_Opnd
(N
))
6476 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
6478 Rewrite
(N
, Left_Opnd
(N
));
6481 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
6482 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
6484 Rewrite
(N
, Right_Opnd
(N
));
6489 -- Arithmetic overflow checks for signed integer/fixed point types
6491 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
6492 Apply_Arithmetic_Overflow_Check
(N
);
6496 -- Overflow checks for floating-point if -gnateF mode active
6498 Check_Float_Op_Overflow
(N
);
6499 end Expand_N_Op_Add
;
6501 ---------------------
6502 -- Expand_N_Op_And --
6503 ---------------------
6505 procedure Expand_N_Op_And
(N
: Node_Id
) is
6506 Typ
: constant Entity_Id
:= Etype
(N
);
6509 Binary_Op_Validity_Checks
(N
);
6511 if Is_Array_Type
(Etype
(N
)) then
6512 Expand_Boolean_Operator
(N
);
6514 elsif Is_Boolean_Type
(Etype
(N
)) then
6515 Adjust_Condition
(Left_Opnd
(N
));
6516 Adjust_Condition
(Right_Opnd
(N
));
6517 Set_Etype
(N
, Standard_Boolean
);
6518 Adjust_Result_Type
(N
, Typ
);
6520 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
6521 Expand_Intrinsic_Call
(N
, Entity
(N
));
6524 end Expand_N_Op_And
;
6526 ------------------------
6527 -- Expand_N_Op_Concat --
6528 ------------------------
6530 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
6532 -- List of operands to be concatenated
6535 -- Node which is to be replaced by the result of concatenating the nodes
6536 -- in the list Opnds.
6539 -- Ensure validity of both operands
6541 Binary_Op_Validity_Checks
(N
);
6543 -- If we are the left operand of a concatenation higher up the tree,
6544 -- then do nothing for now, since we want to deal with a series of
6545 -- concatenations as a unit.
6547 if Nkind
(Parent
(N
)) = N_Op_Concat
6548 and then N
= Left_Opnd
(Parent
(N
))
6553 -- We get here with a concatenation whose left operand may be a
6554 -- concatenation itself with a consistent type. We need to process
6555 -- these concatenation operands from left to right, which means
6556 -- from the deepest node in the tree to the highest node.
6559 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
6560 Cnode
:= Left_Opnd
(Cnode
);
6563 -- Now Cnode is the deepest concatenation, and its parents are the
6564 -- concatenation nodes above, so now we process bottom up, doing the
6567 -- The outer loop runs more than once if more than one concatenation
6568 -- type is involved.
6571 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
6572 Set_Parent
(Opnds
, N
);
6574 -- The inner loop gathers concatenation operands
6576 Inner
: while Cnode
/= N
6577 and then Base_Type
(Etype
(Cnode
)) =
6578 Base_Type
(Etype
(Parent
(Cnode
)))
6580 Cnode
:= Parent
(Cnode
);
6581 Append
(Right_Opnd
(Cnode
), Opnds
);
6584 -- Note: The following code is a temporary workaround for N731-034
6585 -- and N829-028 and will be kept until the general issue of internal
6586 -- symbol serialization is addressed. The workaround is kept under a
6587 -- debug switch to avoid permiating into the general case.
6589 -- Wrap the node to concatenate into an expression actions node to
6590 -- keep it nicely packaged. This is useful in the case of an assert
6591 -- pragma with a concatenation where we want to be able to delete
6592 -- the concatenation and all its expansion stuff.
6594 if Debug_Flag_Dot_H
then
6596 Cnod
: constant Node_Id
:= Relocate_Node
(Cnode
);
6597 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
6600 -- Note: use Rewrite rather than Replace here, so that for
6601 -- example Why_Not_Static can find the original concatenation
6605 Make_Expression_With_Actions
(Sloc
(Cnode
),
6606 Actions
=> New_List
(Make_Null_Statement
(Sloc
(Cnode
))),
6607 Expression
=> Cnod
));
6609 Expand_Concatenate
(Cnod
, Opnds
);
6610 Analyze_And_Resolve
(Cnode
, Typ
);
6616 Expand_Concatenate
(Cnode
, Opnds
);
6619 exit Outer
when Cnode
= N
;
6620 Cnode
:= Parent
(Cnode
);
6622 end Expand_N_Op_Concat
;
6624 ------------------------
6625 -- Expand_N_Op_Divide --
6626 ------------------------
6628 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
6629 Loc
: constant Source_Ptr
:= Sloc
(N
);
6630 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
6631 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
6632 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
6633 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
6634 Typ
: Entity_Id
:= Etype
(N
);
6635 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
6637 Compile_Time_Known_Value
(Ropnd
);
6641 Binary_Op_Validity_Checks
(N
);
6643 -- Check for MINIMIZED/ELIMINATED overflow mode
6645 if Minimized_Eliminated_Overflow_Check
(N
) then
6646 Apply_Arithmetic_Overflow_Check
(N
);
6650 -- Otherwise proceed with expansion of division
6653 Rval
:= Expr_Value
(Ropnd
);
6656 -- N / 1 = N for integer types
6658 if Rknow
and then Rval
= Uint_1
then
6663 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6664 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6665 -- operand is an unsigned integer, as required for this to work.
6667 if Nkind
(Ropnd
) = N_Op_Expon
6668 and then Is_Power_Of_2_For_Shift
(Ropnd
)
6670 -- We cannot do this transformation in configurable run time mode if we
6671 -- have 64-bit integers and long shifts are not available.
6673 and then (Esize
(Ltyp
) <= 32 or else Support_Long_Shifts_On_Target
)
6676 Make_Op_Shift_Right
(Loc
,
6679 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
6680 Analyze_And_Resolve
(N
, Typ
);
6684 -- Do required fixup of universal fixed operation
6686 if Typ
= Universal_Fixed
then
6687 Fixup_Universal_Fixed_Operation
(N
);
6691 -- Divisions with fixed-point results
6693 if Is_Fixed_Point_Type
(Typ
) then
6695 -- Deal with divide-by-zero check if back end cannot handle them
6696 -- and the flag is set indicating that we need such a check. Note
6697 -- that we don't need to bother here with the case of mixed-mode
6698 -- (Right operand an integer type), since these will be rewritten
6699 -- with conversions to a divide with a fixed-point right operand.
6701 if Do_Division_Check
(N
)
6702 and then not Backend_Divide_Checks_On_Target
6703 and then not Is_Integer_Type
(Rtyp
)
6705 Set_Do_Division_Check
(N
, False);
6707 Make_Raise_Constraint_Error
(Loc
,
6710 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Ropnd
),
6711 Right_Opnd
=> Make_Real_Literal
(Loc
, Ureal_0
)),
6712 Reason
=> CE_Divide_By_Zero
));
6715 -- No special processing if Treat_Fixed_As_Integer is set, since
6716 -- from a semantic point of view such operations are simply integer
6717 -- operations and will be treated that way.
6719 if not Treat_Fixed_As_Integer
(N
) then
6720 if Is_Integer_Type
(Rtyp
) then
6721 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
6723 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
6727 -- Other cases of division of fixed-point operands. Again we exclude the
6728 -- case where Treat_Fixed_As_Integer is set.
6730 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
6731 and then not Treat_Fixed_As_Integer
(N
)
6733 if Is_Integer_Type
(Typ
) then
6734 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
6736 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6737 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
6740 -- Mixed-mode operations can appear in a non-static universal context,
6741 -- in which case the integer argument must be converted explicitly.
6743 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
6745 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
6747 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
6749 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
6751 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
6753 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
6755 -- Non-fixed point cases, do integer zero divide and overflow checks
6757 elsif Is_Integer_Type
(Typ
) then
6758 Apply_Divide_Checks
(N
);
6761 -- Overflow checks for floating-point if -gnateF mode active
6763 Check_Float_Op_Overflow
(N
);
6764 end Expand_N_Op_Divide
;
6766 --------------------
6767 -- Expand_N_Op_Eq --
6768 --------------------
6770 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
6771 Loc
: constant Source_Ptr
:= Sloc
(N
);
6772 Typ
: constant Entity_Id
:= Etype
(N
);
6773 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
6774 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
6775 Bodies
: constant List_Id
:= New_List
;
6776 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
6778 Typl
: Entity_Id
:= A_Typ
;
6779 Op_Name
: Entity_Id
;
6782 procedure Build_Equality_Call
(Eq
: Entity_Id
);
6783 -- If a constructed equality exists for the type or for its parent,
6784 -- build and analyze call, adding conversions if the operation is
6787 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
6788 -- Determines whether a type has a subcomponent of an unconstrained
6789 -- Unchecked_Union subtype. Typ is a record type.
6791 -------------------------
6792 -- Build_Equality_Call --
6793 -------------------------
6795 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
6796 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
6797 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
6798 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
6801 -- Adjust operands if necessary to comparison type
6803 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
6804 and then not Is_Class_Wide_Type
(A_Typ
)
6806 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
6807 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
6810 -- If we have an Unchecked_Union, we need to add the inferred
6811 -- discriminant values as actuals in the function call. At this
6812 -- point, the expansion has determined that both operands have
6813 -- inferable discriminants.
6815 if Is_Unchecked_Union
(Op_Type
) then
6817 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
6818 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
6820 Lhs_Discr_Vals
: Elist_Id
;
6821 -- List of inferred discriminant values for left operand.
6823 Rhs_Discr_Vals
: Elist_Id
;
6824 -- List of inferred discriminant values for right operand.
6829 Lhs_Discr_Vals
:= New_Elmt_List
;
6830 Rhs_Discr_Vals
:= New_Elmt_List
;
6832 -- Per-object constrained selected components require special
6833 -- attention. If the enclosing scope of the component is an
6834 -- Unchecked_Union, we cannot reference its discriminants
6835 -- directly. This is why we use the extra parameters of the
6836 -- equality function of the enclosing Unchecked_Union.
6838 -- type UU_Type (Discr : Integer := 0) is
6841 -- pragma Unchecked_Union (UU_Type);
6843 -- 1. Unchecked_Union enclosing record:
6845 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6847 -- Comp : UU_Type (Discr);
6849 -- end Enclosing_UU_Type;
6850 -- pragma Unchecked_Union (Enclosing_UU_Type);
6852 -- Obj1 : Enclosing_UU_Type;
6853 -- Obj2 : Enclosing_UU_Type (1);
6855 -- [. . .] Obj1 = Obj2 [. . .]
6859 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6861 -- A and B are the formal parameters of the equality function
6862 -- of Enclosing_UU_Type. The function always has two extra
6863 -- formals to capture the inferred discriminant values for
6864 -- each discriminant of the type.
6866 -- 2. Non-Unchecked_Union enclosing record:
6869 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6872 -- Comp : UU_Type (Discr);
6874 -- end Enclosing_Non_UU_Type;
6876 -- Obj1 : Enclosing_Non_UU_Type;
6877 -- Obj2 : Enclosing_Non_UU_Type (1);
6879 -- ... Obj1 = Obj2 ...
6883 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6884 -- obj1.discr, obj2.discr)) then
6886 -- In this case we can directly reference the discriminants of
6887 -- the enclosing record.
6889 -- Process left operand of equality
6891 if Nkind
(Lhs
) = N_Selected_Component
6893 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Lhs
)))
6895 -- If enclosing record is an Unchecked_Union, use formals
6896 -- corresponding to each discriminant. The name of the
6897 -- formal is that of the discriminant, with added suffix,
6898 -- see Exp_Ch3.Build_Record_Equality for details.
6900 if Is_Unchecked_Union
(Scope
(Entity
(Selector_Name
(Lhs
))))
6904 (Scope
(Entity
(Selector_Name
(Lhs
))));
6905 while Present
(Discr
) loop
6907 (Make_Identifier
(Loc
,
6908 Chars
=> New_External_Name
(Chars
(Discr
), 'A')),
6909 To
=> Lhs_Discr_Vals
);
6910 Next_Discriminant
(Discr
);
6913 -- If enclosing record is of a non-Unchecked_Union type, it
6914 -- is possible to reference its discriminants directly.
6917 Discr
:= First_Discriminant
(Lhs_Type
);
6918 while Present
(Discr
) loop
6920 (Make_Selected_Component
(Loc
,
6921 Prefix
=> Prefix
(Lhs
),
6924 (Get_Discriminant_Value
(Discr
,
6926 Stored_Constraint
(Lhs_Type
)))),
6927 To
=> Lhs_Discr_Vals
);
6928 Next_Discriminant
(Discr
);
6932 -- Otherwise operand is on object with a constrained type.
6933 -- Infer the discriminant values from the constraint.
6937 Discr
:= First_Discriminant
(Lhs_Type
);
6938 while Present
(Discr
) loop
6941 (Get_Discriminant_Value
(Discr
,
6943 Stored_Constraint
(Lhs_Type
))),
6944 To
=> Lhs_Discr_Vals
);
6945 Next_Discriminant
(Discr
);
6949 -- Similar processing for right operand of equality
6951 if Nkind
(Rhs
) = N_Selected_Component
6953 Has_Per_Object_Constraint
(Entity
(Selector_Name
(Rhs
)))
6955 if Is_Unchecked_Union
6956 (Scope
(Entity
(Selector_Name
(Rhs
))))
6960 (Scope
(Entity
(Selector_Name
(Rhs
))));
6961 while Present
(Discr
) loop
6963 (Make_Identifier
(Loc
,
6964 Chars
=> New_External_Name
(Chars
(Discr
), 'B')),
6965 To
=> Rhs_Discr_Vals
);
6966 Next_Discriminant
(Discr
);
6970 Discr
:= First_Discriminant
(Rhs_Type
);
6971 while Present
(Discr
) loop
6973 (Make_Selected_Component
(Loc
,
6974 Prefix
=> Prefix
(Rhs
),
6976 New_Copy
(Get_Discriminant_Value
6979 Stored_Constraint
(Rhs_Type
)))),
6980 To
=> Rhs_Discr_Vals
);
6981 Next_Discriminant
(Discr
);
6986 Discr
:= First_Discriminant
(Rhs_Type
);
6987 while Present
(Discr
) loop
6989 (New_Copy
(Get_Discriminant_Value
6992 Stored_Constraint
(Rhs_Type
))),
6993 To
=> Rhs_Discr_Vals
);
6994 Next_Discriminant
(Discr
);
6998 -- Now merge the list of discriminant values so that values
6999 -- of corresponding discriminants are adjacent.
7007 Params
:= New_List
(L_Exp
, R_Exp
);
7008 L_Elmt
:= First_Elmt
(Lhs_Discr_Vals
);
7009 R_Elmt
:= First_Elmt
(Rhs_Discr_Vals
);
7010 while Present
(L_Elmt
) loop
7011 Append_To
(Params
, Node
(L_Elmt
));
7012 Append_To
(Params
, Node
(R_Elmt
));
7018 Make_Function_Call
(Loc
,
7019 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7020 Parameter_Associations
=> Params
));
7024 -- Normal case, not an unchecked union
7028 Make_Function_Call
(Loc
,
7029 Name
=> New_Occurrence_Of
(Eq
, Loc
),
7030 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
7033 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7034 end Build_Equality_Call
;
7036 ------------------------------------
7037 -- Has_Unconstrained_UU_Component --
7038 ------------------------------------
7040 function Has_Unconstrained_UU_Component
7041 (Typ
: Node_Id
) return Boolean
7043 Tdef
: constant Node_Id
:=
7044 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
7048 function Component_Is_Unconstrained_UU
7049 (Comp
: Node_Id
) return Boolean;
7050 -- Determines whether the subtype of the component is an
7051 -- unconstrained Unchecked_Union.
7053 function Variant_Is_Unconstrained_UU
7054 (Variant
: Node_Id
) return Boolean;
7055 -- Determines whether a component of the variant has an unconstrained
7056 -- Unchecked_Union subtype.
7058 -----------------------------------
7059 -- Component_Is_Unconstrained_UU --
7060 -----------------------------------
7062 function Component_Is_Unconstrained_UU
7063 (Comp
: Node_Id
) return Boolean
7066 if Nkind
(Comp
) /= N_Component_Declaration
then
7071 Sindic
: constant Node_Id
:=
7072 Subtype_Indication
(Component_Definition
(Comp
));
7075 -- Unconstrained nominal type. In the case of a constraint
7076 -- present, the node kind would have been N_Subtype_Indication.
7078 if Nkind
(Sindic
) = N_Identifier
then
7079 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
7084 end Component_Is_Unconstrained_UU
;
7086 ---------------------------------
7087 -- Variant_Is_Unconstrained_UU --
7088 ---------------------------------
7090 function Variant_Is_Unconstrained_UU
7091 (Variant
: Node_Id
) return Boolean
7093 Clist
: constant Node_Id
:= Component_List
(Variant
);
7096 if Is_Empty_List
(Component_Items
(Clist
)) then
7100 -- We only need to test one component
7103 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7106 while Present
(Comp
) loop
7107 if Component_Is_Unconstrained_UU
(Comp
) then
7115 -- None of the components withing the variant were of
7116 -- unconstrained Unchecked_Union type.
7119 end Variant_Is_Unconstrained_UU
;
7121 -- Start of processing for Has_Unconstrained_UU_Component
7124 if Null_Present
(Tdef
) then
7128 Clist
:= Component_List
(Tdef
);
7129 Vpart
:= Variant_Part
(Clist
);
7131 -- Inspect available components
7133 if Present
(Component_Items
(Clist
)) then
7135 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
7138 while Present
(Comp
) loop
7140 -- One component is sufficient
7142 if Component_Is_Unconstrained_UU
(Comp
) then
7151 -- Inspect available components withing variants
7153 if Present
(Vpart
) then
7155 Variant
: Node_Id
:= First
(Variants
(Vpart
));
7158 while Present
(Variant
) loop
7160 -- One component within a variant is sufficient
7162 if Variant_Is_Unconstrained_UU
(Variant
) then
7171 -- Neither the available components, nor the components inside the
7172 -- variant parts were of an unconstrained Unchecked_Union subtype.
7175 end Has_Unconstrained_UU_Component
;
7177 -- Start of processing for Expand_N_Op_Eq
7180 Binary_Op_Validity_Checks
(N
);
7182 -- Deal with private types
7184 if Ekind
(Typl
) = E_Private_Type
then
7185 Typl
:= Underlying_Type
(Typl
);
7186 elsif Ekind
(Typl
) = E_Private_Subtype
then
7187 Typl
:= Underlying_Type
(Base_Type
(Typl
));
7192 -- It may happen in error situations that the underlying type is not
7193 -- set. The error will be detected later, here we just defend the
7200 -- Now get the implementation base type (note that plain Base_Type here
7201 -- might lead us back to the private type, which is not what we want!)
7203 Typl
:= Implementation_Base_Type
(Typl
);
7205 -- Equality between variant records results in a call to a routine
7206 -- that has conditional tests of the discriminant value(s), and hence
7207 -- violates the No_Implicit_Conditionals restriction.
7209 if Has_Variant_Part
(Typl
) then
7214 Check_Restriction
(Msg
, No_Implicit_Conditionals
, N
);
7218 ("\comparison of variant records tests discriminants", N
);
7224 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7225 -- means we no longer have a comparison operation, we are all done.
7227 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
7229 if Nkind
(N
) /= N_Op_Eq
then
7233 -- Boolean types (requiring handling of non-standard case)
7235 if Is_Boolean_Type
(Typl
) then
7236 Adjust_Condition
(Left_Opnd
(N
));
7237 Adjust_Condition
(Right_Opnd
(N
));
7238 Set_Etype
(N
, Standard_Boolean
);
7239 Adjust_Result_Type
(N
, Typ
);
7243 elsif Is_Array_Type
(Typl
) then
7245 -- If we are doing full validity checking, and it is possible for the
7246 -- array elements to be invalid then expand out array comparisons to
7247 -- make sure that we check the array elements.
7249 if Validity_Check_Operands
7250 and then not Is_Known_Valid
(Component_Type
(Typl
))
7253 Save_Force_Validity_Checks
: constant Boolean :=
7254 Force_Validity_Checks
;
7256 Force_Validity_Checks
:= True;
7258 Expand_Array_Equality
7260 Relocate_Node
(Lhs
),
7261 Relocate_Node
(Rhs
),
7264 Insert_Actions
(N
, Bodies
);
7265 Analyze_And_Resolve
(N
, Standard_Boolean
);
7266 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
7269 -- Packed case where both operands are known aligned
7271 elsif Is_Bit_Packed_Array
(Typl
)
7272 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7273 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7275 Expand_Packed_Eq
(N
);
7277 -- Where the component type is elementary we can use a block bit
7278 -- comparison (if supported on the target) exception in the case
7279 -- of floating-point (negative zero issues require element by
7280 -- element comparison), and atomic/VFA types (where we must be sure
7281 -- to load elements independently) and possibly unaligned arrays.
7283 elsif Is_Elementary_Type
(Component_Type
(Typl
))
7284 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
7285 and then not Is_Atomic_Or_VFA
(Component_Type
(Typl
))
7286 and then not Is_Possibly_Unaligned_Object
(Lhs
)
7287 and then not Is_Possibly_Unaligned_Object
(Rhs
)
7288 and then Support_Composite_Compare_On_Target
7292 -- For composite and floating-point cases, expand equality loop to
7293 -- make sure of using proper comparisons for tagged types, and
7294 -- correctly handling the floating-point case.
7298 Expand_Array_Equality
7300 Relocate_Node
(Lhs
),
7301 Relocate_Node
(Rhs
),
7304 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7305 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7310 elsif Is_Record_Type
(Typl
) then
7312 -- For tagged types, use the primitive "="
7314 if Is_Tagged_Type
(Typl
) then
7316 -- No need to do anything else compiling under restriction
7317 -- No_Dispatching_Calls. During the semantic analysis we
7318 -- already notified such violation.
7320 if Restriction_Active
(No_Dispatching_Calls
) then
7324 -- If this is derived from an untagged private type completed with
7325 -- a tagged type, it does not have a full view, so we use the
7326 -- primitive operations of the private type. This check should no
7327 -- longer be necessary when these types get their full views???
7329 if Is_Private_Type
(A_Typ
)
7330 and then not Is_Tagged_Type
(A_Typ
)
7331 and then Is_Derived_Type
(A_Typ
)
7332 and then No
(Full_View
(A_Typ
))
7334 -- Search for equality operation, checking that the operands
7335 -- have the same type. Note that we must find a matching entry,
7336 -- or something is very wrong.
7338 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
7340 while Present
(Prim
) loop
7341 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7342 and then Etype
(First_Formal
(Node
(Prim
))) =
7343 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7345 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7350 pragma Assert
(Present
(Prim
));
7351 Op_Name
:= Node
(Prim
);
7353 -- Find the type's predefined equality or an overriding
7354 -- user-defined equality. The reason for not simply calling
7355 -- Find_Prim_Op here is that there may be a user-defined
7356 -- overloaded equality op that precedes the equality that we
7357 -- want, so we have to explicitly search (e.g., there could be
7358 -- an equality with two different parameter types).
7361 if Is_Class_Wide_Type
(Typl
) then
7362 Typl
:= Find_Specific_Type
(Typl
);
7365 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
7366 while Present
(Prim
) loop
7367 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7368 and then Etype
(First_Formal
(Node
(Prim
))) =
7369 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7371 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7376 pragma Assert
(Present
(Prim
));
7377 Op_Name
:= Node
(Prim
);
7380 Build_Equality_Call
(Op_Name
);
7382 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7383 -- predefined equality operator for a type which has a subcomponent
7384 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7386 elsif Has_Unconstrained_UU_Component
(Typl
) then
7388 Make_Raise_Program_Error
(Loc
,
7389 Reason
=> PE_Unchecked_Union_Restriction
));
7391 -- Prevent Gigi from generating incorrect code by rewriting the
7392 -- equality as a standard False. (is this documented somewhere???)
7395 New_Occurrence_Of
(Standard_False
, Loc
));
7397 elsif Is_Unchecked_Union
(Typl
) then
7399 -- If we can infer the discriminants of the operands, we make a
7400 -- call to the TSS equality function.
7402 if Has_Inferable_Discriminants
(Lhs
)
7404 Has_Inferable_Discriminants
(Rhs
)
7407 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7410 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7411 -- the predefined equality operator for an Unchecked_Union type
7412 -- if either of the operands lack inferable discriminants.
7415 Make_Raise_Program_Error
(Loc
,
7416 Reason
=> PE_Unchecked_Union_Restriction
));
7418 -- Emit a warning on source equalities only, otherwise the
7419 -- message may appear out of place due to internal use. The
7420 -- warning is unconditional because it is required by the
7423 if Comes_From_Source
(N
) then
7425 ("Unchecked_Union discriminants cannot be determined??",
7428 ("\Program_Error will be raised for equality operation??",
7432 -- Prevent Gigi from generating incorrect code by rewriting
7433 -- the equality as a standard False (documented where???).
7436 New_Occurrence_Of
(Standard_False
, Loc
));
7439 -- If a type support function is present (for complex cases), use it
7441 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
7443 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
7445 -- When comparing two Bounded_Strings, use the primitive equality of
7446 -- the root Super_String type.
7448 elsif Is_Bounded_String
(Typl
) then
7450 First_Elmt
(Collect_Primitive_Operations
(Root_Type
(Typl
)));
7452 while Present
(Prim
) loop
7453 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
7454 and then Etype
(First_Formal
(Node
(Prim
))) =
7455 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
7456 and then Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
7461 -- A Super_String type should always have a primitive equality
7463 pragma Assert
(Present
(Prim
));
7464 Build_Equality_Call
(Node
(Prim
));
7466 -- Otherwise expand the component by component equality. Note that
7467 -- we never use block-bit comparisons for records, because of the
7468 -- problems with gaps. The backend will often be able to recombine
7469 -- the separate comparisons that we generate here.
7472 Remove_Side_Effects
(Lhs
);
7473 Remove_Side_Effects
(Rhs
);
7475 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
7477 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
7478 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
7482 -- Test if result is known at compile time
7484 Rewrite_Comparison
(N
);
7486 -- Special optimization of length comparison
7488 Optimize_Length_Comparison
(N
);
7490 -- One more special case: if we have a comparison of X'Result = expr
7491 -- in floating-point, then if not already there, change expr to be
7492 -- f'Machine (expr) to eliminate surprise from extra precision.
7494 if Is_Floating_Point_Type
(Typl
)
7495 and then Nkind
(Original_Node
(Lhs
)) = N_Attribute_Reference
7496 and then Attribute_Name
(Original_Node
(Lhs
)) = Name_Result
7498 -- Stick in the Typ'Machine call if not already there
7500 if Nkind
(Rhs
) /= N_Attribute_Reference
7501 or else Attribute_Name
(Rhs
) /= Name_Machine
7504 Make_Attribute_Reference
(Loc
,
7505 Prefix
=> New_Occurrence_Of
(Typl
, Loc
),
7506 Attribute_Name
=> Name_Machine
,
7507 Expressions
=> New_List
(Relocate_Node
(Rhs
))));
7508 Analyze_And_Resolve
(Rhs
, Typl
);
7513 -----------------------
7514 -- Expand_N_Op_Expon --
7515 -----------------------
7517 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
7518 Loc
: constant Source_Ptr
:= Sloc
(N
);
7519 Typ
: constant Entity_Id
:= Etype
(N
);
7520 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
7521 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
7522 Bastyp
: constant Node_Id
:= Etype
(Base
);
7523 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
7524 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
7525 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
7533 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
;
7534 -- Given an expression Exp, if the root type is Float or Long_Float,
7535 -- then wrap the expression in a call of Bastyp'Machine, to stop any
7536 -- extra precision. This is done to ensure that X**A = X**B when A is
7537 -- a static constant and B is a variable with the same value. For any
7538 -- other type, the node Exp is returned unchanged.
7544 function Wrap_MA
(Exp
: Node_Id
) return Node_Id
is
7545 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
7547 if Rtyp
= Standard_Float
or else Rtyp
= Standard_Long_Float
then
7549 Make_Attribute_Reference
(Loc
,
7550 Attribute_Name
=> Name_Machine
,
7551 Prefix
=> New_Occurrence_Of
(Bastyp
, Loc
),
7552 Expressions
=> New_List
(Relocate_Node
(Exp
)));
7558 -- Start of processing for Expand_N_Op
7561 Binary_Op_Validity_Checks
(N
);
7563 -- CodePeer wants to see the unexpanded N_Op_Expon node
7565 if CodePeer_Mode
then
7569 -- If either operand is of a private type, then we have the use of an
7570 -- intrinsic operator, and we get rid of the privateness, by using root
7571 -- types of underlying types for the actual operation. Otherwise the
7572 -- private types will cause trouble if we expand multiplications or
7573 -- shifts etc. We also do this transformation if the result type is
7574 -- different from the base type.
7576 if Is_Private_Type
(Etype
(Base
))
7577 or else Is_Private_Type
(Typ
)
7578 or else Is_Private_Type
(Exptyp
)
7579 or else Rtyp
/= Root_Type
(Bastyp
)
7582 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
7583 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
7586 Unchecked_Convert_To
(Typ
,
7588 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
7589 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
7590 Analyze_And_Resolve
(N
, Typ
);
7595 -- Check for MINIMIZED/ELIMINATED overflow mode
7597 if Minimized_Eliminated_Overflow_Check
(N
) then
7598 Apply_Arithmetic_Overflow_Check
(N
);
7602 -- Test for case of known right argument where we can replace the
7603 -- exponentiation by an equivalent expression using multiplication.
7605 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7606 -- configurable run-time mode, we may not have the exponentiation
7607 -- routine available, and we don't want the legality of the program
7608 -- to depend on how clever the compiler is in knowing values.
7610 if CRT_Safe_Compile_Time_Known_Value
(Exp
) then
7611 Expv
:= Expr_Value
(Exp
);
7613 -- We only fold small non-negative exponents. You might think we
7614 -- could fold small negative exponents for the real case, but we
7615 -- can't because we are required to raise Constraint_Error for
7616 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7617 -- See ACVC test C4A012B, and it is not worth generating the test.
7619 if Expv
>= 0 and then Expv
<= 4 then
7621 -- X ** 0 = 1 (or 1.0)
7625 -- Call Remove_Side_Effects to ensure that any side effects
7626 -- in the ignored left operand (in particular function calls
7627 -- to user defined functions) are properly executed.
7629 Remove_Side_Effects
(Base
);
7631 if Ekind
(Typ
) in Integer_Kind
then
7632 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
7634 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
7647 Make_Op_Multiply
(Loc
,
7648 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7649 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
7651 -- X ** 3 = X * X * X
7656 Make_Op_Multiply
(Loc
,
7658 Make_Op_Multiply
(Loc
,
7659 Left_Opnd
=> Duplicate_Subexpr
(Base
),
7660 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
7661 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)));
7666 -- En : constant base'type := base * base;
7671 pragma Assert
(Expv
= 4);
7672 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
7675 Make_Expression_With_Actions
(Loc
,
7676 Actions
=> New_List
(
7677 Make_Object_Declaration
(Loc
,
7678 Defining_Identifier
=> Temp
,
7679 Constant_Present
=> True,
7680 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7683 Make_Op_Multiply
(Loc
,
7685 Duplicate_Subexpr
(Base
),
7687 Duplicate_Subexpr_No_Checks
(Base
))))),
7691 Make_Op_Multiply
(Loc
,
7692 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
7693 Right_Opnd
=> New_Occurrence_Of
(Temp
, Loc
))));
7697 Analyze_And_Resolve
(N
, Typ
);
7702 -- Deal with optimizing 2 ** expression to shift where possible
7704 -- Note: we used to check that Exptyp was an unsigned type. But that is
7705 -- an unnecessary check, since if Exp is negative, we have a run-time
7706 -- error that is either caught (so we get the right result) or we have
7707 -- suppressed the check, in which case the code is erroneous anyway.
7709 if Is_Integer_Type
(Rtyp
)
7711 -- The base value must be "safe compile-time known", and exactly 2
7713 and then Nkind
(Base
) = N_Integer_Literal
7714 and then CRT_Safe_Compile_Time_Known_Value
(Base
)
7715 and then Expr_Value
(Base
) = Uint_2
7717 -- We only handle cases where the right type is a integer
7719 and then Is_Integer_Type
(Root_Type
(Exptyp
))
7720 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
7722 -- This transformation is not applicable for a modular type with a
7723 -- nonbinary modulus because we do not handle modular reduction in
7724 -- a correct manner if we attempt this transformation in this case.
7726 and then not Non_Binary_Modulus
(Typ
)
7728 -- Handle the cases where our parent is a division or multiplication
7729 -- specially. In these cases we can convert to using a shift at the
7730 -- parent level if we are not doing overflow checking, since it is
7731 -- too tricky to combine the overflow check at the parent level.
7734 and then Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
)
7737 P
: constant Node_Id
:= Parent
(N
);
7738 L
: constant Node_Id
:= Left_Opnd
(P
);
7739 R
: constant Node_Id
:= Right_Opnd
(P
);
7742 if (Nkind
(P
) = N_Op_Multiply
7744 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
7746 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
7747 and then not Do_Overflow_Check
(P
))
7750 (Nkind
(P
) = N_Op_Divide
7751 and then Is_Integer_Type
(Etype
(L
))
7752 and then Is_Unsigned_Type
(Etype
(L
))
7754 and then not Do_Overflow_Check
(P
))
7756 Set_Is_Power_Of_2_For_Shift
(N
);
7761 -- Here we just have 2 ** N on its own, so we can convert this to a
7762 -- shift node. We are prepared to deal with overflow here, and we
7763 -- also have to handle proper modular reduction for binary modular.
7772 -- Maximum shift count with no overflow
7775 -- Set True if we must test the shift count
7778 -- Node for test against TestS
7781 -- Compute maximum shift based on the underlying size. For a
7782 -- modular type this is one less than the size.
7784 if Is_Modular_Integer_Type
(Typ
) then
7786 -- For modular integer types, this is the size of the value
7787 -- being shifted minus one. Any larger values will cause
7788 -- modular reduction to a result of zero. Note that we do
7789 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
7790 -- of 6, since 2**7 should be reduced to zero).
7792 MaxS
:= RM_Size
(Rtyp
) - 1;
7794 -- For signed integer types, we use the size of the value
7795 -- being shifted minus 2. Larger values cause overflow.
7798 MaxS
:= Esize
(Rtyp
) - 2;
7801 -- Determine range to see if it can be larger than MaxS
7804 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
7805 TestS
:= (not OK
) or else Hi
> MaxS
;
7807 -- Signed integer case
7809 if Is_Signed_Integer_Type
(Typ
) then
7811 -- Generate overflow check if overflow is active. Note that
7812 -- we can simply ignore the possibility of overflow if the
7813 -- flag is not set (means that overflow cannot happen or
7814 -- that overflow checks are suppressed).
7816 if Ovflo
and TestS
then
7818 Make_Raise_Constraint_Error
(Loc
,
7821 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
7822 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
)),
7823 Reason
=> CE_Overflow_Check_Failed
));
7826 -- Now rewrite node as Shift_Left (1, right-operand)
7829 Make_Op_Shift_Left
(Loc
,
7830 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7831 Right_Opnd
=> Right_Opnd
(N
)));
7833 -- Modular integer case
7835 else pragma Assert
(Is_Modular_Integer_Type
(Typ
));
7837 -- If shift count can be greater than MaxS, we need to wrap
7838 -- the shift in a test that will reduce the result value to
7839 -- zero if this shift count is exceeded.
7843 -- Note: build node for the comparison first, before we
7844 -- reuse the Right_Opnd, so that we have proper parents
7845 -- in place for the Duplicate_Subexpr call.
7849 Left_Opnd
=> Duplicate_Subexpr
(Right_Opnd
(N
)),
7850 Right_Opnd
=> Make_Integer_Literal
(Loc
, MaxS
));
7853 Make_If_Expression
(Loc
,
7854 Expressions
=> New_List
(
7856 Make_Integer_Literal
(Loc
, Uint_0
),
7857 Make_Op_Shift_Left
(Loc
,
7858 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7859 Right_Opnd
=> Right_Opnd
(N
)))));
7861 -- If we know shift count cannot be greater than MaxS, then
7862 -- it is safe to just rewrite as a shift with no test.
7866 Make_Op_Shift_Left
(Loc
,
7867 Left_Opnd
=> Make_Integer_Literal
(Loc
, Uint_1
),
7868 Right_Opnd
=> Right_Opnd
(N
)));
7872 Analyze_And_Resolve
(N
, Typ
);
7878 -- Fall through if exponentiation must be done using a runtime routine
7880 -- First deal with modular case
7882 if Is_Modular_Integer_Type
(Rtyp
) then
7884 -- Nonbinary modular case, we call the special exponentiation
7885 -- routine for the nonbinary case, converting the argument to
7886 -- Long_Long_Integer and passing the modulus value. Then the
7887 -- result is converted back to the base type.
7889 if Non_Binary_Modulus
(Rtyp
) then
7892 Make_Function_Call
(Loc
,
7894 New_Occurrence_Of
(RTE
(RE_Exp_Modular
), Loc
),
7895 Parameter_Associations
=> New_List
(
7896 Convert_To
(RTE
(RE_Unsigned
), Base
),
7897 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
7900 -- Binary modular case, in this case, we call one of two routines,
7901 -- either the unsigned integer case, or the unsigned long long
7902 -- integer case, with a final "and" operation to do the required mod.
7905 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
7906 Ent
:= RTE
(RE_Exp_Unsigned
);
7908 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
7915 Make_Function_Call
(Loc
,
7916 Name
=> New_Occurrence_Of
(Ent
, Loc
),
7917 Parameter_Associations
=> New_List
(
7918 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
7921 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
7925 -- Common exit point for modular type case
7927 Analyze_And_Resolve
(N
, Typ
);
7930 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7931 -- It is not worth having routines for Short_[Short_]Integer, since for
7932 -- most machines it would not help, and it would generate more code that
7933 -- might need certification when a certified run time is required.
7935 -- In the integer cases, we have two routines, one for when overflow
7936 -- checks are required, and one when they are not required, since there
7937 -- is a real gain in omitting checks on many machines.
7939 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
7940 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
7942 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
7943 or else Rtyp
= Universal_Integer
7945 Etyp
:= Standard_Long_Long_Integer
;
7948 Rent
:= RE_Exp_Long_Long_Integer
;
7950 Rent
:= RE_Exn_Long_Long_Integer
;
7953 elsif Is_Signed_Integer_Type
(Rtyp
) then
7954 Etyp
:= Standard_Integer
;
7957 Rent
:= RE_Exp_Integer
;
7959 Rent
:= RE_Exn_Integer
;
7962 -- Floating-point cases. We do not need separate routines for the
7963 -- overflow case here, since in the case of floating-point, we generate
7964 -- infinities anyway as a rule (either that or we automatically trap
7965 -- overflow), and if there is an infinity generated and a range check
7966 -- is required, the check will fail anyway.
7968 -- Historical note: we used to convert everything to Long_Long_Float
7969 -- and call a single common routine, but this had the undesirable effect
7970 -- of giving different results for small static exponent values and the
7971 -- same dynamic values.
7974 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
7976 if Rtyp
= Standard_Float
then
7977 Etyp
:= Standard_Float
;
7978 Rent
:= RE_Exn_Float
;
7980 elsif Rtyp
= Standard_Long_Float
then
7981 Etyp
:= Standard_Long_Float
;
7982 Rent
:= RE_Exn_Long_Float
;
7985 Etyp
:= Standard_Long_Long_Float
;
7986 Rent
:= RE_Exn_Long_Long_Float
;
7990 -- Common processing for integer cases and floating-point cases.
7991 -- If we are in the right type, we can call runtime routine directly
7994 and then Rtyp
/= Universal_Integer
7995 and then Rtyp
/= Universal_Real
7999 Make_Function_Call
(Loc
,
8000 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8001 Parameter_Associations
=> New_List
(Base
, Exp
))));
8003 -- Otherwise we have to introduce conversions (conversions are also
8004 -- required in the universal cases, since the runtime routine is
8005 -- typed using one of the standard types).
8010 Make_Function_Call
(Loc
,
8011 Name
=> New_Occurrence_Of
(RTE
(Rent
), Loc
),
8012 Parameter_Associations
=> New_List
(
8013 Convert_To
(Etyp
, Base
),
8017 Analyze_And_Resolve
(N
, Typ
);
8021 when RE_Not_Available
=>
8023 end Expand_N_Op_Expon
;
8025 --------------------
8026 -- Expand_N_Op_Ge --
8027 --------------------
8029 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
8030 Typ
: constant Entity_Id
:= Etype
(N
);
8031 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8032 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8033 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8036 Binary_Op_Validity_Checks
(N
);
8038 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8039 -- means we no longer have a comparison operation, we are all done.
8041 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8043 if Nkind
(N
) /= N_Op_Ge
then
8049 if Is_Array_Type
(Typ1
) then
8050 Expand_Array_Comparison
(N
);
8054 -- Deal with boolean operands
8056 if Is_Boolean_Type
(Typ1
) then
8057 Adjust_Condition
(Op1
);
8058 Adjust_Condition
(Op2
);
8059 Set_Etype
(N
, Standard_Boolean
);
8060 Adjust_Result_Type
(N
, Typ
);
8063 Rewrite_Comparison
(N
);
8065 Optimize_Length_Comparison
(N
);
8068 --------------------
8069 -- Expand_N_Op_Gt --
8070 --------------------
8072 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
8073 Typ
: constant Entity_Id
:= Etype
(N
);
8074 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8075 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8076 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8079 Binary_Op_Validity_Checks
(N
);
8081 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8082 -- means we no longer have a comparison operation, we are all done.
8084 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8086 if Nkind
(N
) /= N_Op_Gt
then
8090 -- Deal with array type operands
8092 if Is_Array_Type
(Typ1
) then
8093 Expand_Array_Comparison
(N
);
8097 -- Deal with boolean type operands
8099 if Is_Boolean_Type
(Typ1
) then
8100 Adjust_Condition
(Op1
);
8101 Adjust_Condition
(Op2
);
8102 Set_Etype
(N
, Standard_Boolean
);
8103 Adjust_Result_Type
(N
, Typ
);
8106 Rewrite_Comparison
(N
);
8108 Optimize_Length_Comparison
(N
);
8111 --------------------
8112 -- Expand_N_Op_Le --
8113 --------------------
8115 procedure Expand_N_Op_Le
(N
: Node_Id
) is
8116 Typ
: constant Entity_Id
:= Etype
(N
);
8117 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8118 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8119 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8122 Binary_Op_Validity_Checks
(N
);
8124 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8125 -- means we no longer have a comparison operation, we are all done.
8127 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8129 if Nkind
(N
) /= N_Op_Le
then
8133 -- Deal with array type operands
8135 if Is_Array_Type
(Typ1
) then
8136 Expand_Array_Comparison
(N
);
8140 -- Deal with Boolean type operands
8142 if Is_Boolean_Type
(Typ1
) then
8143 Adjust_Condition
(Op1
);
8144 Adjust_Condition
(Op2
);
8145 Set_Etype
(N
, Standard_Boolean
);
8146 Adjust_Result_Type
(N
, Typ
);
8149 Rewrite_Comparison
(N
);
8151 Optimize_Length_Comparison
(N
);
8154 --------------------
8155 -- Expand_N_Op_Lt --
8156 --------------------
8158 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
8159 Typ
: constant Entity_Id
:= Etype
(N
);
8160 Op1
: constant Node_Id
:= Left_Opnd
(N
);
8161 Op2
: constant Node_Id
:= Right_Opnd
(N
);
8162 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
8165 Binary_Op_Validity_Checks
(N
);
8167 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8168 -- means we no longer have a comparison operation, we are all done.
8170 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8172 if Nkind
(N
) /= N_Op_Lt
then
8176 -- Deal with array type operands
8178 if Is_Array_Type
(Typ1
) then
8179 Expand_Array_Comparison
(N
);
8183 -- Deal with Boolean type operands
8185 if Is_Boolean_Type
(Typ1
) then
8186 Adjust_Condition
(Op1
);
8187 Adjust_Condition
(Op2
);
8188 Set_Etype
(N
, Standard_Boolean
);
8189 Adjust_Result_Type
(N
, Typ
);
8192 Rewrite_Comparison
(N
);
8194 Optimize_Length_Comparison
(N
);
8197 -----------------------
8198 -- Expand_N_Op_Minus --
8199 -----------------------
8201 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
8202 Loc
: constant Source_Ptr
:= Sloc
(N
);
8203 Typ
: constant Entity_Id
:= Etype
(N
);
8206 Unary_Op_Validity_Checks
(N
);
8208 -- Check for MINIMIZED/ELIMINATED overflow mode
8210 if Minimized_Eliminated_Overflow_Check
(N
) then
8211 Apply_Arithmetic_Overflow_Check
(N
);
8215 if not Backend_Overflow_Checks_On_Target
8216 and then Is_Signed_Integer_Type
(Etype
(N
))
8217 and then Do_Overflow_Check
(N
)
8219 -- Software overflow checking expands -expr into (0 - expr)
8222 Make_Op_Subtract
(Loc
,
8223 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
8224 Right_Opnd
=> Right_Opnd
(N
)));
8226 Analyze_And_Resolve
(N
, Typ
);
8228 end Expand_N_Op_Minus
;
8230 ---------------------
8231 -- Expand_N_Op_Mod --
8232 ---------------------
8234 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
8235 Loc
: constant Source_Ptr
:= Sloc
(N
);
8236 Typ
: constant Entity_Id
:= Etype
(N
);
8237 DDC
: constant Boolean := Do_Division_Check
(N
);
8250 pragma Warnings
(Off
, Lhi
);
8253 Binary_Op_Validity_Checks
(N
);
8255 -- Check for MINIMIZED/ELIMINATED overflow mode
8257 if Minimized_Eliminated_Overflow_Check
(N
) then
8258 Apply_Arithmetic_Overflow_Check
(N
);
8262 if Is_Integer_Type
(Etype
(N
)) then
8263 Apply_Divide_Checks
(N
);
8265 -- All done if we don't have a MOD any more, which can happen as a
8266 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8268 if Nkind
(N
) /= N_Op_Mod
then
8273 -- Proceed with expansion of mod operator
8275 Left
:= Left_Opnd
(N
);
8276 Right
:= Right_Opnd
(N
);
8278 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
8279 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
8281 -- Convert mod to rem if operands are both known to be non-negative, or
8282 -- both known to be non-positive (these are the cases in which rem and
8283 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8284 -- likely that this will improve the quality of code, (the operation now
8285 -- corresponds to the hardware remainder), and it does not seem likely
8286 -- that it could be harmful. It also avoids some cases of the elaborate
8287 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8290 and then ((Llo
>= 0 and then Rlo
>= 0)
8292 (Lhi
<= 0 and then Rhi
<= 0))
8295 Make_Op_Rem
(Sloc
(N
),
8296 Left_Opnd
=> Left_Opnd
(N
),
8297 Right_Opnd
=> Right_Opnd
(N
)));
8299 -- Instead of reanalyzing the node we do the analysis manually. This
8300 -- avoids anomalies when the replacement is done in an instance and
8301 -- is epsilon more efficient.
8303 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
8305 Set_Do_Division_Check
(N
, DDC
);
8306 Expand_N_Op_Rem
(N
);
8310 -- Otherwise, normal mod processing
8313 -- Apply optimization x mod 1 = 0. We don't really need that with
8314 -- gcc, but it is useful with other back ends and is certainly
8317 if Is_Integer_Type
(Etype
(N
))
8318 and then Compile_Time_Known_Value
(Right
)
8319 and then Expr_Value
(Right
) = Uint_1
8321 -- Call Remove_Side_Effects to ensure that any side effects in
8322 -- the ignored left operand (in particular function calls to
8323 -- user defined functions) are properly executed.
8325 Remove_Side_Effects
(Left
);
8327 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
8328 Analyze_And_Resolve
(N
, Typ
);
8332 -- If we still have a mod operator and we are in Modify_Tree_For_C
8333 -- mode, and we have a signed integer type, then here is where we do
8334 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8335 -- for the special handling of the annoying case of largest negative
8336 -- number mod minus one.
8338 if Nkind
(N
) = N_Op_Mod
8339 and then Is_Signed_Integer_Type
(Typ
)
8340 and then Modify_Tree_For_C
8342 -- In the general case, we expand A mod B as
8344 -- Tnn : constant typ := A rem B;
8346 -- (if (A >= 0) = (B >= 0) then Tnn
8347 -- elsif Tnn = 0 then 0
8350 -- The comparison can be written simply as A >= 0 if we know that
8351 -- B >= 0 which is a very common case.
8353 -- An important optimization is when B is known at compile time
8354 -- to be 2**K for some constant. In this case we can simply AND
8355 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8356 -- and that works for both the positive and negative cases.
8359 P2
: constant Nat
:= Power_Of_Two
(Right
);
8364 Unchecked_Convert_To
(Typ
,
8367 Unchecked_Convert_To
8368 (Corresponding_Unsigned_Type
(Typ
), Left
),
8370 Make_Integer_Literal
(Loc
, 2 ** P2
- 1))));
8371 Analyze_And_Resolve
(N
, Typ
);
8376 -- Here for the full rewrite
8379 Tnn
: constant Entity_Id
:= Make_Temporary
(Sloc
(N
), 'T', N
);
8385 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
8386 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
8388 if not LOK
or else Rlo
< 0 then
8394 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
),
8395 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)));
8399 Make_Object_Declaration
(Loc
,
8400 Defining_Identifier
=> Tnn
,
8401 Constant_Present
=> True,
8402 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8406 Right_Opnd
=> Right
)));
8409 Make_If_Expression
(Loc
,
8410 Expressions
=> New_List
(
8412 New_Occurrence_Of
(Tnn
, Loc
),
8413 Make_If_Expression
(Loc
,
8415 Expressions
=> New_List
(
8417 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8418 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
8419 Make_Integer_Literal
(Loc
, 0),
8421 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8423 Duplicate_Subexpr_No_Checks
(Right
)))))));
8425 Analyze_And_Resolve
(N
, Typ
);
8430 -- Deal with annoying case of largest negative number mod minus one.
8431 -- Gigi may not handle this case correctly, because on some targets,
8432 -- the mod value is computed using a divide instruction which gives
8433 -- an overflow trap for this case.
8435 -- It would be a bit more efficient to figure out which targets
8436 -- this is really needed for, but in practice it is reasonable
8437 -- to do the following special check in all cases, since it means
8438 -- we get a clearer message, and also the overhead is minimal given
8439 -- that division is expensive in any case.
8441 -- In fact the check is quite easy, if the right operand is -1, then
8442 -- the mod value is always 0, and we can just ignore the left operand
8443 -- completely in this case.
8445 -- This only applies if we still have a mod operator. Skip if we
8446 -- have already rewritten this (e.g. in the case of eliminated
8447 -- overflow checks which have driven us into bignum mode).
8449 if Nkind
(N
) = N_Op_Mod
then
8451 -- The operand type may be private (e.g. in the expansion of an
8452 -- intrinsic operation) so we must use the underlying type to get
8453 -- the bounds, and convert the literals explicitly.
8457 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
8459 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
8460 and then ((not LOK
) or else (Llo
= LLB
))
8463 Make_If_Expression
(Loc
,
8464 Expressions
=> New_List
(
8466 Left_Opnd
=> Duplicate_Subexpr
(Right
),
8468 Unchecked_Convert_To
(Typ
,
8469 Make_Integer_Literal
(Loc
, -1))),
8470 Unchecked_Convert_To
(Typ
,
8471 Make_Integer_Literal
(Loc
, Uint_0
)),
8472 Relocate_Node
(N
))));
8474 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
8475 Analyze_And_Resolve
(N
, Typ
);
8479 end Expand_N_Op_Mod
;
8481 --------------------------
8482 -- Expand_N_Op_Multiply --
8483 --------------------------
8485 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
8486 Loc
: constant Source_Ptr
:= Sloc
(N
);
8487 Lop
: constant Node_Id
:= Left_Opnd
(N
);
8488 Rop
: constant Node_Id
:= Right_Opnd
(N
);
8490 Lp2
: constant Boolean :=
8491 Nkind
(Lop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Lop
);
8492 Rp2
: constant Boolean :=
8493 Nkind
(Rop
) = N_Op_Expon
and then Is_Power_Of_2_For_Shift
(Rop
);
8495 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
8496 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
8497 Typ
: Entity_Id
:= Etype
(N
);
8500 Binary_Op_Validity_Checks
(N
);
8502 -- Check for MINIMIZED/ELIMINATED overflow mode
8504 if Minimized_Eliminated_Overflow_Check
(N
) then
8505 Apply_Arithmetic_Overflow_Check
(N
);
8509 -- Special optimizations for integer types
8511 if Is_Integer_Type
(Typ
) then
8513 -- N * 0 = 0 for integer types
8515 if Compile_Time_Known_Value
(Rop
)
8516 and then Expr_Value
(Rop
) = Uint_0
8518 -- Call Remove_Side_Effects to ensure that any side effects in
8519 -- the ignored left operand (in particular function calls to
8520 -- user defined functions) are properly executed.
8522 Remove_Side_Effects
(Lop
);
8524 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8525 Analyze_And_Resolve
(N
, Typ
);
8529 -- Similar handling for 0 * N = 0
8531 if Compile_Time_Known_Value
(Lop
)
8532 and then Expr_Value
(Lop
) = Uint_0
8534 Remove_Side_Effects
(Rop
);
8535 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
8536 Analyze_And_Resolve
(N
, Typ
);
8540 -- N * 1 = 1 * N = N for integer types
8542 -- This optimisation is not done if we are going to
8543 -- rewrite the product 1 * 2 ** N to a shift.
8545 if Compile_Time_Known_Value
(Rop
)
8546 and then Expr_Value
(Rop
) = Uint_1
8552 elsif Compile_Time_Known_Value
(Lop
)
8553 and then Expr_Value
(Lop
) = Uint_1
8561 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8562 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8563 -- operand is an integer, as required for this to work.
8568 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8572 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
8575 Left_Opnd
=> Right_Opnd
(Lop
),
8576 Right_Opnd
=> Right_Opnd
(Rop
))));
8577 Analyze_And_Resolve
(N
, Typ
);
8581 -- If the result is modular, perform the reduction of the result
8584 if Is_Modular_Integer_Type
(Typ
)
8585 and then not Non_Binary_Modulus
(Typ
)
8590 Make_Op_Shift_Left
(Loc
,
8593 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))),
8595 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8599 Make_Op_Shift_Left
(Loc
,
8602 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
8605 Analyze_And_Resolve
(N
, Typ
);
8609 -- Same processing for the operands the other way round
8612 if Is_Modular_Integer_Type
(Typ
)
8613 and then not Non_Binary_Modulus
(Typ
)
8618 Make_Op_Shift_Left
(Loc
,
8621 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))),
8623 Make_Integer_Literal
(Loc
, Modulus
(Typ
) - 1)));
8627 Make_Op_Shift_Left
(Loc
,
8630 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
8633 Analyze_And_Resolve
(N
, Typ
);
8637 -- Do required fixup of universal fixed operation
8639 if Typ
= Universal_Fixed
then
8640 Fixup_Universal_Fixed_Operation
(N
);
8644 -- Multiplications with fixed-point results
8646 if Is_Fixed_Point_Type
(Typ
) then
8648 -- No special processing if Treat_Fixed_As_Integer is set, since from
8649 -- a semantic point of view such operations are simply integer
8650 -- operations and will be treated that way.
8652 if not Treat_Fixed_As_Integer
(N
) then
8654 -- Case of fixed * integer => fixed
8656 if Is_Integer_Type
(Rtyp
) then
8657 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
8659 -- Case of integer * fixed => fixed
8661 elsif Is_Integer_Type
(Ltyp
) then
8662 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
8664 -- Case of fixed * fixed => fixed
8667 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
8671 -- Other cases of multiplication of fixed-point operands. Again we
8672 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8674 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
8675 and then not Treat_Fixed_As_Integer
(N
)
8677 if Is_Integer_Type
(Typ
) then
8678 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
8680 pragma Assert
(Is_Floating_Point_Type
(Typ
));
8681 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
8684 -- Mixed-mode operations can appear in a non-static universal context,
8685 -- in which case the integer argument must be converted explicitly.
8687 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Rtyp
) then
8688 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
8689 Analyze_And_Resolve
(Rop
, Universal_Real
);
8691 elsif Typ
= Universal_Real
and then Is_Integer_Type
(Ltyp
) then
8692 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
8693 Analyze_And_Resolve
(Lop
, Universal_Real
);
8695 -- Non-fixed point cases, check software overflow checking required
8697 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
8698 Apply_Arithmetic_Overflow_Check
(N
);
8701 -- Overflow checks for floating-point if -gnateF mode active
8703 Check_Float_Op_Overflow
(N
);
8704 end Expand_N_Op_Multiply
;
8706 --------------------
8707 -- Expand_N_Op_Ne --
8708 --------------------
8710 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
8711 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
8714 -- Case of elementary type with standard operator
8716 if Is_Elementary_Type
(Typ
)
8717 and then Sloc
(Entity
(N
)) = Standard_Location
8719 Binary_Op_Validity_Checks
(N
);
8721 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8722 -- means we no longer have a /= operation, we are all done.
8724 Expand_Compare_Minimize_Eliminate_Overflow
(N
);
8726 if Nkind
(N
) /= N_Op_Ne
then
8730 -- Boolean types (requiring handling of non-standard case)
8732 if Is_Boolean_Type
(Typ
) then
8733 Adjust_Condition
(Left_Opnd
(N
));
8734 Adjust_Condition
(Right_Opnd
(N
));
8735 Set_Etype
(N
, Standard_Boolean
);
8736 Adjust_Result_Type
(N
, Typ
);
8739 Rewrite_Comparison
(N
);
8741 -- For all cases other than elementary types, we rewrite node as the
8742 -- negation of an equality operation, and reanalyze. The equality to be
8743 -- used is defined in the same scope and has the same signature. This
8744 -- signature must be set explicitly since in an instance it may not have
8745 -- the same visibility as in the generic unit. This avoids duplicating
8746 -- or factoring the complex code for record/array equality tests etc.
8750 Loc
: constant Source_Ptr
:= Sloc
(N
);
8752 Ne
: constant Entity_Id
:= Entity
(N
);
8755 Binary_Op_Validity_Checks
(N
);
8761 Left_Opnd
=> Left_Opnd
(N
),
8762 Right_Opnd
=> Right_Opnd
(N
)));
8763 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
8765 if Scope
(Ne
) /= Standard_Standard
then
8766 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
8769 -- For navigation purposes, we want to treat the inequality as an
8770 -- implicit reference to the corresponding equality. Preserve the
8771 -- Comes_From_ source flag to generate proper Xref entries.
8773 Preserve_Comes_From_Source
(Neg
, N
);
8774 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
8776 Analyze_And_Resolve
(N
, Standard_Boolean
);
8780 Optimize_Length_Comparison
(N
);
8783 ---------------------
8784 -- Expand_N_Op_Not --
8785 ---------------------
8787 -- If the argument is other than a Boolean array type, there is no special
8788 -- expansion required, except for dealing with validity checks, and non-
8789 -- standard boolean representations.
8791 -- For the packed array case, we call the special routine in Exp_Pakd,
8792 -- except that if the component size is greater than one, we use the
8793 -- standard routine generating a gruesome loop (it is so peculiar to have
8794 -- packed arrays with non-standard Boolean representations anyway, so it
8795 -- does not matter that we do not handle this case efficiently).
8797 -- For the unpacked array case (and for the special packed case where we
8798 -- have non standard Booleans, as discussed above), we generate and insert
8799 -- into the tree the following function definition:
8801 -- function Nnnn (A : arr) is
8804 -- for J in a'range loop
8805 -- B (J) := not A (J);
8810 -- Here arr is the actual subtype of the parameter (and hence always
8811 -- constrained). Then we replace the not with a call to this function.
8813 procedure Expand_N_Op_Not
(N
: Node_Id
) is
8814 Loc
: constant Source_Ptr
:= Sloc
(N
);
8815 Typ
: constant Entity_Id
:= Etype
(N
);
8824 Func_Name
: Entity_Id
;
8825 Loop_Statement
: Node_Id
;
8828 Unary_Op_Validity_Checks
(N
);
8830 -- For boolean operand, deal with non-standard booleans
8832 if Is_Boolean_Type
(Typ
) then
8833 Adjust_Condition
(Right_Opnd
(N
));
8834 Set_Etype
(N
, Standard_Boolean
);
8835 Adjust_Result_Type
(N
, Typ
);
8839 -- Only array types need any other processing
8841 if not Is_Array_Type
(Typ
) then
8845 -- Case of array operand. If bit packed with a component size of 1,
8846 -- handle it in Exp_Pakd if the operand is known to be aligned.
8848 if Is_Bit_Packed_Array
(Typ
)
8849 and then Component_Size
(Typ
) = 1
8850 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
8852 Expand_Packed_Not
(N
);
8856 -- Case of array operand which is not bit-packed. If the context is
8857 -- a safe assignment, call in-place operation, If context is a larger
8858 -- boolean expression in the context of a safe assignment, expansion is
8859 -- done by enclosing operation.
8861 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
8862 Convert_To_Actual_Subtype
(Opnd
);
8863 Arr
:= Etype
(Opnd
);
8864 Ensure_Defined
(Arr
, N
);
8865 Silly_Boolean_Array_Not_Test
(N
, Arr
);
8867 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
8868 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
8869 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8872 -- Special case the negation of a binary operation
8874 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
8875 and then Safe_In_Place_Array_Op
8876 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
8878 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
8882 elsif Nkind
(Parent
(N
)) in N_Binary_Op
8883 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
8886 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
8887 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
8888 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
8891 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
8893 -- (not A) op (not B) can be reduced to a single call
8895 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
8898 elsif N
= Op2
and then Nkind
(Op1
) = N_Op_Not
then
8901 -- A xor (not B) can also be special-cased
8903 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
8910 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
8911 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
8912 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
8915 Make_Indexed_Component
(Loc
,
8916 Prefix
=> New_Occurrence_Of
(A
, Loc
),
8917 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8920 Make_Indexed_Component
(Loc
,
8921 Prefix
=> New_Occurrence_Of
(B
, Loc
),
8922 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
8925 Make_Implicit_Loop_Statement
(N
,
8926 Identifier
=> Empty
,
8929 Make_Iteration_Scheme
(Loc
,
8930 Loop_Parameter_Specification
=>
8931 Make_Loop_Parameter_Specification
(Loc
,
8932 Defining_Identifier
=> J
,
8933 Discrete_Subtype_Definition
=>
8934 Make_Attribute_Reference
(Loc
,
8935 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
8936 Attribute_Name
=> Name_Range
))),
8938 Statements
=> New_List
(
8939 Make_Assignment_Statement
(Loc
,
8941 Expression
=> Make_Op_Not
(Loc
, A_J
))));
8943 Func_Name
:= Make_Temporary
(Loc
, 'N');
8944 Set_Is_Inlined
(Func_Name
);
8947 Make_Subprogram_Body
(Loc
,
8949 Make_Function_Specification
(Loc
,
8950 Defining_Unit_Name
=> Func_Name
,
8951 Parameter_Specifications
=> New_List
(
8952 Make_Parameter_Specification
(Loc
,
8953 Defining_Identifier
=> A
,
8954 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
8955 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8957 Declarations
=> New_List
(
8958 Make_Object_Declaration
(Loc
,
8959 Defining_Identifier
=> B
,
8960 Object_Definition
=> New_Occurrence_Of
(Arr
, Loc
))),
8962 Handled_Statement_Sequence
=>
8963 Make_Handled_Sequence_Of_Statements
(Loc
,
8964 Statements
=> New_List
(
8966 Make_Simple_Return_Statement
(Loc
,
8967 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
8970 Make_Function_Call
(Loc
,
8971 Name
=> New_Occurrence_Of
(Func_Name
, Loc
),
8972 Parameter_Associations
=> New_List
(Opnd
)));
8974 Analyze_And_Resolve
(N
, Typ
);
8975 end Expand_N_Op_Not
;
8977 --------------------
8978 -- Expand_N_Op_Or --
8979 --------------------
8981 procedure Expand_N_Op_Or
(N
: Node_Id
) is
8982 Typ
: constant Entity_Id
:= Etype
(N
);
8985 Binary_Op_Validity_Checks
(N
);
8987 if Is_Array_Type
(Etype
(N
)) then
8988 Expand_Boolean_Operator
(N
);
8990 elsif Is_Boolean_Type
(Etype
(N
)) then
8991 Adjust_Condition
(Left_Opnd
(N
));
8992 Adjust_Condition
(Right_Opnd
(N
));
8993 Set_Etype
(N
, Standard_Boolean
);
8994 Adjust_Result_Type
(N
, Typ
);
8996 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
8997 Expand_Intrinsic_Call
(N
, Entity
(N
));
9002 ----------------------
9003 -- Expand_N_Op_Plus --
9004 ----------------------
9006 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
9008 Unary_Op_Validity_Checks
(N
);
9010 -- Check for MINIMIZED/ELIMINATED overflow mode
9012 if Minimized_Eliminated_Overflow_Check
(N
) then
9013 Apply_Arithmetic_Overflow_Check
(N
);
9016 end Expand_N_Op_Plus
;
9018 ---------------------
9019 -- Expand_N_Op_Rem --
9020 ---------------------
9022 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
9023 Loc
: constant Source_Ptr
:= Sloc
(N
);
9024 Typ
: constant Entity_Id
:= Etype
(N
);
9035 -- Set if corresponding operand can be negative
9037 pragma Unreferenced
(Hi
);
9040 Binary_Op_Validity_Checks
(N
);
9042 -- Check for MINIMIZED/ELIMINATED overflow mode
9044 if Minimized_Eliminated_Overflow_Check
(N
) then
9045 Apply_Arithmetic_Overflow_Check
(N
);
9049 if Is_Integer_Type
(Etype
(N
)) then
9050 Apply_Divide_Checks
(N
);
9052 -- All done if we don't have a REM any more, which can happen as a
9053 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9055 if Nkind
(N
) /= N_Op_Rem
then
9060 -- Proceed with expansion of REM
9062 Left
:= Left_Opnd
(N
);
9063 Right
:= Right_Opnd
(N
);
9065 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
9066 -- but it is useful with other back ends, and is certainly harmless.
9068 if Is_Integer_Type
(Etype
(N
))
9069 and then Compile_Time_Known_Value
(Right
)
9070 and then Expr_Value
(Right
) = Uint_1
9072 -- Call Remove_Side_Effects to ensure that any side effects in the
9073 -- ignored left operand (in particular function calls to user defined
9074 -- functions) are properly executed.
9076 Remove_Side_Effects
(Left
);
9078 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9079 Analyze_And_Resolve
(N
, Typ
);
9083 -- Deal with annoying case of largest negative number remainder minus
9084 -- one. Gigi may not handle this case correctly, because on some
9085 -- targets, the mod value is computed using a divide instruction
9086 -- which gives an overflow trap for this case.
9088 -- It would be a bit more efficient to figure out which targets this
9089 -- is really needed for, but in practice it is reasonable to do the
9090 -- following special check in all cases, since it means we get a clearer
9091 -- message, and also the overhead is minimal given that division is
9092 -- expensive in any case.
9094 -- In fact the check is quite easy, if the right operand is -1, then
9095 -- the remainder is always 0, and we can just ignore the left operand
9096 -- completely in this case.
9098 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9099 Lneg
:= (not OK
) or else Lo
< 0;
9101 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9102 Rneg
:= (not OK
) or else Lo
< 0;
9104 -- We won't mess with trying to find out if the left operand can really
9105 -- be the largest negative number (that's a pain in the case of private
9106 -- types and this is really marginal). We will just assume that we need
9107 -- the test if the left operand can be negative at all.
9109 if Lneg
and Rneg
then
9111 Make_If_Expression
(Loc
,
9112 Expressions
=> New_List
(
9114 Left_Opnd
=> Duplicate_Subexpr
(Right
),
9116 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
9118 Unchecked_Convert_To
(Typ
,
9119 Make_Integer_Literal
(Loc
, Uint_0
)),
9121 Relocate_Node
(N
))));
9123 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
9124 Analyze_And_Resolve
(N
, Typ
);
9126 end Expand_N_Op_Rem
;
9128 -----------------------------
9129 -- Expand_N_Op_Rotate_Left --
9130 -----------------------------
9132 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
9134 Binary_Op_Validity_Checks
(N
);
9136 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
9137 -- so we rewrite in terms of logical shifts
9139 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
9141 -- where Bits is the shift count mod Esize (the mod operation here
9142 -- deals with ludicrous large shift counts, which are apparently OK).
9144 -- What about nonbinary modulus ???
9147 Loc
: constant Source_Ptr
:= Sloc
(N
);
9148 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9149 Typ
: constant Entity_Id
:= Etype
(N
);
9152 if Modify_Tree_For_C
then
9153 Rewrite
(Right_Opnd
(N
),
9155 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9156 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9158 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9163 Make_Op_Shift_Left
(Loc
,
9164 Left_Opnd
=> Left_Opnd
(N
),
9165 Right_Opnd
=> Right_Opnd
(N
)),
9168 Make_Op_Shift_Right
(Loc
,
9169 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9171 Make_Op_Subtract
(Loc
,
9172 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9174 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9176 Analyze_And_Resolve
(N
, Typ
);
9179 end Expand_N_Op_Rotate_Left
;
9181 ------------------------------
9182 -- Expand_N_Op_Rotate_Right --
9183 ------------------------------
9185 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
9187 Binary_Op_Validity_Checks
(N
);
9189 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
9190 -- so we rewrite in terms of logical shifts
9192 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
9194 -- where Bits is the shift count mod Esize (the mod operation here
9195 -- deals with ludicrous large shift counts, which are apparently OK).
9197 -- What about nonbinary modulus ???
9200 Loc
: constant Source_Ptr
:= Sloc
(N
);
9201 Rtp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
9202 Typ
: constant Entity_Id
:= Etype
(N
);
9205 Rewrite
(Right_Opnd
(N
),
9207 Left_Opnd
=> Relocate_Node
(Right_Opnd
(N
)),
9208 Right_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
))));
9210 Analyze_And_Resolve
(Right_Opnd
(N
), Rtp
);
9212 if Modify_Tree_For_C
then
9216 Make_Op_Shift_Right
(Loc
,
9217 Left_Opnd
=> Left_Opnd
(N
),
9218 Right_Opnd
=> Right_Opnd
(N
)),
9221 Make_Op_Shift_Left
(Loc
,
9222 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left_Opnd
(N
)),
9224 Make_Op_Subtract
(Loc
,
9225 Left_Opnd
=> Make_Integer_Literal
(Loc
, Esize
(Typ
)),
9227 Duplicate_Subexpr_No_Checks
(Right_Opnd
(N
))))));
9229 Analyze_And_Resolve
(N
, Typ
);
9232 end Expand_N_Op_Rotate_Right
;
9234 ----------------------------
9235 -- Expand_N_Op_Shift_Left --
9236 ----------------------------
9238 -- Note: nothing in this routine depends on left as opposed to right shifts
9239 -- so we share the routine for expanding shift right operations.
9241 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
9243 Binary_Op_Validity_Checks
(N
);
9245 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9246 -- operand is not greater than the word size (since that would not
9247 -- be defined properly by the corresponding C shift operator).
9249 if Modify_Tree_For_C
then
9251 Right
: constant Node_Id
:= Right_Opnd
(N
);
9252 Loc
: constant Source_Ptr
:= Sloc
(Right
);
9253 Typ
: constant Entity_Id
:= Etype
(N
);
9254 Siz
: constant Uint
:= Esize
(Typ
);
9261 if Compile_Time_Known_Value
(Right
) then
9262 if Expr_Value
(Right
) >= Siz
then
9263 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
9264 Analyze_And_Resolve
(N
, Typ
);
9267 -- Not compile time known, find range
9270 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
9272 -- Nothing to do if known to be OK range, otherwise expand
9274 if not OK
or else Hi
>= Siz
then
9276 -- Prevent recursion on copy of shift node
9278 Orig
:= Relocate_Node
(N
);
9279 Set_Analyzed
(Orig
);
9281 -- Now do the rewrite
9284 Make_If_Expression
(Loc
,
9285 Expressions
=> New_List
(
9287 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
9288 Right_Opnd
=> Make_Integer_Literal
(Loc
, Siz
)),
9289 Make_Integer_Literal
(Loc
, 0),
9291 Analyze_And_Resolve
(N
, Typ
);
9296 end Expand_N_Op_Shift_Left
;
9298 -----------------------------
9299 -- Expand_N_Op_Shift_Right --
9300 -----------------------------
9302 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
9304 -- Share shift left circuit
9306 Expand_N_Op_Shift_Left
(N
);
9307 end Expand_N_Op_Shift_Right
;
9309 ----------------------------------------
9310 -- Expand_N_Op_Shift_Right_Arithmetic --
9311 ----------------------------------------
9313 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
9315 Binary_Op_Validity_Checks
(N
);
9317 -- If we are in Modify_Tree_For_C mode, there is no shift right
9318 -- arithmetic in C, so we rewrite in terms of logical shifts.
9320 -- Shift_Right (Num, Bits) or
9322 -- then not (Shift_Right (Mask, bits))
9325 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9327 -- Note: in almost all C compilers it would work to just shift a
9328 -- signed integer right, but it's undefined and we cannot rely on it.
9330 -- Note: the above works fine for shift counts greater than or equal
9331 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9332 -- generates all 1'bits.
9334 -- What about nonbinary modulus ???
9337 Loc
: constant Source_Ptr
:= Sloc
(N
);
9338 Typ
: constant Entity_Id
:= Etype
(N
);
9339 Sign
: constant Uint
:= 2 ** (Esize
(Typ
) - 1);
9340 Mask
: constant Uint
:= (2 ** Esize
(Typ
)) - 1;
9341 Left
: constant Node_Id
:= Left_Opnd
(N
);
9342 Right
: constant Node_Id
:= Right_Opnd
(N
);
9346 if Modify_Tree_For_C
then
9348 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9349 -- compile time as a single constant.
9351 if Compile_Time_Known_Value
(Right
) then
9353 Val
: constant Uint
:= Expr_Value
(Right
);
9356 if Val
>= Esize
(Typ
) then
9357 Maskx
:= Make_Integer_Literal
(Loc
, Mask
);
9361 Make_Integer_Literal
(Loc
,
9362 Intval
=> Mask
- (Mask
/ (2 ** Expr_Value
(Right
))));
9370 Make_Op_Shift_Right
(Loc
,
9371 Left_Opnd
=> Make_Integer_Literal
(Loc
, Mask
),
9372 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Right
)));
9375 -- Now do the rewrite
9380 Make_Op_Shift_Right
(Loc
,
9382 Right_Opnd
=> Right
),
9384 Make_If_Expression
(Loc
,
9385 Expressions
=> New_List
(
9387 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Left
),
9388 Right_Opnd
=> Make_Integer_Literal
(Loc
, Sign
)),
9390 Make_Integer_Literal
(Loc
, 0)))));
9391 Analyze_And_Resolve
(N
, Typ
);
9394 end Expand_N_Op_Shift_Right_Arithmetic
;
9396 --------------------------
9397 -- Expand_N_Op_Subtract --
9398 --------------------------
9400 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
9401 Typ
: constant Entity_Id
:= Etype
(N
);
9404 Binary_Op_Validity_Checks
(N
);
9406 -- Check for MINIMIZED/ELIMINATED overflow mode
9408 if Minimized_Eliminated_Overflow_Check
(N
) then
9409 Apply_Arithmetic_Overflow_Check
(N
);
9413 -- N - 0 = N for integer types
9415 if Is_Integer_Type
(Typ
)
9416 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
9417 and then Expr_Value
(Right_Opnd
(N
)) = 0
9419 Rewrite
(N
, Left_Opnd
(N
));
9423 -- Arithmetic overflow checks for signed integer/fixed point types
9425 if Is_Signed_Integer_Type
(Typ
) or else Is_Fixed_Point_Type
(Typ
) then
9426 Apply_Arithmetic_Overflow_Check
(N
);
9429 -- Overflow checks for floating-point if -gnateF mode active
9431 Check_Float_Op_Overflow
(N
);
9432 end Expand_N_Op_Subtract
;
9434 ---------------------
9435 -- Expand_N_Op_Xor --
9436 ---------------------
9438 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
9439 Typ
: constant Entity_Id
:= Etype
(N
);
9442 Binary_Op_Validity_Checks
(N
);
9444 if Is_Array_Type
(Etype
(N
)) then
9445 Expand_Boolean_Operator
(N
);
9447 elsif Is_Boolean_Type
(Etype
(N
)) then
9448 Adjust_Condition
(Left_Opnd
(N
));
9449 Adjust_Condition
(Right_Opnd
(N
));
9450 Set_Etype
(N
, Standard_Boolean
);
9451 Adjust_Result_Type
(N
, Typ
);
9453 elsif Is_Intrinsic_Subprogram
(Entity
(N
)) then
9454 Expand_Intrinsic_Call
(N
, Entity
(N
));
9457 end Expand_N_Op_Xor
;
9459 ----------------------
9460 -- Expand_N_Or_Else --
9461 ----------------------
9463 procedure Expand_N_Or_Else
(N
: Node_Id
)
9464 renames Expand_Short_Circuit_Operator
;
9466 -----------------------------------
9467 -- Expand_N_Qualified_Expression --
9468 -----------------------------------
9470 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
9471 Operand
: constant Node_Id
:= Expression
(N
);
9472 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
9475 -- Do validity check if validity checking operands
9477 if Validity_Checks_On
and Validity_Check_Operands
then
9478 Ensure_Valid
(Operand
);
9481 -- Apply possible constraint check
9483 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
9485 if Do_Range_Check
(Operand
) then
9486 Set_Do_Range_Check
(Operand
, False);
9487 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
9489 end Expand_N_Qualified_Expression
;
9491 ------------------------------------
9492 -- Expand_N_Quantified_Expression --
9493 ------------------------------------
9497 -- for all X in range => Cond
9502 -- for X in range loop
9509 -- Similarly, an existentially quantified expression:
9511 -- for some X in range => Cond
9516 -- for X in range loop
9523 -- In both cases, the iteration may be over a container in which case it is
9524 -- given by an iterator specification, not a loop parameter specification.
9526 procedure Expand_N_Quantified_Expression
(N
: Node_Id
) is
9527 Actions
: constant List_Id
:= New_List
;
9528 For_All
: constant Boolean := All_Present
(N
);
9529 Iter_Spec
: constant Node_Id
:= Iterator_Specification
(N
);
9530 Loc
: constant Source_Ptr
:= Sloc
(N
);
9531 Loop_Spec
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
9538 -- Create the declaration of the flag which tracks the status of the
9539 -- quantified expression. Generate:
9541 -- Flag : Boolean := (True | False);
9543 Flag
:= Make_Temporary
(Loc
, 'T', N
);
9546 Make_Object_Declaration
(Loc
,
9547 Defining_Identifier
=> Flag
,
9548 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
9550 New_Occurrence_Of
(Boolean_Literals
(For_All
), Loc
)));
9552 -- Construct the circuitry which tracks the status of the quantified
9553 -- expression. Generate:
9555 -- if [not] Cond then
9556 -- Flag := (False | True);
9560 Cond
:= Relocate_Node
(Condition
(N
));
9563 Cond
:= Make_Op_Not
(Loc
, Cond
);
9567 Make_Implicit_If_Statement
(N
,
9569 Then_Statements
=> New_List
(
9570 Make_Assignment_Statement
(Loc
,
9571 Name
=> New_Occurrence_Of
(Flag
, Loc
),
9573 New_Occurrence_Of
(Boolean_Literals
(not For_All
), Loc
)),
9574 Make_Exit_Statement
(Loc
))));
9576 -- Build the loop equivalent of the quantified expression
9578 if Present
(Iter_Spec
) then
9580 Make_Iteration_Scheme
(Loc
,
9581 Iterator_Specification
=> Iter_Spec
);
9584 Make_Iteration_Scheme
(Loc
,
9585 Loop_Parameter_Specification
=> Loop_Spec
);
9589 Make_Loop_Statement
(Loc
,
9590 Iteration_Scheme
=> Scheme
,
9591 Statements
=> Stmts
,
9592 End_Label
=> Empty
));
9594 -- Transform the quantified expression
9597 Make_Expression_With_Actions
(Loc
,
9598 Expression
=> New_Occurrence_Of
(Flag
, Loc
),
9599 Actions
=> Actions
));
9600 Analyze_And_Resolve
(N
, Standard_Boolean
);
9601 end Expand_N_Quantified_Expression
;
9603 ---------------------------------
9604 -- Expand_N_Selected_Component --
9605 ---------------------------------
9607 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
9608 Loc
: constant Source_Ptr
:= Sloc
(N
);
9609 Par
: constant Node_Id
:= Parent
(N
);
9610 P
: constant Node_Id
:= Prefix
(N
);
9611 S
: constant Node_Id
:= Selector_Name
(N
);
9612 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
9618 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
9619 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9620 -- unless the context of an assignment can provide size information.
9621 -- Don't we have a general routine that does this???
9623 function Is_Subtype_Declaration
return Boolean;
9624 -- The replacement of a discriminant reference by its value is required
9625 -- if this is part of the initialization of an temporary generated by a
9626 -- change of representation. This shows up as the construction of a
9627 -- discriminant constraint for a subtype declared at the same point as
9628 -- the entity in the prefix of the selected component. We recognize this
9629 -- case when the context of the reference is:
9630 -- subtype ST is T(Obj.D);
9631 -- where the entity for Obj comes from source, and ST has the same sloc.
9633 -----------------------
9634 -- In_Left_Hand_Side --
9635 -----------------------
9637 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
9639 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
9640 and then Comp
= Name
(Parent
(Comp
)))
9641 or else (Present
(Parent
(Comp
))
9642 and then Nkind
(Parent
(Comp
)) in N_Subexpr
9643 and then In_Left_Hand_Side
(Parent
(Comp
)));
9644 end In_Left_Hand_Side
;
9646 -----------------------------
9647 -- Is_Subtype_Declaration --
9648 -----------------------------
9650 function Is_Subtype_Declaration
return Boolean is
9651 Par
: constant Node_Id
:= Parent
(N
);
9654 Nkind
(Par
) = N_Index_Or_Discriminant_Constraint
9655 and then Nkind
(Parent
(Parent
(Par
))) = N_Subtype_Declaration
9656 and then Comes_From_Source
(Entity
(Prefix
(N
)))
9657 and then Sloc
(Par
) = Sloc
(Entity
(Prefix
(N
)));
9658 end Is_Subtype_Declaration
;
9660 -- Start of processing for Expand_N_Selected_Component
9663 -- Insert explicit dereference if required
9665 if Is_Access_Type
(Ptyp
) then
9667 -- First set prefix type to proper access type, in case it currently
9668 -- has a private (non-access) view of this type.
9670 Set_Etype
(P
, Ptyp
);
9672 Insert_Explicit_Dereference
(P
);
9673 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
9675 if Ekind
(Etype
(P
)) = E_Private_Subtype
9676 and then Is_For_Access_Subtype
(Etype
(P
))
9678 Set_Etype
(P
, Base_Type
(Etype
(P
)));
9684 -- Deal with discriminant check required
9686 if Do_Discriminant_Check
(N
) then
9687 if Present
(Discriminant_Checking_Func
9688 (Original_Record_Component
(Entity
(S
))))
9690 -- Present the discriminant checking function to the backend, so
9691 -- that it can inline the call to the function.
9694 (Discriminant_Checking_Func
9695 (Original_Record_Component
(Entity
(S
))),
9698 -- Now reset the flag and generate the call
9700 Set_Do_Discriminant_Check
(N
, False);
9701 Generate_Discriminant_Check
(N
);
9703 -- In the case of Unchecked_Union, no discriminant checking is
9704 -- actually performed.
9707 Set_Do_Discriminant_Check
(N
, False);
9711 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9712 -- function, then additional actuals must be passed.
9714 if Ada_Version
>= Ada_2005
9715 and then Is_Build_In_Place_Function_Call
(P
)
9717 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
9720 -- Gigi cannot handle unchecked conversions that are the prefix of a
9721 -- selected component with discriminants. This must be checked during
9722 -- expansion, because during analysis the type of the selector is not
9723 -- known at the point the prefix is analyzed. If the conversion is the
9724 -- target of an assignment, then we cannot force the evaluation.
9726 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
9727 and then Has_Discriminants
(Etype
(N
))
9728 and then not In_Left_Hand_Side
(N
)
9730 Force_Evaluation
(Prefix
(N
));
9733 -- Remaining processing applies only if selector is a discriminant
9735 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
9737 -- If the selector is a discriminant of a constrained record type,
9738 -- we may be able to rewrite the expression with the actual value
9739 -- of the discriminant, a useful optimization in some cases.
9741 if Is_Record_Type
(Ptyp
)
9742 and then Has_Discriminants
(Ptyp
)
9743 and then Is_Constrained
(Ptyp
)
9745 -- Do this optimization for discrete types only, and not for
9746 -- access types (access discriminants get us into trouble).
9748 if not Is_Discrete_Type
(Etype
(N
)) then
9751 -- Don't do this on the left-hand side of an assignment statement.
9752 -- Normally one would think that references like this would not
9753 -- occur, but they do in generated code, and mean that we really
9754 -- do want to assign the discriminant.
9756 elsif Nkind
(Par
) = N_Assignment_Statement
9757 and then Name
(Par
) = N
9761 -- Don't do this optimization for the prefix of an attribute or
9762 -- the name of an object renaming declaration since these are
9763 -- contexts where we do not want the value anyway.
9765 elsif (Nkind
(Par
) = N_Attribute_Reference
9766 and then Prefix
(Par
) = N
)
9767 or else Is_Renamed_Object
(N
)
9771 -- Don't do this optimization if we are within the code for a
9772 -- discriminant check, since the whole point of such a check may
9773 -- be to verify the condition on which the code below depends.
9775 elsif Is_In_Discriminant_Check
(N
) then
9778 -- Green light to see if we can do the optimization. There is
9779 -- still one condition that inhibits the optimization below but
9780 -- now is the time to check the particular discriminant.
9783 -- Loop through discriminants to find the matching discriminant
9784 -- constraint to see if we can copy it.
9786 Disc
:= First_Discriminant
(Ptyp
);
9787 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
9788 Discr_Loop
: while Present
(Dcon
) loop
9789 Dval
:= Node
(Dcon
);
9791 -- Check if this is the matching discriminant and if the
9792 -- discriminant value is simple enough to make sense to
9793 -- copy. We don't want to copy complex expressions, and
9794 -- indeed to do so can cause trouble (before we put in
9795 -- this guard, a discriminant expression containing an
9796 -- AND THEN was copied, causing problems for coverage
9799 -- However, if the reference is part of the initialization
9800 -- code generated for an object declaration, we must use
9801 -- the discriminant value from the subtype constraint,
9802 -- because the selected component may be a reference to the
9803 -- object being initialized, whose discriminant is not yet
9804 -- set. This only happens in complex cases involving changes
9805 -- or representation.
9807 if Disc
= Entity
(Selector_Name
(N
))
9808 and then (Is_Entity_Name
(Dval
)
9809 or else Compile_Time_Known_Value
(Dval
)
9810 or else Is_Subtype_Declaration
)
9812 -- Here we have the matching discriminant. Check for
9813 -- the case of a discriminant of a component that is
9814 -- constrained by an outer discriminant, which cannot
9815 -- be optimized away.
9817 if Denotes_Discriminant
9818 (Dval
, Check_Concurrent
=> True)
9822 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
9824 Denotes_Discriminant
9825 (Selector_Name
(Original_Node
(Dval
)), True)
9829 -- Do not retrieve value if constraint is not static. It
9830 -- is generally not useful, and the constraint may be a
9831 -- rewritten outer discriminant in which case it is in
9834 elsif Is_Entity_Name
(Dval
)
9836 Nkind
(Parent
(Entity
(Dval
))) = N_Object_Declaration
9837 and then Present
(Expression
(Parent
(Entity
(Dval
))))
9839 Is_OK_Static_Expression
9840 (Expression
(Parent
(Entity
(Dval
))))
9844 -- In the context of a case statement, the expression may
9845 -- have the base type of the discriminant, and we need to
9846 -- preserve the constraint to avoid spurious errors on
9849 elsif Nkind
(Parent
(N
)) = N_Case_Statement
9850 and then Etype
(Dval
) /= Etype
(Disc
)
9853 Make_Qualified_Expression
(Loc
,
9855 New_Occurrence_Of
(Etype
(Disc
), Loc
),
9857 New_Copy_Tree
(Dval
)));
9858 Analyze_And_Resolve
(N
, Etype
(Disc
));
9860 -- In case that comes out as a static expression,
9861 -- reset it (a selected component is never static).
9863 Set_Is_Static_Expression
(N
, False);
9866 -- Otherwise we can just copy the constraint, but the
9867 -- result is certainly not static. In some cases the
9868 -- discriminant constraint has been analyzed in the
9869 -- context of the original subtype indication, but for
9870 -- itypes the constraint might not have been analyzed
9871 -- yet, and this must be done now.
9874 Rewrite
(N
, New_Copy_Tree
(Dval
));
9875 Analyze_And_Resolve
(N
);
9876 Set_Is_Static_Expression
(N
, False);
9882 Next_Discriminant
(Disc
);
9883 end loop Discr_Loop
;
9885 -- Note: the above loop should always find a matching
9886 -- discriminant, but if it does not, we just missed an
9887 -- optimization due to some glitch (perhaps a previous
9888 -- error), so ignore.
9893 -- The only remaining processing is in the case of a discriminant of
9894 -- a concurrent object, where we rewrite the prefix to denote the
9895 -- corresponding record type. If the type is derived and has renamed
9896 -- discriminants, use corresponding discriminant, which is the one
9897 -- that appears in the corresponding record.
9899 if not Is_Concurrent_Type
(Ptyp
) then
9903 Disc
:= Entity
(Selector_Name
(N
));
9905 if Is_Derived_Type
(Ptyp
)
9906 and then Present
(Corresponding_Discriminant
(Disc
))
9908 Disc
:= Corresponding_Discriminant
(Disc
);
9912 Make_Selected_Component
(Loc
,
9914 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
9916 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
9922 -- Set Atomic_Sync_Required if necessary for atomic component
9924 if Nkind
(N
) = N_Selected_Component
then
9926 E
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
9930 -- If component is atomic, but type is not, setting depends on
9931 -- disable/enable state for the component.
9933 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
9934 Set
:= not Atomic_Synchronization_Disabled
(E
);
9936 -- If component is not atomic, but its type is atomic, setting
9937 -- depends on disable/enable state for the type.
9939 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9940 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
9942 -- If both component and type are atomic, we disable if either
9943 -- component or its type have sync disabled.
9945 elsif Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
9946 Set
:= (not Atomic_Synchronization_Disabled
(E
))
9948 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
9954 -- Set flag if required
9957 Activate_Atomic_Synchronization
(N
);
9961 end Expand_N_Selected_Component
;
9963 --------------------
9964 -- Expand_N_Slice --
9965 --------------------
9967 procedure Expand_N_Slice
(N
: Node_Id
) is
9968 Loc
: constant Source_Ptr
:= Sloc
(N
);
9969 Typ
: constant Entity_Id
:= Etype
(N
);
9971 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
9972 -- Check whether the argument is an actual for a procedure call, in
9973 -- which case the expansion of a bit-packed slice is deferred until the
9974 -- call itself is expanded. The reason this is required is that we might
9975 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9976 -- that copy out would be missed if we created a temporary here in
9977 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9978 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9979 -- is harmless to defer expansion in the IN case, since the call
9980 -- processing will still generate the appropriate copy in operation,
9981 -- which will take care of the slice.
9983 procedure Make_Temporary_For_Slice
;
9984 -- Create a named variable for the value of the slice, in cases where
9985 -- the back-end cannot handle it properly, e.g. when packed types or
9986 -- unaligned slices are involved.
9988 -------------------------
9989 -- Is_Procedure_Actual --
9990 -------------------------
9992 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
9993 Par
: Node_Id
:= Parent
(N
);
9997 -- If our parent is a procedure call we can return
9999 if Nkind
(Par
) = N_Procedure_Call_Statement
then
10002 -- If our parent is a type conversion, keep climbing the tree,
10003 -- since a type conversion can be a procedure actual. Also keep
10004 -- climbing if parameter association or a qualified expression,
10005 -- since these are additional cases that do can appear on
10006 -- procedure actuals.
10008 elsif Nkind_In
(Par
, N_Type_Conversion
,
10009 N_Parameter_Association
,
10010 N_Qualified_Expression
)
10012 Par
:= Parent
(Par
);
10014 -- Any other case is not what we are looking for
10020 end Is_Procedure_Actual
;
10022 ------------------------------
10023 -- Make_Temporary_For_Slice --
10024 ------------------------------
10026 procedure Make_Temporary_For_Slice
is
10027 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
10032 Make_Object_Declaration
(Loc
,
10033 Defining_Identifier
=> Ent
,
10034 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
10036 Set_No_Initialization
(Decl
);
10038 Insert_Actions
(N
, New_List
(
10040 Make_Assignment_Statement
(Loc
,
10041 Name
=> New_Occurrence_Of
(Ent
, Loc
),
10042 Expression
=> Relocate_Node
(N
))));
10044 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
10045 Analyze_And_Resolve
(N
, Typ
);
10046 end Make_Temporary_For_Slice
;
10050 Pref
: constant Node_Id
:= Prefix
(N
);
10051 Pref_Typ
: Entity_Id
:= Etype
(Pref
);
10053 -- Start of processing for Expand_N_Slice
10056 -- Special handling for access types
10058 if Is_Access_Type
(Pref_Typ
) then
10059 Pref_Typ
:= Designated_Type
(Pref_Typ
);
10062 Make_Explicit_Dereference
(Sloc
(N
),
10063 Prefix
=> Relocate_Node
(Pref
)));
10065 Analyze_And_Resolve
(Pref
, Pref_Typ
);
10068 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10069 -- function, then additional actuals must be passed.
10071 if Ada_Version
>= Ada_2005
10072 and then Is_Build_In_Place_Function_Call
(Pref
)
10074 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
10077 -- The remaining case to be handled is packed slices. We can leave
10078 -- packed slices as they are in the following situations:
10080 -- 1. Right or left side of an assignment (we can handle this
10081 -- situation correctly in the assignment statement expansion).
10083 -- 2. Prefix of indexed component (the slide is optimized away in this
10084 -- case, see the start of Expand_N_Slice.)
10086 -- 3. Object renaming declaration, since we want the name of the
10087 -- slice, not the value.
10089 -- 4. Argument to procedure call, since copy-in/copy-out handling may
10090 -- be required, and this is handled in the expansion of call
10093 -- 5. Prefix of an address attribute (this is an error which is caught
10094 -- elsewhere, and the expansion would interfere with generating the
10097 if not Is_Packed
(Typ
) then
10099 -- Apply transformation for actuals of a function call, where
10100 -- Expand_Actuals is not used.
10102 if Nkind
(Parent
(N
)) = N_Function_Call
10103 and then Is_Possibly_Unaligned_Slice
(N
)
10105 Make_Temporary_For_Slice
;
10108 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
10109 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
10110 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
10114 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
10115 or else Is_Renamed_Object
(N
)
10116 or else Is_Procedure_Actual
(N
)
10120 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
10121 and then Attribute_Name
(Parent
(N
)) = Name_Address
10126 Make_Temporary_For_Slice
;
10128 end Expand_N_Slice
;
10130 ------------------------------
10131 -- Expand_N_Type_Conversion --
10132 ------------------------------
10134 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
10135 Loc
: constant Source_Ptr
:= Sloc
(N
);
10136 Operand
: constant Node_Id
:= Expression
(N
);
10137 Target_Type
: constant Entity_Id
:= Etype
(N
);
10138 Operand_Type
: Entity_Id
:= Etype
(Operand
);
10140 procedure Handle_Changed_Representation
;
10141 -- This is called in the case of record and array type conversions to
10142 -- see if there is a change of representation to be handled. Change of
10143 -- representation is actually handled at the assignment statement level,
10144 -- and what this procedure does is rewrite node N conversion as an
10145 -- assignment to temporary. If there is no change of representation,
10146 -- then the conversion node is unchanged.
10148 procedure Raise_Accessibility_Error
;
10149 -- Called when we know that an accessibility check will fail. Rewrites
10150 -- node N to an appropriate raise statement and outputs warning msgs.
10151 -- The Etype of the raise node is set to Target_Type. Note that in this
10152 -- case the rest of the processing should be skipped (i.e. the call to
10153 -- this procedure will be followed by "goto Done").
10155 procedure Real_Range_Check
;
10156 -- Handles generation of range check for real target value
10158 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean;
10159 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
10160 -- evaluates to True.
10162 -----------------------------------
10163 -- Handle_Changed_Representation --
10164 -----------------------------------
10166 procedure Handle_Changed_Representation
is
10175 -- Nothing else to do if no change of representation
10177 if Same_Representation
(Operand_Type
, Target_Type
) then
10180 -- The real change of representation work is done by the assignment
10181 -- statement processing. So if this type conversion is appearing as
10182 -- the expression of an assignment statement, nothing needs to be
10183 -- done to the conversion.
10185 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
10188 -- Otherwise we need to generate a temporary variable, and do the
10189 -- change of representation assignment into that temporary variable.
10190 -- The conversion is then replaced by a reference to this variable.
10195 -- If type is unconstrained we have to add a constraint, copied
10196 -- from the actual value of the left-hand side.
10198 if not Is_Constrained
(Target_Type
) then
10199 if Has_Discriminants
(Operand_Type
) then
10200 Disc
:= First_Discriminant
(Operand_Type
);
10202 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
10203 Disc
:= First_Stored_Discriminant
(Operand_Type
);
10207 while Present
(Disc
) loop
10209 Make_Selected_Component
(Loc
,
10211 Duplicate_Subexpr_Move_Checks
(Operand
),
10213 Make_Identifier
(Loc
, Chars
(Disc
))));
10214 Next_Discriminant
(Disc
);
10217 elsif Is_Array_Type
(Operand_Type
) then
10218 N_Ix
:= First_Index
(Target_Type
);
10221 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
10223 -- We convert the bounds explicitly. We use an unchecked
10224 -- conversion because bounds checks are done elsewhere.
10229 Unchecked_Convert_To
(Etype
(N_Ix
),
10230 Make_Attribute_Reference
(Loc
,
10232 Duplicate_Subexpr_No_Checks
10233 (Operand
, Name_Req
=> True),
10234 Attribute_Name
=> Name_First
,
10235 Expressions
=> New_List
(
10236 Make_Integer_Literal
(Loc
, J
)))),
10239 Unchecked_Convert_To
(Etype
(N_Ix
),
10240 Make_Attribute_Reference
(Loc
,
10242 Duplicate_Subexpr_No_Checks
10243 (Operand
, Name_Req
=> True),
10244 Attribute_Name
=> Name_Last
,
10245 Expressions
=> New_List
(
10246 Make_Integer_Literal
(Loc
, J
))))));
10253 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
10255 if Present
(Cons
) then
10257 Make_Subtype_Indication
(Loc
,
10258 Subtype_Mark
=> Odef
,
10260 Make_Index_Or_Discriminant_Constraint
(Loc
,
10261 Constraints
=> Cons
));
10264 Temp
:= Make_Temporary
(Loc
, 'C');
10266 Make_Object_Declaration
(Loc
,
10267 Defining_Identifier
=> Temp
,
10268 Object_Definition
=> Odef
);
10270 Set_No_Initialization
(Decl
, True);
10272 -- Insert required actions. It is essential to suppress checks
10273 -- since we have suppressed default initialization, which means
10274 -- that the variable we create may have no discriminants.
10279 Make_Assignment_Statement
(Loc
,
10280 Name
=> New_Occurrence_Of
(Temp
, Loc
),
10281 Expression
=> Relocate_Node
(N
))),
10282 Suppress
=> All_Checks
);
10284 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
10287 end Handle_Changed_Representation
;
10289 -------------------------------
10290 -- Raise_Accessibility_Error --
10291 -------------------------------
10293 procedure Raise_Accessibility_Error
is
10295 Error_Msg_Warn
:= SPARK_Mode
/= On
;
10297 Make_Raise_Program_Error
(Sloc
(N
),
10298 Reason
=> PE_Accessibility_Check_Failed
));
10299 Set_Etype
(N
, Target_Type
);
10301 Error_Msg_N
("<<accessibility check failure", N
);
10302 Error_Msg_NE
("\<<& [", N
, Standard_Program_Error
);
10303 end Raise_Accessibility_Error
;
10305 ----------------------
10306 -- Real_Range_Check --
10307 ----------------------
10309 -- Case of conversions to floating-point or fixed-point. If range checks
10310 -- are enabled and the target type has a range constraint, we convert:
10316 -- Tnn : typ'Base := typ'Base (x);
10317 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10320 -- This is necessary when there is a conversion of integer to float or
10321 -- to fixed-point to ensure that the correct checks are made. It is not
10322 -- necessary for float to float where it is enough to simply set the
10323 -- Do_Range_Check flag.
10325 procedure Real_Range_Check
is
10326 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
10327 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
10328 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
10329 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
10334 -- Nothing to do if conversion was rewritten
10336 if Nkind
(N
) /= N_Type_Conversion
then
10340 -- Nothing to do if range checks suppressed, or target has the same
10341 -- range as the base type (or is the base type).
10343 if Range_Checks_Suppressed
(Target_Type
)
10344 or else (Lo
= Type_Low_Bound
(Btyp
)
10346 Hi
= Type_High_Bound
(Btyp
))
10351 -- Nothing to do if expression is an entity on which checks have been
10354 if Is_Entity_Name
(Operand
)
10355 and then Range_Checks_Suppressed
(Entity
(Operand
))
10360 -- Nothing to do if bounds are all static and we can tell that the
10361 -- expression is within the bounds of the target. Note that if the
10362 -- operand is of an unconstrained floating-point type, then we do
10363 -- not trust it to be in range (might be infinite)
10366 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
10367 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
10370 if (not Is_Floating_Point_Type
(Xtyp
)
10371 or else Is_Constrained
(Xtyp
))
10372 and then Compile_Time_Known_Value
(S_Lo
)
10373 and then Compile_Time_Known_Value
(S_Hi
)
10374 and then Compile_Time_Known_Value
(Hi
)
10375 and then Compile_Time_Known_Value
(Lo
)
10378 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
10379 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
10384 if Is_Real_Type
(Xtyp
) then
10385 S_Lov
:= Expr_Value_R
(S_Lo
);
10386 S_Hiv
:= Expr_Value_R
(S_Hi
);
10388 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
10389 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
10393 and then S_Lov
>= D_Lov
10394 and then S_Hiv
<= D_Hiv
10396 -- Unset the range check flag on the current value of
10397 -- Expression (N), since the captured Operand may have
10398 -- been rewritten (such as for the case of a conversion
10399 -- to a fixed-point type).
10401 Set_Do_Range_Check
(Expression
(N
), False);
10409 -- For float to float conversions, we are done
10411 if Is_Floating_Point_Type
(Xtyp
)
10413 Is_Floating_Point_Type
(Btyp
)
10418 -- Otherwise rewrite the conversion as described above
10420 Conv
:= Relocate_Node
(N
);
10421 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
10422 Set_Etype
(Conv
, Btyp
);
10424 -- Enable overflow except for case of integer to float conversions,
10425 -- where it is never required, since we can never have overflow in
10428 if not Is_Integer_Type
(Etype
(Operand
)) then
10429 Enable_Overflow_Check
(Conv
);
10432 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
10434 Insert_Actions
(N
, New_List
(
10435 Make_Object_Declaration
(Loc
,
10436 Defining_Identifier
=> Tnn
,
10437 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
10438 Constant_Present
=> True,
10439 Expression
=> Conv
),
10441 Make_Raise_Constraint_Error
(Loc
,
10446 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10448 Make_Attribute_Reference
(Loc
,
10449 Attribute_Name
=> Name_First
,
10451 New_Occurrence_Of
(Target_Type
, Loc
))),
10455 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
10457 Make_Attribute_Reference
(Loc
,
10458 Attribute_Name
=> Name_Last
,
10460 New_Occurrence_Of
(Target_Type
, Loc
)))),
10461 Reason
=> CE_Range_Check_Failed
)));
10463 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
10464 Analyze_And_Resolve
(N
, Btyp
);
10465 end Real_Range_Check
;
10467 -----------------------------
10468 -- Has_Extra_Accessibility --
10469 -----------------------------
10471 -- Returns true for a formal of an anonymous access type or for
10472 -- an Ada 2012-style stand-alone object of an anonymous access type.
10474 function Has_Extra_Accessibility
(Id
: Entity_Id
) return Boolean is
10476 if Is_Formal
(Id
) or else Ekind_In
(Id
, E_Constant
, E_Variable
) then
10477 return Present
(Effective_Extra_Accessibility
(Id
));
10481 end Has_Extra_Accessibility
;
10483 -- Start of processing for Expand_N_Type_Conversion
10486 -- First remove check marks put by the semantic analysis on the type
10487 -- conversion between array types. We need these checks, and they will
10488 -- be generated by this expansion routine, but we do not depend on these
10489 -- flags being set, and since we do intend to expand the checks in the
10490 -- front end, we don't want them on the tree passed to the back end.
10492 if Is_Array_Type
(Target_Type
) then
10493 if Is_Constrained
(Target_Type
) then
10494 Set_Do_Length_Check
(N
, False);
10496 Set_Do_Range_Check
(Operand
, False);
10500 -- Nothing at all to do if conversion is to the identical type so remove
10501 -- the conversion completely, it is useless, except that it may carry
10502 -- an Assignment_OK attribute, which must be propagated to the operand.
10504 if Operand_Type
= Target_Type
then
10505 if Assignment_OK
(N
) then
10506 Set_Assignment_OK
(Operand
);
10509 Rewrite
(N
, Relocate_Node
(Operand
));
10513 -- Nothing to do if this is the second argument of read. This is a
10514 -- "backwards" conversion that will be handled by the specialized code
10515 -- in attribute processing.
10517 if Nkind
(Parent
(N
)) = N_Attribute_Reference
10518 and then Attribute_Name
(Parent
(N
)) = Name_Read
10519 and then Next
(First
(Expressions
(Parent
(N
)))) = N
10524 -- Check for case of converting to a type that has an invariant
10525 -- associated with it. This required an invariant check. We convert
10531 -- do invariant_check (typ (expr)) in typ (expr);
10533 -- using Duplicate_Subexpr to avoid multiple side effects
10535 -- Note: the Comes_From_Source check, and then the resetting of this
10536 -- flag prevents what would otherwise be an infinite recursion.
10538 if Has_Invariants
(Target_Type
)
10539 and then Present
(Invariant_Procedure
(Target_Type
))
10540 and then Comes_From_Source
(N
)
10542 Set_Comes_From_Source
(N
, False);
10544 Make_Expression_With_Actions
(Loc
,
10545 Actions
=> New_List
(
10546 Make_Invariant_Call
(Duplicate_Subexpr
(N
))),
10547 Expression
=> Duplicate_Subexpr_No_Checks
(N
)));
10548 Analyze_And_Resolve
(N
, Target_Type
);
10552 -- Here if we may need to expand conversion
10554 -- If the operand of the type conversion is an arithmetic operation on
10555 -- signed integers, and the based type of the signed integer type in
10556 -- question is smaller than Standard.Integer, we promote both of the
10557 -- operands to type Integer.
10559 -- For example, if we have
10561 -- target-type (opnd1 + opnd2)
10563 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10566 -- target-type (integer(opnd1) + integer(opnd2))
10568 -- We do this because we are always allowed to compute in a larger type
10569 -- if we do the right thing with the result, and in this case we are
10570 -- going to do a conversion which will do an appropriate check to make
10571 -- sure that things are in range of the target type in any case. This
10572 -- avoids some unnecessary intermediate overflows.
10574 -- We might consider a similar transformation in the case where the
10575 -- target is a real type or a 64-bit integer type, and the operand
10576 -- is an arithmetic operation using a 32-bit integer type. However,
10577 -- we do not bother with this case, because it could cause significant
10578 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10579 -- much cheaper, but we don't want different behavior on 32-bit and
10580 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10581 -- handles the configurable run-time cases where 64-bit arithmetic
10582 -- may simply be unavailable.
10584 -- Note: this circuit is partially redundant with respect to the circuit
10585 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10586 -- the processing here. Also we still need the Checks circuit, since we
10587 -- have to be sure not to generate junk overflow checks in the first
10588 -- place, since it would be trick to remove them here.
10590 if Integer_Promotion_Possible
(N
) then
10592 -- All conditions met, go ahead with transformation
10600 Make_Type_Conversion
(Loc
,
10601 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10602 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
10604 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
10605 Set_Right_Opnd
(Opnd
, R
);
10607 if Nkind
(Operand
) in N_Binary_Op
then
10609 Make_Type_Conversion
(Loc
,
10610 Subtype_Mark
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
10611 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
10613 Set_Left_Opnd
(Opnd
, L
);
10617 Make_Type_Conversion
(Loc
,
10618 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
10619 Expression
=> Opnd
));
10621 Analyze_And_Resolve
(N
, Target_Type
);
10626 -- Do validity check if validity checking operands
10628 if Validity_Checks_On
and Validity_Check_Operands
then
10629 Ensure_Valid
(Operand
);
10632 -- Special case of converting from non-standard boolean type
10634 if Is_Boolean_Type
(Operand_Type
)
10635 and then (Nonzero_Is_True
(Operand_Type
))
10637 Adjust_Condition
(Operand
);
10638 Set_Etype
(Operand
, Standard_Boolean
);
10639 Operand_Type
:= Standard_Boolean
;
10642 -- Case of converting to an access type
10644 if Is_Access_Type
(Target_Type
) then
10646 -- Apply an accessibility check when the conversion operand is an
10647 -- access parameter (or a renaming thereof), unless conversion was
10648 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10649 -- Note that other checks may still need to be applied below (such
10650 -- as tagged type checks).
10652 if Is_Entity_Name
(Operand
)
10653 and then Has_Extra_Accessibility
(Entity
(Operand
))
10654 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
10655 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
10656 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
10658 Apply_Accessibility_Check
10659 (Operand
, Target_Type
, Insert_Node
=> Operand
);
10661 -- If the level of the operand type is statically deeper than the
10662 -- level of the target type, then force Program_Error. Note that this
10663 -- can only occur for cases where the attribute is within the body of
10664 -- an instantiation, otherwise the conversion will already have been
10665 -- rejected as illegal.
10667 -- Note: warnings are issued by the analyzer for the instance cases
10669 elsif In_Instance_Body
10671 -- The case where the target type is an anonymous access type of
10672 -- a discriminant is excluded, because the level of such a type
10673 -- depends on the context and currently the level returned for such
10674 -- types is zero, resulting in warnings about about check failures
10675 -- in certain legal cases involving class-wide interfaces as the
10676 -- designated type (some cases, such as return statements, are
10677 -- checked at run time, but not clear if these are handled right
10678 -- in general, see 3.10.2(12/2-12.5/3) ???).
10681 not (Ekind
(Target_Type
) = E_Anonymous_Access_Type
10682 and then Present
(Associated_Node_For_Itype
(Target_Type
))
10683 and then Nkind
(Associated_Node_For_Itype
(Target_Type
)) =
10684 N_Discriminant_Specification
)
10686 Type_Access_Level
(Operand_Type
) > Type_Access_Level
(Target_Type
)
10688 Raise_Accessibility_Error
;
10691 -- When the operand is a selected access discriminant the check needs
10692 -- to be made against the level of the object denoted by the prefix
10693 -- of the selected name. Force Program_Error for this case as well
10694 -- (this accessibility violation can only happen if within the body
10695 -- of an instantiation).
10697 elsif In_Instance_Body
10698 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
10699 and then Nkind
(Operand
) = N_Selected_Component
10700 and then Object_Access_Level
(Operand
) >
10701 Type_Access_Level
(Target_Type
)
10703 Raise_Accessibility_Error
;
10708 -- Case of conversions of tagged types and access to tagged types
10710 -- When needed, that is to say when the expression is class-wide, Add
10711 -- runtime a tag check for (strict) downward conversion by using the
10712 -- membership test, generating:
10714 -- [constraint_error when Operand not in Target_Type'Class]
10716 -- or in the access type case
10718 -- [constraint_error
10719 -- when Operand /= null
10720 -- and then Operand.all not in
10721 -- Designated_Type (Target_Type)'Class]
10723 if (Is_Access_Type
(Target_Type
)
10724 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
10725 or else Is_Tagged_Type
(Target_Type
)
10727 -- Do not do any expansion in the access type case if the parent is a
10728 -- renaming, since this is an error situation which will be caught by
10729 -- Sem_Ch8, and the expansion can interfere with this error check.
10731 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
10735 -- Otherwise, proceed with processing tagged conversion
10737 Tagged_Conversion
: declare
10738 Actual_Op_Typ
: Entity_Id
;
10739 Actual_Targ_Typ
: Entity_Id
;
10740 Make_Conversion
: Boolean := False;
10741 Root_Op_Typ
: Entity_Id
;
10743 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
10744 -- Create a membership check to test whether Operand is a member
10745 -- of Targ_Typ. If the original Target_Type is an access, include
10746 -- a test for null value. The check is inserted at N.
10748 --------------------
10749 -- Make_Tag_Check --
10750 --------------------
10752 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
10757 -- [Constraint_Error
10758 -- when Operand /= null
10759 -- and then Operand.all not in Targ_Typ]
10761 if Is_Access_Type
(Target_Type
) then
10763 Make_And_Then
(Loc
,
10766 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10767 Right_Opnd
=> Make_Null
(Loc
)),
10772 Make_Explicit_Dereference
(Loc
,
10773 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
10774 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
)));
10777 -- [Constraint_Error when Operand not in Targ_Typ]
10782 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
10783 Right_Opnd
=> New_Occurrence_Of
(Targ_Typ
, Loc
));
10787 Make_Raise_Constraint_Error
(Loc
,
10789 Reason
=> CE_Tag_Check_Failed
));
10790 end Make_Tag_Check
;
10792 -- Start of processing for Tagged_Conversion
10795 -- Handle entities from the limited view
10797 if Is_Access_Type
(Operand_Type
) then
10799 Available_View
(Designated_Type
(Operand_Type
));
10801 Actual_Op_Typ
:= Operand_Type
;
10804 if Is_Access_Type
(Target_Type
) then
10806 Available_View
(Designated_Type
(Target_Type
));
10808 Actual_Targ_Typ
:= Target_Type
;
10811 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
10813 -- Ada 2005 (AI-251): Handle interface type conversion
10815 if Is_Interface
(Actual_Op_Typ
)
10817 Is_Interface
(Actual_Targ_Typ
)
10819 Expand_Interface_Conversion
(N
);
10823 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
10825 -- Create a runtime tag check for a downward class-wide type
10828 if Is_Class_Wide_Type
(Actual_Op_Typ
)
10829 and then Actual_Op_Typ
/= Actual_Targ_Typ
10830 and then Root_Op_Typ
/= Actual_Targ_Typ
10831 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
,
10832 Use_Full_View
=> True)
10834 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
10835 Make_Conversion
:= True;
10838 -- AI05-0073: If the result subtype of the function is defined
10839 -- by an access_definition designating a specific tagged type
10840 -- T, a check is made that the result value is null or the tag
10841 -- of the object designated by the result value identifies T.
10842 -- Constraint_Error is raised if this check fails.
10844 if Nkind
(Parent
(N
)) = N_Simple_Return_Statement
then
10847 Func_Typ
: Entity_Id
;
10850 -- Climb scope stack looking for the enclosing function
10852 Func
:= Current_Scope
;
10853 while Present
(Func
)
10854 and then Ekind
(Func
) /= E_Function
10856 Func
:= Scope
(Func
);
10859 -- The function's return subtype must be defined using
10860 -- an access definition.
10862 if Nkind
(Result_Definition
(Parent
(Func
))) =
10863 N_Access_Definition
10865 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
10867 -- The return subtype denotes a specific tagged type,
10868 -- in other words, a non class-wide type.
10870 if Is_Tagged_Type
(Func_Typ
)
10871 and then not Is_Class_Wide_Type
(Func_Typ
)
10873 Make_Tag_Check
(Actual_Targ_Typ
);
10874 Make_Conversion
:= True;
10880 -- We have generated a tag check for either a class-wide type
10881 -- conversion or for AI05-0073.
10883 if Make_Conversion
then
10888 Make_Unchecked_Type_Conversion
(Loc
,
10889 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
10890 Expression
=> Relocate_Node
(Expression
(N
)));
10892 Analyze_And_Resolve
(N
, Target_Type
);
10896 end Tagged_Conversion
;
10898 -- Case of other access type conversions
10900 elsif Is_Access_Type
(Target_Type
) then
10901 Apply_Constraint_Check
(Operand
, Target_Type
);
10903 -- Case of conversions from a fixed-point type
10905 -- These conversions require special expansion and processing, found in
10906 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10907 -- since from a semantic point of view, these are simple integer
10908 -- conversions, which do not need further processing.
10910 elsif Is_Fixed_Point_Type
(Operand_Type
)
10911 and then not Conversion_OK
(N
)
10913 -- We should never see universal fixed at this case, since the
10914 -- expansion of the constituent divide or multiply should have
10915 -- eliminated the explicit mention of universal fixed.
10917 pragma Assert
(Operand_Type
/= Universal_Fixed
);
10919 -- Check for special case of the conversion to universal real that
10920 -- occurs as a result of the use of a round attribute. In this case,
10921 -- the real type for the conversion is taken from the target type of
10922 -- the Round attribute and the result must be marked as rounded.
10924 if Target_Type
= Universal_Real
10925 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
10926 and then Attribute_Name
(Parent
(N
)) = Name_Round
10928 Set_Rounded_Result
(N
);
10929 Set_Etype
(N
, Etype
(Parent
(N
)));
10932 -- Otherwise do correct fixed-conversion, but skip these if the
10933 -- Conversion_OK flag is set, because from a semantic point of view
10934 -- these are simple integer conversions needing no further processing
10935 -- (the backend will simply treat them as integers).
10937 if not Conversion_OK
(N
) then
10938 if Is_Fixed_Point_Type
(Etype
(N
)) then
10939 Expand_Convert_Fixed_To_Fixed
(N
);
10942 elsif Is_Integer_Type
(Etype
(N
)) then
10943 Expand_Convert_Fixed_To_Integer
(N
);
10946 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
10947 Expand_Convert_Fixed_To_Float
(N
);
10952 -- Case of conversions to a fixed-point type
10954 -- These conversions require special expansion and processing, found in
10955 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10956 -- since from a semantic point of view, these are simple integer
10957 -- conversions, which do not need further processing.
10959 elsif Is_Fixed_Point_Type
(Target_Type
)
10960 and then not Conversion_OK
(N
)
10962 if Is_Integer_Type
(Operand_Type
) then
10963 Expand_Convert_Integer_To_Fixed
(N
);
10966 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
10967 Expand_Convert_Float_To_Fixed
(N
);
10971 -- Case of float-to-integer conversions
10973 -- We also handle float-to-fixed conversions with Conversion_OK set
10974 -- since semantically the fixed-point target is treated as though it
10975 -- were an integer in such cases.
10977 elsif Is_Floating_Point_Type
(Operand_Type
)
10979 (Is_Integer_Type
(Target_Type
)
10981 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
10983 -- One more check here, gcc is still not able to do conversions of
10984 -- this type with proper overflow checking, and so gigi is doing an
10985 -- approximation of what is required by doing floating-point compares
10986 -- with the end-point. But that can lose precision in some cases, and
10987 -- give a wrong result. Converting the operand to Universal_Real is
10988 -- helpful, but still does not catch all cases with 64-bit integers
10989 -- on targets with only 64-bit floats.
10991 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10992 -- Can this code be removed ???
10994 if Do_Range_Check
(Operand
) then
10996 Make_Type_Conversion
(Loc
,
10998 New_Occurrence_Of
(Universal_Real
, Loc
),
11000 Relocate_Node
(Operand
)));
11002 Set_Etype
(Operand
, Universal_Real
);
11003 Enable_Range_Check
(Operand
);
11004 Set_Do_Range_Check
(Expression
(Operand
), False);
11007 -- Case of array conversions
11009 -- Expansion of array conversions, add required length/range checks but
11010 -- only do this if there is no change of representation. For handling of
11011 -- this case, see Handle_Changed_Representation.
11013 elsif Is_Array_Type
(Target_Type
) then
11014 if Is_Constrained
(Target_Type
) then
11015 Apply_Length_Check
(Operand
, Target_Type
);
11017 Apply_Range_Check
(Operand
, Target_Type
);
11020 Handle_Changed_Representation
;
11022 -- Case of conversions of discriminated types
11024 -- Add required discriminant checks if target is constrained. Again this
11025 -- change is skipped if we have a change of representation.
11027 elsif Has_Discriminants
(Target_Type
)
11028 and then Is_Constrained
(Target_Type
)
11030 Apply_Discriminant_Check
(Operand
, Target_Type
);
11031 Handle_Changed_Representation
;
11033 -- Case of all other record conversions. The only processing required
11034 -- is to check for a change of representation requiring the special
11035 -- assignment processing.
11037 elsif Is_Record_Type
(Target_Type
) then
11039 -- Ada 2005 (AI-216): Program_Error is raised when converting from
11040 -- a derived Unchecked_Union type to an unconstrained type that is
11041 -- not Unchecked_Union if the operand lacks inferable discriminants.
11043 if Is_Derived_Type
(Operand_Type
)
11044 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
11045 and then not Is_Constrained
(Target_Type
)
11046 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
11047 and then not Has_Inferable_Discriminants
(Operand
)
11049 -- To prevent Gigi from generating illegal code, we generate a
11050 -- Program_Error node, but we give it the target type of the
11051 -- conversion (is this requirement documented somewhere ???)
11054 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
11055 Reason
=> PE_Unchecked_Union_Restriction
);
11058 Set_Etype
(PE
, Target_Type
);
11063 Handle_Changed_Representation
;
11066 -- Case of conversions of enumeration types
11068 elsif Is_Enumeration_Type
(Target_Type
) then
11070 -- Special processing is required if there is a change of
11071 -- representation (from enumeration representation clauses).
11073 if not Same_Representation
(Target_Type
, Operand_Type
) then
11075 -- Convert: x(y) to x'val (ytyp'val (y))
11078 Make_Attribute_Reference
(Loc
,
11079 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
11080 Attribute_Name
=> Name_Val
,
11081 Expressions
=> New_List
(
11082 Make_Attribute_Reference
(Loc
,
11083 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
11084 Attribute_Name
=> Name_Pos
,
11085 Expressions
=> New_List
(Operand
)))));
11087 Analyze_And_Resolve
(N
, Target_Type
);
11090 -- Case of conversions to floating-point
11092 elsif Is_Floating_Point_Type
(Target_Type
) then
11096 -- At this stage, either the conversion node has been transformed into
11097 -- some other equivalent expression, or left as a conversion that can be
11098 -- handled by Gigi, in the following cases:
11100 -- Conversions with no change of representation or type
11102 -- Numeric conversions involving integer, floating- and fixed-point
11103 -- values. Fixed-point values are allowed only if Conversion_OK is
11104 -- set, i.e. if the fixed-point values are to be treated as integers.
11106 -- No other conversions should be passed to Gigi
11108 -- Check: are these rules stated in sinfo??? if so, why restate here???
11110 -- The only remaining step is to generate a range check if we still have
11111 -- a type conversion at this stage and Do_Range_Check is set. For now we
11112 -- do this only for conversions of discrete types and for float-to-float
11115 if Nkind
(N
) = N_Type_Conversion
then
11117 -- For now we only support floating-point cases where both source
11118 -- and target are floating-point types. Conversions where the source
11119 -- and target involve integer or fixed-point types are still TBD,
11120 -- though not clear whether those can even happen at this point, due
11121 -- to transformations above. ???
11123 if Is_Floating_Point_Type
(Etype
(N
))
11124 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
11126 if Do_Range_Check
(Expression
(N
))
11127 and then Is_Floating_Point_Type
(Target_Type
)
11129 Generate_Range_Check
11130 (Expression
(N
), Target_Type
, CE_Range_Check_Failed
);
11133 -- Discrete-to-discrete conversions
11135 elsif Is_Discrete_Type
(Etype
(N
)) then
11137 Expr
: constant Node_Id
:= Expression
(N
);
11142 if Do_Range_Check
(Expr
)
11143 and then Is_Discrete_Type
(Etype
(Expr
))
11145 Set_Do_Range_Check
(Expr
, False);
11147 -- Before we do a range check, we have to deal with treating
11148 -- a fixed-point operand as an integer. The way we do this
11149 -- is simply to do an unchecked conversion to an appropriate
11150 -- integer type large enough to hold the result.
11152 -- This code is not active yet, because we are only dealing
11153 -- with discrete types so far ???
11155 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
11156 and then Treat_Fixed_As_Integer
(Expr
)
11158 Ftyp
:= Base_Type
(Etype
(Expr
));
11160 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
11161 Ityp
:= Standard_Long_Long_Integer
;
11163 Ityp
:= Standard_Integer
;
11166 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
11169 -- Reset overflow flag, since the range check will include
11170 -- dealing with possible overflow, and generate the check.
11171 -- If Address is either a source type or target type,
11172 -- suppress range check to avoid typing anomalies when
11173 -- it is a visible integer type.
11175 Set_Do_Overflow_Check
(N
, False);
11177 if not Is_Descendant_Of_Address
(Etype
(Expr
))
11178 and then not Is_Descendant_Of_Address
(Target_Type
)
11180 Generate_Range_Check
11181 (Expr
, Target_Type
, CE_Range_Check_Failed
);
11188 -- Here at end of processing
11191 -- Apply predicate check if required. Note that we can't just call
11192 -- Apply_Predicate_Check here, because the type looks right after
11193 -- the conversion and it would omit the check. The Comes_From_Source
11194 -- guard is necessary to prevent infinite recursions when we generate
11195 -- internal conversions for the purpose of checking predicates.
11197 if Present
(Predicate_Function
(Target_Type
))
11198 and then not Predicates_Ignored
(Target_Type
)
11199 and then Target_Type
/= Operand_Type
11200 and then Comes_From_Source
(N
)
11203 New_Expr
: constant Node_Id
:= Duplicate_Subexpr
(N
);
11206 -- Avoid infinite recursion on the subsequent expansion of
11207 -- of the copy of the original type conversion.
11209 Set_Comes_From_Source
(New_Expr
, False);
11210 Insert_Action
(N
, Make_Predicate_Check
(Target_Type
, New_Expr
));
11213 end Expand_N_Type_Conversion
;
11215 -----------------------------------
11216 -- Expand_N_Unchecked_Expression --
11217 -----------------------------------
11219 -- Remove the unchecked expression node from the tree. Its job was simply
11220 -- to make sure that its constituent expression was handled with checks
11221 -- off, and now that that is done, we can remove it from the tree, and
11222 -- indeed must, since Gigi does not expect to see these nodes.
11224 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
11225 Exp
: constant Node_Id
:= Expression
(N
);
11227 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
11229 end Expand_N_Unchecked_Expression
;
11231 ----------------------------------------
11232 -- Expand_N_Unchecked_Type_Conversion --
11233 ----------------------------------------
11235 -- If this cannot be handled by Gigi and we haven't already made a
11236 -- temporary for it, do it now.
11238 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
11239 Target_Type
: constant Entity_Id
:= Etype
(N
);
11240 Operand
: constant Node_Id
:= Expression
(N
);
11241 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
11244 -- Nothing at all to do if conversion is to the identical type so remove
11245 -- the conversion completely, it is useless, except that it may carry
11246 -- an Assignment_OK indication which must be propagated to the operand.
11248 if Operand_Type
= Target_Type
then
11250 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
11252 if Assignment_OK
(N
) then
11253 Set_Assignment_OK
(Operand
);
11256 Rewrite
(N
, Relocate_Node
(Operand
));
11260 -- If we have a conversion of a compile time known value to a target
11261 -- type and the value is in range of the target type, then we can simply
11262 -- replace the construct by an integer literal of the correct type. We
11263 -- only apply this to integer types being converted. Possibly it may
11264 -- apply in other cases, but it is too much trouble to worry about.
11266 -- Note that we do not do this transformation if the Kill_Range_Check
11267 -- flag is set, since then the value may be outside the expected range.
11268 -- This happens in the Normalize_Scalars case.
11270 -- We also skip this if either the target or operand type is biased
11271 -- because in this case, the unchecked conversion is supposed to
11272 -- preserve the bit pattern, not the integer value.
11274 if Is_Integer_Type
(Target_Type
)
11275 and then not Has_Biased_Representation
(Target_Type
)
11276 and then Is_Integer_Type
(Operand_Type
)
11277 and then not Has_Biased_Representation
(Operand_Type
)
11278 and then Compile_Time_Known_Value
(Operand
)
11279 and then not Kill_Range_Check
(N
)
11282 Val
: constant Uint
:= Expr_Value
(Operand
);
11285 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
11287 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
11289 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
11291 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
11293 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
11295 -- If Address is the target type, just set the type to avoid a
11296 -- spurious type error on the literal when Address is a visible
11299 if Is_Descendant_Of_Address
(Target_Type
) then
11300 Set_Etype
(N
, Target_Type
);
11302 Analyze_And_Resolve
(N
, Target_Type
);
11310 -- Nothing to do if conversion is safe
11312 if Safe_Unchecked_Type_Conversion
(N
) then
11316 -- Otherwise force evaluation unless Assignment_OK flag is set (this
11317 -- flag indicates ??? More comments needed here)
11319 if Assignment_OK
(N
) then
11322 Force_Evaluation
(N
);
11324 end Expand_N_Unchecked_Type_Conversion
;
11326 ----------------------------
11327 -- Expand_Record_Equality --
11328 ----------------------------
11330 -- For non-variant records, Equality is expanded when needed into:
11332 -- and then Lhs.Discr1 = Rhs.Discr1
11334 -- and then Lhs.Discrn = Rhs.Discrn
11335 -- and then Lhs.Cmp1 = Rhs.Cmp1
11337 -- and then Lhs.Cmpn = Rhs.Cmpn
11339 -- The expression is folded by the back-end for adjacent fields. This
11340 -- function is called for tagged record in only one occasion: for imple-
11341 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11342 -- otherwise the primitive "=" is used directly.
11344 function Expand_Record_Equality
11349 Bodies
: List_Id
) return Node_Id
11351 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
11356 First_Time
: Boolean := True;
11358 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
;
11359 -- Return the next discriminant or component to compare, starting with
11360 -- C, skipping inherited components.
11362 ------------------------
11363 -- Element_To_Compare --
11364 ------------------------
11366 function Element_To_Compare
(C
: Entity_Id
) return Entity_Id
is
11372 -- Exit loop when the next element to be compared is found, or
11373 -- there is no more such element.
11375 exit when No
(Comp
);
11377 exit when Ekind_In
(Comp
, E_Discriminant
, E_Component
)
11380 -- Skip inherited components
11382 -- Note: for a tagged type, we always generate the "=" primitive
11383 -- for the base type (not on the first subtype), so the test for
11384 -- Comp /= Original_Record_Component (Comp) is True for
11385 -- inherited components only.
11387 (Is_Tagged_Type
(Typ
)
11388 and then Comp
/= Original_Record_Component
(Comp
))
11392 or else Chars
(Comp
) = Name_uTag
11394 -- Skip interface elements (secondary tags???)
11396 or else Is_Interface
(Etype
(Comp
)));
11398 Next_Entity
(Comp
);
11402 end Element_To_Compare
;
11404 -- Start of processing for Expand_Record_Equality
11407 -- Generates the following code: (assuming that Typ has one Discr and
11408 -- component C2 is also a record)
11411 -- and then Lhs.Discr1 = Rhs.Discr1
11412 -- and then Lhs.C1 = Rhs.C1
11413 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11415 -- and then Lhs.Cmpn = Rhs.Cmpn
11417 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
11418 C
:= Element_To_Compare
(First_Entity
(Typ
));
11419 while Present
(C
) loop
11427 First_Time
:= False;
11431 New_Lhs
:= New_Copy_Tree
(Lhs
);
11432 New_Rhs
:= New_Copy_Tree
(Rhs
);
11436 Expand_Composite_Equality
(Nod
, Etype
(C
),
11438 Make_Selected_Component
(Loc
,
11440 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11442 Make_Selected_Component
(Loc
,
11444 Selector_Name
=> New_Occurrence_Of
(C
, Loc
)),
11447 -- If some (sub)component is an unchecked_union, the whole
11448 -- operation will raise program error.
11450 if Nkind
(Check
) = N_Raise_Program_Error
then
11452 Set_Etype
(Result
, Standard_Boolean
);
11456 Make_And_Then
(Loc
,
11457 Left_Opnd
=> Result
,
11458 Right_Opnd
=> Check
);
11462 C
:= Element_To_Compare
(Next_Entity
(C
));
11466 end Expand_Record_Equality
;
11468 ---------------------------
11469 -- Expand_Set_Membership --
11470 ---------------------------
11472 procedure Expand_Set_Membership
(N
: Node_Id
) is
11473 Lop
: constant Node_Id
:= Left_Opnd
(N
);
11477 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
11478 -- If the alternative is a subtype mark, create a simple membership
11479 -- test. Otherwise create an equality test for it.
11485 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
11487 L
: constant Node_Id
:= New_Copy
(Lop
);
11488 R
: constant Node_Id
:= Relocate_Node
(Alt
);
11491 if (Is_Entity_Name
(Alt
) and then Is_Type
(Entity
(Alt
)))
11492 or else Nkind
(Alt
) = N_Range
11495 Make_In
(Sloc
(Alt
),
11500 Make_Op_Eq
(Sloc
(Alt
),
11508 -- Start of processing for Expand_Set_Membership
11511 Remove_Side_Effects
(Lop
);
11513 Alt
:= Last
(Alternatives
(N
));
11514 Res
:= Make_Cond
(Alt
);
11517 while Present
(Alt
) loop
11519 Make_Or_Else
(Sloc
(Alt
),
11520 Left_Opnd
=> Make_Cond
(Alt
),
11521 Right_Opnd
=> Res
);
11526 Analyze_And_Resolve
(N
, Standard_Boolean
);
11527 end Expand_Set_Membership
;
11529 -----------------------------------
11530 -- Expand_Short_Circuit_Operator --
11531 -----------------------------------
11533 -- Deal with special expansion if actions are present for the right operand
11534 -- and deal with optimizing case of arguments being True or False. We also
11535 -- deal with the special case of non-standard boolean values.
11537 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
11538 Loc
: constant Source_Ptr
:= Sloc
(N
);
11539 Typ
: constant Entity_Id
:= Etype
(N
);
11540 Left
: constant Node_Id
:= Left_Opnd
(N
);
11541 Right
: constant Node_Id
:= Right_Opnd
(N
);
11542 LocR
: constant Source_Ptr
:= Sloc
(Right
);
11545 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
11546 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
11547 -- If Left = Shortcut_Value then Right need not be evaluated
11549 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
11550 -- For Opnd a boolean expression, return a Boolean expression equivalent
11551 -- to Opnd /= Shortcut_Value.
11553 --------------------
11554 -- Make_Test_Expr --
11555 --------------------
11557 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
11559 if Shortcut_Value
then
11560 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
11564 end Make_Test_Expr
;
11568 Op_Var
: Entity_Id
;
11569 -- Entity for a temporary variable holding the value of the operator,
11570 -- used for expansion in the case where actions are present.
11572 -- Start of processing for Expand_Short_Circuit_Operator
11575 -- Deal with non-standard booleans
11577 if Is_Boolean_Type
(Typ
) then
11578 Adjust_Condition
(Left
);
11579 Adjust_Condition
(Right
);
11580 Set_Etype
(N
, Standard_Boolean
);
11583 -- Check for cases where left argument is known to be True or False
11585 if Compile_Time_Known_Value
(Left
) then
11587 -- Mark SCO for left condition as compile time known
11589 if Generate_SCO
and then Comes_From_Source
(Left
) then
11590 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
11593 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11594 -- Any actions associated with Right will be executed unconditionally
11595 -- and can thus be inserted into the tree unconditionally.
11597 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
11598 if Present
(Actions
(N
)) then
11599 Insert_Actions
(N
, Actions
(N
));
11602 Rewrite
(N
, Right
);
11604 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11605 -- In this case we can forget the actions associated with Right,
11606 -- since they will never be executed.
11609 Kill_Dead_Code
(Right
);
11610 Kill_Dead_Code
(Actions
(N
));
11611 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11614 Adjust_Result_Type
(N
, Typ
);
11618 -- If Actions are present for the right operand, we have to do some
11619 -- special processing. We can't just let these actions filter back into
11620 -- code preceding the short circuit (which is what would have happened
11621 -- if we had not trapped them in the short-circuit form), since they
11622 -- must only be executed if the right operand of the short circuit is
11623 -- executed and not otherwise.
11625 if Present
(Actions
(N
)) then
11626 Actlist
:= Actions
(N
);
11628 -- The old approach is to expand:
11630 -- left AND THEN right
11634 -- C : Boolean := False;
11642 -- and finally rewrite the operator into a reference to C. Similarly
11643 -- for left OR ELSE right, with negated values. Note that this
11644 -- rewrite causes some difficulties for coverage analysis because
11645 -- of the introduction of the new variable C, which obscures the
11646 -- structure of the test.
11648 -- We use this "old approach" if Minimize_Expression_With_Actions
11651 if Minimize_Expression_With_Actions
then
11652 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
11655 Make_Object_Declaration
(Loc
,
11656 Defining_Identifier
=> Op_Var
,
11657 Object_Definition
=>
11658 New_Occurrence_Of
(Standard_Boolean
, Loc
),
11660 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
11662 Append_To
(Actlist
,
11663 Make_Implicit_If_Statement
(Right
,
11664 Condition
=> Make_Test_Expr
(Right
),
11665 Then_Statements
=> New_List
(
11666 Make_Assignment_Statement
(LocR
,
11667 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
11670 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
11673 Make_Implicit_If_Statement
(Left
,
11674 Condition
=> Make_Test_Expr
(Left
),
11675 Then_Statements
=> Actlist
));
11677 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
11678 Analyze_And_Resolve
(N
, Standard_Boolean
);
11680 -- The new approach (the default) is to use an
11681 -- Expression_With_Actions node for the right operand of the
11682 -- short-circuit form. Note that this solves the traceability
11683 -- problems for coverage analysis.
11687 Make_Expression_With_Actions
(LocR
,
11688 Expression
=> Relocate_Node
(Right
),
11689 Actions
=> Actlist
));
11691 Set_Actions
(N
, No_List
);
11692 Analyze_And_Resolve
(Right
, Standard_Boolean
);
11695 Adjust_Result_Type
(N
, Typ
);
11699 -- No actions present, check for cases of right argument True/False
11701 if Compile_Time_Known_Value
(Right
) then
11703 -- Mark SCO for left condition as compile time known
11705 if Generate_SCO
and then Comes_From_Source
(Right
) then
11706 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
11709 -- Change (Left and then True), (Left or else False) to Left. Note
11710 -- that we know there are no actions associated with the right
11711 -- operand, since we just checked for this case above.
11713 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
11716 -- Change (Left and then False), (Left or else True) to Right,
11717 -- making sure to preserve any side effects associated with the Left
11721 Remove_Side_Effects
(Left
);
11722 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
11726 Adjust_Result_Type
(N
, Typ
);
11727 end Expand_Short_Circuit_Operator
;
11729 -------------------------------------
11730 -- Fixup_Universal_Fixed_Operation --
11731 -------------------------------------
11733 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
11734 Conv
: constant Node_Id
:= Parent
(N
);
11737 -- We must have a type conversion immediately above us
11739 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
11741 -- Normally the type conversion gives our target type. The exception
11742 -- occurs in the case of the Round attribute, where the conversion
11743 -- will be to universal real, and our real type comes from the Round
11744 -- attribute (as well as an indication that we must round the result)
11746 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
11747 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
11749 Set_Etype
(N
, Etype
(Parent
(Conv
)));
11750 Set_Rounded_Result
(N
);
11752 -- Normal case where type comes from conversion above us
11755 Set_Etype
(N
, Etype
(Conv
));
11757 end Fixup_Universal_Fixed_Operation
;
11759 ---------------------------------
11760 -- Has_Inferable_Discriminants --
11761 ---------------------------------
11763 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
11765 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
11766 -- Determines whether the left-most prefix of a selected component is a
11767 -- formal parameter in a subprogram. Assumes N is a selected component.
11769 --------------------------------
11770 -- Prefix_Is_Formal_Parameter --
11771 --------------------------------
11773 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
11774 Sel_Comp
: Node_Id
;
11777 -- Move to the left-most prefix by climbing up the tree
11780 while Present
(Parent
(Sel_Comp
))
11781 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
11783 Sel_Comp
:= Parent
(Sel_Comp
);
11786 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
11787 end Prefix_Is_Formal_Parameter
;
11789 -- Start of processing for Has_Inferable_Discriminants
11792 -- For selected components, the subtype of the selector must be a
11793 -- constrained Unchecked_Union. If the component is subject to a
11794 -- per-object constraint, then the enclosing object must have inferable
11797 if Nkind
(N
) = N_Selected_Component
then
11798 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
11800 -- A small hack. If we have a per-object constrained selected
11801 -- component of a formal parameter, return True since we do not
11802 -- know the actual parameter association yet.
11804 if Prefix_Is_Formal_Parameter
(N
) then
11807 -- Otherwise, check the enclosing object and the selector
11810 return Has_Inferable_Discriminants
(Prefix
(N
))
11811 and then Has_Inferable_Discriminants
(Selector_Name
(N
));
11814 -- The call to Has_Inferable_Discriminants will determine whether
11815 -- the selector has a constrained Unchecked_Union nominal type.
11818 return Has_Inferable_Discriminants
(Selector_Name
(N
));
11821 -- A qualified expression has inferable discriminants if its subtype
11822 -- mark is a constrained Unchecked_Union subtype.
11824 elsif Nkind
(N
) = N_Qualified_Expression
then
11825 return Is_Unchecked_Union
(Etype
(Subtype_Mark
(N
)))
11826 and then Is_Constrained
(Etype
(Subtype_Mark
(N
)));
11828 -- For all other names, it is sufficient to have a constrained
11829 -- Unchecked_Union nominal subtype.
11832 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
11833 and then Is_Constrained
(Etype
(N
));
11835 end Has_Inferable_Discriminants
;
11837 -------------------------------
11838 -- Insert_Dereference_Action --
11839 -------------------------------
11841 procedure Insert_Dereference_Action
(N
: Node_Id
) is
11843 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
11844 -- Return true if type of P is derived from Checked_Pool;
11846 -----------------------------
11847 -- Is_Checked_Storage_Pool --
11848 -----------------------------
11850 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
11859 while T
/= Etype
(T
) loop
11860 if Is_RTE
(T
, RE_Checked_Pool
) then
11868 end Is_Checked_Storage_Pool
;
11872 Typ
: constant Entity_Id
:= Etype
(N
);
11873 Desig
: constant Entity_Id
:= Available_View
(Designated_Type
(Typ
));
11874 Loc
: constant Source_Ptr
:= Sloc
(N
);
11875 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
11876 Pnod
: constant Node_Id
:= Parent
(N
);
11882 Size_Bits
: Node_Id
;
11885 -- Start of processing for Insert_Dereference_Action
11888 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
11890 -- Do not re-expand a dereference which has already been processed by
11893 if Has_Dereference_Action
(Pnod
) then
11896 -- Do not perform this type of expansion for internally-generated
11899 elsif not Comes_From_Source
(Original_Node
(Pnod
)) then
11902 -- A dereference action is only applicable to objects which have been
11903 -- allocated on a checked pool.
11905 elsif not Is_Checked_Storage_Pool
(Pool
) then
11909 -- Extract the address of the dereferenced object. Generate:
11911 -- Addr : System.Address := <N>'Pool_Address;
11913 Addr
:= Make_Temporary
(Loc
, 'P');
11916 Make_Object_Declaration
(Loc
,
11917 Defining_Identifier
=> Addr
,
11918 Object_Definition
=>
11919 New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
11921 Make_Attribute_Reference
(Loc
,
11922 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
11923 Attribute_Name
=> Name_Pool_Address
)));
11925 -- Calculate the size of the dereferenced object. Generate:
11927 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11930 Make_Explicit_Dereference
(Loc
,
11931 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11932 Set_Has_Dereference_Action
(Deref
);
11935 Make_Attribute_Reference
(Loc
,
11937 Attribute_Name
=> Name_Size
);
11939 -- Special case of an unconstrained array: need to add descriptor size
11941 if Is_Array_Type
(Desig
)
11942 and then not Is_Constrained
(First_Subtype
(Desig
))
11947 Make_Attribute_Reference
(Loc
,
11949 New_Occurrence_Of
(First_Subtype
(Desig
), Loc
),
11950 Attribute_Name
=> Name_Descriptor_Size
),
11951 Right_Opnd
=> Size_Bits
);
11954 Size
:= Make_Temporary
(Loc
, 'S');
11956 Make_Object_Declaration
(Loc
,
11957 Defining_Identifier
=> Size
,
11958 Object_Definition
=>
11959 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
11961 Make_Op_Divide
(Loc
,
11962 Left_Opnd
=> Size_Bits
,
11963 Right_Opnd
=> Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
11965 -- Calculate the alignment of the dereferenced object. Generate:
11966 -- Alig : constant Storage_Count := <N>.all'Alignment;
11969 Make_Explicit_Dereference
(Loc
,
11970 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
11971 Set_Has_Dereference_Action
(Deref
);
11973 Alig
:= Make_Temporary
(Loc
, 'A');
11975 Make_Object_Declaration
(Loc
,
11976 Defining_Identifier
=> Alig
,
11977 Object_Definition
=>
11978 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
),
11980 Make_Attribute_Reference
(Loc
,
11982 Attribute_Name
=> Name_Alignment
)));
11984 -- A dereference of a controlled object requires special processing. The
11985 -- finalization machinery requests additional space from the underlying
11986 -- pool to allocate and hide two pointers. As a result, a checked pool
11987 -- may mark the wrong memory as valid. Since checked pools do not have
11988 -- knowledge of hidden pointers, we have to bring the two pointers back
11989 -- in view in order to restore the original state of the object.
11991 if Needs_Finalization
(Desig
) then
11993 -- Adjust the address and size of the dereferenced object. Generate:
11994 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11997 Make_Procedure_Call_Statement
(Loc
,
11999 New_Occurrence_Of
(RTE
(RE_Adjust_Controlled_Dereference
), Loc
),
12000 Parameter_Associations
=> New_List
(
12001 New_Occurrence_Of
(Addr
, Loc
),
12002 New_Occurrence_Of
(Size
, Loc
),
12003 New_Occurrence_Of
(Alig
, Loc
)));
12005 -- Class-wide types complicate things because we cannot determine
12006 -- statically whether the actual object is truly controlled. We must
12007 -- generate a runtime check to detect this property. Generate:
12009 -- if Needs_Finalization (<N>.all'Tag) then
12013 if Is_Class_Wide_Type
(Desig
) then
12015 Make_Explicit_Dereference
(Loc
,
12016 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
));
12017 Set_Has_Dereference_Action
(Deref
);
12020 Make_Implicit_If_Statement
(N
,
12022 Make_Function_Call
(Loc
,
12024 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
12025 Parameter_Associations
=> New_List
(
12026 Make_Attribute_Reference
(Loc
,
12028 Attribute_Name
=> Name_Tag
))),
12029 Then_Statements
=> New_List
(Stmt
));
12032 Insert_Action
(N
, Stmt
);
12036 -- Dereference (Pool, Addr, Size, Alig);
12039 Make_Procedure_Call_Statement
(Loc
,
12042 (Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
12043 Parameter_Associations
=> New_List
(
12044 New_Occurrence_Of
(Pool
, Loc
),
12045 New_Occurrence_Of
(Addr
, Loc
),
12046 New_Occurrence_Of
(Size
, Loc
),
12047 New_Occurrence_Of
(Alig
, Loc
))));
12049 -- Mark the explicit dereference as processed to avoid potential
12050 -- infinite expansion.
12052 Set_Has_Dereference_Action
(Pnod
);
12055 when RE_Not_Available
=>
12057 end Insert_Dereference_Action
;
12059 --------------------------------
12060 -- Integer_Promotion_Possible --
12061 --------------------------------
12063 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
12064 Operand
: constant Node_Id
:= Expression
(N
);
12065 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
12066 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
12069 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
12073 -- We only do the transformation for source constructs. We assume
12074 -- that the expander knows what it is doing when it generates code.
12076 Comes_From_Source
(N
)
12078 -- If the operand type is Short_Integer or Short_Short_Integer,
12079 -- then we will promote to Integer, which is available on all
12080 -- targets, and is sufficient to ensure no intermediate overflow.
12081 -- Furthermore it is likely to be as efficient or more efficient
12082 -- than using the smaller type for the computation so we do this
12083 -- unconditionally.
12086 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
12088 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
12090 -- Test for interesting operation, which includes addition,
12091 -- division, exponentiation, multiplication, subtraction, absolute
12092 -- value and unary negation. Unary "+" is omitted since it is a
12093 -- no-op and thus can't overflow.
12095 and then Nkind_In
(Operand
, N_Op_Abs
,
12102 end Integer_Promotion_Possible
;
12104 ------------------------------
12105 -- Make_Array_Comparison_Op --
12106 ------------------------------
12108 -- This is a hand-coded expansion of the following generic function:
12111 -- type elem is (<>);
12112 -- type index is (<>);
12113 -- type a is array (index range <>) of elem;
12115 -- function Gnnn (X : a; Y: a) return boolean is
12116 -- J : index := Y'first;
12119 -- if X'length = 0 then
12122 -- elsif Y'length = 0 then
12126 -- for I in X'range loop
12127 -- if X (I) = Y (J) then
12128 -- if J = Y'last then
12131 -- J := index'succ (J);
12135 -- return X (I) > Y (J);
12139 -- return X'length > Y'length;
12143 -- Note that since we are essentially doing this expansion by hand, we
12144 -- do not need to generate an actual or formal generic part, just the
12145 -- instantiated function itself.
12147 -- Perhaps we could have the actual generic available in the run-time,
12148 -- obtained by rtsfind, and actually expand a real instantiation ???
12150 function Make_Array_Comparison_Op
12152 Nod
: Node_Id
) return Node_Id
12154 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
12156 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
12157 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
12158 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
12159 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12161 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
12163 Loop_Statement
: Node_Id
;
12164 Loop_Body
: Node_Id
;
12166 Inner_If
: Node_Id
;
12167 Final_Expr
: Node_Id
;
12168 Func_Body
: Node_Id
;
12169 Func_Name
: Entity_Id
;
12175 -- if J = Y'last then
12178 -- J := index'succ (J);
12182 Make_Implicit_If_Statement
(Nod
,
12185 Left_Opnd
=> New_Occurrence_Of
(J
, Loc
),
12187 Make_Attribute_Reference
(Loc
,
12188 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12189 Attribute_Name
=> Name_Last
)),
12191 Then_Statements
=> New_List
(
12192 Make_Exit_Statement
(Loc
)),
12196 Make_Assignment_Statement
(Loc
,
12197 Name
=> New_Occurrence_Of
(J
, Loc
),
12199 Make_Attribute_Reference
(Loc
,
12200 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
12201 Attribute_Name
=> Name_Succ
,
12202 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
))))));
12204 -- if X (I) = Y (J) then
12207 -- return X (I) > Y (J);
12211 Make_Implicit_If_Statement
(Nod
,
12215 Make_Indexed_Component
(Loc
,
12216 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12217 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
12220 Make_Indexed_Component
(Loc
,
12221 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12222 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)))),
12224 Then_Statements
=> New_List
(Inner_If
),
12226 Else_Statements
=> New_List
(
12227 Make_Simple_Return_Statement
(Loc
,
12231 Make_Indexed_Component
(Loc
,
12232 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12233 Expressions
=> New_List
(New_Occurrence_Of
(I
, Loc
))),
12236 Make_Indexed_Component
(Loc
,
12237 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12238 Expressions
=> New_List
(
12239 New_Occurrence_Of
(J
, Loc
)))))));
12241 -- for I in X'range loop
12246 Make_Implicit_Loop_Statement
(Nod
,
12247 Identifier
=> Empty
,
12249 Iteration_Scheme
=>
12250 Make_Iteration_Scheme
(Loc
,
12251 Loop_Parameter_Specification
=>
12252 Make_Loop_Parameter_Specification
(Loc
,
12253 Defining_Identifier
=> I
,
12254 Discrete_Subtype_Definition
=>
12255 Make_Attribute_Reference
(Loc
,
12256 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12257 Attribute_Name
=> Name_Range
))),
12259 Statements
=> New_List
(Loop_Body
));
12261 -- if X'length = 0 then
12263 -- elsif Y'length = 0 then
12266 -- for ... loop ... end loop;
12267 -- return X'length > Y'length;
12271 Make_Attribute_Reference
(Loc
,
12272 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12273 Attribute_Name
=> Name_Length
);
12276 Make_Attribute_Reference
(Loc
,
12277 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12278 Attribute_Name
=> Name_Length
);
12282 Left_Opnd
=> Length1
,
12283 Right_Opnd
=> Length2
);
12286 Make_Implicit_If_Statement
(Nod
,
12290 Make_Attribute_Reference
(Loc
,
12291 Prefix
=> New_Occurrence_Of
(X
, Loc
),
12292 Attribute_Name
=> Name_Length
),
12294 Make_Integer_Literal
(Loc
, 0)),
12298 Make_Simple_Return_Statement
(Loc
,
12299 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
12301 Elsif_Parts
=> New_List
(
12302 Make_Elsif_Part
(Loc
,
12306 Make_Attribute_Reference
(Loc
,
12307 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12308 Attribute_Name
=> Name_Length
),
12310 Make_Integer_Literal
(Loc
, 0)),
12314 Make_Simple_Return_Statement
(Loc
,
12315 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
))))),
12317 Else_Statements
=> New_List
(
12319 Make_Simple_Return_Statement
(Loc
,
12320 Expression
=> Final_Expr
)));
12324 Formals
:= New_List
(
12325 Make_Parameter_Specification
(Loc
,
12326 Defining_Identifier
=> X
,
12327 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12329 Make_Parameter_Specification
(Loc
,
12330 Defining_Identifier
=> Y
,
12331 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12333 -- function Gnnn (...) return boolean is
12334 -- J : index := Y'first;
12339 Func_Name
:= Make_Temporary
(Loc
, 'G');
12342 Make_Subprogram_Body
(Loc
,
12344 Make_Function_Specification
(Loc
,
12345 Defining_Unit_Name
=> Func_Name
,
12346 Parameter_Specifications
=> Formals
,
12347 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
12349 Declarations
=> New_List
(
12350 Make_Object_Declaration
(Loc
,
12351 Defining_Identifier
=> J
,
12352 Object_Definition
=> New_Occurrence_Of
(Index
, Loc
),
12354 Make_Attribute_Reference
(Loc
,
12355 Prefix
=> New_Occurrence_Of
(Y
, Loc
),
12356 Attribute_Name
=> Name_First
))),
12358 Handled_Statement_Sequence
=>
12359 Make_Handled_Sequence_Of_Statements
(Loc
,
12360 Statements
=> New_List
(If_Stat
)));
12363 end Make_Array_Comparison_Op
;
12365 ---------------------------
12366 -- Make_Boolean_Array_Op --
12367 ---------------------------
12369 -- For logical operations on boolean arrays, expand in line the following,
12370 -- replacing 'and' with 'or' or 'xor' where needed:
12372 -- function Annn (A : typ; B: typ) return typ is
12375 -- for J in A'range loop
12376 -- C (J) := A (J) op B (J);
12381 -- Here typ is the boolean array type
12383 function Make_Boolean_Array_Op
12385 N
: Node_Id
) return Node_Id
12387 Loc
: constant Source_Ptr
:= Sloc
(N
);
12389 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
12390 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
12391 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
12392 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
12400 Func_Name
: Entity_Id
;
12401 Func_Body
: Node_Id
;
12402 Loop_Statement
: Node_Id
;
12406 Make_Indexed_Component
(Loc
,
12407 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12408 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12411 Make_Indexed_Component
(Loc
,
12412 Prefix
=> New_Occurrence_Of
(B
, Loc
),
12413 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12416 Make_Indexed_Component
(Loc
,
12417 Prefix
=> New_Occurrence_Of
(C
, Loc
),
12418 Expressions
=> New_List
(New_Occurrence_Of
(J
, Loc
)));
12420 if Nkind
(N
) = N_Op_And
then
12424 Right_Opnd
=> B_J
);
12426 elsif Nkind
(N
) = N_Op_Or
then
12430 Right_Opnd
=> B_J
);
12436 Right_Opnd
=> B_J
);
12440 Make_Implicit_Loop_Statement
(N
,
12441 Identifier
=> Empty
,
12443 Iteration_Scheme
=>
12444 Make_Iteration_Scheme
(Loc
,
12445 Loop_Parameter_Specification
=>
12446 Make_Loop_Parameter_Specification
(Loc
,
12447 Defining_Identifier
=> J
,
12448 Discrete_Subtype_Definition
=>
12449 Make_Attribute_Reference
(Loc
,
12450 Prefix
=> New_Occurrence_Of
(A
, Loc
),
12451 Attribute_Name
=> Name_Range
))),
12453 Statements
=> New_List
(
12454 Make_Assignment_Statement
(Loc
,
12456 Expression
=> Op
)));
12458 Formals
:= New_List
(
12459 Make_Parameter_Specification
(Loc
,
12460 Defining_Identifier
=> A
,
12461 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
12463 Make_Parameter_Specification
(Loc
,
12464 Defining_Identifier
=> B
,
12465 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
12467 Func_Name
:= Make_Temporary
(Loc
, 'A');
12468 Set_Is_Inlined
(Func_Name
);
12471 Make_Subprogram_Body
(Loc
,
12473 Make_Function_Specification
(Loc
,
12474 Defining_Unit_Name
=> Func_Name
,
12475 Parameter_Specifications
=> Formals
,
12476 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
12478 Declarations
=> New_List
(
12479 Make_Object_Declaration
(Loc
,
12480 Defining_Identifier
=> C
,
12481 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
))),
12483 Handled_Statement_Sequence
=>
12484 Make_Handled_Sequence_Of_Statements
(Loc
,
12485 Statements
=> New_List
(
12487 Make_Simple_Return_Statement
(Loc
,
12488 Expression
=> New_Occurrence_Of
(C
, Loc
)))));
12491 end Make_Boolean_Array_Op
;
12493 -----------------------------------------
12494 -- Minimized_Eliminated_Overflow_Check --
12495 -----------------------------------------
12497 function Minimized_Eliminated_Overflow_Check
(N
: Node_Id
) return Boolean is
12500 Is_Signed_Integer_Type
(Etype
(N
))
12501 and then Overflow_Check_Mode
in Minimized_Or_Eliminated
;
12502 end Minimized_Eliminated_Overflow_Check
;
12504 --------------------------------
12505 -- Optimize_Length_Comparison --
12506 --------------------------------
12508 procedure Optimize_Length_Comparison
(N
: Node_Id
) is
12509 Loc
: constant Source_Ptr
:= Sloc
(N
);
12510 Typ
: constant Entity_Id
:= Etype
(N
);
12515 -- First and Last attribute reference nodes, which end up as left and
12516 -- right operands of the optimized result.
12519 -- True for comparison operand of zero
12522 -- Comparison operand, set only if Is_Zero is false
12525 -- Entity whose length is being compared
12528 -- Integer_Literal node for length attribute expression, or Empty
12529 -- if there is no such expression present.
12532 -- Type of array index to which 'Length is applied
12534 Op
: Node_Kind
:= Nkind
(N
);
12535 -- Kind of comparison operator, gets flipped if operands backwards
12537 function Is_Optimizable
(N
: Node_Id
) return Boolean;
12538 -- Tests N to see if it is an optimizable comparison value (defined as
12539 -- constant zero or one, or something else where the value is known to
12540 -- be positive and in the range of 32-bits, and where the corresponding
12541 -- Length value is also known to be 32-bits. If result is true, sets
12542 -- Is_Zero, Ityp, and Comp accordingly.
12544 function Is_Entity_Length
(N
: Node_Id
) return Boolean;
12545 -- Tests if N is a length attribute applied to a simple entity. If so,
12546 -- returns True, and sets Ent to the entity, and Index to the integer
12547 -- literal provided as an attribute expression, or to Empty if none.
12548 -- Also returns True if the expression is a generated type conversion
12549 -- whose expression is of the desired form. This latter case arises
12550 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12551 -- to check for being in range, which is not needed in this context.
12552 -- Returns False if neither condition holds.
12554 function Prepare_64
(N
: Node_Id
) return Node_Id
;
12555 -- Given a discrete expression, returns a Long_Long_Integer typed
12556 -- expression representing the underlying value of the expression.
12557 -- This is done with an unchecked conversion to the result type. We
12558 -- use unchecked conversion to handle the enumeration type case.
12560 ----------------------
12561 -- Is_Entity_Length --
12562 ----------------------
12564 function Is_Entity_Length
(N
: Node_Id
) return Boolean is
12566 if Nkind
(N
) = N_Attribute_Reference
12567 and then Attribute_Name
(N
) = Name_Length
12568 and then Is_Entity_Name
(Prefix
(N
))
12570 Ent
:= Entity
(Prefix
(N
));
12572 if Present
(Expressions
(N
)) then
12573 Index
:= First
(Expressions
(N
));
12580 elsif Nkind
(N
) = N_Type_Conversion
12581 and then not Comes_From_Source
(N
)
12583 return Is_Entity_Length
(Expression
(N
));
12588 end Is_Entity_Length
;
12590 --------------------
12591 -- Is_Optimizable --
12592 --------------------
12594 function Is_Optimizable
(N
: Node_Id
) return Boolean is
12602 if Compile_Time_Known_Value
(N
) then
12603 Val
:= Expr_Value
(N
);
12605 if Val
= Uint_0
then
12610 elsif Val
= Uint_1
then
12617 -- Here we have to make sure of being within 32-bits
12619 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
12622 or else Lo
< Uint_1
12623 or else Hi
> UI_From_Int
(Int
'Last)
12628 -- Comparison value was within range, so now we must check the index
12629 -- value to make sure it is also within 32-bits.
12631 Indx
:= First_Index
(Etype
(Ent
));
12633 if Present
(Index
) then
12634 for J
in 2 .. UI_To_Int
(Intval
(Index
)) loop
12639 Ityp
:= Etype
(Indx
);
12641 if Esize
(Ityp
) > 32 then
12648 end Is_Optimizable
;
12654 function Prepare_64
(N
: Node_Id
) return Node_Id
is
12656 return Unchecked_Convert_To
(Standard_Long_Long_Integer
, N
);
12659 -- Start of processing for Optimize_Length_Comparison
12662 -- Nothing to do if not a comparison
12664 if Op
not in N_Op_Compare
then
12668 -- Nothing to do if special -gnatd.P debug flag set.
12670 if Debug_Flag_Dot_PP
then
12674 -- Ent'Length op 0/1
12676 if Is_Entity_Length
(Left_Opnd
(N
))
12677 and then Is_Optimizable
(Right_Opnd
(N
))
12681 -- 0/1 op Ent'Length
12683 elsif Is_Entity_Length
(Right_Opnd
(N
))
12684 and then Is_Optimizable
(Left_Opnd
(N
))
12686 -- Flip comparison to opposite sense
12689 when N_Op_Lt
=> Op
:= N_Op_Gt
;
12690 when N_Op_Le
=> Op
:= N_Op_Ge
;
12691 when N_Op_Gt
=> Op
:= N_Op_Lt
;
12692 when N_Op_Ge
=> Op
:= N_Op_Le
;
12693 when others => null;
12696 -- Else optimization not possible
12702 -- Fall through if we will do the optimization
12704 -- Cases to handle:
12706 -- X'Length = 0 => X'First > X'Last
12707 -- X'Length = 1 => X'First = X'Last
12708 -- X'Length = n => X'First + (n - 1) = X'Last
12710 -- X'Length /= 0 => X'First <= X'Last
12711 -- X'Length /= 1 => X'First /= X'Last
12712 -- X'Length /= n => X'First + (n - 1) /= X'Last
12714 -- X'Length >= 0 => always true, warn
12715 -- X'Length >= 1 => X'First <= X'Last
12716 -- X'Length >= n => X'First + (n - 1) <= X'Last
12718 -- X'Length > 0 => X'First <= X'Last
12719 -- X'Length > 1 => X'First < X'Last
12720 -- X'Length > n => X'First + (n - 1) < X'Last
12722 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12723 -- X'Length <= 1 => X'First >= X'Last
12724 -- X'Length <= n => X'First + (n - 1) >= X'Last
12726 -- X'Length < 0 => always false (warn)
12727 -- X'Length < 1 => X'First > X'Last
12728 -- X'Length < n => X'First + (n - 1) > X'Last
12730 -- Note: for the cases of n (not constant 0,1), we require that the
12731 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12732 -- and the same for the comparison value. Then we do the comparison
12733 -- using 64-bit arithmetic (actually long long integer), so that we
12734 -- cannot have overflow intefering with the result.
12736 -- First deal with warning cases
12745 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Loc
)));
12746 Analyze_And_Resolve
(N
, Typ
);
12747 Warn_On_Known_Condition
(N
);
12754 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Loc
)));
12755 Analyze_And_Resolve
(N
, Typ
);
12756 Warn_On_Known_Condition
(N
);
12760 if Constant_Condition_Warnings
12761 and then Comes_From_Source
(Original_Node
(N
))
12763 Error_Msg_N
("could replace by ""'=""?c?", N
);
12773 -- Build the First reference we will use
12776 Make_Attribute_Reference
(Loc
,
12777 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12778 Attribute_Name
=> Name_First
);
12780 if Present
(Index
) then
12781 Set_Expressions
(Left
, New_List
(New_Copy
(Index
)));
12784 -- If general value case, then do the addition of (n - 1), and
12785 -- also add the needed conversions to type Long_Long_Integer.
12787 if Present
(Comp
) then
12790 Left_Opnd
=> Prepare_64
(Left
),
12792 Make_Op_Subtract
(Loc
,
12793 Left_Opnd
=> Prepare_64
(Comp
),
12794 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
12797 -- Build the Last reference we will use
12800 Make_Attribute_Reference
(Loc
,
12801 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
12802 Attribute_Name
=> Name_Last
);
12804 if Present
(Index
) then
12805 Set_Expressions
(Right
, New_List
(New_Copy
(Index
)));
12808 -- If general operand, convert Last reference to Long_Long_Integer
12810 if Present
(Comp
) then
12811 Right
:= Prepare_64
(Right
);
12814 -- Check for cases to optimize
12816 -- X'Length = 0 => X'First > X'Last
12817 -- X'Length < 1 => X'First > X'Last
12818 -- X'Length < n => X'First + (n - 1) > X'Last
12820 if (Is_Zero
and then Op
= N_Op_Eq
)
12821 or else (not Is_Zero
and then Op
= N_Op_Lt
)
12826 Right_Opnd
=> Right
);
12828 -- X'Length = 1 => X'First = X'Last
12829 -- X'Length = n => X'First + (n - 1) = X'Last
12831 elsif not Is_Zero
and then Op
= N_Op_Eq
then
12835 Right_Opnd
=> Right
);
12837 -- X'Length /= 0 => X'First <= X'Last
12838 -- X'Length > 0 => X'First <= X'Last
12840 elsif Is_Zero
and (Op
= N_Op_Ne
or else Op
= N_Op_Gt
) then
12844 Right_Opnd
=> Right
);
12846 -- X'Length /= 1 => X'First /= X'Last
12847 -- X'Length /= n => X'First + (n - 1) /= X'Last
12849 elsif not Is_Zero
and then Op
= N_Op_Ne
then
12853 Right_Opnd
=> Right
);
12855 -- X'Length >= 1 => X'First <= X'Last
12856 -- X'Length >= n => X'First + (n - 1) <= X'Last
12858 elsif not Is_Zero
and then Op
= N_Op_Ge
then
12862 Right_Opnd
=> Right
);
12864 -- X'Length > 1 => X'First < X'Last
12865 -- X'Length > n => X'First + (n = 1) < X'Last
12867 elsif not Is_Zero
and then Op
= N_Op_Gt
then
12871 Right_Opnd
=> Right
);
12873 -- X'Length <= 1 => X'First >= X'Last
12874 -- X'Length <= n => X'First + (n - 1) >= X'Last
12876 elsif not Is_Zero
and then Op
= N_Op_Le
then
12880 Right_Opnd
=> Right
);
12882 -- Should not happen at this stage
12885 raise Program_Error
;
12888 -- Rewrite and finish up
12890 Rewrite
(N
, Result
);
12891 Analyze_And_Resolve
(N
, Typ
);
12893 end Optimize_Length_Comparison
;
12895 ------------------------------
12896 -- Process_Transient_Object --
12897 ------------------------------
12899 procedure Process_Transient_Object
12901 Rel_Node
: Node_Id
)
12903 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
12904 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
12905 Obj_Typ
: constant Node_Id
:= Etype
(Obj_Id
);
12906 Desig_Typ
: Entity_Id
;
12908 Hook_Id
: Entity_Id
;
12909 Hook_Insert
: Node_Id
;
12910 Ptr_Id
: Entity_Id
;
12912 Hook_Context
: constant Node_Id
:= Find_Hook_Context
(Rel_Node
);
12913 -- The node on which to insert the hook as an action. This is usually
12914 -- the innermost enclosing non-transient construct.
12916 Fin_Context
: Node_Id
;
12917 -- The node after which to insert the finalization actions of the
12918 -- transient controlled object.
12921 if Is_Boolean_Type
(Etype
(Rel_Node
)) then
12922 Fin_Context
:= Last
(Actions
(Rel_Node
));
12924 Fin_Context
:= Hook_Context
;
12927 -- Step 1: Create the access type which provides a reference to the
12928 -- transient controlled object.
12930 if Is_Access_Type
(Obj_Typ
) then
12931 Desig_Typ
:= Directly_Designated_Type
(Obj_Typ
);
12933 Desig_Typ
:= Obj_Typ
;
12936 Desig_Typ
:= Base_Type
(Desig_Typ
);
12939 -- Ann : access [all] <Desig_Typ>;
12941 Ptr_Id
:= Make_Temporary
(Loc
, 'A');
12943 Insert_Action
(Hook_Context
,
12944 Make_Full_Type_Declaration
(Loc
,
12945 Defining_Identifier
=> Ptr_Id
,
12947 Make_Access_To_Object_Definition
(Loc
,
12948 All_Present
=> Ekind
(Obj_Typ
) = E_General_Access_Type
,
12949 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))));
12951 -- Step 2: Create a temporary which acts as a hook to the transient
12952 -- controlled object. Generate:
12954 -- Hook : Ptr_Id := null;
12956 Hook_Id
:= Make_Temporary
(Loc
, 'T');
12958 Insert_Action
(Hook_Context
,
12959 Make_Object_Declaration
(Loc
,
12960 Defining_Identifier
=> Hook_Id
,
12961 Object_Definition
=> New_Occurrence_Of
(Ptr_Id
, Loc
)));
12963 -- Mark the hook as created for the purposes of exporting the transient
12964 -- controlled object out of the expression_with_action or if expression.
12965 -- This signals the machinery in Build_Finalizer to treat this case in
12966 -- a special manner.
12968 Set_Status_Flag_Or_Transient_Decl
(Hook_Id
, Decl
);
12970 -- Step 3: Associate the transient object to the hook
12972 -- This must be inserted right after the object declaration, so that
12973 -- the assignment is executed if, and only if, the object is actually
12974 -- created (whereas the declaration of the hook pointer, and the
12975 -- finalization call, may be inserted at an outer level, and may
12976 -- remain unused for some executions, if the actual creation of
12977 -- the object is conditional).
12979 -- The use of unchecked conversion / unrestricted access is needed to
12980 -- avoid an accessibility violation. Note that the finalization code is
12981 -- structured in such a way that the "hook" is processed only when it
12982 -- points to an existing object.
12984 if Is_Access_Type
(Obj_Typ
) then
12986 Unchecked_Convert_To
12988 Expr
=> New_Occurrence_Of
(Obj_Id
, Loc
));
12991 Make_Attribute_Reference
(Loc
,
12992 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
12993 Attribute_Name
=> Name_Unrestricted_Access
);
12997 -- Hook := Ptr_Id (Obj_Id);
12999 -- Hook := Obj_Id'Unrestricted_Access;
13001 -- When the transient object is initialized by an aggregate, the hook
13002 -- must capture the object after the last component assignment takes
13003 -- place. Only then is the object fully initialized.
13005 if Ekind
(Obj_Id
) = E_Variable
13006 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
13008 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
13010 -- Otherwise the hook seizes the related object immediately
13013 Hook_Insert
:= Decl
;
13016 Insert_After_And_Analyze
(Hook_Insert
,
13017 Make_Assignment_Statement
(Loc
,
13018 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13019 Expression
=> Expr
));
13021 -- Step 4: Finalize the hook after the context has been evaluated or
13022 -- elaborated. Generate:
13024 -- if Hook /= null then
13025 -- [Deep_]Finalize (Hook.all);
13029 -- When the node is part of a return statement, there is no need to
13030 -- insert a finalization call, as the general finalization mechanism
13031 -- (see Build_Finalizer) would take care of the transient controlled
13032 -- object on subprogram exit. Note that it would also be impossible to
13033 -- insert the finalization code after the return statement as this will
13034 -- render it unreachable.
13036 if Nkind
(Fin_Context
) = N_Simple_Return_Statement
then
13039 -- Otherwise finalize the hook
13042 Insert_Action_After
(Fin_Context
,
13043 Make_Implicit_If_Statement
(Decl
,
13046 Left_Opnd
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13047 Right_Opnd
=> Make_Null
(Loc
)),
13049 Then_Statements
=> New_List
(
13052 Make_Explicit_Dereference
(Loc
,
13053 Prefix
=> New_Occurrence_Of
(Hook_Id
, Loc
)),
13056 Make_Assignment_Statement
(Loc
,
13057 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
13058 Expression
=> Make_Null
(Loc
)))));
13060 end Process_Transient_Object
;
13062 ------------------------
13063 -- Rewrite_Comparison --
13064 ------------------------
13066 procedure Rewrite_Comparison
(N
: Node_Id
) is
13067 Warning_Generated
: Boolean := False;
13068 -- Set to True if first pass with Assume_Valid generates a warning in
13069 -- which case we skip the second pass to avoid warning overloaded.
13072 -- Set to Standard_True or Standard_False
13075 if Nkind
(N
) = N_Type_Conversion
then
13076 Rewrite_Comparison
(Expression
(N
));
13079 elsif Nkind
(N
) not in N_Op_Compare
then
13083 -- Now start looking at the comparison in detail. We potentially go
13084 -- through this loop twice. The first time, Assume_Valid is set False
13085 -- in the call to Compile_Time_Compare. If this call results in a
13086 -- clear result of always True or Always False, that's decisive and
13087 -- we are done. Otherwise we repeat the processing with Assume_Valid
13088 -- set to True to generate additional warnings. We can skip that step
13089 -- if Constant_Condition_Warnings is False.
13091 for AV
in False .. True loop
13093 Typ
: constant Entity_Id
:= Etype
(N
);
13094 Op1
: constant Node_Id
:= Left_Opnd
(N
);
13095 Op2
: constant Node_Id
:= Right_Opnd
(N
);
13097 Res
: constant Compare_Result
:=
13098 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
13099 -- Res indicates if compare outcome can be compile time determined
13101 True_Result
: Boolean;
13102 False_Result
: Boolean;
13105 case N_Op_Compare
(Nkind
(N
)) is
13107 True_Result
:= Res
= EQ
;
13108 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
13111 True_Result
:= Res
in Compare_GE
;
13112 False_Result
:= Res
= LT
;
13115 and then Constant_Condition_Warnings
13116 and then Comes_From_Source
(Original_Node
(N
))
13117 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
13118 and then not In_Instance
13119 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
13120 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
13123 ("can never be greater than, could replace by ""'=""?c?",
13125 Warning_Generated
:= True;
13129 True_Result
:= Res
= GT
;
13130 False_Result
:= Res
in Compare_LE
;
13133 True_Result
:= Res
= LT
;
13134 False_Result
:= Res
in Compare_GE
;
13137 True_Result
:= Res
in Compare_LE
;
13138 False_Result
:= Res
= GT
;
13141 and then Constant_Condition_Warnings
13142 and then Comes_From_Source
(Original_Node
(N
))
13143 and then Nkind
(Original_Node
(N
)) = N_Op_Le
13144 and then not In_Instance
13145 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
13146 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
13149 ("can never be less than, could replace by ""'=""?c?", N
);
13150 Warning_Generated
:= True;
13154 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
13155 False_Result
:= Res
= EQ
;
13158 -- If this is the first iteration, then we actually convert the
13159 -- comparison into True or False, if the result is certain.
13162 if True_Result
or False_Result
then
13163 Result
:= Boolean_Literals
(True_Result
);
13166 New_Occurrence_Of
(Result
, Sloc
(N
))));
13167 Analyze_And_Resolve
(N
, Typ
);
13168 Warn_On_Known_Condition
(N
);
13172 -- If this is the second iteration (AV = True), and the original
13173 -- node comes from source and we are not in an instance, then give
13174 -- a warning if we know result would be True or False. Note: we
13175 -- know Constant_Condition_Warnings is set if we get here.
13177 elsif Comes_From_Source
(Original_Node
(N
))
13178 and then not In_Instance
13180 if True_Result
then
13182 ("condition can only be False if invalid values present??",
13184 elsif False_Result
then
13186 ("condition can only be True if invalid values present??",
13192 -- Skip second iteration if not warning on constant conditions or
13193 -- if the first iteration already generated a warning of some kind or
13194 -- if we are in any case assuming all values are valid (so that the
13195 -- first iteration took care of the valid case).
13197 exit when not Constant_Condition_Warnings
;
13198 exit when Warning_Generated
;
13199 exit when Assume_No_Invalid_Values
;
13201 end Rewrite_Comparison
;
13203 ----------------------------
13204 -- Safe_In_Place_Array_Op --
13205 ----------------------------
13207 function Safe_In_Place_Array_Op
13210 Op2
: Node_Id
) return Boolean
13212 Target
: Entity_Id
;
13214 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
13215 -- Operand is safe if it cannot overlap part of the target of the
13216 -- operation. If the operand and the target are identical, the operand
13217 -- is safe. The operand can be empty in the case of negation.
13219 function Is_Unaliased
(N
: Node_Id
) return Boolean;
13220 -- Check that N is a stand-alone entity
13226 function Is_Unaliased
(N
: Node_Id
) return Boolean is
13230 and then No
(Address_Clause
(Entity
(N
)))
13231 and then No
(Renamed_Object
(Entity
(N
)));
13234 ---------------------
13235 -- Is_Safe_Operand --
13236 ---------------------
13238 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
13243 elsif Is_Entity_Name
(Op
) then
13244 return Is_Unaliased
(Op
);
13246 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
13247 return Is_Unaliased
(Prefix
(Op
));
13249 elsif Nkind
(Op
) = N_Slice
then
13251 Is_Unaliased
(Prefix
(Op
))
13252 and then Entity
(Prefix
(Op
)) /= Target
;
13254 elsif Nkind
(Op
) = N_Op_Not
then
13255 return Is_Safe_Operand
(Right_Opnd
(Op
));
13260 end Is_Safe_Operand
;
13262 -- Start of processing for Safe_In_Place_Array_Op
13265 -- Skip this processing if the component size is different from system
13266 -- storage unit (since at least for NOT this would cause problems).
13268 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
13271 -- Cannot do in place stuff if non-standard Boolean representation
13273 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
13276 elsif not Is_Unaliased
(Lhs
) then
13280 Target
:= Entity
(Lhs
);
13281 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
13283 end Safe_In_Place_Array_Op
;
13285 -----------------------
13286 -- Tagged_Membership --
13287 -----------------------
13289 -- There are two different cases to consider depending on whether the right
13290 -- operand is a class-wide type or not. If not we just compare the actual
13291 -- tag of the left expr to the target type tag:
13293 -- Left_Expr.Tag = Right_Type'Tag;
13295 -- If it is a class-wide type we use the RT function CW_Membership which is
13296 -- usually implemented by looking in the ancestor tables contained in the
13297 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13299 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13300 -- function IW_Membership which is usually implemented by looking in the
13301 -- table of abstract interface types plus the ancestor table contained in
13302 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13304 procedure Tagged_Membership
13306 SCIL_Node
: out Node_Id
;
13307 Result
: out Node_Id
)
13309 Left
: constant Node_Id
:= Left_Opnd
(N
);
13310 Right
: constant Node_Id
:= Right_Opnd
(N
);
13311 Loc
: constant Source_Ptr
:= Sloc
(N
);
13313 Full_R_Typ
: Entity_Id
;
13314 Left_Type
: Entity_Id
;
13315 New_Node
: Node_Id
;
13316 Right_Type
: Entity_Id
;
13320 SCIL_Node
:= Empty
;
13322 -- Handle entities from the limited view
13324 Left_Type
:= Available_View
(Etype
(Left
));
13325 Right_Type
:= Available_View
(Etype
(Right
));
13327 -- In the case where the type is an access type, the test is applied
13328 -- using the designated types (needed in Ada 2012 for implicit anonymous
13329 -- access conversions, for AI05-0149).
13331 if Is_Access_Type
(Right_Type
) then
13332 Left_Type
:= Designated_Type
(Left_Type
);
13333 Right_Type
:= Designated_Type
(Right_Type
);
13336 if Is_Class_Wide_Type
(Left_Type
) then
13337 Left_Type
:= Root_Type
(Left_Type
);
13340 if Is_Class_Wide_Type
(Right_Type
) then
13341 Full_R_Typ
:= Underlying_Type
(Root_Type
(Right_Type
));
13343 Full_R_Typ
:= Underlying_Type
(Right_Type
);
13347 Make_Selected_Component
(Loc
,
13348 Prefix
=> Relocate_Node
(Left
),
13350 New_Occurrence_Of
(First_Tag_Component
(Left_Type
), Loc
));
13352 if Is_Class_Wide_Type
(Right_Type
) then
13354 -- No need to issue a run-time check if we statically know that the
13355 -- result of this membership test is always true. For example,
13356 -- considering the following declarations:
13358 -- type Iface is interface;
13359 -- type T is tagged null record;
13360 -- type DT is new T and Iface with null record;
13365 -- These membership tests are always true:
13368 -- Obj2 in T'Class;
13369 -- Obj2 in Iface'Class;
13371 -- We do not need to handle cases where the membership is illegal.
13374 -- Obj1 in DT'Class; -- Compile time error
13375 -- Obj1 in Iface'Class; -- Compile time error
13377 if not Is_Class_Wide_Type
(Left_Type
)
13378 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
,
13379 Use_Full_View
=> True)
13380 or else (Is_Interface
(Etype
(Right_Type
))
13381 and then Interface_Present_In_Ancestor
13383 Iface
=> Etype
(Right_Type
))))
13385 Result
:= New_Occurrence_Of
(Standard_True
, Loc
);
13389 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13391 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
13393 -- Support to: "Iface_CW_Typ in Typ'Class"
13395 or else Is_Interface
(Left_Type
)
13397 -- Issue error if IW_Membership operation not available in a
13398 -- configurable run time setting.
13400 if not RTE_Available
(RE_IW_Membership
) then
13402 ("dynamic membership test on interface types", N
);
13408 Make_Function_Call
(Loc
,
13409 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
13410 Parameter_Associations
=> New_List
(
13411 Make_Attribute_Reference
(Loc
,
13413 Attribute_Name
=> Name_Address
),
13414 New_Occurrence_Of
(
13415 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))),
13418 -- Ada 95: Normal case
13421 Build_CW_Membership
(Loc
,
13422 Obj_Tag_Node
=> Obj_Tag
,
13424 New_Occurrence_Of
(
13425 Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
),
13427 New_Node
=> New_Node
);
13429 -- Generate the SCIL node for this class-wide membership test.
13430 -- Done here because the previous call to Build_CW_Membership
13431 -- relocates Obj_Tag.
13433 if Generate_SCIL
then
13434 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
13435 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
13436 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
13439 Result
:= New_Node
;
13442 -- Right_Type is not a class-wide type
13445 -- No need to check the tag of the object if Right_Typ is abstract
13447 if Is_Abstract_Type
(Right_Type
) then
13448 Result
:= New_Occurrence_Of
(Standard_False
, Loc
);
13453 Left_Opnd
=> Obj_Tag
,
13456 (Node
(First_Elmt
(Access_Disp_Table
(Full_R_Typ
))), Loc
));
13459 end Tagged_Membership
;
13461 ------------------------------
13462 -- Unary_Op_Validity_Checks --
13463 ------------------------------
13465 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
13467 if Validity_Checks_On
and Validity_Check_Operands
then
13468 Ensure_Valid
(Right_Opnd
(N
));
13470 end Unary_Op_Validity_Checks
;