1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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_Ch3
; use Exp_Ch3
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch7
; use Exp_Ch7
;
37 with Exp_Ch9
; use Exp_Ch9
;
38 with Exp_Disp
; use Exp_Disp
;
39 with Exp_Fixd
; use Exp_Fixd
;
40 with Exp_Pakd
; use Exp_Pakd
;
41 with Exp_Tss
; use Exp_Tss
;
42 with Exp_Util
; use Exp_Util
;
43 with Exp_VFpt
; use Exp_VFpt
;
44 with Freeze
; use Freeze
;
45 with Inline
; use Inline
;
46 with Namet
; use Namet
;
47 with Nlists
; use Nlists
;
48 with Nmake
; use Nmake
;
50 with Par_SCO
; use Par_SCO
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Cat
; use Sem_Cat
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch8
; use Sem_Ch8
;
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 function Expand_Composite_Equality
139 Bodies
: List_Id
) return Node_Id
;
140 -- Local recursive function used to expand equality for nested composite
141 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
142 -- to attach bodies of local functions that are created in the process.
143 -- This is the responsibility of the caller to insert those bodies at the
144 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
145 -- are the left and right sides for the comparison, and Typ is the type of
146 -- the arrays to compare.
148 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
);
149 -- Routine to expand concatenation of a sequence of two or more operands
150 -- (in the list Operands) and replace node Cnode with the result of the
151 -- concatenation. The operands can be of any appropriate type, and can
152 -- include both arrays and singleton elements.
154 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
155 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
156 -- fixed. We do not have such a type at runtime, so the purpose of this
157 -- routine is to find the real type by looking up the tree. We also
158 -- determine if the operation must be rounded.
160 function Get_Allocator_Final_List
163 PtrT
: Entity_Id
) return Entity_Id
;
164 -- If the designated type is controlled, build final_list expression for
165 -- created object. If context is an access parameter, create a local access
166 -- type to have a usable finalization list.
168 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
169 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
170 -- discriminants if it has a constrained nominal type, unless the object
171 -- is a component of an enclosing Unchecked_Union object that is subject
172 -- to a per-object constraint and the enclosing object lacks inferable
175 -- An expression of an Unchecked_Union type has inferable discriminants
176 -- if it is either a name of an object with inferable discriminants or a
177 -- qualified expression whose subtype mark denotes a constrained subtype.
179 procedure Insert_Dereference_Action
(N
: Node_Id
);
180 -- N is an expression whose type is an access. When the type of the
181 -- associated storage pool is derived from Checked_Pool, generate a
182 -- call to the 'Dereference' primitive operation.
184 function Make_Array_Comparison_Op
186 Nod
: Node_Id
) return Node_Id
;
187 -- Comparisons between arrays are expanded in line. This function produces
188 -- the body of the implementation of (a > b), where a and b are one-
189 -- dimensional arrays of some discrete type. The original node is then
190 -- expanded into the appropriate call to this function. Nod provides the
191 -- Sloc value for the generated code.
193 function Make_Boolean_Array_Op
195 N
: Node_Id
) return Node_Id
;
196 -- Boolean operations on boolean arrays are expanded in line. This function
197 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
198 -- b). It is used only the normal case and not the packed case. The type
199 -- involved, Typ, is the Boolean array type, and the logical operations in
200 -- the body are simple boolean operations. Note that Typ is always a
201 -- constrained type (the caller has ensured this by using
202 -- Convert_To_Actual_Subtype if necessary).
204 procedure Rewrite_Comparison
(N
: Node_Id
);
205 -- If N is the node for a comparison whose outcome can be determined at
206 -- compile time, then the node N can be rewritten with True or False. If
207 -- the outcome cannot be determined at compile time, the call has no
208 -- effect. If N is a type conversion, then this processing is applied to
209 -- its expression. If N is neither comparison nor a type conversion, the
210 -- call has no effect.
212 procedure Tagged_Membership
214 SCIL_Node
: out Node_Id
;
215 Result
: out Node_Id
);
216 -- Construct the expression corresponding to the tagged membership test.
217 -- Deals with a second operand being (or not) a class-wide type.
219 function Safe_In_Place_Array_Op
222 Op2
: Node_Id
) return Boolean;
223 -- In the context of an assignment, where the right-hand side is a boolean
224 -- operation on arrays, check whether operation can be performed in place.
226 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
227 pragma Inline
(Unary_Op_Validity_Checks
);
228 -- Performs validity checks for a unary operator
230 -------------------------------
231 -- Binary_Op_Validity_Checks --
232 -------------------------------
234 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
236 if Validity_Checks_On
and Validity_Check_Operands
then
237 Ensure_Valid
(Left_Opnd
(N
));
238 Ensure_Valid
(Right_Opnd
(N
));
240 end Binary_Op_Validity_Checks
;
242 ------------------------------------
243 -- Build_Boolean_Array_Proc_Call --
244 ------------------------------------
246 procedure Build_Boolean_Array_Proc_Call
251 Loc
: constant Source_Ptr
:= Sloc
(N
);
252 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
253 Target
: constant Node_Id
:=
254 Make_Attribute_Reference
(Loc
,
256 Attribute_Name
=> Name_Address
);
258 Arg1
: constant Node_Id
:= Op1
;
259 Arg2
: Node_Id
:= Op2
;
261 Proc_Name
: Entity_Id
;
264 if Kind
= N_Op_Not
then
265 if Nkind
(Op1
) in N_Binary_Op
then
267 -- Use negated version of the binary operators
269 if Nkind
(Op1
) = N_Op_And
then
270 Proc_Name
:= RTE
(RE_Vector_Nand
);
272 elsif Nkind
(Op1
) = N_Op_Or
then
273 Proc_Name
:= RTE
(RE_Vector_Nor
);
275 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
276 Proc_Name
:= RTE
(RE_Vector_Xor
);
280 Make_Procedure_Call_Statement
(Loc
,
281 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
283 Parameter_Associations
=> New_List
(
285 Make_Attribute_Reference
(Loc
,
286 Prefix
=> Left_Opnd
(Op1
),
287 Attribute_Name
=> Name_Address
),
289 Make_Attribute_Reference
(Loc
,
290 Prefix
=> Right_Opnd
(Op1
),
291 Attribute_Name
=> Name_Address
),
293 Make_Attribute_Reference
(Loc
,
294 Prefix
=> Left_Opnd
(Op1
),
295 Attribute_Name
=> Name_Length
)));
298 Proc_Name
:= RTE
(RE_Vector_Not
);
301 Make_Procedure_Call_Statement
(Loc
,
302 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
303 Parameter_Associations
=> New_List
(
306 Make_Attribute_Reference
(Loc
,
308 Attribute_Name
=> Name_Address
),
310 Make_Attribute_Reference
(Loc
,
312 Attribute_Name
=> Name_Length
)));
316 -- We use the following equivalences:
318 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
319 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
320 -- (not X) xor (not Y) = X xor Y
321 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
323 if Nkind
(Op1
) = N_Op_Not
then
324 if Kind
= N_Op_And
then
325 Proc_Name
:= RTE
(RE_Vector_Nor
);
326 elsif Kind
= N_Op_Or
then
327 Proc_Name
:= RTE
(RE_Vector_Nand
);
329 Proc_Name
:= RTE
(RE_Vector_Xor
);
333 if Kind
= N_Op_And
then
334 Proc_Name
:= RTE
(RE_Vector_And
);
335 elsif Kind
= N_Op_Or
then
336 Proc_Name
:= RTE
(RE_Vector_Or
);
337 elsif Nkind
(Op2
) = N_Op_Not
then
338 Proc_Name
:= RTE
(RE_Vector_Nxor
);
339 Arg2
:= Right_Opnd
(Op2
);
341 Proc_Name
:= RTE
(RE_Vector_Xor
);
346 Make_Procedure_Call_Statement
(Loc
,
347 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
348 Parameter_Associations
=> New_List
(
350 Make_Attribute_Reference
(Loc
,
352 Attribute_Name
=> Name_Address
),
353 Make_Attribute_Reference
(Loc
,
355 Attribute_Name
=> Name_Address
),
356 Make_Attribute_Reference
(Loc
,
358 Attribute_Name
=> Name_Length
)));
361 Rewrite
(N
, Call_Node
);
365 when RE_Not_Available
=>
367 end Build_Boolean_Array_Proc_Call
;
369 --------------------------------
370 -- Displace_Allocator_Pointer --
371 --------------------------------
373 procedure Displace_Allocator_Pointer
(N
: Node_Id
) is
374 Loc
: constant Source_Ptr
:= Sloc
(N
);
375 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
381 -- Do nothing in case of VM targets: the virtual machine will handle
382 -- interfaces directly.
384 if not Tagged_Type_Expansion
then
388 pragma Assert
(Nkind
(N
) = N_Identifier
389 and then Nkind
(Orig_Node
) = N_Allocator
);
391 PtrT
:= Etype
(Orig_Node
);
392 Dtyp
:= Available_View
(Designated_Type
(PtrT
));
393 Etyp
:= Etype
(Expression
(Orig_Node
));
395 if Is_Class_Wide_Type
(Dtyp
)
396 and then Is_Interface
(Dtyp
)
398 -- If the type of the allocator expression is not an interface type
399 -- we can generate code to reference the record component containing
400 -- the pointer to the secondary dispatch table.
402 if not Is_Interface
(Etyp
) then
404 Saved_Typ
: constant Entity_Id
:= Etype
(Orig_Node
);
407 -- 1) Get access to the allocated object
410 Make_Explicit_Dereference
(Loc
,
415 -- 2) Add the conversion to displace the pointer to reference
416 -- the secondary dispatch table.
418 Rewrite
(N
, Convert_To
(Dtyp
, Relocate_Node
(N
)));
419 Analyze_And_Resolve
(N
, Dtyp
);
421 -- 3) The 'access to the secondary dispatch table will be used
422 -- as the value returned by the allocator.
425 Make_Attribute_Reference
(Loc
,
426 Prefix
=> Relocate_Node
(N
),
427 Attribute_Name
=> Name_Access
));
428 Set_Etype
(N
, Saved_Typ
);
432 -- If the type of the allocator expression is an interface type we
433 -- generate a run-time call to displace "this" to reference the
434 -- component containing the pointer to the secondary dispatch table
435 -- or else raise Constraint_Error if the actual object does not
436 -- implement the target interface. This case corresponds with the
437 -- following example:
439 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
441 -- return new Iface_2'Class'(Obj);
446 Unchecked_Convert_To
(PtrT
,
447 Make_Function_Call
(Loc
,
448 Name
=> New_Reference_To
(RTE
(RE_Displace
), Loc
),
449 Parameter_Associations
=> New_List
(
450 Unchecked_Convert_To
(RTE
(RE_Address
),
456 (Access_Disp_Table
(Etype
(Base_Type
(Dtyp
))))),
458 Analyze_And_Resolve
(N
, PtrT
);
461 end Displace_Allocator_Pointer
;
463 ---------------------------------
464 -- Expand_Allocator_Expression --
465 ---------------------------------
467 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
468 Loc
: constant Source_Ptr
:= Sloc
(N
);
469 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
470 PtrT
: constant Entity_Id
:= Etype
(N
);
471 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
473 procedure Apply_Accessibility_Check
475 Built_In_Place
: Boolean := False);
476 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
477 -- type, generate an accessibility check to verify that the level of the
478 -- type of the created object is not deeper than the level of the access
479 -- type. If the type of the qualified expression is class- wide, then
480 -- always generate the check (except in the case where it is known to be
481 -- unnecessary, see comment below). Otherwise, only generate the check
482 -- if the level of the qualified expression type is statically deeper
483 -- than the access type.
485 -- Although the static accessibility will generally have been performed
486 -- as a legality check, it won't have been done in cases where the
487 -- allocator appears in generic body, so a run-time check is needed in
488 -- general. One special case is when the access type is declared in the
489 -- same scope as the class-wide allocator, in which case the check can
490 -- never fail, so it need not be generated.
492 -- As an open issue, there seem to be cases where the static level
493 -- associated with the class-wide object's underlying type is not
494 -- sufficient to perform the proper accessibility check, such as for
495 -- allocators in nested subprograms or accept statements initialized by
496 -- class-wide formals when the actual originates outside at a deeper
497 -- static level. The nested subprogram case might require passing
498 -- accessibility levels along with class-wide parameters, and the task
499 -- case seems to be an actual gap in the language rules that needs to
500 -- be fixed by the ARG. ???
502 -------------------------------
503 -- Apply_Accessibility_Check --
504 -------------------------------
506 procedure Apply_Accessibility_Check
508 Built_In_Place
: Boolean := False)
513 -- Note: we skip the accessibility check for the VM case, since
514 -- there does not seem to be any practical way of implementing it.
516 if Ada_Version
>= Ada_05
517 and then Tagged_Type_Expansion
518 and then Is_Class_Wide_Type
(DesigT
)
519 and then not Scope_Suppress
(Accessibility_Check
)
521 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
523 (Is_Class_Wide_Type
(Etype
(Exp
))
524 and then Scope
(PtrT
) /= Current_Scope
))
526 -- If the allocator was built in place Ref is already a reference
527 -- to the access object initialized to the result of the allocator
528 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
529 -- it is the entity associated with the object containing the
530 -- address of the allocated object.
532 if Built_In_Place
then
533 Ref_Node
:= New_Copy
(Ref
);
535 Ref_Node
:= New_Reference_To
(Ref
, Loc
);
539 Make_Raise_Program_Error
(Loc
,
543 Build_Get_Access_Level
(Loc
,
544 Make_Attribute_Reference
(Loc
,
546 Attribute_Name
=> Name_Tag
)),
548 Make_Integer_Literal
(Loc
,
549 Type_Access_Level
(PtrT
))),
550 Reason
=> PE_Accessibility_Check_Failed
));
552 end Apply_Accessibility_Check
;
556 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
557 T
: constant Entity_Id
:= Entity
(Indic
);
562 TagT
: Entity_Id
:= Empty
;
563 -- Type used as source for tag assignment
565 TagR
: Node_Id
:= Empty
;
566 -- Target reference for tag assignment
568 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
570 Tag_Assign
: Node_Id
;
573 -- Start of processing for Expand_Allocator_Expression
576 if Is_Tagged_Type
(T
) or else Needs_Finalization
(T
) then
578 if Is_CPP_Constructor_Call
(Exp
) then
581 -- Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn
583 -- Allocate the object with no expression
585 Node
:= Relocate_Node
(N
);
586 Set_Expression
(Node
, New_Reference_To
(Etype
(Exp
), Loc
));
588 -- Avoid its expansion to avoid generating a call to the default
593 Temp
:= Make_Temporary
(Loc
, 'P', N
);
596 Make_Object_Declaration
(Loc
,
597 Defining_Identifier
=> Temp
,
598 Constant_Present
=> True,
599 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
600 Expression
=> Node
));
602 Apply_Accessibility_Check
(Temp
);
604 -- Locate the enclosing list and insert the C++ constructor call
611 while not Is_List_Member
(P
) loop
615 Insert_List_After_And_Analyze
(P
,
616 Build_Initialization_Call
(Loc
,
618 Make_Explicit_Dereference
(Loc
,
619 Prefix
=> New_Reference_To
(Temp
, Loc
)),
621 Constructor_Ref
=> Exp
));
624 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
625 Analyze_And_Resolve
(N
, PtrT
);
629 -- Ada 2005 (AI-318-02): If the initialization expression is a call
630 -- to a build-in-place function, then access to the allocated object
631 -- must be passed to the function. Currently we limit such functions
632 -- to those with constrained limited result subtypes, but eventually
633 -- we plan to expand the allowed forms of functions that are treated
634 -- as build-in-place.
636 if Ada_Version
>= Ada_05
637 and then Is_Build_In_Place_Function_Call
(Exp
)
639 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
640 Apply_Accessibility_Check
(N
, Built_In_Place
=> True);
644 -- Actions inserted before:
645 -- Temp : constant ptr_T := new T'(Expression);
646 -- <no CW> Temp._tag := T'tag;
647 -- <CTRL> Adjust (Finalizable (Temp.all));
648 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
650 -- We analyze by hand the new internal allocator to avoid
651 -- any recursion and inappropriate call to Initialize
653 -- We don't want to remove side effects when the expression must be
654 -- built in place. In the case of a build-in-place function call,
655 -- that could lead to a duplication of the call, which was already
656 -- substituted for the allocator.
658 if not Aggr_In_Place
then
659 Remove_Side_Effects
(Exp
);
662 Temp
:= Make_Temporary
(Loc
, 'P', N
);
664 -- For a class wide allocation generate the following code:
666 -- type Equiv_Record is record ... end record;
667 -- implicit subtype CW is <Class_Wide_Subytpe>;
668 -- temp : PtrT := new CW'(CW!(expr));
670 if Is_Class_Wide_Type
(T
) then
671 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
673 -- Ada 2005 (AI-251): If the expression is a class-wide interface
674 -- object we generate code to move up "this" to reference the
675 -- base of the object before allocating the new object.
677 -- Note that Exp'Address is recursively expanded into a call
678 -- to Base_Address (Exp.Tag)
680 if Is_Class_Wide_Type
(Etype
(Exp
))
681 and then Is_Interface
(Etype
(Exp
))
682 and then Tagged_Type_Expansion
686 Unchecked_Convert_To
(Entity
(Indic
),
687 Make_Explicit_Dereference
(Loc
,
688 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
689 Make_Attribute_Reference
(Loc
,
691 Attribute_Name
=> Name_Address
)))));
696 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
699 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
702 -- Keep separate the management of allocators returning interfaces
704 if not Is_Interface
(Directly_Designated_Type
(PtrT
)) then
705 if Aggr_In_Place
then
707 Make_Object_Declaration
(Loc
,
708 Defining_Identifier
=> Temp
,
709 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
712 New_Reference_To
(Etype
(Exp
), Loc
)));
714 -- Copy the Comes_From_Source flag for the allocator we just
715 -- built, since logically this allocator is a replacement of
716 -- the original allocator node. This is for proper handling of
717 -- restriction No_Implicit_Heap_Allocations.
719 Set_Comes_From_Source
720 (Expression
(Tmp_Node
), Comes_From_Source
(N
));
722 Set_No_Initialization
(Expression
(Tmp_Node
));
723 Insert_Action
(N
, Tmp_Node
);
725 if Needs_Finalization
(T
)
726 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
728 -- Create local finalization list for access parameter
730 Flist
:= Get_Allocator_Final_List
(N
, Base_Type
(T
), PtrT
);
733 Convert_Aggr_In_Allocator
(N
, Tmp_Node
, Exp
);
736 Node
:= Relocate_Node
(N
);
739 Make_Object_Declaration
(Loc
,
740 Defining_Identifier
=> Temp
,
741 Constant_Present
=> True,
742 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
743 Expression
=> Node
));
746 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
747 -- interface type. In this case we use the type of the qualified
748 -- expression to allocate the object.
752 Def_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
757 Make_Full_Type_Declaration
(Loc
,
758 Defining_Identifier
=> Def_Id
,
760 Make_Access_To_Object_Definition
(Loc
,
762 Null_Exclusion_Present
=> False,
763 Constant_Present
=> False,
764 Subtype_Indication
=>
765 New_Reference_To
(Etype
(Exp
), Loc
)));
767 Insert_Action
(N
, New_Decl
);
769 -- Inherit the final chain to ensure that the expansion of the
770 -- aggregate is correct in case of controlled types
772 if Needs_Finalization
(Directly_Designated_Type
(PtrT
)) then
773 Set_Associated_Final_Chain
(Def_Id
,
774 Associated_Final_Chain
(PtrT
));
777 -- Declare the object using the previous type declaration
779 if Aggr_In_Place
then
781 Make_Object_Declaration
(Loc
,
782 Defining_Identifier
=> Temp
,
783 Object_Definition
=> New_Reference_To
(Def_Id
, Loc
),
786 New_Reference_To
(Etype
(Exp
), Loc
)));
788 -- Copy the Comes_From_Source flag for the allocator we just
789 -- built, since logically this allocator is a replacement of
790 -- the original allocator node. This is for proper handling
791 -- of restriction No_Implicit_Heap_Allocations.
793 Set_Comes_From_Source
794 (Expression
(Tmp_Node
), Comes_From_Source
(N
));
796 Set_No_Initialization
(Expression
(Tmp_Node
));
797 Insert_Action
(N
, Tmp_Node
);
799 if Needs_Finalization
(T
)
800 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
802 -- Create local finalization list for access parameter
805 Get_Allocator_Final_List
(N
, Base_Type
(T
), PtrT
);
808 Convert_Aggr_In_Allocator
(N
, Tmp_Node
, Exp
);
810 Node
:= Relocate_Node
(N
);
813 Make_Object_Declaration
(Loc
,
814 Defining_Identifier
=> Temp
,
815 Constant_Present
=> True,
816 Object_Definition
=> New_Reference_To
(Def_Id
, Loc
),
817 Expression
=> Node
));
820 -- Generate an additional object containing the address of the
821 -- returned object. The type of this second object declaration
822 -- is the correct type required for the common processing that
823 -- is still performed by this subprogram. The displacement of
824 -- this pointer to reference the component associated with the
825 -- interface type will be done at the end of common processing.
828 Make_Object_Declaration
(Loc
,
829 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
830 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
831 Expression
=> Unchecked_Convert_To
(PtrT
,
832 New_Reference_To
(Temp
, Loc
)));
834 Insert_Action
(N
, New_Decl
);
836 Tmp_Node
:= New_Decl
;
837 Temp
:= Defining_Identifier
(New_Decl
);
841 Apply_Accessibility_Check
(Temp
);
843 -- Generate the tag assignment
845 -- Suppress the tag assignment when VM_Target because VM tags are
846 -- represented implicitly in objects.
848 if not Tagged_Type_Expansion
then
851 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
852 -- interface objects because in this case the tag does not change.
854 elsif Is_Interface
(Directly_Designated_Type
(Etype
(N
))) then
855 pragma Assert
(Is_Class_Wide_Type
856 (Directly_Designated_Type
(Etype
(N
))));
859 elsif Is_Tagged_Type
(T
) and then not Is_Class_Wide_Type
(T
) then
861 TagR
:= New_Reference_To
(Temp
, Loc
);
863 elsif Is_Private_Type
(T
)
864 and then Is_Tagged_Type
(Underlying_Type
(T
))
866 TagT
:= Underlying_Type
(T
);
868 Unchecked_Convert_To
(Underlying_Type
(T
),
869 Make_Explicit_Dereference
(Loc
,
870 Prefix
=> New_Reference_To
(Temp
, Loc
)));
873 if Present
(TagT
) then
875 Make_Assignment_Statement
(Loc
,
877 Make_Selected_Component
(Loc
,
880 New_Reference_To
(First_Tag_Component
(TagT
), Loc
)),
883 Unchecked_Convert_To
(RTE
(RE_Tag
),
885 (Elists
.Node
(First_Elmt
(Access_Disp_Table
(TagT
))),
888 -- The previous assignment has to be done in any case
890 Set_Assignment_OK
(Name
(Tag_Assign
));
891 Insert_Action
(N
, Tag_Assign
);
894 if Needs_Finalization
(DesigT
)
895 and then Needs_Finalization
(T
)
899 Apool
: constant Entity_Id
:=
900 Associated_Storage_Pool
(PtrT
);
903 -- If it is an allocation on the secondary stack (i.e. a value
904 -- returned from a function), the object is attached on the
905 -- caller side as soon as the call is completed (see
906 -- Expand_Ctrl_Function_Call)
908 if Is_RTE
(Apool
, RE_SS_Pool
) then
910 F
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F');
913 Make_Object_Declaration
(Loc
,
914 Defining_Identifier
=> F
,
916 New_Reference_To
(RTE
(RE_Finalizable_Ptr
), Loc
)));
917 Flist
:= New_Reference_To
(F
, Loc
);
918 Attach
:= Make_Integer_Literal
(Loc
, 1);
921 -- Normal case, not a secondary stack allocation
924 if Needs_Finalization
(T
)
925 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
927 -- Create local finalization list for access parameter
930 Get_Allocator_Final_List
(N
, Base_Type
(T
), PtrT
);
932 Flist
:= Find_Final_List
(PtrT
);
935 Attach
:= Make_Integer_Literal
(Loc
, 2);
938 -- Generate an Adjust call if the object will be moved. In Ada
939 -- 2005, the object may be inherently limited, in which case
940 -- there is no Adjust procedure, and the object is built in
941 -- place. In Ada 95, the object can be limited but not
942 -- inherently limited if this allocator came from a return
943 -- statement (we're allocating the result on the secondary
944 -- stack). In that case, the object will be moved, so we _do_
948 and then not Is_Inherently_Limited_Type
(T
)
954 -- An unchecked conversion is needed in the classwide
955 -- case because the designated type can be an ancestor of
956 -- the subtype mark of the allocator.
958 Unchecked_Convert_To
(T
,
959 Make_Explicit_Dereference
(Loc
,
960 Prefix
=> New_Reference_To
(Temp
, Loc
))),
964 With_Attach
=> Attach
,
970 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
971 Analyze_And_Resolve
(N
, PtrT
);
973 -- Ada 2005 (AI-251): Displace the pointer to reference the record
974 -- component containing the secondary dispatch table of the interface
977 if Is_Interface
(Directly_Designated_Type
(PtrT
)) then
978 Displace_Allocator_Pointer
(N
);
981 elsif Aggr_In_Place
then
982 Temp
:= Make_Temporary
(Loc
, 'P', N
);
984 Make_Object_Declaration
(Loc
,
985 Defining_Identifier
=> Temp
,
986 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
987 Expression
=> Make_Allocator
(Loc
,
988 New_Reference_To
(Etype
(Exp
), Loc
)));
990 -- Copy the Comes_From_Source flag for the allocator we just built,
991 -- since logically this allocator is a replacement of the original
992 -- allocator node. This is for proper handling of restriction
993 -- No_Implicit_Heap_Allocations.
995 Set_Comes_From_Source
996 (Expression
(Tmp_Node
), Comes_From_Source
(N
));
998 Set_No_Initialization
(Expression
(Tmp_Node
));
999 Insert_Action
(N
, Tmp_Node
);
1000 Convert_Aggr_In_Allocator
(N
, Tmp_Node
, Exp
);
1001 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1002 Analyze_And_Resolve
(N
, PtrT
);
1004 elsif Is_Access_Type
(T
)
1005 and then Can_Never_Be_Null
(T
)
1007 Install_Null_Excluding_Check
(Exp
);
1009 elsif Is_Access_Type
(DesigT
)
1010 and then Nkind
(Exp
) = N_Allocator
1011 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1013 -- Apply constraint to designated subtype indication
1015 Apply_Constraint_Check
(Expression
(Exp
),
1016 Designated_Type
(DesigT
),
1017 No_Sliding
=> True);
1019 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1021 -- Propagate constraint_error to enclosing allocator
1023 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1027 -- type A is access T1;
1028 -- X : A := new T2'(...);
1029 -- T1 and T2 can be different subtypes, and we might need to check
1030 -- both constraints. First check against the type of the qualified
1033 Apply_Constraint_Check
(Exp
, T
, No_Sliding
=> True);
1035 if Do_Range_Check
(Exp
) then
1036 Set_Do_Range_Check
(Exp
, False);
1037 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1040 -- A check is also needed in cases where the designated subtype is
1041 -- constrained and differs from the subtype given in the qualified
1042 -- expression. Note that the check on the qualified expression does
1043 -- not allow sliding, but this check does (a relaxation from Ada 83).
1045 if Is_Constrained
(DesigT
)
1046 and then not Subtypes_Statically_Match
(T
, DesigT
)
1048 Apply_Constraint_Check
1049 (Exp
, DesigT
, No_Sliding
=> False);
1051 if Do_Range_Check
(Exp
) then
1052 Set_Do_Range_Check
(Exp
, False);
1053 Generate_Range_Check
(Exp
, DesigT
, CE_Range_Check_Failed
);
1057 -- For an access to unconstrained packed array, GIGI needs to see an
1058 -- expression with a constrained subtype in order to compute the
1059 -- proper size for the allocator.
1061 if Is_Array_Type
(T
)
1062 and then not Is_Constrained
(T
)
1063 and then Is_Packed
(T
)
1066 ConstrT
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1067 Internal_Exp
: constant Node_Id
:= Relocate_Node
(Exp
);
1070 Make_Subtype_Declaration
(Loc
,
1071 Defining_Identifier
=> ConstrT
,
1072 Subtype_Indication
=>
1073 Make_Subtype_From_Expr
(Exp
, T
)));
1074 Freeze_Itype
(ConstrT
, Exp
);
1075 Rewrite
(Exp
, OK_Convert_To
(ConstrT
, Internal_Exp
));
1079 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1080 -- to a build-in-place function, then access to the allocated object
1081 -- must be passed to the function. Currently we limit such functions
1082 -- to those with constrained limited result subtypes, but eventually
1083 -- we plan to expand the allowed forms of functions that are treated
1084 -- as build-in-place.
1086 if Ada_Version
>= Ada_05
1087 and then Is_Build_In_Place_Function_Call
(Exp
)
1089 Make_Build_In_Place_Call_In_Allocator
(N
, Exp
);
1094 when RE_Not_Available
=>
1096 end Expand_Allocator_Expression
;
1098 -----------------------------
1099 -- Expand_Array_Comparison --
1100 -----------------------------
1102 -- Expansion is only required in the case of array types. For the unpacked
1103 -- case, an appropriate runtime routine is called. For packed cases, and
1104 -- also in some other cases where a runtime routine cannot be called, the
1105 -- form of the expansion is:
1107 -- [body for greater_nn; boolean_expression]
1109 -- The body is built by Make_Array_Comparison_Op, and the form of the
1110 -- Boolean expression depends on the operator involved.
1112 procedure Expand_Array_Comparison
(N
: Node_Id
) is
1113 Loc
: constant Source_Ptr
:= Sloc
(N
);
1114 Op1
: Node_Id
:= Left_Opnd
(N
);
1115 Op2
: Node_Id
:= Right_Opnd
(N
);
1116 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
1117 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
1120 Func_Body
: Node_Id
;
1121 Func_Name
: Entity_Id
;
1125 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
1126 -- True for byte addressable target
1128 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
1129 -- Returns True if the length of the given operand is known to be less
1130 -- than 4. Returns False if this length is known to be four or greater
1131 -- or is not known at compile time.
1133 ------------------------
1134 -- Length_Less_Than_4 --
1135 ------------------------
1137 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
1138 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
1141 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
1142 return String_Literal_Length
(Otyp
) < 4;
1146 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
1147 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
1148 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
1153 if Compile_Time_Known_Value
(Lo
) then
1154 Lov
:= Expr_Value
(Lo
);
1159 if Compile_Time_Known_Value
(Hi
) then
1160 Hiv
:= Expr_Value
(Hi
);
1165 return Hiv
< Lov
+ 3;
1168 end Length_Less_Than_4
;
1170 -- Start of processing for Expand_Array_Comparison
1173 -- Deal first with unpacked case, where we can call a runtime routine
1174 -- except that we avoid this for targets for which are not addressable
1175 -- by bytes, and for the JVM/CIL, since they do not support direct
1176 -- addressing of array components.
1178 if not Is_Bit_Packed_Array
(Typ1
)
1179 and then Byte_Addressable
1180 and then VM_Target
= No_VM
1182 -- The call we generate is:
1184 -- Compare_Array_xn[_Unaligned]
1185 -- (left'address, right'address, left'length, right'length) <op> 0
1187 -- x = U for unsigned, S for signed
1188 -- n = 8,16,32,64 for component size
1189 -- Add _Unaligned if length < 4 and component size is 8.
1190 -- <op> is the standard comparison operator
1192 if Component_Size
(Typ1
) = 8 then
1193 if Length_Less_Than_4
(Op1
)
1195 Length_Less_Than_4
(Op2
)
1197 if Is_Unsigned_Type
(Ctyp
) then
1198 Comp
:= RE_Compare_Array_U8_Unaligned
;
1200 Comp
:= RE_Compare_Array_S8_Unaligned
;
1204 if Is_Unsigned_Type
(Ctyp
) then
1205 Comp
:= RE_Compare_Array_U8
;
1207 Comp
:= RE_Compare_Array_S8
;
1211 elsif Component_Size
(Typ1
) = 16 then
1212 if Is_Unsigned_Type
(Ctyp
) then
1213 Comp
:= RE_Compare_Array_U16
;
1215 Comp
:= RE_Compare_Array_S16
;
1218 elsif Component_Size
(Typ1
) = 32 then
1219 if Is_Unsigned_Type
(Ctyp
) then
1220 Comp
:= RE_Compare_Array_U32
;
1222 Comp
:= RE_Compare_Array_S32
;
1225 else pragma Assert
(Component_Size
(Typ1
) = 64);
1226 if Is_Unsigned_Type
(Ctyp
) then
1227 Comp
:= RE_Compare_Array_U64
;
1229 Comp
:= RE_Compare_Array_S64
;
1233 Remove_Side_Effects
(Op1
, Name_Req
=> True);
1234 Remove_Side_Effects
(Op2
, Name_Req
=> True);
1237 Make_Function_Call
(Sloc
(Op1
),
1238 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
1240 Parameter_Associations
=> New_List
(
1241 Make_Attribute_Reference
(Loc
,
1242 Prefix
=> Relocate_Node
(Op1
),
1243 Attribute_Name
=> Name_Address
),
1245 Make_Attribute_Reference
(Loc
,
1246 Prefix
=> Relocate_Node
(Op2
),
1247 Attribute_Name
=> Name_Address
),
1249 Make_Attribute_Reference
(Loc
,
1250 Prefix
=> Relocate_Node
(Op1
),
1251 Attribute_Name
=> Name_Length
),
1253 Make_Attribute_Reference
(Loc
,
1254 Prefix
=> Relocate_Node
(Op2
),
1255 Attribute_Name
=> Name_Length
))));
1258 Make_Integer_Literal
(Sloc
(Op2
),
1261 Analyze_And_Resolve
(Op1
, Standard_Integer
);
1262 Analyze_And_Resolve
(Op2
, Standard_Integer
);
1266 -- Cases where we cannot make runtime call
1268 -- For (a <= b) we convert to not (a > b)
1270 if Chars
(N
) = Name_Op_Le
then
1276 Right_Opnd
=> Op2
)));
1277 Analyze_And_Resolve
(N
, Standard_Boolean
);
1280 -- For < the Boolean expression is
1281 -- greater__nn (op2, op1)
1283 elsif Chars
(N
) = Name_Op_Lt
then
1284 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1288 Op1
:= Right_Opnd
(N
);
1289 Op2
:= Left_Opnd
(N
);
1291 -- For (a >= b) we convert to not (a < b)
1293 elsif Chars
(N
) = Name_Op_Ge
then
1299 Right_Opnd
=> Op2
)));
1300 Analyze_And_Resolve
(N
, Standard_Boolean
);
1303 -- For > the Boolean expression is
1304 -- greater__nn (op1, op2)
1307 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
1308 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
1311 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1313 Make_Function_Call
(Loc
,
1314 Name
=> New_Reference_To
(Func_Name
, Loc
),
1315 Parameter_Associations
=> New_List
(Op1
, Op2
));
1317 Insert_Action
(N
, Func_Body
);
1319 Analyze_And_Resolve
(N
, Standard_Boolean
);
1322 when RE_Not_Available
=>
1324 end Expand_Array_Comparison
;
1326 ---------------------------
1327 -- Expand_Array_Equality --
1328 ---------------------------
1330 -- Expand an equality function for multi-dimensional arrays. Here is an
1331 -- example of such a function for Nb_Dimension = 2
1333 -- function Enn (A : atyp; B : btyp) return boolean is
1335 -- if (A'length (1) = 0 or else A'length (2) = 0)
1337 -- (B'length (1) = 0 or else B'length (2) = 0)
1339 -- return True; -- RM 4.5.2(22)
1342 -- if A'length (1) /= B'length (1)
1344 -- A'length (2) /= B'length (2)
1346 -- return False; -- RM 4.5.2(23)
1350 -- A1 : Index_T1 := A'first (1);
1351 -- B1 : Index_T1 := B'first (1);
1355 -- A2 : Index_T2 := A'first (2);
1356 -- B2 : Index_T2 := B'first (2);
1359 -- if A (A1, A2) /= B (B1, B2) then
1363 -- exit when A2 = A'last (2);
1364 -- A2 := Index_T2'succ (A2);
1365 -- B2 := Index_T2'succ (B2);
1369 -- exit when A1 = A'last (1);
1370 -- A1 := Index_T1'succ (A1);
1371 -- B1 := Index_T1'succ (B1);
1378 -- Note on the formal types used (atyp and btyp). If either of the arrays
1379 -- is of a private type, we use the underlying type, and do an unchecked
1380 -- conversion of the actual. If either of the arrays has a bound depending
1381 -- on a discriminant, then we use the base type since otherwise we have an
1382 -- escaped discriminant in the function.
1384 -- If both arrays are constrained and have the same bounds, we can generate
1385 -- a loop with an explicit iteration scheme using a 'Range attribute over
1388 function Expand_Array_Equality
1393 Typ
: Entity_Id
) return Node_Id
1395 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1396 Decls
: constant List_Id
:= New_List
;
1397 Index_List1
: constant List_Id
:= New_List
;
1398 Index_List2
: constant List_Id
:= New_List
;
1402 Func_Name
: Entity_Id
;
1403 Func_Body
: Node_Id
;
1405 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1406 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1410 -- The parameter types to be used for the formals
1415 Num
: Int
) return Node_Id
;
1416 -- This builds the attribute reference Arr'Nam (Expr)
1418 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1419 -- Create one statement to compare corresponding components, designated
1420 -- by a full set of indices.
1422 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1423 -- Given one of the arguments, computes the appropriate type to be used
1424 -- for that argument in the corresponding function formal
1426 function Handle_One_Dimension
1428 Index
: Node_Id
) return Node_Id
;
1429 -- This procedure returns the following code
1432 -- Bn : Index_T := B'First (N);
1436 -- exit when An = A'Last (N);
1437 -- An := Index_T'Succ (An)
1438 -- Bn := Index_T'Succ (Bn)
1442 -- If both indices are constrained and identical, the procedure
1443 -- returns a simpler loop:
1445 -- for An in A'Range (N) loop
1449 -- N is the dimension for which we are generating a loop. Index is the
1450 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1451 -- xxx statement is either the loop or declare for the next dimension
1452 -- or if this is the last dimension the comparison of corresponding
1453 -- components of the arrays.
1455 -- The actual way the code works is to return the comparison of
1456 -- corresponding components for the N+1 call. That's neater!
1458 function Test_Empty_Arrays
return Node_Id
;
1459 -- This function constructs the test for both arrays being empty
1460 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1462 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1464 function Test_Lengths_Correspond
return Node_Id
;
1465 -- This function constructs the test for arrays having different lengths
1466 -- in at least one index position, in which case the resulting code is:
1468 -- A'length (1) /= B'length (1)
1470 -- A'length (2) /= B'length (2)
1481 Num
: Int
) return Node_Id
1485 Make_Attribute_Reference
(Loc
,
1486 Attribute_Name
=> Nam
,
1487 Prefix
=> New_Reference_To
(Arr
, Loc
),
1488 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1491 ------------------------
1492 -- Component_Equality --
1493 ------------------------
1495 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1500 -- if a(i1...) /= b(j1...) then return false; end if;
1503 Make_Indexed_Component
(Loc
,
1504 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1505 Expressions
=> Index_List1
);
1508 Make_Indexed_Component
(Loc
,
1509 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1510 Expressions
=> Index_List2
);
1512 Test
:= Expand_Composite_Equality
1513 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1515 -- If some (sub)component is an unchecked_union, the whole operation
1516 -- will raise program error.
1518 if Nkind
(Test
) = N_Raise_Program_Error
then
1520 -- This node is going to be inserted at a location where a
1521 -- statement is expected: clear its Etype so analysis will set
1522 -- it to the expected Standard_Void_Type.
1524 Set_Etype
(Test
, Empty
);
1529 Make_Implicit_If_Statement
(Nod
,
1530 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1531 Then_Statements
=> New_List
(
1532 Make_Simple_Return_Statement
(Loc
,
1533 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1535 end Component_Equality
;
1541 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1552 T
:= Underlying_Type
(T
);
1554 X
:= First_Index
(T
);
1555 while Present
(X
) loop
1556 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1558 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1571 --------------------------
1572 -- Handle_One_Dimension --
1573 ---------------------------
1575 function Handle_One_Dimension
1577 Index
: Node_Id
) return Node_Id
1579 Need_Separate_Indexes
: constant Boolean :=
1581 or else not Is_Constrained
(Ltyp
);
1582 -- If the index types are identical, and we are working with
1583 -- constrained types, then we can use the same index for both
1586 An
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
1589 Index_T
: Entity_Id
;
1594 if N
> Number_Dimensions
(Ltyp
) then
1595 return Component_Equality
(Ltyp
);
1598 -- Case where we generate a loop
1600 Index_T
:= Base_Type
(Etype
(Index
));
1602 if Need_Separate_Indexes
then
1603 Bn
:= Make_Temporary
(Loc
, 'B');
1608 Append
(New_Reference_To
(An
, Loc
), Index_List1
);
1609 Append
(New_Reference_To
(Bn
, Loc
), Index_List2
);
1611 Stm_List
:= New_List
(
1612 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1614 if Need_Separate_Indexes
then
1616 -- Generate guard for loop, followed by increments of indices
1618 Append_To
(Stm_List
,
1619 Make_Exit_Statement
(Loc
,
1622 Left_Opnd
=> New_Reference_To
(An
, Loc
),
1623 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1625 Append_To
(Stm_List
,
1626 Make_Assignment_Statement
(Loc
,
1627 Name
=> New_Reference_To
(An
, Loc
),
1629 Make_Attribute_Reference
(Loc
,
1630 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1631 Attribute_Name
=> Name_Succ
,
1632 Expressions
=> New_List
(New_Reference_To
(An
, Loc
)))));
1634 Append_To
(Stm_List
,
1635 Make_Assignment_Statement
(Loc
,
1636 Name
=> New_Reference_To
(Bn
, Loc
),
1638 Make_Attribute_Reference
(Loc
,
1639 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1640 Attribute_Name
=> Name_Succ
,
1641 Expressions
=> New_List
(New_Reference_To
(Bn
, Loc
)))));
1644 -- If separate indexes, we need a declare block for An and Bn, and a
1645 -- loop without an iteration scheme.
1647 if Need_Separate_Indexes
then
1649 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1652 Make_Block_Statement
(Loc
,
1653 Declarations
=> New_List
(
1654 Make_Object_Declaration
(Loc
,
1655 Defining_Identifier
=> An
,
1656 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1657 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1659 Make_Object_Declaration
(Loc
,
1660 Defining_Identifier
=> Bn
,
1661 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1662 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1664 Handled_Statement_Sequence
=>
1665 Make_Handled_Sequence_Of_Statements
(Loc
,
1666 Statements
=> New_List
(Loop_Stm
)));
1668 -- If no separate indexes, return loop statement with explicit
1669 -- iteration scheme on its own
1673 Make_Implicit_Loop_Statement
(Nod
,
1674 Statements
=> Stm_List
,
1676 Make_Iteration_Scheme
(Loc
,
1677 Loop_Parameter_Specification
=>
1678 Make_Loop_Parameter_Specification
(Loc
,
1679 Defining_Identifier
=> An
,
1680 Discrete_Subtype_Definition
=>
1681 Arr_Attr
(A
, Name_Range
, N
))));
1684 end Handle_One_Dimension
;
1686 -----------------------
1687 -- Test_Empty_Arrays --
1688 -----------------------
1690 function Test_Empty_Arrays
return Node_Id
is
1700 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1703 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1704 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1708 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1709 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1718 Left_Opnd
=> Relocate_Node
(Alist
),
1719 Right_Opnd
=> Atest
);
1723 Left_Opnd
=> Relocate_Node
(Blist
),
1724 Right_Opnd
=> Btest
);
1731 Right_Opnd
=> Blist
);
1732 end Test_Empty_Arrays
;
1734 -----------------------------
1735 -- Test_Lengths_Correspond --
1736 -----------------------------
1738 function Test_Lengths_Correspond
return Node_Id
is
1744 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1747 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1748 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
1755 Left_Opnd
=> Relocate_Node
(Result
),
1756 Right_Opnd
=> Rtest
);
1761 end Test_Lengths_Correspond
;
1763 -- Start of processing for Expand_Array_Equality
1766 Ltyp
:= Get_Arg_Type
(Lhs
);
1767 Rtyp
:= Get_Arg_Type
(Rhs
);
1769 -- For now, if the argument types are not the same, go to the base type,
1770 -- since the code assumes that the formals have the same type. This is
1771 -- fixable in future ???
1773 if Ltyp
/= Rtyp
then
1774 Ltyp
:= Base_Type
(Ltyp
);
1775 Rtyp
:= Base_Type
(Rtyp
);
1776 pragma Assert
(Ltyp
= Rtyp
);
1779 -- Build list of formals for function
1781 Formals
:= New_List
(
1782 Make_Parameter_Specification
(Loc
,
1783 Defining_Identifier
=> A
,
1784 Parameter_Type
=> New_Reference_To
(Ltyp
, Loc
)),
1786 Make_Parameter_Specification
(Loc
,
1787 Defining_Identifier
=> B
,
1788 Parameter_Type
=> New_Reference_To
(Rtyp
, Loc
)));
1790 Func_Name
:= Make_Temporary
(Loc
, 'E');
1792 -- Build statement sequence for function
1795 Make_Subprogram_Body
(Loc
,
1797 Make_Function_Specification
(Loc
,
1798 Defining_Unit_Name
=> Func_Name
,
1799 Parameter_Specifications
=> Formals
,
1800 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
1802 Declarations
=> Decls
,
1804 Handled_Statement_Sequence
=>
1805 Make_Handled_Sequence_Of_Statements
(Loc
,
1806 Statements
=> New_List
(
1808 Make_Implicit_If_Statement
(Nod
,
1809 Condition
=> Test_Empty_Arrays
,
1810 Then_Statements
=> New_List
(
1811 Make_Simple_Return_Statement
(Loc
,
1813 New_Occurrence_Of
(Standard_True
, Loc
)))),
1815 Make_Implicit_If_Statement
(Nod
,
1816 Condition
=> Test_Lengths_Correspond
,
1817 Then_Statements
=> New_List
(
1818 Make_Simple_Return_Statement
(Loc
,
1820 New_Occurrence_Of
(Standard_False
, Loc
)))),
1822 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
1824 Make_Simple_Return_Statement
(Loc
,
1825 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1827 Set_Has_Completion
(Func_Name
, True);
1828 Set_Is_Inlined
(Func_Name
);
1830 -- If the array type is distinct from the type of the arguments, it
1831 -- is the full view of a private type. Apply an unchecked conversion
1832 -- to insure that analysis of the call succeeds.
1842 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1844 L
:= OK_Convert_To
(Ltyp
, Lhs
);
1848 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1850 R
:= OK_Convert_To
(Rtyp
, Rhs
);
1853 Actuals
:= New_List
(L
, R
);
1856 Append_To
(Bodies
, Func_Body
);
1859 Make_Function_Call
(Loc
,
1860 Name
=> New_Reference_To
(Func_Name
, Loc
),
1861 Parameter_Associations
=> Actuals
);
1862 end Expand_Array_Equality
;
1864 -----------------------------
1865 -- Expand_Boolean_Operator --
1866 -----------------------------
1868 -- Note that we first get the actual subtypes of the operands, since we
1869 -- always want to deal with types that have bounds.
1871 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
1872 Typ
: constant Entity_Id
:= Etype
(N
);
1875 -- Special case of bit packed array where both operands are known to be
1876 -- properly aligned. In this case we use an efficient run time routine
1877 -- to carry out the operation (see System.Bit_Ops).
1879 if Is_Bit_Packed_Array
(Typ
)
1880 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
1881 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
1883 Expand_Packed_Boolean_Operator
(N
);
1887 -- For the normal non-packed case, the general expansion is to build
1888 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1889 -- and then inserting it into the tree. The original operator node is
1890 -- then rewritten as a call to this function. We also use this in the
1891 -- packed case if either operand is a possibly unaligned object.
1894 Loc
: constant Source_Ptr
:= Sloc
(N
);
1895 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
1896 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
1897 Func_Body
: Node_Id
;
1898 Func_Name
: Entity_Id
;
1901 Convert_To_Actual_Subtype
(L
);
1902 Convert_To_Actual_Subtype
(R
);
1903 Ensure_Defined
(Etype
(L
), N
);
1904 Ensure_Defined
(Etype
(R
), N
);
1905 Apply_Length_Check
(R
, Etype
(L
));
1907 if Nkind
(N
) = N_Op_Xor
then
1908 Silly_Boolean_Array_Xor_Test
(N
, Etype
(L
));
1911 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1912 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
1914 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
1916 elsif Nkind
(Parent
(N
)) = N_Op_Not
1917 and then Nkind
(N
) = N_Op_And
1919 Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
1924 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
1925 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1926 Insert_Action
(N
, Func_Body
);
1928 -- Now rewrite the expression with a call
1931 Make_Function_Call
(Loc
,
1932 Name
=> New_Reference_To
(Func_Name
, Loc
),
1933 Parameter_Associations
=>
1936 Make_Type_Conversion
1937 (Loc
, New_Reference_To
(Etype
(L
), Loc
), R
))));
1939 Analyze_And_Resolve
(N
, Typ
);
1942 end Expand_Boolean_Operator
;
1944 -------------------------------
1945 -- Expand_Composite_Equality --
1946 -------------------------------
1948 -- This function is only called for comparing internal fields of composite
1949 -- types when these fields are themselves composites. This is a special
1950 -- case because it is not possible to respect normal Ada visibility rules.
1952 function Expand_Composite_Equality
1957 Bodies
: List_Id
) return Node_Id
1959 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1960 Full_Type
: Entity_Id
;
1965 if Is_Private_Type
(Typ
) then
1966 Full_Type
:= Underlying_Type
(Typ
);
1971 -- Defense against malformed private types with no completion the error
1972 -- will be diagnosed later by check_completion
1974 if No
(Full_Type
) then
1975 return New_Reference_To
(Standard_False
, Loc
);
1978 Full_Type
:= Base_Type
(Full_Type
);
1980 if Is_Array_Type
(Full_Type
) then
1982 -- If the operand is an elementary type other than a floating-point
1983 -- type, then we can simply use the built-in block bitwise equality,
1984 -- since the predefined equality operators always apply and bitwise
1985 -- equality is fine for all these cases.
1987 if Is_Elementary_Type
(Component_Type
(Full_Type
))
1988 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
1990 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
1992 -- For composite component types, and floating-point types, use the
1993 -- expansion. This deals with tagged component types (where we use
1994 -- the applicable equality routine) and floating-point, (where we
1995 -- need to worry about negative zeroes), and also the case of any
1996 -- composite type recursively containing such fields.
1999 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
2002 elsif Is_Tagged_Type
(Full_Type
) then
2004 -- Call the primitive operation "=" of this type
2006 if Is_Class_Wide_Type
(Full_Type
) then
2007 Full_Type
:= Root_Type
(Full_Type
);
2010 -- If this is derived from an untagged private type completed with a
2011 -- tagged type, it does not have a full view, so we use the primitive
2012 -- operations of the private type. This check should no longer be
2013 -- necessary when these types receive their full views ???
2015 if Is_Private_Type
(Typ
)
2016 and then not Is_Tagged_Type
(Typ
)
2017 and then not Is_Controlled
(Typ
)
2018 and then Is_Derived_Type
(Typ
)
2019 and then No
(Full_View
(Typ
))
2021 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
2023 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
2027 Eq_Op
:= Node
(Prim
);
2028 exit when Chars
(Eq_Op
) = Name_Op_Eq
2029 and then Etype
(First_Formal
(Eq_Op
)) =
2030 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
2031 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
2033 pragma Assert
(Present
(Prim
));
2036 Eq_Op
:= Node
(Prim
);
2039 Make_Function_Call
(Loc
,
2040 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2041 Parameter_Associations
=>
2043 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
2044 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
2046 elsif Is_Record_Type
(Full_Type
) then
2047 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
2049 if Present
(Eq_Op
) then
2050 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
2052 -- Inherited equality from parent type. Convert the actuals to
2053 -- match signature of operation.
2056 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
2060 Make_Function_Call
(Loc
,
2061 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2062 Parameter_Associations
=>
2063 New_List
(OK_Convert_To
(T
, Lhs
),
2064 OK_Convert_To
(T
, Rhs
)));
2068 -- Comparison between Unchecked_Union components
2070 if Is_Unchecked_Union
(Full_Type
) then
2072 Lhs_Type
: Node_Id
:= Full_Type
;
2073 Rhs_Type
: Node_Id
:= Full_Type
;
2074 Lhs_Discr_Val
: Node_Id
;
2075 Rhs_Discr_Val
: Node_Id
;
2080 if Nkind
(Lhs
) = N_Selected_Component
then
2081 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
2086 if Nkind
(Rhs
) = N_Selected_Component
then
2087 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
2090 -- Lhs of the composite equality
2092 if Is_Constrained
(Lhs_Type
) then
2094 -- Since the enclosing record type can never be an
2095 -- Unchecked_Union (this code is executed for records
2096 -- that do not have variants), we may reference its
2099 if Nkind
(Lhs
) = N_Selected_Component
2100 and then Has_Per_Object_Constraint
(
2101 Entity
(Selector_Name
(Lhs
)))
2104 Make_Selected_Component
(Loc
,
2105 Prefix
=> Prefix
(Lhs
),
2108 Get_Discriminant_Value
(
2109 First_Discriminant
(Lhs_Type
),
2111 Stored_Constraint
(Lhs_Type
))));
2114 Lhs_Discr_Val
:= New_Copy
(
2115 Get_Discriminant_Value
(
2116 First_Discriminant
(Lhs_Type
),
2118 Stored_Constraint
(Lhs_Type
)));
2122 -- It is not possible to infer the discriminant since
2123 -- the subtype is not constrained.
2126 Make_Raise_Program_Error
(Loc
,
2127 Reason
=> PE_Unchecked_Union_Restriction
);
2130 -- Rhs of the composite equality
2132 if Is_Constrained
(Rhs_Type
) then
2133 if Nkind
(Rhs
) = N_Selected_Component
2134 and then Has_Per_Object_Constraint
(
2135 Entity
(Selector_Name
(Rhs
)))
2138 Make_Selected_Component
(Loc
,
2139 Prefix
=> Prefix
(Rhs
),
2142 Get_Discriminant_Value
(
2143 First_Discriminant
(Rhs_Type
),
2145 Stored_Constraint
(Rhs_Type
))));
2148 Rhs_Discr_Val
:= New_Copy
(
2149 Get_Discriminant_Value
(
2150 First_Discriminant
(Rhs_Type
),
2152 Stored_Constraint
(Rhs_Type
)));
2157 Make_Raise_Program_Error
(Loc
,
2158 Reason
=> PE_Unchecked_Union_Restriction
);
2161 -- Call the TSS equality function with the inferred
2162 -- discriminant values.
2165 Make_Function_Call
(Loc
,
2166 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2167 Parameter_Associations
=> New_List
(
2176 Make_Function_Call
(Loc
,
2177 Name
=> New_Reference_To
(Eq_Op
, Loc
),
2178 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2182 elsif Ada_Version
>= Ada_12
then
2184 -- if no TSS has been created for the type, check whether there is
2185 -- a primitive equality declared for it. If it is abstract replace
2186 -- the call with an explicit raise.
2192 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Full_Type
));
2193 while Present
(Prim
) loop
2194 if Chars
(Node
(Prim
)) = Name_Op_Eq
then
2195 if Is_Abstract_Subprogram
(Node
(Prim
)) then
2197 Make_Raise_Program_Error
(Loc
,
2198 Reason
=> PE_Explicit_Raise
);
2201 Make_Function_Call
(Loc
,
2202 Name
=> New_Reference_To
(Node
(Prim
), Loc
),
2203 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
2211 -- Predfined equality applies iff no user-defined primitive exists
2213 return Make_Op_Eq
(Loc
, Lhs
, Rhs
);
2216 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
2221 -- It can be a simple record or the full view of a scalar private
2223 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
2225 end Expand_Composite_Equality
;
2227 ------------------------
2228 -- Expand_Concatenate --
2229 ------------------------
2231 procedure Expand_Concatenate
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2232 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2234 Atyp
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
2235 -- Result type of concatenation
2237 Ctyp
: constant Entity_Id
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2238 -- Component type. Elements of this component type can appear as one
2239 -- of the operands of concatenation as well as arrays.
2241 Istyp
: constant Entity_Id
:= Etype
(First_Index
(Atyp
));
2244 Ityp
: constant Entity_Id
:= Base_Type
(Istyp
);
2245 -- Index type. This is the base type of the index subtype, and is used
2246 -- for all computed bounds (which may be out of range of Istyp in the
2247 -- case of null ranges).
2250 -- This is the type we use to do arithmetic to compute the bounds and
2251 -- lengths of operands. The choice of this type is a little subtle and
2252 -- is discussed in a separate section at the start of the body code.
2254 Concatenation_Error
: exception;
2255 -- Raised if concatenation is sure to raise a CE
2257 Result_May_Be_Null
: Boolean := True;
2258 -- Reset to False if at least one operand is encountered which is known
2259 -- at compile time to be non-null. Used for handling the special case
2260 -- of setting the high bound to the last operand high bound for a null
2261 -- result, thus ensuring a proper high bound in the super-flat case.
2263 N
: constant Nat
:= List_Length
(Opnds
);
2264 -- Number of concatenation operands including possibly null operands
2267 -- Number of operands excluding any known to be null, except that the
2268 -- last operand is always retained, in case it provides the bounds for
2272 -- Current operand being processed in the loop through operands. After
2273 -- this loop is complete, always contains the last operand (which is not
2274 -- the same as Operands (NN), since null operands are skipped).
2276 -- Arrays describing the operands, only the first NN entries of each
2277 -- array are set (NN < N when we exclude known null operands).
2279 Is_Fixed_Length
: array (1 .. N
) of Boolean;
2280 -- True if length of corresponding operand known at compile time
2282 Operands
: array (1 .. N
) of Node_Id
;
2283 -- Set to the corresponding entry in the Opnds list (but note that null
2284 -- operands are excluded, so not all entries in the list are stored).
2286 Fixed_Length
: array (1 .. N
) of Uint
;
2287 -- Set to length of operand. Entries in this array are set only if the
2288 -- corresponding entry in Is_Fixed_Length is True.
2290 Opnd_Low_Bound
: array (1 .. N
) of Node_Id
;
2291 -- Set to lower bound of operand. Either an integer literal in the case
2292 -- where the bound is known at compile time, else actual lower bound.
2293 -- The operand low bound is of type Ityp.
2295 Var_Length
: array (1 .. N
) of Entity_Id
;
2296 -- Set to an entity of type Natural that contains the length of an
2297 -- operand whose length is not known at compile time. Entries in this
2298 -- array are set only if the corresponding entry in Is_Fixed_Length
2299 -- is False. The entity is of type Artyp.
2301 Aggr_Length
: array (0 .. N
) of Node_Id
;
2302 -- The J'th entry in an expression node that represents the total length
2303 -- of operands 1 through J. It is either an integer literal node, or a
2304 -- reference to a constant entity with the right value, so it is fine
2305 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2306 -- entry always is set to zero. The length is of type Artyp.
2308 Low_Bound
: Node_Id
;
2309 -- A tree node representing the low bound of the result (of type Ityp).
2310 -- This is either an integer literal node, or an identifier reference to
2311 -- a constant entity initialized to the appropriate value.
2313 Last_Opnd_High_Bound
: Node_Id
;
2314 -- A tree node representing the high bound of the last operand. This
2315 -- need only be set if the result could be null. It is used for the
2316 -- special case of setting the right high bound for a null result.
2317 -- This is of type Ityp.
2319 High_Bound
: Node_Id
;
2320 -- A tree node representing the high bound of the result (of type Ityp)
2323 -- Result of the concatenation (of type Ityp)
2325 Actions
: constant List_Id
:= New_List
;
2326 -- Collect actions to be inserted if Save_Space is False
2328 Save_Space
: Boolean;
2329 pragma Warnings
(Off
, Save_Space
);
2330 -- Set to True if we are saving generated code space by calling routines
2331 -- in packages System.Concat_n.
2333 Known_Non_Null_Operand_Seen
: Boolean;
2334 -- Set True during generation of the assignements of operands into
2335 -- result once an operand known to be non-null has been seen.
2337 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
;
2338 -- This function makes an N_Integer_Literal node that is returned in
2339 -- analyzed form with the type set to Artyp. Importantly this literal
2340 -- is not flagged as static, so that if we do computations with it that
2341 -- result in statically detected out of range conditions, we will not
2342 -- generate error messages but instead warning messages.
2344 function To_Artyp
(X
: Node_Id
) return Node_Id
;
2345 -- Given a node of type Ityp, returns the corresponding value of type
2346 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2347 -- For enum types, the Pos of the value is returned.
2349 function To_Ityp
(X
: Node_Id
) return Node_Id
;
2350 -- The inverse function (uses Val in the case of enumeration types)
2352 ------------------------
2353 -- Make_Artyp_Literal --
2354 ------------------------
2356 function Make_Artyp_Literal
(Val
: Nat
) return Node_Id
is
2357 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Val
);
2359 Set_Etype
(Result
, Artyp
);
2360 Set_Analyzed
(Result
, True);
2361 Set_Is_Static_Expression
(Result
, False);
2363 end Make_Artyp_Literal
;
2369 function To_Artyp
(X
: Node_Id
) return Node_Id
is
2371 if Ityp
= Base_Type
(Artyp
) then
2374 elsif Is_Enumeration_Type
(Ityp
) then
2376 Make_Attribute_Reference
(Loc
,
2377 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2378 Attribute_Name
=> Name_Pos
,
2379 Expressions
=> New_List
(X
));
2382 return Convert_To
(Artyp
, X
);
2390 function To_Ityp
(X
: Node_Id
) return Node_Id
is
2392 if Is_Enumeration_Type
(Ityp
) then
2394 Make_Attribute_Reference
(Loc
,
2395 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2396 Attribute_Name
=> Name_Val
,
2397 Expressions
=> New_List
(X
));
2399 -- Case where we will do a type conversion
2402 if Ityp
= Base_Type
(Artyp
) then
2405 return Convert_To
(Ityp
, X
);
2410 -- Local Declarations
2412 Opnd_Typ
: Entity_Id
;
2420 -- Choose an appropriate computational type
2422 -- We will be doing calculations of lengths and bounds in this routine
2423 -- and computing one from the other in some cases, e.g. getting the high
2424 -- bound by adding the length-1 to the low bound.
2426 -- We can't just use the index type, or even its base type for this
2427 -- purpose for two reasons. First it might be an enumeration type which
2428 -- is not suitable fo computations of any kind, and second it may simply
2429 -- not have enough range. For example if the index type is -128..+127
2430 -- then lengths can be up to 256, which is out of range of the type.
2432 -- For enumeration types, we can simply use Standard_Integer, this is
2433 -- sufficient since the actual number of enumeration literals cannot
2434 -- possibly exceed the range of integer (remember we will be doing the
2435 -- arithmetic with POS values, not representation values).
2437 if Is_Enumeration_Type
(Ityp
) then
2438 Artyp
:= Standard_Integer
;
2440 -- If index type is Positive, we use the standard unsigned type, to give
2441 -- more room on the top of the range, obviating the need for an overflow
2442 -- check when creating the upper bound. This is needed to avoid junk
2443 -- overflow checks in the common case of String types.
2445 -- ??? Disabled for now
2447 -- elsif Istyp = Standard_Positive then
2448 -- Artyp := Standard_Unsigned;
2450 -- For modular types, we use a 32-bit modular type for types whose size
2451 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2452 -- identity type, and for larger unsigned types we use 64-bits.
2454 elsif Is_Modular_Integer_Type
(Ityp
) then
2455 if RM_Size
(Ityp
) < RM_Size
(Standard_Unsigned
) then
2456 Artyp
:= Standard_Unsigned
;
2457 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Unsigned
) then
2460 Artyp
:= RTE
(RE_Long_Long_Unsigned
);
2463 -- Similar treatment for signed types
2466 if RM_Size
(Ityp
) < RM_Size
(Standard_Integer
) then
2467 Artyp
:= Standard_Integer
;
2468 elsif RM_Size
(Ityp
) = RM_Size
(Standard_Integer
) then
2471 Artyp
:= Standard_Long_Long_Integer
;
2475 -- Supply dummy entry at start of length array
2477 Aggr_Length
(0) := Make_Artyp_Literal
(0);
2479 -- Go through operands setting up the above arrays
2483 Opnd
:= Remove_Head
(Opnds
);
2484 Opnd_Typ
:= Etype
(Opnd
);
2486 -- The parent got messed up when we put the operands in a list,
2487 -- so now put back the proper parent for the saved operand.
2489 Set_Parent
(Opnd
, Parent
(Cnode
));
2491 -- Set will be True when we have setup one entry in the array
2495 -- Singleton element (or character literal) case
2497 if Base_Type
(Opnd_Typ
) = Ctyp
then
2499 Operands
(NN
) := Opnd
;
2500 Is_Fixed_Length
(NN
) := True;
2501 Fixed_Length
(NN
) := Uint_1
;
2502 Result_May_Be_Null
:= False;
2504 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2505 -- since we know that the result cannot be null).
2507 Opnd_Low_Bound
(NN
) :=
2508 Make_Attribute_Reference
(Loc
,
2509 Prefix
=> New_Reference_To
(Istyp
, Loc
),
2510 Attribute_Name
=> Name_First
);
2514 -- String literal case (can only occur for strings of course)
2516 elsif Nkind
(Opnd
) = N_String_Literal
then
2517 Len
:= String_Literal_Length
(Opnd_Typ
);
2520 Result_May_Be_Null
:= False;
2523 -- Capture last operand high bound if result could be null
2525 if J
= N
and then Result_May_Be_Null
then
2526 Last_Opnd_High_Bound
:=
2529 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
)),
2530 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
2533 -- Skip null string literal
2535 if J
< N
and then Len
= 0 then
2540 Operands
(NN
) := Opnd
;
2541 Is_Fixed_Length
(NN
) := True;
2543 -- Set length and bounds
2545 Fixed_Length
(NN
) := Len
;
2547 Opnd_Low_Bound
(NN
) :=
2548 New_Copy_Tree
(String_Literal_Low_Bound
(Opnd_Typ
));
2555 -- Check constrained case with known bounds
2557 if Is_Constrained
(Opnd_Typ
) then
2559 Index
: constant Node_Id
:= First_Index
(Opnd_Typ
);
2560 Indx_Typ
: constant Entity_Id
:= Etype
(Index
);
2561 Lo
: constant Node_Id
:= Type_Low_Bound
(Indx_Typ
);
2562 Hi
: constant Node_Id
:= Type_High_Bound
(Indx_Typ
);
2565 -- Fixed length constrained array type with known at compile
2566 -- time bounds is last case of fixed length operand.
2568 if Compile_Time_Known_Value
(Lo
)
2570 Compile_Time_Known_Value
(Hi
)
2573 Loval
: constant Uint
:= Expr_Value
(Lo
);
2574 Hival
: constant Uint
:= Expr_Value
(Hi
);
2575 Len
: constant Uint
:=
2576 UI_Max
(Hival
- Loval
+ 1, Uint_0
);
2580 Result_May_Be_Null
:= False;
2583 -- Capture last operand bound if result could be null
2585 if J
= N
and then Result_May_Be_Null
then
2586 Last_Opnd_High_Bound
:=
2588 Make_Integer_Literal
(Loc
,
2589 Intval
=> Expr_Value
(Hi
)));
2592 -- Exclude null length case unless last operand
2594 if J
< N
and then Len
= 0 then
2599 Operands
(NN
) := Opnd
;
2600 Is_Fixed_Length
(NN
) := True;
2601 Fixed_Length
(NN
) := Len
;
2603 Opnd_Low_Bound
(NN
) := To_Ityp
(
2604 Make_Integer_Literal
(Loc
,
2605 Intval
=> Expr_Value
(Lo
)));
2613 -- All cases where the length is not known at compile time, or the
2614 -- special case of an operand which is known to be null but has a
2615 -- lower bound other than 1 or is other than a string type.
2620 -- Capture operand bounds
2622 Opnd_Low_Bound
(NN
) :=
2623 Make_Attribute_Reference
(Loc
,
2625 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2626 Attribute_Name
=> Name_First
);
2628 if J
= N
and Result_May_Be_Null
then
2629 Last_Opnd_High_Bound
:=
2631 Make_Attribute_Reference
(Loc
,
2633 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2634 Attribute_Name
=> Name_Last
));
2637 -- Capture length of operand in entity
2639 Operands
(NN
) := Opnd
;
2640 Is_Fixed_Length
(NN
) := False;
2642 Var_Length
(NN
) := Make_Temporary
(Loc
, 'L');
2645 Make_Object_Declaration
(Loc
,
2646 Defining_Identifier
=> Var_Length
(NN
),
2647 Constant_Present
=> True,
2649 Object_Definition
=>
2650 New_Occurrence_Of
(Artyp
, Loc
),
2653 Make_Attribute_Reference
(Loc
,
2655 Duplicate_Subexpr
(Opnd
, Name_Req
=> True),
2656 Attribute_Name
=> Name_Length
)));
2660 -- Set next entry in aggregate length array
2662 -- For first entry, make either integer literal for fixed length
2663 -- or a reference to the saved length for variable length.
2666 if Is_Fixed_Length
(1) then
2668 Make_Integer_Literal
(Loc
,
2669 Intval
=> Fixed_Length
(1));
2672 New_Reference_To
(Var_Length
(1), Loc
);
2675 -- If entry is fixed length and only fixed lengths so far, make
2676 -- appropriate new integer literal adding new length.
2678 elsif Is_Fixed_Length
(NN
)
2679 and then Nkind
(Aggr_Length
(NN
- 1)) = N_Integer_Literal
2682 Make_Integer_Literal
(Loc
,
2683 Intval
=> Fixed_Length
(NN
) + Intval
(Aggr_Length
(NN
- 1)));
2685 -- All other cases, construct an addition node for the length and
2686 -- create an entity initialized to this length.
2689 Ent
:= Make_Temporary
(Loc
, 'L');
2691 if Is_Fixed_Length
(NN
) then
2692 Clen
:= Make_Integer_Literal
(Loc
, Fixed_Length
(NN
));
2694 Clen
:= New_Reference_To
(Var_Length
(NN
), Loc
);
2698 Make_Object_Declaration
(Loc
,
2699 Defining_Identifier
=> Ent
,
2700 Constant_Present
=> True,
2702 Object_Definition
=>
2703 New_Occurrence_Of
(Artyp
, Loc
),
2707 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
- 1)),
2708 Right_Opnd
=> Clen
)));
2710 Aggr_Length
(NN
) := Make_Identifier
(Loc
, Chars
=> Chars
(Ent
));
2717 -- If we have only skipped null operands, return the last operand
2724 -- If we have only one non-null operand, return it and we are done.
2725 -- There is one case in which this cannot be done, and that is when
2726 -- the sole operand is of the element type, in which case it must be
2727 -- converted to an array, and the easiest way of doing that is to go
2728 -- through the normal general circuit.
2731 and then Base_Type
(Etype
(Operands
(1))) /= Ctyp
2733 Result
:= Operands
(1);
2737 -- Cases where we have a real concatenation
2739 -- Next step is to find the low bound for the result array that we
2740 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
2742 -- If the ultimate ancestor of the index subtype is a constrained array
2743 -- definition, then the lower bound is that of the index subtype as
2744 -- specified by (RM 4.5.3(6)).
2746 -- The right test here is to go to the root type, and then the ultimate
2747 -- ancestor is the first subtype of this root type.
2749 if Is_Constrained
(First_Subtype
(Root_Type
(Atyp
))) then
2751 Make_Attribute_Reference
(Loc
,
2753 New_Occurrence_Of
(First_Subtype
(Root_Type
(Atyp
)), Loc
),
2754 Attribute_Name
=> Name_First
);
2756 -- If the first operand in the list has known length we know that
2757 -- the lower bound of the result is the lower bound of this operand.
2759 elsif Is_Fixed_Length
(1) then
2760 Low_Bound
:= Opnd_Low_Bound
(1);
2762 -- OK, we don't know the lower bound, we have to build a horrible
2763 -- expression actions node of the form
2765 -- if Cond1'Length /= 0 then
2768 -- if Opnd2'Length /= 0 then
2773 -- The nesting ends either when we hit an operand whose length is known
2774 -- at compile time, or on reaching the last operand, whose low bound we
2775 -- take unconditionally whether or not it is null. It's easiest to do
2776 -- this with a recursive procedure:
2780 function Get_Known_Bound
(J
: Nat
) return Node_Id
;
2781 -- Returns the lower bound determined by operands J .. NN
2783 ---------------------
2784 -- Get_Known_Bound --
2785 ---------------------
2787 function Get_Known_Bound
(J
: Nat
) return Node_Id
is
2789 if Is_Fixed_Length
(J
) or else J
= NN
then
2790 return New_Copy
(Opnd_Low_Bound
(J
));
2794 Make_Conditional_Expression
(Loc
,
2795 Expressions
=> New_List
(
2798 Left_Opnd
=> New_Reference_To
(Var_Length
(J
), Loc
),
2799 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
2801 New_Copy
(Opnd_Low_Bound
(J
)),
2802 Get_Known_Bound
(J
+ 1)));
2804 end Get_Known_Bound
;
2807 Ent
:= Make_Temporary
(Loc
, 'L');
2810 Make_Object_Declaration
(Loc
,
2811 Defining_Identifier
=> Ent
,
2812 Constant_Present
=> True,
2813 Object_Definition
=> New_Occurrence_Of
(Ityp
, Loc
),
2814 Expression
=> Get_Known_Bound
(1)));
2816 Low_Bound
:= New_Reference_To
(Ent
, Loc
);
2820 -- Now we can safely compute the upper bound, normally
2821 -- Low_Bound + Length - 1.
2826 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
2828 Make_Op_Subtract
(Loc
,
2829 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
2830 Right_Opnd
=> Make_Artyp_Literal
(1))));
2832 -- Note that calculation of the high bound may cause overflow in some
2833 -- very weird cases, so in the general case we need an overflow check on
2834 -- the high bound. We can avoid this for the common case of string types
2835 -- and other types whose index is Positive, since we chose a wider range
2836 -- for the arithmetic type.
2838 if Istyp
/= Standard_Positive
then
2839 Activate_Overflow_Check
(High_Bound
);
2842 -- Handle the exceptional case where the result is null, in which case
2843 -- case the bounds come from the last operand (so that we get the proper
2844 -- bounds if the last operand is super-flat).
2846 if Result_May_Be_Null
then
2848 Make_Conditional_Expression
(Loc
,
2849 Expressions
=> New_List
(
2851 Left_Opnd
=> New_Copy
(Aggr_Length
(NN
)),
2852 Right_Opnd
=> Make_Artyp_Literal
(0)),
2853 Last_Opnd_High_Bound
,
2857 -- Here is where we insert the saved up actions
2859 Insert_Actions
(Cnode
, Actions
, Suppress
=> All_Checks
);
2861 -- Now we construct an array object with appropriate bounds. We mark
2862 -- the target as internal to prevent useless initialization when
2863 -- Initialize_Scalars is enabled.
2865 Ent
:= Make_Temporary
(Loc
, 'S');
2866 Set_Is_Internal
(Ent
);
2868 -- If the bound is statically known to be out of range, we do not want
2869 -- to abort, we want a warning and a runtime constraint error. Note that
2870 -- we have arranged that the result will not be treated as a static
2871 -- constant, so we won't get an illegality during this insertion.
2873 Insert_Action
(Cnode
,
2874 Make_Object_Declaration
(Loc
,
2875 Defining_Identifier
=> Ent
,
2876 Object_Definition
=>
2877 Make_Subtype_Indication
(Loc
,
2878 Subtype_Mark
=> New_Occurrence_Of
(Atyp
, Loc
),
2880 Make_Index_Or_Discriminant_Constraint
(Loc
,
2881 Constraints
=> New_List
(
2883 Low_Bound
=> Low_Bound
,
2884 High_Bound
=> High_Bound
))))),
2885 Suppress
=> All_Checks
);
2887 -- If the result of the concatenation appears as the initializing
2888 -- expression of an object declaration, we can just rename the
2889 -- result, rather than copying it.
2891 Set_OK_To_Rename
(Ent
);
2893 -- Catch the static out of range case now
2895 if Raises_Constraint_Error
(High_Bound
) then
2896 raise Concatenation_Error
;
2899 -- Now we will generate the assignments to do the actual concatenation
2901 -- There is one case in which we will not do this, namely when all the
2902 -- following conditions are met:
2904 -- The result type is Standard.String
2906 -- There are nine or fewer retained (non-null) operands
2908 -- The optimization level is -O0
2910 -- The corresponding System.Concat_n.Str_Concat_n routine is
2911 -- available in the run time.
2913 -- The debug flag gnatd.c is not set
2915 -- If all these conditions are met then we generate a call to the
2916 -- relevant concatenation routine. The purpose of this is to avoid
2917 -- undesirable code bloat at -O0.
2919 if Atyp
= Standard_String
2920 and then NN
in 2 .. 9
2921 and then (Opt
.Optimization_Level
= 0 or else Debug_Flag_Dot_CC
)
2922 and then not Debug_Flag_Dot_C
2925 RR
: constant array (Nat
range 2 .. 9) of RE_Id
:=
2936 if RTE_Available
(RR
(NN
)) then
2938 Opnds
: constant List_Id
:=
2939 New_List
(New_Occurrence_Of
(Ent
, Loc
));
2942 for J
in 1 .. NN
loop
2943 if Is_List_Member
(Operands
(J
)) then
2944 Remove
(Operands
(J
));
2947 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
2949 Make_Aggregate
(Loc
,
2950 Component_Associations
=> New_List
(
2951 Make_Component_Association
(Loc
,
2952 Choices
=> New_List
(
2953 Make_Integer_Literal
(Loc
, 1)),
2954 Expression
=> Operands
(J
)))));
2957 Append_To
(Opnds
, Operands
(J
));
2961 Insert_Action
(Cnode
,
2962 Make_Procedure_Call_Statement
(Loc
,
2963 Name
=> New_Reference_To
(RTE
(RR
(NN
)), Loc
),
2964 Parameter_Associations
=> Opnds
));
2966 Result
:= New_Reference_To
(Ent
, Loc
);
2973 -- Not special case so generate the assignments
2975 Known_Non_Null_Operand_Seen
:= False;
2977 for J
in 1 .. NN
loop
2979 Lo
: constant Node_Id
:=
2981 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
2982 Right_Opnd
=> Aggr_Length
(J
- 1));
2984 Hi
: constant Node_Id
:=
2986 Left_Opnd
=> To_Artyp
(New_Copy
(Low_Bound
)),
2988 Make_Op_Subtract
(Loc
,
2989 Left_Opnd
=> Aggr_Length
(J
),
2990 Right_Opnd
=> Make_Artyp_Literal
(1)));
2993 -- Singleton case, simple assignment
2995 if Base_Type
(Etype
(Operands
(J
))) = Ctyp
then
2996 Known_Non_Null_Operand_Seen
:= True;
2997 Insert_Action
(Cnode
,
2998 Make_Assignment_Statement
(Loc
,
3000 Make_Indexed_Component
(Loc
,
3001 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
3002 Expressions
=> New_List
(To_Ityp
(Lo
))),
3003 Expression
=> Operands
(J
)),
3004 Suppress
=> All_Checks
);
3006 -- Array case, slice assignment, skipped when argument is fixed
3007 -- length and known to be null.
3009 elsif (not Is_Fixed_Length
(J
)) or else (Fixed_Length
(J
) > 0) then
3012 Make_Assignment_Statement
(Loc
,
3016 New_Occurrence_Of
(Ent
, Loc
),
3019 Low_Bound
=> To_Ityp
(Lo
),
3020 High_Bound
=> To_Ityp
(Hi
))),
3021 Expression
=> Operands
(J
));
3023 if Is_Fixed_Length
(J
) then
3024 Known_Non_Null_Operand_Seen
:= True;
3026 elsif not Known_Non_Null_Operand_Seen
then
3028 -- Here if operand length is not statically known and no
3029 -- operand known to be non-null has been processed yet.
3030 -- If operand length is 0, we do not need to perform the
3031 -- assignment, and we must avoid the evaluation of the
3032 -- high bound of the slice, since it may underflow if the
3033 -- low bound is Ityp'First.
3036 Make_Implicit_If_Statement
(Cnode
,
3040 New_Occurrence_Of
(Var_Length
(J
), Loc
),
3041 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3046 Insert_Action
(Cnode
, Assign
, Suppress
=> All_Checks
);
3052 -- Finally we build the result, which is a reference to the array object
3054 Result
:= New_Reference_To
(Ent
, Loc
);
3057 Rewrite
(Cnode
, Result
);
3058 Analyze_And_Resolve
(Cnode
, Atyp
);
3061 when Concatenation_Error
=>
3063 -- Kill warning generated for the declaration of the static out of
3064 -- range high bound, and instead generate a Constraint_Error with
3065 -- an appropriate specific message.
3067 Kill_Dead_Code
(Declaration_Node
(Entity
(High_Bound
)));
3068 Apply_Compile_Time_Constraint_Error
3070 Msg
=> "concatenation result upper bound out of range?",
3071 Reason
=> CE_Range_Check_Failed
);
3072 -- Set_Etype (Cnode, Atyp);
3073 end Expand_Concatenate
;
3075 ------------------------
3076 -- Expand_N_Allocator --
3077 ------------------------
3079 procedure Expand_N_Allocator
(N
: Node_Id
) is
3080 PtrT
: constant Entity_Id
:= Etype
(N
);
3081 Dtyp
: constant Entity_Id
:= Available_View
(Designated_Type
(PtrT
));
3082 Etyp
: constant Entity_Id
:= Etype
(Expression
(N
));
3083 Loc
: constant Source_Ptr
:= Sloc
(N
);
3088 procedure Complete_Coextension_Finalization
;
3089 -- Generate finalization calls for all nested coextensions of N. This
3090 -- routine may allocate list controllers if necessary.
3092 procedure Rewrite_Coextension
(N
: Node_Id
);
3093 -- Static coextensions have the same lifetime as the entity they
3094 -- constrain. Such occurrences can be rewritten as aliased objects
3095 -- and their unrestricted access used instead of the coextension.
3097 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
;
3098 -- Given a constrained array type E, returns a node representing the
3099 -- code to compute the size in storage elements for the given type.
3100 -- This is done without using the attribute (which malfunctions for
3103 ---------------------------------------
3104 -- Complete_Coextension_Finalization --
3105 ---------------------------------------
3107 procedure Complete_Coextension_Finalization
is
3109 Coext_Elmt
: Elmt_Id
;
3113 function Inside_A_Return_Statement
(N
: Node_Id
) return Boolean;
3114 -- Determine whether node N is part of a return statement
3116 function Needs_Initialization_Call
(N
: Node_Id
) return Boolean;
3117 -- Determine whether node N is a subtype indicator allocator which
3118 -- acts a coextension. Such coextensions need initialization.
3120 -------------------------------
3121 -- Inside_A_Return_Statement --
3122 -------------------------------
3124 function Inside_A_Return_Statement
(N
: Node_Id
) return Boolean is
3129 while Present
(P
) loop
3131 (P
, N_Extended_Return_Statement
, N_Simple_Return_Statement
)
3135 -- Stop the traversal when we reach a subprogram body
3137 elsif Nkind
(P
) = N_Subprogram_Body
then
3145 end Inside_A_Return_Statement
;
3147 -------------------------------
3148 -- Needs_Initialization_Call --
3149 -------------------------------
3151 function Needs_Initialization_Call
(N
: Node_Id
) return Boolean is
3155 if Nkind
(N
) = N_Explicit_Dereference
3156 and then Nkind
(Prefix
(N
)) = N_Identifier
3157 and then Nkind
(Parent
(Entity
(Prefix
(N
)))) =
3158 N_Object_Declaration
3160 Obj_Decl
:= Parent
(Entity
(Prefix
(N
)));
3163 Present
(Expression
(Obj_Decl
))
3164 and then Nkind
(Expression
(Obj_Decl
)) = N_Allocator
3165 and then Nkind
(Expression
(Expression
(Obj_Decl
))) /=
3166 N_Qualified_Expression
;
3170 end Needs_Initialization_Call
;
3172 -- Start of processing for Complete_Coextension_Finalization
3175 -- When a coextension root is inside a return statement, we need to
3176 -- use the finalization chain of the function's scope. This does not
3177 -- apply for controlled named access types because in those cases we
3178 -- can use the finalization chain of the type itself.
3180 if Inside_A_Return_Statement
(N
)
3182 (Ekind
(PtrT
) = E_Anonymous_Access_Type
3184 (Ekind
(PtrT
) = E_Access_Type
3185 and then No
(Associated_Final_Chain
(PtrT
))))
3189 Outer_S
: Entity_Id
;
3194 while Present
(S
) and then S
/= Standard_Standard
loop
3195 if Ekind
(S
) = E_Function
then
3196 Outer_S
:= Scope
(S
);
3198 -- Retrieve the declaration of the body
3203 (Corresponding_Body
(Parent
(Parent
(S
)))));
3210 -- Push the scope of the function body since we are inserting
3211 -- the list before the body, but we are currently in the body
3212 -- itself. Override the finalization list of PtrT since the
3213 -- finalization context is now different.
3215 Push_Scope
(Outer_S
);
3216 Build_Final_List
(Decl
, PtrT
);
3220 -- The root allocator may not be controlled, but it still needs a
3221 -- finalization list for all nested coextensions.
3223 elsif No
(Associated_Final_Chain
(PtrT
)) then
3224 Build_Final_List
(N
, PtrT
);
3228 Make_Selected_Component
(Loc
,
3230 New_Reference_To
(Associated_Final_Chain
(PtrT
), Loc
),
3232 Make_Identifier
(Loc
, Name_F
));
3234 Coext_Elmt
:= First_Elmt
(Coextensions
(N
));
3235 while Present
(Coext_Elmt
) loop
3236 Coext
:= Node
(Coext_Elmt
);
3241 if Nkind
(Coext
) = N_Identifier
then
3243 Make_Unchecked_Type_Conversion
(Loc
,
3244 Subtype_Mark
=> New_Reference_To
(Etype
(Coext
), Loc
),
3246 Make_Explicit_Dereference
(Loc
,
3247 Prefix
=> New_Copy_Tree
(Coext
)));
3249 Ref
:= New_Copy_Tree
(Coext
);
3252 -- No initialization call if not allowed
3254 Check_Restriction
(No_Default_Initialization
, N
);
3256 if not Restriction_Active
(No_Default_Initialization
) then
3260 -- attach_to_final_list (Ref, Flist, 2)
3262 if Needs_Initialization_Call
(Coext
) then
3266 Typ
=> Etype
(Coext
),
3268 With_Attach
=> Make_Integer_Literal
(Loc
, Uint_2
)));
3271 -- attach_to_final_list (Ref, Flist, 2)
3277 Flist_Ref
=> New_Copy_Tree
(Flist
),
3278 With_Attach
=> Make_Integer_Literal
(Loc
, Uint_2
)));
3282 Next_Elmt
(Coext_Elmt
);
3284 end Complete_Coextension_Finalization
;
3286 -------------------------
3287 -- Rewrite_Coextension --
3288 -------------------------
3290 procedure Rewrite_Coextension
(N
: Node_Id
) is
3291 Temp
: constant Node_Id
:= Make_Temporary
(Loc
, 'C');
3294 -- Cnn : aliased Etyp;
3296 Decl
: constant Node_Id
:=
3297 Make_Object_Declaration
(Loc
,
3298 Defining_Identifier
=> Temp
,
3299 Aliased_Present
=> True,
3300 Object_Definition
=>
3301 New_Occurrence_Of
(Etyp
, Loc
));
3305 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
3306 Set_Expression
(Decl
, Expression
(Expression
(N
)));
3309 -- Find the proper insertion node for the declaration
3312 while Present
(Nod
) loop
3313 exit when Nkind
(Nod
) in N_Statement_Other_Than_Procedure_Call
3314 or else Nkind
(Nod
) = N_Procedure_Call_Statement
3315 or else Nkind
(Nod
) in N_Declaration
;
3316 Nod
:= Parent
(Nod
);
3319 Insert_Before
(Nod
, Decl
);
3323 Make_Attribute_Reference
(Loc
,
3324 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
3325 Attribute_Name
=> Name_Unrestricted_Access
));
3327 Analyze_And_Resolve
(N
, PtrT
);
3328 end Rewrite_Coextension
;
3330 ------------------------------
3331 -- Size_In_Storage_Elements --
3332 ------------------------------
3334 function Size_In_Storage_Elements
(E
: Entity_Id
) return Node_Id
is
3336 -- Logically this just returns E'Max_Size_In_Storage_Elements.
3337 -- However, the reason for the existence of this function is
3338 -- to construct a test for sizes too large, which means near the
3339 -- 32-bit limit on a 32-bit machine, and precisely the trouble
3340 -- is that we get overflows when sizes are greater than 2**31.
3342 -- So what we end up doing for array types is to use the expression:
3344 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
3346 -- which avoids this problem. All this is a big bogus, but it does
3347 -- mean we catch common cases of trying to allocate arrays that
3348 -- are too large, and which in the absence of a check results in
3349 -- undetected chaos ???
3356 for J
in 1 .. Number_Dimensions
(E
) loop
3358 Make_Attribute_Reference
(Loc
,
3359 Prefix
=> New_Occurrence_Of
(E
, Loc
),
3360 Attribute_Name
=> Name_Length
,
3361 Expressions
=> New_List
(
3362 Make_Integer_Literal
(Loc
, J
)));
3369 Make_Op_Multiply
(Loc
,
3376 Make_Op_Multiply
(Loc
,
3379 Make_Attribute_Reference
(Loc
,
3380 Prefix
=> New_Occurrence_Of
(Component_Type
(E
), Loc
),
3381 Attribute_Name
=> Name_Max_Size_In_Storage_Elements
));
3383 end Size_In_Storage_Elements
;
3385 -- Start of processing for Expand_N_Allocator
3388 -- RM E.2.3(22). We enforce that the expected type of an allocator
3389 -- shall not be a remote access-to-class-wide-limited-private type
3391 -- Why is this being done at expansion time, seems clearly wrong ???
3393 Validate_Remote_Access_To_Class_Wide_Type
(N
);
3395 -- Set the Storage Pool
3397 Set_Storage_Pool
(N
, Associated_Storage_Pool
(Root_Type
(PtrT
)));
3399 if Present
(Storage_Pool
(N
)) then
3400 if Is_RTE
(Storage_Pool
(N
), RE_SS_Pool
) then
3401 if VM_Target
= No_VM
then
3402 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
3405 elsif Is_Class_Wide_Type
(Etype
(Storage_Pool
(N
))) then
3406 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
3409 Set_Procedure_To_Call
(N
,
3410 Find_Prim_Op
(Etype
(Storage_Pool
(N
)), Name_Allocate
));
3414 -- Under certain circumstances we can replace an allocator by an access
3415 -- to statically allocated storage. The conditions, as noted in AARM
3416 -- 3.10 (10c) are as follows:
3418 -- Size and initial value is known at compile time
3419 -- Access type is access-to-constant
3421 -- The allocator is not part of a constraint on a record component,
3422 -- because in that case the inserted actions are delayed until the
3423 -- record declaration is fully analyzed, which is too late for the
3424 -- analysis of the rewritten allocator.
3426 if Is_Access_Constant
(PtrT
)
3427 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
3428 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
3429 and then Size_Known_At_Compile_Time
(Etype
(Expression
3431 and then not Is_Record_Type
(Current_Scope
)
3433 -- Here we can do the optimization. For the allocator
3437 -- We insert an object declaration
3439 -- Tnn : aliased x := y;
3441 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3442 -- marked as requiring static allocation.
3444 Temp
:= Make_Temporary
(Loc
, 'T', Expression
(Expression
(N
)));
3445 Desig
:= Subtype_Mark
(Expression
(N
));
3447 -- If context is constrained, use constrained subtype directly,
3448 -- so that the constant is not labelled as having a nominally
3449 -- unconstrained subtype.
3451 if Entity
(Desig
) = Base_Type
(Dtyp
) then
3452 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
3456 Make_Object_Declaration
(Loc
,
3457 Defining_Identifier
=> Temp
,
3458 Aliased_Present
=> True,
3459 Constant_Present
=> Is_Access_Constant
(PtrT
),
3460 Object_Definition
=> Desig
,
3461 Expression
=> Expression
(Expression
(N
))));
3464 Make_Attribute_Reference
(Loc
,
3465 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
3466 Attribute_Name
=> Name_Unrestricted_Access
));
3468 Analyze_And_Resolve
(N
, PtrT
);
3470 -- We set the variable as statically allocated, since we don't want
3471 -- it going on the stack of the current procedure!
3473 Set_Is_Statically_Allocated
(Temp
);
3477 -- Same if the allocator is an access discriminant for a local object:
3478 -- instead of an allocator we create a local value and constrain the
3479 -- the enclosing object with the corresponding access attribute.
3481 if Is_Static_Coextension
(N
) then
3482 Rewrite_Coextension
(N
);
3486 -- The current allocator creates an object which may contain nested
3487 -- coextensions. Use the current allocator's finalization list to
3488 -- generate finalization call for all nested coextensions.
3490 if Is_Coextension_Root
(N
) then
3491 Complete_Coextension_Finalization
;
3494 -- Check for size too large, we do this because the back end misses
3495 -- proper checks here and can generate rubbish allocation calls when
3496 -- we are near the limit. We only do this for the 32-bit address case
3497 -- since that is from a practical point of view where we see a problem.
3499 if System_Address_Size
= 32
3500 and then not Storage_Checks_Suppressed
(PtrT
)
3501 and then not Storage_Checks_Suppressed
(Dtyp
)
3502 and then not Storage_Checks_Suppressed
(Etyp
)
3504 -- The check we want to generate should look like
3506 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
3507 -- raise Storage_Error;
3510 -- where 3.5 gigabytes is a constant large enough to accomodate any
3511 -- reasonable request for. But we can't do it this way because at
3512 -- least at the moment we don't compute this attribute right, and
3513 -- can silently give wrong results when the result gets large. Since
3514 -- this is all about large results, that's bad, so instead we only
3515 -- apply the check for constrained arrays, and manually compute the
3516 -- value of the attribute ???
3518 if Is_Array_Type
(Etyp
) and then Is_Constrained
(Etyp
) then
3520 Make_Raise_Storage_Error
(Loc
,
3523 Left_Opnd
=> Size_In_Storage_Elements
(Etyp
),
3525 Make_Integer_Literal
(Loc
,
3526 Intval
=> Uint_7
* (Uint_2
** 29))),
3527 Reason
=> SE_Object_Too_Large
));
3531 -- Handle case of qualified expression (other than optimization above)
3532 -- First apply constraint checks, because the bounds or discriminants
3533 -- in the aggregate might not match the subtype mark in the allocator.
3535 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
3536 Apply_Constraint_Check
3537 (Expression
(Expression
(N
)), Etype
(Expression
(N
)));
3539 Expand_Allocator_Expression
(N
);
3543 -- If the allocator is for a type which requires initialization, and
3544 -- there is no initial value (i.e. operand is a subtype indication
3545 -- rather than a qualified expression), then we must generate a call to
3546 -- the initialization routine using an expressions action node:
3548 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3550 -- Here ptr_T is the pointer type for the allocator, and T is the
3551 -- subtype of the allocator. A special case arises if the designated
3552 -- type of the access type is a task or contains tasks. In this case
3553 -- the call to Init (Temp.all ...) is replaced by code that ensures
3554 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3555 -- for details). In addition, if the type T is a task T, then the
3556 -- first argument to Init must be converted to the task record type.
3559 T
: constant Entity_Id
:= Entity
(Expression
(N
));
3567 Temp_Decl
: Node_Id
;
3568 Temp_Type
: Entity_Id
;
3569 Attach_Level
: Uint
;
3572 if No_Initialization
(N
) then
3575 -- Case of no initialization procedure present
3577 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
3579 -- Case of simple initialization required
3581 if Needs_Simple_Initialization
(T
) then
3582 Check_Restriction
(No_Default_Initialization
, N
);
3583 Rewrite
(Expression
(N
),
3584 Make_Qualified_Expression
(Loc
,
3585 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
3586 Expression
=> Get_Simple_Init_Val
(T
, N
)));
3588 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
3589 Analyze_And_Resolve
(Expression
(N
), T
);
3590 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
3591 Expand_N_Allocator
(N
);
3593 -- No initialization required
3599 -- Case of initialization procedure present, must be called
3602 Check_Restriction
(No_Default_Initialization
, N
);
3604 if not Restriction_Active
(No_Default_Initialization
) then
3605 Init
:= Base_Init_Proc
(T
);
3607 Temp
:= Make_Temporary
(Loc
, 'P');
3609 -- Construct argument list for the initialization routine call
3612 Make_Explicit_Dereference
(Loc
,
3613 Prefix
=> New_Reference_To
(Temp
, Loc
));
3614 Set_Assignment_OK
(Arg1
);
3617 -- The initialization procedure expects a specific type. if the
3618 -- context is access to class wide, indicate that the object
3619 -- being allocated has the right specific type.
3621 if Is_Class_Wide_Type
(Dtyp
) then
3622 Arg1
:= Unchecked_Convert_To
(T
, Arg1
);
3625 -- If designated type is a concurrent type or if it is private
3626 -- type whose definition is a concurrent type, the first
3627 -- argument in the Init routine has to be unchecked conversion
3628 -- to the corresponding record type. If the designated type is
3629 -- a derived type, we also convert the argument to its root
3632 if Is_Concurrent_Type
(T
) then
3634 Unchecked_Convert_To
(Corresponding_Record_Type
(T
), Arg1
);
3636 elsif Is_Private_Type
(T
)
3637 and then Present
(Full_View
(T
))
3638 and then Is_Concurrent_Type
(Full_View
(T
))
3641 Unchecked_Convert_To
3642 (Corresponding_Record_Type
(Full_View
(T
)), Arg1
);
3644 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
3646 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
3648 Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Arg1
);
3649 Set_Etype
(Arg1
, Ftyp
);
3653 Args
:= New_List
(Arg1
);
3655 -- For the task case, pass the Master_Id of the access type as
3656 -- the value of the _Master parameter, and _Chain as the value
3657 -- of the _Chain parameter (_Chain will be defined as part of
3658 -- the generated code for the allocator).
3660 -- In Ada 2005, the context may be a function that returns an
3661 -- anonymous access type. In that case the Master_Id has been
3662 -- created when expanding the function declaration.
3664 if Has_Task
(T
) then
3665 if No
(Master_Id
(Base_Type
(PtrT
))) then
3667 -- If we have a non-library level task with restriction
3668 -- No_Task_Hierarchy set, then no point in expanding.
3670 if not Is_Library_Level_Entity
(T
)
3671 and then Restriction_Active
(No_Task_Hierarchy
)
3676 -- The designated type was an incomplete type, and the
3677 -- access type did not get expanded. Salvage it now.
3679 if not Restriction_Active
(No_Task_Hierarchy
) then
3680 pragma Assert
(Present
(Parent
(Base_Type
(PtrT
))));
3681 Expand_N_Full_Type_Declaration
3682 (Parent
(Base_Type
(PtrT
)));
3686 -- If the context of the allocator is a declaration or an
3687 -- assignment, we can generate a meaningful image for it,
3688 -- even though subsequent assignments might remove the
3689 -- connection between task and entity. We build this image
3690 -- when the left-hand side is a simple variable, a simple
3691 -- indexed assignment or a simple selected component.
3693 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
3695 Nam
: constant Node_Id
:= Name
(Parent
(N
));
3698 if Is_Entity_Name
(Nam
) then
3700 Build_Task_Image_Decls
3703 (Entity
(Nam
), Sloc
(Nam
)), T
);
3706 (Nam
, N_Indexed_Component
, N_Selected_Component
)
3707 and then Is_Entity_Name
(Prefix
(Nam
))
3710 Build_Task_Image_Decls
3711 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
3713 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
3717 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
3719 Build_Task_Image_Decls
3720 (Loc
, Defining_Identifier
(Parent
(N
)), T
);
3723 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
3726 if Restriction_Active
(No_Task_Hierarchy
) then
3728 New_Occurrence_Of
(RTE
(RE_Library_Task_Level
), Loc
));
3732 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
3735 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
3737 Decl
:= Last
(Decls
);
3739 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
3741 -- Has_Task is false, Decls not used
3747 -- Add discriminants if discriminated type
3750 Dis
: Boolean := False;
3754 if Has_Discriminants
(T
) then
3758 elsif Is_Private_Type
(T
)
3759 and then Present
(Full_View
(T
))
3760 and then Has_Discriminants
(Full_View
(T
))
3763 Typ
:= Full_View
(T
);
3768 -- If the allocated object will be constrained by the
3769 -- default values for discriminants, then build a subtype
3770 -- with those defaults, and change the allocated subtype
3771 -- to that. Note that this happens in fewer cases in Ada
3774 if not Is_Constrained
(Typ
)
3775 and then Present
(Discriminant_Default_Value
3776 (First_Discriminant
(Typ
)))
3777 and then (Ada_Version
< Ada_05
3779 not Has_Constrained_Partial_View
(Typ
))
3781 Typ
:= Build_Default_Subtype
(Typ
, N
);
3782 Set_Expression
(N
, New_Reference_To
(Typ
, Loc
));
3785 Discr
:= First_Elmt
(Discriminant_Constraint
(Typ
));
3786 while Present
(Discr
) loop
3787 Nod
:= Node
(Discr
);
3788 Append
(New_Copy_Tree
(Node
(Discr
)), Args
);
3790 -- AI-416: when the discriminant constraint is an
3791 -- anonymous access type make sure an accessibility
3792 -- check is inserted if necessary (3.10.2(22.q/2))
3794 if Ada_Version
>= Ada_05
3796 Ekind
(Etype
(Nod
)) = E_Anonymous_Access_Type
3798 Apply_Accessibility_Check
3799 (Nod
, Typ
, Insert_Node
=> Nod
);
3807 -- We set the allocator as analyzed so that when we analyze the
3808 -- expression actions node, we do not get an unwanted recursive
3809 -- expansion of the allocator expression.
3811 Set_Analyzed
(N
, True);
3812 Nod
:= Relocate_Node
(N
);
3814 -- Here is the transformation:
3816 -- output: Temp : constant ptr_T := new T;
3817 -- Init (Temp.all, ...);
3818 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
3819 -- <CTRL> Initialize (Finalizable (Temp.all));
3821 -- Here ptr_T is the pointer type for the allocator, and is the
3822 -- subtype of the allocator.
3825 Make_Object_Declaration
(Loc
,
3826 Defining_Identifier
=> Temp
,
3827 Constant_Present
=> True,
3828 Object_Definition
=> New_Reference_To
(Temp_Type
, Loc
),
3831 Set_Assignment_OK
(Temp_Decl
);
3832 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
3834 -- If the designated type is a task type or contains tasks,
3835 -- create block to activate created tasks, and insert
3836 -- declaration for Task_Image variable ahead of call.
3838 if Has_Task
(T
) then
3840 L
: constant List_Id
:= New_List
;
3843 Build_Task_Allocate_Block
(L
, Nod
, Args
);
3845 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
3846 Insert_Actions
(N
, L
);
3851 Make_Procedure_Call_Statement
(Loc
,
3852 Name
=> New_Reference_To
(Init
, Loc
),
3853 Parameter_Associations
=> Args
));
3856 if Needs_Finalization
(T
) then
3858 -- Postpone the generation of a finalization call for the
3859 -- current allocator if it acts as a coextension.
3861 if Is_Dynamic_Coextension
(N
) then
3862 if No
(Coextensions
(N
)) then
3863 Set_Coextensions
(N
, New_Elmt_List
);
3866 Append_Elmt
(New_Copy_Tree
(Arg1
), Coextensions
(N
));
3870 Get_Allocator_Final_List
(N
, Base_Type
(T
), PtrT
);
3872 -- Anonymous access types created for access parameters
3873 -- are attached to an explicitly constructed controller,
3874 -- which ensures that they can be finalized properly,
3875 -- even if their deallocation might not happen. The list
3876 -- associated with the controller is doubly-linked. For
3877 -- other anonymous access types, the object may end up
3878 -- on the global final list which is singly-linked.
3879 -- Work needed for access discriminants in Ada 2005 ???
3881 if Ekind
(PtrT
) = E_Anonymous_Access_Type
then
3882 Attach_Level
:= Uint_1
;
3884 Attach_Level
:= Uint_2
;
3889 Ref
=> New_Copy_Tree
(Arg1
),
3892 With_Attach
=> Make_Integer_Literal
(Loc
,
3893 Intval
=> Attach_Level
)));
3897 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
3898 Analyze_And_Resolve
(N
, PtrT
);
3903 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
3904 -- object that has been rewritten as a reference, we displace "this"
3905 -- to reference properly its secondary dispatch table.
3907 if Nkind
(N
) = N_Identifier
3908 and then Is_Interface
(Dtyp
)
3910 Displace_Allocator_Pointer
(N
);
3914 when RE_Not_Available
=>
3916 end Expand_N_Allocator
;
3918 -----------------------
3919 -- Expand_N_And_Then --
3920 -----------------------
3922 procedure Expand_N_And_Then
(N
: Node_Id
)
3923 renames Expand_Short_Circuit_Operator
;
3925 ------------------------------
3926 -- Expand_N_Case_Expression --
3927 ------------------------------
3929 procedure Expand_N_Case_Expression
(N
: Node_Id
) is
3930 Loc
: constant Source_Ptr
:= Sloc
(N
);
3931 Typ
: constant Entity_Id
:= Etype
(N
);
3943 -- case X is when A => AX, when B => BX ...
3958 -- However, this expansion is wrong for limited types, and also
3959 -- wrong for unconstrained types (since the bounds may not be the
3960 -- same in all branches). Furthermore it involves an extra copy
3961 -- for large objects. So we take care of this by using the following
3962 -- modified expansion for non-scalar types:
3965 -- type Pnn is access all typ;
3969 -- T := AX'Unrestricted_Access;
3971 -- T := BX'Unrestricted_Access;
3977 Make_Case_Statement
(Loc
,
3978 Expression
=> Expression
(N
),
3979 Alternatives
=> New_List
);
3981 Actions
:= New_List
;
3985 if Is_Scalar_Type
(Typ
) then
3989 Pnn
:= Make_Temporary
(Loc
, 'P');
3991 Make_Full_Type_Declaration
(Loc
,
3992 Defining_Identifier
=> Pnn
,
3994 Make_Access_To_Object_Definition
(Loc
,
3995 All_Present
=> True,
3996 Subtype_Indication
=>
3997 New_Reference_To
(Typ
, Loc
))));
4001 Tnn
:= Make_Temporary
(Loc
, 'T');
4003 Make_Object_Declaration
(Loc
,
4004 Defining_Identifier
=> Tnn
,
4005 Object_Definition
=> New_Occurrence_Of
(Ttyp
, Loc
)));
4007 -- Now process the alternatives
4009 Alt
:= First
(Alternatives
(N
));
4010 while Present
(Alt
) loop
4012 Aexp
: Node_Id
:= Expression
(Alt
);
4013 Aloc
: constant Source_Ptr
:= Sloc
(Aexp
);
4016 if not Is_Scalar_Type
(Typ
) then
4018 Make_Attribute_Reference
(Aloc
,
4019 Prefix
=> Relocate_Node
(Aexp
),
4020 Attribute_Name
=> Name_Unrestricted_Access
);
4024 (Alternatives
(Cstmt
),
4025 Make_Case_Statement_Alternative
(Sloc
(Alt
),
4026 Discrete_Choices
=> Discrete_Choices
(Alt
),
4027 Statements
=> New_List
(
4028 Make_Assignment_Statement
(Aloc
,
4029 Name
=> New_Occurrence_Of
(Tnn
, Loc
),
4030 Expression
=> Aexp
))));
4036 Append_To
(Actions
, Cstmt
);
4038 -- Construct and return final expression with actions
4040 if Is_Scalar_Type
(Typ
) then
4041 Fexp
:= New_Occurrence_Of
(Tnn
, Loc
);
4044 Make_Explicit_Dereference
(Loc
,
4045 Prefix
=> New_Occurrence_Of
(Tnn
, Loc
));
4049 Make_Expression_With_Actions
(Loc
,
4051 Actions
=> Actions
));
4053 Analyze_And_Resolve
(N
, Typ
);
4054 end Expand_N_Case_Expression
;
4056 -------------------------------------
4057 -- Expand_N_Conditional_Expression --
4058 -------------------------------------
4060 -- Deal with limited types and expression actions
4062 procedure Expand_N_Conditional_Expression
(N
: Node_Id
) is
4063 Loc
: constant Source_Ptr
:= Sloc
(N
);
4064 Cond
: constant Node_Id
:= First
(Expressions
(N
));
4065 Thenx
: constant Node_Id
:= Next
(Cond
);
4066 Elsex
: constant Node_Id
:= Next
(Thenx
);
4067 Typ
: constant Entity_Id
:= Etype
(N
);
4078 -- Fold at compile time if condition known. We have already folded
4079 -- static conditional expressions, but it is possible to fold any
4080 -- case in which the condition is known at compile time, even though
4081 -- the result is non-static.
4083 -- Note that we don't do the fold of such cases in Sem_Elab because
4084 -- it can cause infinite loops with the expander adding a conditional
4085 -- expression, and Sem_Elab circuitry removing it repeatedly.
4087 if Compile_Time_Known_Value
(Cond
) then
4088 if Is_True
(Expr_Value
(Cond
)) then
4090 Actions
:= Then_Actions
(N
);
4093 Actions
:= Else_Actions
(N
);
4098 if Present
(Actions
) then
4100 -- If we are not allowed to use Expression_With_Actions, just
4101 -- skip the optimization, it is not critical for correctness.
4103 if not Use_Expression_With_Actions
then
4104 goto Skip_Optimization
;
4108 Make_Expression_With_Actions
(Loc
,
4109 Expression
=> Relocate_Node
(Expr
),
4110 Actions
=> Actions
));
4111 Analyze_And_Resolve
(N
, Typ
);
4114 Rewrite
(N
, Relocate_Node
(Expr
));
4117 -- Note that the result is never static (legitimate cases of static
4118 -- conditional expressions were folded in Sem_Eval).
4120 Set_Is_Static_Expression
(N
, False);
4124 <<Skip_Optimization
>>
4126 -- If the type is limited or unconstrained, we expand as follows to
4127 -- avoid any possibility of improper copies.
4129 -- Note: it may be possible to avoid this special processing if the
4130 -- back end uses its own mechanisms for handling by-reference types ???
4132 -- type Ptr is access all Typ;
4136 -- Cnn := then-expr'Unrestricted_Access;
4139 -- Cnn := else-expr'Unrestricted_Access;
4142 -- and replace the conditional expresion by a reference to Cnn.all.
4144 -- This special case can be skipped if the back end handles limited
4145 -- types properly and ensures that no incorrect copies are made.
4147 if Is_By_Reference_Type
(Typ
)
4148 and then not Back_End_Handles_Limited_Types
4150 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
4153 Make_Full_Type_Declaration
(Loc
,
4154 Defining_Identifier
=> Make_Temporary
(Loc
, 'A'),
4156 Make_Access_To_Object_Definition
(Loc
,
4157 All_Present
=> True,
4158 Subtype_Indication
=>
4159 New_Reference_To
(Typ
, Loc
)));
4161 Insert_Action
(N
, P_Decl
);
4164 Make_Object_Declaration
(Loc
,
4165 Defining_Identifier
=> Cnn
,
4166 Object_Definition
=>
4167 New_Occurrence_Of
(Defining_Identifier
(P_Decl
), Loc
));
4170 Make_Implicit_If_Statement
(N
,
4171 Condition
=> Relocate_Node
(Cond
),
4173 Then_Statements
=> New_List
(
4174 Make_Assignment_Statement
(Sloc
(Thenx
),
4175 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
4177 Make_Attribute_Reference
(Loc
,
4178 Attribute_Name
=> Name_Unrestricted_Access
,
4179 Prefix
=> Relocate_Node
(Thenx
)))),
4181 Else_Statements
=> New_List
(
4182 Make_Assignment_Statement
(Sloc
(Elsex
),
4183 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
4185 Make_Attribute_Reference
(Loc
,
4186 Attribute_Name
=> Name_Unrestricted_Access
,
4187 Prefix
=> Relocate_Node
(Elsex
)))));
4190 Make_Explicit_Dereference
(Loc
,
4191 Prefix
=> New_Occurrence_Of
(Cnn
, Loc
));
4193 -- For other types, we only need to expand if there are other actions
4194 -- associated with either branch.
4196 elsif Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
4198 -- We have two approaches to handling this. If we are allowed to use
4199 -- N_Expression_With_Actions, then we can just wrap the actions into
4200 -- the appropriate expression.
4202 if Use_Expression_With_Actions
then
4203 if Present
(Then_Actions
(N
)) then
4205 Make_Expression_With_Actions
(Sloc
(Thenx
),
4206 Actions
=> Then_Actions
(N
),
4207 Expression
=> Relocate_Node
(Thenx
)));
4208 Set_Then_Actions
(N
, No_List
);
4209 Analyze_And_Resolve
(Thenx
, Typ
);
4212 if Present
(Else_Actions
(N
)) then
4214 Make_Expression_With_Actions
(Sloc
(Elsex
),
4215 Actions
=> Else_Actions
(N
),
4216 Expression
=> Relocate_Node
(Elsex
)));
4217 Set_Else_Actions
(N
, No_List
);
4218 Analyze_And_Resolve
(Elsex
, Typ
);
4223 -- if we can't use N_Expression_With_Actions nodes, then we insert
4224 -- the following sequence of actions (using Insert_Actions):
4229 -- Cnn := then-expr;
4235 -- and replace the conditional expression by a reference to Cnn
4238 Cnn
:= Make_Temporary
(Loc
, 'C', N
);
4241 Make_Object_Declaration
(Loc
,
4242 Defining_Identifier
=> Cnn
,
4243 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
4246 Make_Implicit_If_Statement
(N
,
4247 Condition
=> Relocate_Node
(Cond
),
4249 Then_Statements
=> New_List
(
4250 Make_Assignment_Statement
(Sloc
(Thenx
),
4251 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
4252 Expression
=> Relocate_Node
(Thenx
))),
4254 Else_Statements
=> New_List
(
4255 Make_Assignment_Statement
(Sloc
(Elsex
),
4256 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
4257 Expression
=> Relocate_Node
(Elsex
))));
4259 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
4260 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
4262 New_N
:= New_Occurrence_Of
(Cnn
, Loc
);
4265 -- If no actions then no expansion needed, gigi will handle it using
4266 -- the same approach as a C conditional expression.
4272 -- Fall through here for either the limited expansion, or the case of
4273 -- inserting actions for non-limited types. In both these cases, we must
4274 -- move the SLOC of the parent If statement to the newly created one and
4275 -- change it to the SLOC of the expression which, after expansion, will
4276 -- correspond to what is being evaluated.
4278 if Present
(Parent
(N
))
4279 and then Nkind
(Parent
(N
)) = N_If_Statement
4281 Set_Sloc
(New_If
, Sloc
(Parent
(N
)));
4282 Set_Sloc
(Parent
(N
), Loc
);
4285 -- Make sure Then_Actions and Else_Actions are appropriately moved
4286 -- to the new if statement.
4288 if Present
(Then_Actions
(N
)) then
4290 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
4293 if Present
(Else_Actions
(N
)) then
4295 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
4298 Insert_Action
(N
, Decl
);
4299 Insert_Action
(N
, New_If
);
4301 Analyze_And_Resolve
(N
, Typ
);
4302 end Expand_N_Conditional_Expression
;
4304 -----------------------------------
4305 -- Expand_N_Explicit_Dereference --
4306 -----------------------------------
4308 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
4310 -- Insert explicit dereference call for the checked storage pool case
4312 Insert_Dereference_Action
(Prefix
(N
));
4313 end Expand_N_Explicit_Dereference
;
4319 procedure Expand_N_In
(N
: Node_Id
) is
4320 Loc
: constant Source_Ptr
:= Sloc
(N
);
4321 Rtyp
: constant Entity_Id
:= Etype
(N
);
4322 Lop
: constant Node_Id
:= Left_Opnd
(N
);
4323 Rop
: constant Node_Id
:= Right_Opnd
(N
);
4324 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
4326 procedure Expand_Set_Membership
;
4327 -- For each disjunct we create a simple equality or membership test.
4328 -- The whole membership is rewritten as a short-circuit disjunction.
4330 ---------------------------
4331 -- Expand_Set_Membership --
4332 ---------------------------
4334 procedure Expand_Set_Membership
is
4338 function Make_Cond
(Alt
: Node_Id
) return Node_Id
;
4339 -- If the alternative is a subtype mark, create a simple membership
4340 -- test. Otherwise create an equality test for it.
4346 function Make_Cond
(Alt
: Node_Id
) return Node_Id
is
4348 L
: constant Node_Id
:= New_Copy
(Lop
);
4349 R
: constant Node_Id
:= Relocate_Node
(Alt
);
4352 if Is_Entity_Name
(Alt
)
4353 and then Is_Type
(Entity
(Alt
))
4356 Make_In
(Sloc
(Alt
),
4360 Cond
:= Make_Op_Eq
(Sloc
(Alt
),
4368 -- Start of proessing for Expand_N_In
4371 Alt
:= Last
(Alternatives
(N
));
4372 Res
:= Make_Cond
(Alt
);
4375 while Present
(Alt
) loop
4377 Make_Or_Else
(Sloc
(Alt
),
4378 Left_Opnd
=> Make_Cond
(Alt
),
4384 Analyze_And_Resolve
(N
, Standard_Boolean
);
4385 end Expand_Set_Membership
;
4387 procedure Substitute_Valid_Check
;
4388 -- Replaces node N by Lop'Valid. This is done when we have an explicit
4389 -- test for the left operand being in range of its subtype.
4391 ----------------------------
4392 -- Substitute_Valid_Check --
4393 ----------------------------
4395 procedure Substitute_Valid_Check
is
4398 Make_Attribute_Reference
(Loc
,
4399 Prefix
=> Relocate_Node
(Lop
),
4400 Attribute_Name
=> Name_Valid
));
4402 Analyze_And_Resolve
(N
, Rtyp
);
4404 Error_Msg_N
("?explicit membership test may be optimized away", N
);
4405 Error_Msg_N
-- CODEFIX
4406 ("\?use ''Valid attribute instead", N
);
4408 end Substitute_Valid_Check
;
4410 -- Start of processing for Expand_N_In
4413 if Present
(Alternatives
(N
)) then
4414 Remove_Side_Effects
(Lop
);
4415 Expand_Set_Membership
;
4419 -- Check case of explicit test for an expression in range of its
4420 -- subtype. This is suspicious usage and we replace it with a 'Valid
4421 -- test and give a warning. For floating point types however, this is a
4422 -- standard way to check for finite numbers, and using 'Valid vould
4423 -- typically be a pessimization.
4425 if Is_Scalar_Type
(Etype
(Lop
))
4426 and then not Is_Floating_Point_Type
(Etype
(Lop
))
4427 and then Nkind
(Rop
) in N_Has_Entity
4428 and then Etype
(Lop
) = Entity
(Rop
)
4429 and then Comes_From_Source
(N
)
4430 and then VM_Target
= No_VM
4432 Substitute_Valid_Check
;
4436 -- Do validity check on operands
4438 if Validity_Checks_On
and Validity_Check_Operands
then
4439 Ensure_Valid
(Left_Opnd
(N
));
4440 Validity_Check_Range
(Right_Opnd
(N
));
4443 -- Case of explicit range
4445 if Nkind
(Rop
) = N_Range
then
4447 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
4448 Hi
: constant Node_Id
:= High_Bound
(Rop
);
4450 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
4452 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
4453 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
4455 Lcheck
: Compare_Result
;
4456 Ucheck
: Compare_Result
;
4458 Warn1
: constant Boolean :=
4459 Constant_Condition_Warnings
4460 and then Comes_From_Source
(N
)
4461 and then not In_Instance
;
4462 -- This must be true for any of the optimization warnings, we
4463 -- clearly want to give them only for source with the flag on. We
4464 -- also skip these warnings in an instance since it may be the
4465 -- case that different instantiations have different ranges.
4467 Warn2
: constant Boolean :=
4469 and then Nkind
(Original_Node
(Rop
)) = N_Range
4470 and then Is_Integer_Type
(Etype
(Lo
));
4471 -- For the case where only one bound warning is elided, we also
4472 -- insist on an explicit range and an integer type. The reason is
4473 -- that the use of enumeration ranges including an end point is
4474 -- common, as is the use of a subtype name, one of whose bounds is
4475 -- the same as the type of the expression.
4478 -- If test is explicit x'first .. x'last, replace by valid check
4480 if Is_Scalar_Type
(Ltyp
)
4481 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
4482 and then Attribute_Name
(Lo_Orig
) = Name_First
4483 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
4484 and then Entity
(Prefix
(Lo_Orig
)) = Ltyp
4485 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
4486 and then Attribute_Name
(Hi_Orig
) = Name_Last
4487 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
4488 and then Entity
(Prefix
(Hi_Orig
)) = Ltyp
4489 and then Comes_From_Source
(N
)
4490 and then VM_Target
= No_VM
4492 Substitute_Valid_Check
;
4496 -- If bounds of type are known at compile time, and the end points
4497 -- are known at compile time and identical, this is another case
4498 -- for substituting a valid test. We only do this for discrete
4499 -- types, since it won't arise in practice for float types.
4501 if Comes_From_Source
(N
)
4502 and then Is_Discrete_Type
(Ltyp
)
4503 and then Compile_Time_Known_Value
(Type_High_Bound
(Ltyp
))
4504 and then Compile_Time_Known_Value
(Type_Low_Bound
(Ltyp
))
4505 and then Compile_Time_Known_Value
(Lo
)
4506 and then Compile_Time_Known_Value
(Hi
)
4507 and then Expr_Value
(Type_High_Bound
(Ltyp
)) = Expr_Value
(Hi
)
4508 and then Expr_Value
(Type_Low_Bound
(Ltyp
)) = Expr_Value
(Lo
)
4510 -- Kill warnings in instances, since they may be cases where we
4511 -- have a test in the generic that makes sense with some types
4512 -- and not with other types.
4514 and then not In_Instance
4516 Substitute_Valid_Check
;
4520 -- If we have an explicit range, do a bit of optimization based on
4521 -- range analysis (we may be able to kill one or both checks).
4523 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> False);
4524 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> False);
4526 -- If either check is known to fail, replace result by False since
4527 -- the other check does not matter. Preserve the static flag for
4528 -- legality checks, because we are constant-folding beyond RM 4.9.
4530 if Lcheck
= LT
or else Ucheck
= GT
then
4532 Error_Msg_N
("?range test optimized away", N
);
4533 Error_Msg_N
("\?value is known to be out of range", N
);
4536 Rewrite
(N
, New_Reference_To
(Standard_False
, Loc
));
4537 Analyze_And_Resolve
(N
, Rtyp
);
4538 Set_Is_Static_Expression
(N
, Static
);
4542 -- If both checks are known to succeed, replace result by True,
4543 -- since we know we are in range.
4545 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
4547 Error_Msg_N
("?range test optimized away", N
);
4548 Error_Msg_N
("\?value is known to be in range", N
);
4551 Rewrite
(N
, New_Reference_To
(Standard_True
, Loc
));
4552 Analyze_And_Resolve
(N
, Rtyp
);
4553 Set_Is_Static_Expression
(N
, Static
);
4557 -- If lower bound check succeeds and upper bound check is not
4558 -- known to succeed or fail, then replace the range check with
4559 -- a comparison against the upper bound.
4561 elsif Lcheck
in Compare_GE
then
4562 if Warn2
and then not In_Instance
then
4563 Error_Msg_N
("?lower bound test optimized away", Lo
);
4564 Error_Msg_N
("\?value is known to be in range", Lo
);
4570 Right_Opnd
=> High_Bound
(Rop
)));
4571 Analyze_And_Resolve
(N
, Rtyp
);
4575 -- If upper bound check succeeds and lower bound check is not
4576 -- known to succeed or fail, then replace the range check with
4577 -- a comparison against the lower bound.
4579 elsif Ucheck
in Compare_LE
then
4580 if Warn2
and then not In_Instance
then
4581 Error_Msg_N
("?upper bound test optimized away", Hi
);
4582 Error_Msg_N
("\?value is known to be in range", Hi
);
4588 Right_Opnd
=> Low_Bound
(Rop
)));
4589 Analyze_And_Resolve
(N
, Rtyp
);
4594 -- We couldn't optimize away the range check, but there is one
4595 -- more issue. If we are checking constant conditionals, then we
4596 -- see if we can determine the outcome assuming everything is
4597 -- valid, and if so give an appropriate warning.
4599 if Warn1
and then not Assume_No_Invalid_Values
then
4600 Lcheck
:= Compile_Time_Compare
(Lop
, Lo
, Assume_Valid
=> True);
4601 Ucheck
:= Compile_Time_Compare
(Lop
, Hi
, Assume_Valid
=> True);
4603 -- Result is out of range for valid value
4605 if Lcheck
= LT
or else Ucheck
= GT
then
4607 ("?value can only be in range if it is invalid", N
);
4609 -- Result is in range for valid value
4611 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
4613 ("?value can only be out of range if it is invalid", N
);
4615 -- Lower bound check succeeds if value is valid
4617 elsif Warn2
and then Lcheck
in Compare_GE
then
4619 ("?lower bound check only fails if it is invalid", Lo
);
4621 -- Upper bound check succeeds if value is valid
4623 elsif Warn2
and then Ucheck
in Compare_LE
then
4625 ("?upper bound check only fails for invalid values", Hi
);
4630 -- For all other cases of an explicit range, nothing to be done
4634 -- Here right operand is a subtype mark
4638 Typ
: Entity_Id
:= Etype
(Rop
);
4639 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
4640 Cond
: Node_Id
:= Empty
;
4642 Obj
: Node_Id
:= Lop
;
4643 SCIL_Node
: Node_Id
;
4646 Remove_Side_Effects
(Obj
);
4648 -- For tagged type, do tagged membership operation
4650 if Is_Tagged_Type
(Typ
) then
4652 -- No expansion will be performed when VM_Target, as the VM
4653 -- back-ends will handle the membership tests directly (tags
4654 -- are not explicitly represented in Java objects, so the
4655 -- normal tagged membership expansion is not what we want).
4657 if Tagged_Type_Expansion
then
4658 Tagged_Membership
(N
, SCIL_Node
, New_N
);
4660 Analyze_And_Resolve
(N
, Rtyp
);
4662 -- Update decoration of relocated node referenced by the
4665 if Generate_SCIL
and then Present
(SCIL_Node
) then
4666 Set_SCIL_Node
(N
, SCIL_Node
);
4672 -- If type is scalar type, rewrite as x in t'first .. t'last.
4673 -- This reason we do this is that the bounds may have the wrong
4674 -- type if they come from the original type definition. Also this
4675 -- way we get all the processing above for an explicit range.
4677 elsif Is_Scalar_Type
(Typ
) then
4681 Make_Attribute_Reference
(Loc
,
4682 Attribute_Name
=> Name_First
,
4683 Prefix
=> New_Reference_To
(Typ
, Loc
)),
4686 Make_Attribute_Reference
(Loc
,
4687 Attribute_Name
=> Name_Last
,
4688 Prefix
=> New_Reference_To
(Typ
, Loc
))));
4689 Analyze_And_Resolve
(N
, Rtyp
);
4692 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4693 -- a membership test if the subtype mark denotes a constrained
4694 -- Unchecked_Union subtype and the expression lacks inferable
4697 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
4698 and then Is_Constrained
(Typ
)
4699 and then not Has_Inferable_Discriminants
(Lop
)
4702 Make_Raise_Program_Error
(Loc
,
4703 Reason
=> PE_Unchecked_Union_Restriction
));
4705 -- Prevent Gigi from generating incorrect code by rewriting the
4708 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
4712 -- Here we have a non-scalar type
4715 Typ
:= Designated_Type
(Typ
);
4718 if not Is_Constrained
(Typ
) then
4719 Rewrite
(N
, New_Reference_To
(Standard_True
, Loc
));
4720 Analyze_And_Resolve
(N
, Rtyp
);
4722 -- For the constrained array case, we have to check the subscripts
4723 -- for an exact match if the lengths are non-zero (the lengths
4724 -- must match in any case).
4726 elsif Is_Array_Type
(Typ
) then
4727 Check_Subscripts
: declare
4728 function Build_Attribute_Reference
4731 Dim
: Nat
) return Node_Id
;
4732 -- Build attribute reference E'Nam (Dim)
4734 -------------------------------
4735 -- Build_Attribute_Reference --
4736 -------------------------------
4738 function Build_Attribute_Reference
4741 Dim
: Nat
) return Node_Id
4745 Make_Attribute_Reference
(Loc
,
4747 Attribute_Name
=> Nam
,
4748 Expressions
=> New_List
(
4749 Make_Integer_Literal
(Loc
, Dim
)));
4750 end Build_Attribute_Reference
;
4752 -- Start of processing for Check_Subscripts
4755 for J
in 1 .. Number_Dimensions
(Typ
) loop
4756 Evolve_And_Then
(Cond
,
4759 Build_Attribute_Reference
4760 (Duplicate_Subexpr_No_Checks
(Obj
),
4763 Build_Attribute_Reference
4764 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
4766 Evolve_And_Then
(Cond
,
4769 Build_Attribute_Reference
4770 (Duplicate_Subexpr_No_Checks
(Obj
),
4773 Build_Attribute_Reference
4774 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
4783 Right_Opnd
=> Make_Null
(Loc
)),
4784 Right_Opnd
=> Cond
);
4788 Analyze_And_Resolve
(N
, Rtyp
);
4789 end Check_Subscripts
;
4791 -- These are the cases where constraint checks may be required,
4792 -- e.g. records with possible discriminants
4795 -- Expand the test into a series of discriminant comparisons.
4796 -- The expression that is built is the negation of the one that
4797 -- is used for checking discriminant constraints.
4799 Obj
:= Relocate_Node
(Left_Opnd
(N
));
4801 if Has_Discriminants
(Typ
) then
4802 Cond
:= Make_Op_Not
(Loc
,
4803 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
4806 Cond
:= Make_Or_Else
(Loc
,
4810 Right_Opnd
=> Make_Null
(Loc
)),
4811 Right_Opnd
=> Cond
);
4815 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
4819 Analyze_And_Resolve
(N
, Rtyp
);
4825 --------------------------------
4826 -- Expand_N_Indexed_Component --
4827 --------------------------------
4829 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
4830 Loc
: constant Source_Ptr
:= Sloc
(N
);
4831 Typ
: constant Entity_Id
:= Etype
(N
);
4832 P
: constant Node_Id
:= Prefix
(N
);
4833 T
: constant Entity_Id
:= Etype
(P
);
4836 -- A special optimization, if we have an indexed component that is
4837 -- selecting from a slice, then we can eliminate the slice, since, for
4838 -- example, x (i .. j)(k) is identical to x(k). The only difference is
4839 -- the range check required by the slice. The range check for the slice
4840 -- itself has already been generated. The range check for the
4841 -- subscripting operation is ensured by converting the subject to
4842 -- the subtype of the slice.
4844 -- This optimization not only generates better code, avoiding slice
4845 -- messing especially in the packed case, but more importantly bypasses
4846 -- some problems in handling this peculiar case, for example, the issue
4847 -- of dealing specially with object renamings.
4849 if Nkind
(P
) = N_Slice
then
4851 Make_Indexed_Component
(Loc
,
4852 Prefix
=> Prefix
(P
),
4853 Expressions
=> New_List
(
4855 (Etype
(First_Index
(Etype
(P
))),
4856 First
(Expressions
(N
))))));
4857 Analyze_And_Resolve
(N
, Typ
);
4861 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4862 -- function, then additional actuals must be passed.
4864 if Ada_Version
>= Ada_05
4865 and then Is_Build_In_Place_Function_Call
(P
)
4867 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
4870 -- If the prefix is an access type, then we unconditionally rewrite if
4871 -- as an explicit dereference. This simplifies processing for several
4872 -- cases, including packed array cases and certain cases in which checks
4873 -- must be generated. We used to try to do this only when it was
4874 -- necessary, but it cleans up the code to do it all the time.
4876 if Is_Access_Type
(T
) then
4877 Insert_Explicit_Dereference
(P
);
4878 Analyze_And_Resolve
(P
, Designated_Type
(T
));
4881 -- Generate index and validity checks
4883 Generate_Index_Checks
(N
);
4885 if Validity_Checks_On
and then Validity_Check_Subscripts
then
4886 Apply_Subscript_Validity_Checks
(N
);
4889 -- All done for the non-packed case
4891 if not Is_Packed
(Etype
(Prefix
(N
))) then
4895 -- For packed arrays that are not bit-packed (i.e. the case of an array
4896 -- with one or more index types with a non-contiguous enumeration type),
4897 -- we can always use the normal packed element get circuit.
4899 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
4900 Expand_Packed_Element_Reference
(N
);
4904 -- For a reference to a component of a bit packed array, we have to
4905 -- convert it to a reference to the corresponding Packed_Array_Type.
4906 -- We only want to do this for simple references, and not for:
4908 -- Left side of assignment, or prefix of left side of assignment, or
4909 -- prefix of the prefix, to handle packed arrays of packed arrays,
4910 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4912 -- Renaming objects in renaming associations
4913 -- This case is handled when a use of the renamed variable occurs
4915 -- Actual parameters for a procedure call
4916 -- This case is handled in Exp_Ch6.Expand_Actuals
4918 -- The second expression in a 'Read attribute reference
4920 -- The prefix of an address or bit or size attribute reference
4922 -- The following circuit detects these exceptions
4925 Child
: Node_Id
:= N
;
4926 Parnt
: Node_Id
:= Parent
(N
);
4930 if Nkind
(Parnt
) = N_Unchecked_Expression
then
4933 elsif Nkind_In
(Parnt
, N_Object_Renaming_Declaration
,
4934 N_Procedure_Call_Statement
)
4935 or else (Nkind
(Parnt
) = N_Parameter_Association
4937 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
4941 elsif Nkind
(Parnt
) = N_Attribute_Reference
4942 and then (Attribute_Name
(Parnt
) = Name_Address
4944 Attribute_Name
(Parnt
) = Name_Bit
4946 Attribute_Name
(Parnt
) = Name_Size
)
4947 and then Prefix
(Parnt
) = Child
4951 elsif Nkind
(Parnt
) = N_Assignment_Statement
4952 and then Name
(Parnt
) = Child
4956 -- If the expression is an index of an indexed component, it must
4957 -- be expanded regardless of context.
4959 elsif Nkind
(Parnt
) = N_Indexed_Component
4960 and then Child
/= Prefix
(Parnt
)
4962 Expand_Packed_Element_Reference
(N
);
4965 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
4966 and then Name
(Parent
(Parnt
)) = Parnt
4970 elsif Nkind
(Parnt
) = N_Attribute_Reference
4971 and then Attribute_Name
(Parnt
) = Name_Read
4972 and then Next
(First
(Expressions
(Parnt
))) = Child
4976 elsif Nkind_In
(Parnt
, N_Indexed_Component
, N_Selected_Component
)
4977 and then Prefix
(Parnt
) = Child
4982 Expand_Packed_Element_Reference
(N
);
4986 -- Keep looking up tree for unchecked expression, or if we are the
4987 -- prefix of a possible assignment left side.
4990 Parnt
:= Parent
(Child
);
4993 end Expand_N_Indexed_Component
;
4995 ---------------------
4996 -- Expand_N_Not_In --
4997 ---------------------
4999 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
5000 -- can be done. This avoids needing to duplicate this expansion code.
5002 procedure Expand_N_Not_In
(N
: Node_Id
) is
5003 Loc
: constant Source_Ptr
:= Sloc
(N
);
5004 Typ
: constant Entity_Id
:= Etype
(N
);
5005 Cfs
: constant Boolean := Comes_From_Source
(N
);
5012 Left_Opnd
=> Left_Opnd
(N
),
5013 Right_Opnd
=> Right_Opnd
(N
))));
5015 -- If this is a set membership, preserve list of alternatives
5017 Set_Alternatives
(Right_Opnd
(N
), Alternatives
(Original_Node
(N
)));
5019 -- We want this to appear as coming from source if original does (see
5020 -- transformations in Expand_N_In).
5022 Set_Comes_From_Source
(N
, Cfs
);
5023 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
5025 -- Now analyze transformed node
5027 Analyze_And_Resolve
(N
, Typ
);
5028 end Expand_N_Not_In
;
5034 -- The only replacement required is for the case of a null of type that is
5035 -- an access to protected subprogram. We represent such access values as a
5036 -- record, and so we must replace the occurrence of null by the equivalent
5037 -- record (with a null address and a null pointer in it), so that the
5038 -- backend creates the proper value.
5040 procedure Expand_N_Null
(N
: Node_Id
) is
5041 Loc
: constant Source_Ptr
:= Sloc
(N
);
5042 Typ
: constant Entity_Id
:= Etype
(N
);
5046 if Is_Access_Protected_Subprogram_Type
(Typ
) then
5048 Make_Aggregate
(Loc
,
5049 Expressions
=> New_List
(
5050 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
5054 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
5056 -- For subsequent semantic analysis, the node must retain its type.
5057 -- Gigi in any case replaces this type by the corresponding record
5058 -- type before processing the node.
5064 when RE_Not_Available
=>
5068 ---------------------
5069 -- Expand_N_Op_Abs --
5070 ---------------------
5072 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
5073 Loc
: constant Source_Ptr
:= Sloc
(N
);
5074 Expr
: constant Node_Id
:= Right_Opnd
(N
);
5077 Unary_Op_Validity_Checks
(N
);
5079 -- Deal with software overflow checking
5081 if not Backend_Overflow_Checks_On_Target
5082 and then Is_Signed_Integer_Type
(Etype
(N
))
5083 and then Do_Overflow_Check
(N
)
5085 -- The only case to worry about is when the argument is equal to the
5086 -- largest negative number, so what we do is to insert the check:
5088 -- [constraint_error when Expr = typ'Base'First]
5090 -- with the usual Duplicate_Subexpr use coding for expr
5093 Make_Raise_Constraint_Error
(Loc
,
5096 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
5098 Make_Attribute_Reference
(Loc
,
5100 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
5101 Attribute_Name
=> Name_First
)),
5102 Reason
=> CE_Overflow_Check_Failed
));
5105 -- Vax floating-point types case
5107 if Vax_Float
(Etype
(N
)) then
5108 Expand_Vax_Arith
(N
);
5110 end Expand_N_Op_Abs
;
5112 ---------------------
5113 -- Expand_N_Op_Add --
5114 ---------------------
5116 procedure Expand_N_Op_Add
(N
: Node_Id
) is
5117 Typ
: constant Entity_Id
:= Etype
(N
);
5120 Binary_Op_Validity_Checks
(N
);
5122 -- N + 0 = 0 + N = N for integer types
5124 if Is_Integer_Type
(Typ
) then
5125 if Compile_Time_Known_Value
(Right_Opnd
(N
))
5126 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
5128 Rewrite
(N
, Left_Opnd
(N
));
5131 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
5132 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
5134 Rewrite
(N
, Right_Opnd
(N
));
5139 -- Arithmetic overflow checks for signed integer/fixed point types
5141 if Is_Signed_Integer_Type
(Typ
)
5142 or else Is_Fixed_Point_Type
(Typ
)
5144 Apply_Arithmetic_Overflow_Check
(N
);
5147 -- Vax floating-point types case
5149 elsif Vax_Float
(Typ
) then
5150 Expand_Vax_Arith
(N
);
5152 end Expand_N_Op_Add
;
5154 ---------------------
5155 -- Expand_N_Op_And --
5156 ---------------------
5158 procedure Expand_N_Op_And
(N
: Node_Id
) is
5159 Typ
: constant Entity_Id
:= Etype
(N
);
5162 Binary_Op_Validity_Checks
(N
);
5164 if Is_Array_Type
(Etype
(N
)) then
5165 Expand_Boolean_Operator
(N
);
5167 elsif Is_Boolean_Type
(Etype
(N
)) then
5169 -- Replace AND by AND THEN if Short_Circuit_And_Or active and the
5170 -- type is standard Boolean (do not mess with AND that uses a non-
5171 -- standard Boolean type, because something strange is going on).
5173 if Short_Circuit_And_Or
and then Typ
= Standard_Boolean
then
5175 Make_And_Then
(Sloc
(N
),
5176 Left_Opnd
=> Relocate_Node
(Left_Opnd
(N
)),
5177 Right_Opnd
=> Relocate_Node
(Right_Opnd
(N
))));
5178 Analyze_And_Resolve
(N
, Typ
);
5180 -- Otherwise, adjust conditions
5183 Adjust_Condition
(Left_Opnd
(N
));
5184 Adjust_Condition
(Right_Opnd
(N
));
5185 Set_Etype
(N
, Standard_Boolean
);
5186 Adjust_Result_Type
(N
, Typ
);
5189 end Expand_N_Op_And
;
5191 ------------------------
5192 -- Expand_N_Op_Concat --
5193 ------------------------
5195 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
5197 -- List of operands to be concatenated
5200 -- Node which is to be replaced by the result of concatenating the nodes
5201 -- in the list Opnds.
5204 -- Ensure validity of both operands
5206 Binary_Op_Validity_Checks
(N
);
5208 -- If we are the left operand of a concatenation higher up the tree,
5209 -- then do nothing for now, since we want to deal with a series of
5210 -- concatenations as a unit.
5212 if Nkind
(Parent
(N
)) = N_Op_Concat
5213 and then N
= Left_Opnd
(Parent
(N
))
5218 -- We get here with a concatenation whose left operand may be a
5219 -- concatenation itself with a consistent type. We need to process
5220 -- these concatenation operands from left to right, which means
5221 -- from the deepest node in the tree to the highest node.
5224 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
5225 Cnode
:= Left_Opnd
(Cnode
);
5228 -- Now Cnode is the deepest concatenation, and its parents are the
5229 -- concatenation nodes above, so now we process bottom up, doing the
5230 -- operations. We gather a string that is as long as possible up to five
5233 -- The outer loop runs more than once if more than one concatenation
5234 -- type is involved.
5237 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
5238 Set_Parent
(Opnds
, N
);
5240 -- The inner loop gathers concatenation operands
5242 Inner
: while Cnode
/= N
5243 and then Base_Type
(Etype
(Cnode
)) =
5244 Base_Type
(Etype
(Parent
(Cnode
)))
5246 Cnode
:= Parent
(Cnode
);
5247 Append
(Right_Opnd
(Cnode
), Opnds
);
5250 Expand_Concatenate
(Cnode
, Opnds
);
5252 exit Outer
when Cnode
= N
;
5253 Cnode
:= Parent
(Cnode
);
5255 end Expand_N_Op_Concat
;
5257 ------------------------
5258 -- Expand_N_Op_Divide --
5259 ------------------------
5261 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
5262 Loc
: constant Source_Ptr
:= Sloc
(N
);
5263 Lopnd
: constant Node_Id
:= Left_Opnd
(N
);
5264 Ropnd
: constant Node_Id
:= Right_Opnd
(N
);
5265 Ltyp
: constant Entity_Id
:= Etype
(Lopnd
);
5266 Rtyp
: constant Entity_Id
:= Etype
(Ropnd
);
5267 Typ
: Entity_Id
:= Etype
(N
);
5268 Rknow
: constant Boolean := Is_Integer_Type
(Typ
)
5270 Compile_Time_Known_Value
(Ropnd
);
5274 Binary_Op_Validity_Checks
(N
);
5277 Rval
:= Expr_Value
(Ropnd
);
5280 -- N / 1 = N for integer types
5282 if Rknow
and then Rval
= Uint_1
then
5287 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
5288 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5289 -- operand is an unsigned integer, as required for this to work.
5291 if Nkind
(Ropnd
) = N_Op_Expon
5292 and then Is_Power_Of_2_For_Shift
(Ropnd
)
5294 -- We cannot do this transformation in configurable run time mode if we
5295 -- have 64-bit integers and long shifts are not available.
5299 or else Support_Long_Shifts_On_Target
)
5302 Make_Op_Shift_Right
(Loc
,
5305 Convert_To
(Standard_Natural
, Right_Opnd
(Ropnd
))));
5306 Analyze_And_Resolve
(N
, Typ
);
5310 -- Do required fixup of universal fixed operation
5312 if Typ
= Universal_Fixed
then
5313 Fixup_Universal_Fixed_Operation
(N
);
5317 -- Divisions with fixed-point results
5319 if Is_Fixed_Point_Type
(Typ
) then
5321 -- No special processing if Treat_Fixed_As_Integer is set, since
5322 -- from a semantic point of view such operations are simply integer
5323 -- operations and will be treated that way.
5325 if not Treat_Fixed_As_Integer
(N
) then
5326 if Is_Integer_Type
(Rtyp
) then
5327 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
5329 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
5333 -- Other cases of division of fixed-point operands. Again we exclude the
5334 -- case where Treat_Fixed_As_Integer is set.
5336 elsif (Is_Fixed_Point_Type
(Ltyp
) or else
5337 Is_Fixed_Point_Type
(Rtyp
))
5338 and then not Treat_Fixed_As_Integer
(N
)
5340 if Is_Integer_Type
(Typ
) then
5341 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
5343 pragma Assert
(Is_Floating_Point_Type
(Typ
));
5344 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
5347 -- Mixed-mode operations can appear in a non-static universal context,
5348 -- in which case the integer argument must be converted explicitly.
5350 elsif Typ
= Universal_Real
5351 and then Is_Integer_Type
(Rtyp
)
5354 Convert_To
(Universal_Real
, Relocate_Node
(Ropnd
)));
5356 Analyze_And_Resolve
(Ropnd
, Universal_Real
);
5358 elsif Typ
= Universal_Real
5359 and then Is_Integer_Type
(Ltyp
)
5362 Convert_To
(Universal_Real
, Relocate_Node
(Lopnd
)));
5364 Analyze_And_Resolve
(Lopnd
, Universal_Real
);
5366 -- Non-fixed point cases, do integer zero divide and overflow checks
5368 elsif Is_Integer_Type
(Typ
) then
5369 Apply_Divide_Check
(N
);
5371 -- Check for 64-bit division available, or long shifts if the divisor
5372 -- is a small power of 2 (since such divides will be converted into
5375 if Esize
(Ltyp
) > 32
5376 and then not Support_64_Bit_Divides_On_Target
5379 or else not Support_Long_Shifts_On_Target
5380 or else (Rval
/= Uint_2
and then
5381 Rval
/= Uint_4
and then
5382 Rval
/= Uint_8
and then
5383 Rval
/= Uint_16
and then
5384 Rval
/= Uint_32
and then
5387 Error_Msg_CRT
("64-bit division", N
);
5390 -- Deal with Vax_Float
5392 elsif Vax_Float
(Typ
) then
5393 Expand_Vax_Arith
(N
);
5396 end Expand_N_Op_Divide
;
5398 --------------------
5399 -- Expand_N_Op_Eq --
5400 --------------------
5402 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
5403 Loc
: constant Source_Ptr
:= Sloc
(N
);
5404 Typ
: constant Entity_Id
:= Etype
(N
);
5405 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
5406 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
5407 Bodies
: constant List_Id
:= New_List
;
5408 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
5410 Typl
: Entity_Id
:= A_Typ
;
5411 Op_Name
: Entity_Id
;
5414 procedure Build_Equality_Call
(Eq
: Entity_Id
);
5415 -- If a constructed equality exists for the type or for its parent,
5416 -- build and analyze call, adding conversions if the operation is
5419 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
5420 -- Determines whether a type has a subcomponent of an unconstrained
5421 -- Unchecked_Union subtype. Typ is a record type.
5423 -------------------------
5424 -- Build_Equality_Call --
5425 -------------------------
5427 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
5428 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
5429 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
5430 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
5433 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
5434 and then not Is_Class_Wide_Type
(A_Typ
)
5436 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
5437 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
5440 -- If we have an Unchecked_Union, we need to add the inferred
5441 -- discriminant values as actuals in the function call. At this
5442 -- point, the expansion has determined that both operands have
5443 -- inferable discriminants.
5445 if Is_Unchecked_Union
(Op_Type
) then
5447 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
5448 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
5449 Lhs_Discr_Val
: Node_Id
;
5450 Rhs_Discr_Val
: Node_Id
;
5453 -- Per-object constrained selected components require special
5454 -- attention. If the enclosing scope of the component is an
5455 -- Unchecked_Union, we cannot reference its discriminants
5456 -- directly. This is why we use the two extra parameters of
5457 -- the equality function of the enclosing Unchecked_Union.
5459 -- type UU_Type (Discr : Integer := 0) is
5462 -- pragma Unchecked_Union (UU_Type);
5464 -- 1. Unchecked_Union enclosing record:
5466 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
5468 -- Comp : UU_Type (Discr);
5470 -- end Enclosing_UU_Type;
5471 -- pragma Unchecked_Union (Enclosing_UU_Type);
5473 -- Obj1 : Enclosing_UU_Type;
5474 -- Obj2 : Enclosing_UU_Type (1);
5476 -- [. . .] Obj1 = Obj2 [. . .]
5480 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
5482 -- A and B are the formal parameters of the equality function
5483 -- of Enclosing_UU_Type. The function always has two extra
5484 -- formals to capture the inferred discriminant values.
5486 -- 2. Non-Unchecked_Union enclosing record:
5489 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
5492 -- Comp : UU_Type (Discr);
5494 -- end Enclosing_Non_UU_Type;
5496 -- Obj1 : Enclosing_Non_UU_Type;
5497 -- Obj2 : Enclosing_Non_UU_Type (1);
5499 -- ... Obj1 = Obj2 ...
5503 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
5504 -- obj1.discr, obj2.discr)) then
5506 -- In this case we can directly reference the discriminants of
5507 -- the enclosing record.
5511 if Nkind
(Lhs
) = N_Selected_Component
5512 and then Has_Per_Object_Constraint
5513 (Entity
(Selector_Name
(Lhs
)))
5515 -- Enclosing record is an Unchecked_Union, use formal A
5517 if Is_Unchecked_Union
(Scope
5518 (Entity
(Selector_Name
(Lhs
))))
5521 Make_Identifier
(Loc
,
5524 -- Enclosing record is of a non-Unchecked_Union type, it is
5525 -- possible to reference the discriminant.
5529 Make_Selected_Component
(Loc
,
5530 Prefix
=> Prefix
(Lhs
),
5533 (Get_Discriminant_Value
5534 (First_Discriminant
(Lhs_Type
),
5536 Stored_Constraint
(Lhs_Type
))));
5539 -- Comment needed here ???
5542 -- Infer the discriminant value
5546 (Get_Discriminant_Value
5547 (First_Discriminant
(Lhs_Type
),
5549 Stored_Constraint
(Lhs_Type
)));
5554 if Nkind
(Rhs
) = N_Selected_Component
5555 and then Has_Per_Object_Constraint
5556 (Entity
(Selector_Name
(Rhs
)))
5558 if Is_Unchecked_Union
5559 (Scope
(Entity
(Selector_Name
(Rhs
))))
5562 Make_Identifier
(Loc
,
5567 Make_Selected_Component
(Loc
,
5568 Prefix
=> Prefix
(Rhs
),
5570 New_Copy
(Get_Discriminant_Value
(
5571 First_Discriminant
(Rhs_Type
),
5573 Stored_Constraint
(Rhs_Type
))));
5578 New_Copy
(Get_Discriminant_Value
(
5579 First_Discriminant
(Rhs_Type
),
5581 Stored_Constraint
(Rhs_Type
)));
5586 Make_Function_Call
(Loc
,
5587 Name
=> New_Reference_To
(Eq
, Loc
),
5588 Parameter_Associations
=> New_List
(
5595 -- Normal case, not an unchecked union
5599 Make_Function_Call
(Loc
,
5600 Name
=> New_Reference_To
(Eq
, Loc
),
5601 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
5604 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
5605 end Build_Equality_Call
;
5607 ------------------------------------
5608 -- Has_Unconstrained_UU_Component --
5609 ------------------------------------
5611 function Has_Unconstrained_UU_Component
5612 (Typ
: Node_Id
) return Boolean
5614 Tdef
: constant Node_Id
:=
5615 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
5619 function Component_Is_Unconstrained_UU
5620 (Comp
: Node_Id
) return Boolean;
5621 -- Determines whether the subtype of the component is an
5622 -- unconstrained Unchecked_Union.
5624 function Variant_Is_Unconstrained_UU
5625 (Variant
: Node_Id
) return Boolean;
5626 -- Determines whether a component of the variant has an unconstrained
5627 -- Unchecked_Union subtype.
5629 -----------------------------------
5630 -- Component_Is_Unconstrained_UU --
5631 -----------------------------------
5633 function Component_Is_Unconstrained_UU
5634 (Comp
: Node_Id
) return Boolean
5637 if Nkind
(Comp
) /= N_Component_Declaration
then
5642 Sindic
: constant Node_Id
:=
5643 Subtype_Indication
(Component_Definition
(Comp
));
5646 -- Unconstrained nominal type. In the case of a constraint
5647 -- present, the node kind would have been N_Subtype_Indication.
5649 if Nkind
(Sindic
) = N_Identifier
then
5650 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
5655 end Component_Is_Unconstrained_UU
;
5657 ---------------------------------
5658 -- Variant_Is_Unconstrained_UU --
5659 ---------------------------------
5661 function Variant_Is_Unconstrained_UU
5662 (Variant
: Node_Id
) return Boolean
5664 Clist
: constant Node_Id
:= Component_List
(Variant
);
5667 if Is_Empty_List
(Component_Items
(Clist
)) then
5671 -- We only need to test one component
5674 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
5677 while Present
(Comp
) loop
5678 if Component_Is_Unconstrained_UU
(Comp
) then
5686 -- None of the components withing the variant were of
5687 -- unconstrained Unchecked_Union type.
5690 end Variant_Is_Unconstrained_UU
;
5692 -- Start of processing for Has_Unconstrained_UU_Component
5695 if Null_Present
(Tdef
) then
5699 Clist
:= Component_List
(Tdef
);
5700 Vpart
:= Variant_Part
(Clist
);
5702 -- Inspect available components
5704 if Present
(Component_Items
(Clist
)) then
5706 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
5709 while Present
(Comp
) loop
5711 -- One component is sufficient
5713 if Component_Is_Unconstrained_UU
(Comp
) then
5722 -- Inspect available components withing variants
5724 if Present
(Vpart
) then
5726 Variant
: Node_Id
:= First
(Variants
(Vpart
));
5729 while Present
(Variant
) loop
5731 -- One component within a variant is sufficient
5733 if Variant_Is_Unconstrained_UU
(Variant
) then
5742 -- Neither the available components, nor the components inside the
5743 -- variant parts were of an unconstrained Unchecked_Union subtype.
5746 end Has_Unconstrained_UU_Component
;
5748 -- Start of processing for Expand_N_Op_Eq
5751 Binary_Op_Validity_Checks
(N
);
5753 if Ekind
(Typl
) = E_Private_Type
then
5754 Typl
:= Underlying_Type
(Typl
);
5755 elsif Ekind
(Typl
) = E_Private_Subtype
then
5756 Typl
:= Underlying_Type
(Base_Type
(Typl
));
5761 -- It may happen in error situations that the underlying type is not
5762 -- set. The error will be detected later, here we just defend the
5769 Typl
:= Base_Type
(Typl
);
5771 -- Boolean types (requiring handling of non-standard case)
5773 if Is_Boolean_Type
(Typl
) then
5774 Adjust_Condition
(Left_Opnd
(N
));
5775 Adjust_Condition
(Right_Opnd
(N
));
5776 Set_Etype
(N
, Standard_Boolean
);
5777 Adjust_Result_Type
(N
, Typ
);
5781 elsif Is_Array_Type
(Typl
) then
5783 -- If we are doing full validity checking, and it is possible for the
5784 -- array elements to be invalid then expand out array comparisons to
5785 -- make sure that we check the array elements.
5787 if Validity_Check_Operands
5788 and then not Is_Known_Valid
(Component_Type
(Typl
))
5791 Save_Force_Validity_Checks
: constant Boolean :=
5792 Force_Validity_Checks
;
5794 Force_Validity_Checks
:= True;
5796 Expand_Array_Equality
5798 Relocate_Node
(Lhs
),
5799 Relocate_Node
(Rhs
),
5802 Insert_Actions
(N
, Bodies
);
5803 Analyze_And_Resolve
(N
, Standard_Boolean
);
5804 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
5807 -- Packed case where both operands are known aligned
5809 elsif Is_Bit_Packed_Array
(Typl
)
5810 and then not Is_Possibly_Unaligned_Object
(Lhs
)
5811 and then not Is_Possibly_Unaligned_Object
(Rhs
)
5813 Expand_Packed_Eq
(N
);
5815 -- Where the component type is elementary we can use a block bit
5816 -- comparison (if supported on the target) exception in the case
5817 -- of floating-point (negative zero issues require element by
5818 -- element comparison), and atomic types (where we must be sure
5819 -- to load elements independently) and possibly unaligned arrays.
5821 elsif Is_Elementary_Type
(Component_Type
(Typl
))
5822 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
5823 and then not Is_Atomic
(Component_Type
(Typl
))
5824 and then not Is_Possibly_Unaligned_Object
(Lhs
)
5825 and then not Is_Possibly_Unaligned_Object
(Rhs
)
5826 and then Support_Composite_Compare_On_Target
5830 -- For composite and floating-point cases, expand equality loop to
5831 -- make sure of using proper comparisons for tagged types, and
5832 -- correctly handling the floating-point case.
5836 Expand_Array_Equality
5838 Relocate_Node
(Lhs
),
5839 Relocate_Node
(Rhs
),
5842 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
5843 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
5848 elsif Is_Record_Type
(Typl
) then
5850 -- For tagged types, use the primitive "="
5852 if Is_Tagged_Type
(Typl
) then
5854 -- No need to do anything else compiling under restriction
5855 -- No_Dispatching_Calls. During the semantic analysis we
5856 -- already notified such violation.
5858 if Restriction_Active
(No_Dispatching_Calls
) then
5862 -- If this is derived from an untagged private type completed with
5863 -- a tagged type, it does not have a full view, so we use the
5864 -- primitive operations of the private type. This check should no
5865 -- longer be necessary when these types get their full views???
5867 if Is_Private_Type
(A_Typ
)
5868 and then not Is_Tagged_Type
(A_Typ
)
5869 and then Is_Derived_Type
(A_Typ
)
5870 and then No
(Full_View
(A_Typ
))
5872 -- Search for equality operation, checking that the operands
5873 -- have the same type. Note that we must find a matching entry,
5874 -- or something is very wrong!
5876 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
5878 while Present
(Prim
) loop
5879 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
5880 and then Etype
(First_Formal
(Node
(Prim
))) =
5881 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
5883 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
5888 pragma Assert
(Present
(Prim
));
5889 Op_Name
:= Node
(Prim
);
5891 -- Find the type's predefined equality or an overriding
5892 -- user- defined equality. The reason for not simply calling
5893 -- Find_Prim_Op here is that there may be a user-defined
5894 -- overloaded equality op that precedes the equality that we want,
5895 -- so we have to explicitly search (e.g., there could be an
5896 -- equality with two different parameter types).
5899 if Is_Class_Wide_Type
(Typl
) then
5900 Typl
:= Root_Type
(Typl
);
5903 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
5904 while Present
(Prim
) loop
5905 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
5906 and then Etype
(First_Formal
(Node
(Prim
))) =
5907 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
5909 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
5914 pragma Assert
(Present
(Prim
));
5915 Op_Name
:= Node
(Prim
);
5918 Build_Equality_Call
(Op_Name
);
5920 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
5921 -- predefined equality operator for a type which has a subcomponent
5922 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
5924 elsif Has_Unconstrained_UU_Component
(Typl
) then
5926 Make_Raise_Program_Error
(Loc
,
5927 Reason
=> PE_Unchecked_Union_Restriction
));
5929 -- Prevent Gigi from generating incorrect code by rewriting the
5930 -- equality as a standard False.
5933 New_Occurrence_Of
(Standard_False
, Loc
));
5935 elsif Is_Unchecked_Union
(Typl
) then
5937 -- If we can infer the discriminants of the operands, we make a
5938 -- call to the TSS equality function.
5940 if Has_Inferable_Discriminants
(Lhs
)
5942 Has_Inferable_Discriminants
(Rhs
)
5945 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
5948 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5949 -- the predefined equality operator for an Unchecked_Union type
5950 -- if either of the operands lack inferable discriminants.
5953 Make_Raise_Program_Error
(Loc
,
5954 Reason
=> PE_Unchecked_Union_Restriction
));
5956 -- Prevent Gigi from generating incorrect code by rewriting
5957 -- the equality as a standard False.
5960 New_Occurrence_Of
(Standard_False
, Loc
));
5964 -- If a type support function is present (for complex cases), use it
5966 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
5968 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
5970 -- Otherwise expand the component by component equality. Note that
5971 -- we never use block-bit comparisons for records, because of the
5972 -- problems with gaps. The backend will often be able to recombine
5973 -- the separate comparisons that we generate here.
5976 Remove_Side_Effects
(Lhs
);
5977 Remove_Side_Effects
(Rhs
);
5979 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
5981 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
5982 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
5986 -- Test if result is known at compile time
5988 Rewrite_Comparison
(N
);
5990 -- If we still have comparison for Vax_Float, process it
5992 if Vax_Float
(Typl
) and then Nkind
(N
) in N_Op_Compare
then
5993 Expand_Vax_Comparison
(N
);
5998 -----------------------
5999 -- Expand_N_Op_Expon --
6000 -----------------------
6002 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
6003 Loc
: constant Source_Ptr
:= Sloc
(N
);
6004 Typ
: constant Entity_Id
:= Etype
(N
);
6005 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
6006 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
6007 Bastyp
: constant Node_Id
:= Etype
(Base
);
6008 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
6009 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
6010 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
6019 Binary_Op_Validity_Checks
(N
);
6021 -- If either operand is of a private type, then we have the use of an
6022 -- intrinsic operator, and we get rid of the privateness, by using root
6023 -- types of underlying types for the actual operation. Otherwise the
6024 -- private types will cause trouble if we expand multiplications or
6025 -- shifts etc. We also do this transformation if the result type is
6026 -- different from the base type.
6028 if Is_Private_Type
(Etype
(Base
))
6030 Is_Private_Type
(Typ
)
6032 Is_Private_Type
(Exptyp
)
6034 Rtyp
/= Root_Type
(Bastyp
)
6037 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
6038 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
6042 Unchecked_Convert_To
(Typ
,
6044 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
6045 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
6046 Analyze_And_Resolve
(N
, Typ
);
6051 -- Test for case of known right argument
6053 if Compile_Time_Known_Value
(Exp
) then
6054 Expv
:= Expr_Value
(Exp
);
6056 -- We only fold small non-negative exponents. You might think we
6057 -- could fold small negative exponents for the real case, but we
6058 -- can't because we are required to raise Constraint_Error for
6059 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
6060 -- See ACVC test C4A012B.
6062 if Expv
>= 0 and then Expv
<= 4 then
6064 -- X ** 0 = 1 (or 1.0)
6068 -- Call Remove_Side_Effects to ensure that any side effects
6069 -- in the ignored left operand (in particular function calls
6070 -- to user defined functions) are properly executed.
6072 Remove_Side_Effects
(Base
);
6074 if Ekind
(Typ
) in Integer_Kind
then
6075 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
6077 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
6089 Make_Op_Multiply
(Loc
,
6090 Left_Opnd
=> Duplicate_Subexpr
(Base
),
6091 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
6093 -- X ** 3 = X * X * X
6097 Make_Op_Multiply
(Loc
,
6099 Make_Op_Multiply
(Loc
,
6100 Left_Opnd
=> Duplicate_Subexpr
(Base
),
6101 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
6102 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
6105 -- En : constant base'type := base * base;
6110 Temp
:= Make_Temporary
(Loc
, 'E', Base
);
6112 Insert_Actions
(N
, New_List
(
6113 Make_Object_Declaration
(Loc
,
6114 Defining_Identifier
=> Temp
,
6115 Constant_Present
=> True,
6116 Object_Definition
=> New_Reference_To
(Typ
, Loc
),
6118 Make_Op_Multiply
(Loc
,
6119 Left_Opnd
=> Duplicate_Subexpr
(Base
),
6120 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)))));
6123 Make_Op_Multiply
(Loc
,
6124 Left_Opnd
=> New_Reference_To
(Temp
, Loc
),
6125 Right_Opnd
=> New_Reference_To
(Temp
, Loc
));
6129 Analyze_And_Resolve
(N
, Typ
);
6134 -- Case of (2 ** expression) appearing as an argument of an integer
6135 -- multiplication, or as the right argument of a division of a non-
6136 -- negative integer. In such cases we leave the node untouched, setting
6137 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
6138 -- of the higher level node converts it into a shift.
6140 -- Another case is 2 ** N in any other context. We simply convert
6141 -- this to 1 * 2 ** N, and then the above transformation applies.
6143 -- Note: this transformation is not applicable for a modular type with
6144 -- a non-binary modulus in the multiplication case, since we get a wrong
6145 -- result if the shift causes an overflow before the modular reduction.
6147 if Nkind
(Base
) = N_Integer_Literal
6148 and then Intval
(Base
) = 2
6149 and then Is_Integer_Type
(Root_Type
(Exptyp
))
6150 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
6151 and then Is_Unsigned_Type
(Exptyp
)
6154 -- First the multiply and divide cases
6156 if Nkind_In
(Parent
(N
), N_Op_Divide
, N_Op_Multiply
) then
6158 P
: constant Node_Id
:= Parent
(N
);
6159 L
: constant Node_Id
:= Left_Opnd
(P
);
6160 R
: constant Node_Id
:= Right_Opnd
(P
);
6163 if (Nkind
(P
) = N_Op_Multiply
6164 and then not Non_Binary_Modulus
(Typ
)
6166 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
6168 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
6169 and then not Do_Overflow_Check
(P
))
6171 (Nkind
(P
) = N_Op_Divide
6172 and then Is_Integer_Type
(Etype
(L
))
6173 and then Is_Unsigned_Type
(Etype
(L
))
6175 and then not Do_Overflow_Check
(P
))
6177 Set_Is_Power_Of_2_For_Shift
(N
);
6182 -- Now the other cases
6184 elsif not Non_Binary_Modulus
(Typ
) then
6186 Make_Op_Multiply
(Loc
,
6187 Left_Opnd
=> Make_Integer_Literal
(Loc
, 1),
6188 Right_Opnd
=> Relocate_Node
(N
)));
6189 Analyze_And_Resolve
(N
, Typ
);
6194 -- Fall through if exponentiation must be done using a runtime routine
6196 -- First deal with modular case
6198 if Is_Modular_Integer_Type
(Rtyp
) then
6200 -- Non-binary case, we call the special exponentiation routine for
6201 -- the non-binary case, converting the argument to Long_Long_Integer
6202 -- and passing the modulus value. Then the result is converted back
6203 -- to the base type.
6205 if Non_Binary_Modulus
(Rtyp
) then
6208 Make_Function_Call
(Loc
,
6209 Name
=> New_Reference_To
(RTE
(RE_Exp_Modular
), Loc
),
6210 Parameter_Associations
=> New_List
(
6211 Convert_To
(Standard_Integer
, Base
),
6212 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
6215 -- Binary case, in this case, we call one of two routines, either the
6216 -- unsigned integer case, or the unsigned long long integer case,
6217 -- with a final "and" operation to do the required mod.
6220 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
6221 Ent
:= RTE
(RE_Exp_Unsigned
);
6223 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
6230 Make_Function_Call
(Loc
,
6231 Name
=> New_Reference_To
(Ent
, Loc
),
6232 Parameter_Associations
=> New_List
(
6233 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
6236 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
6240 -- Common exit point for modular type case
6242 Analyze_And_Resolve
(N
, Typ
);
6245 -- Signed integer cases, done using either Integer or Long_Long_Integer.
6246 -- It is not worth having routines for Short_[Short_]Integer, since for
6247 -- most machines it would not help, and it would generate more code that
6248 -- might need certification when a certified run time is required.
6250 -- In the integer cases, we have two routines, one for when overflow
6251 -- checks are required, and one when they are not required, since there
6252 -- is a real gain in omitting checks on many machines.
6254 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
6255 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
6257 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
6258 or else (Rtyp
= Universal_Integer
)
6260 Etyp
:= Standard_Long_Long_Integer
;
6263 Rent
:= RE_Exp_Long_Long_Integer
;
6265 Rent
:= RE_Exn_Long_Long_Integer
;
6268 elsif Is_Signed_Integer_Type
(Rtyp
) then
6269 Etyp
:= Standard_Integer
;
6272 Rent
:= RE_Exp_Integer
;
6274 Rent
:= RE_Exn_Integer
;
6277 -- Floating-point cases, always done using Long_Long_Float. We do not
6278 -- need separate routines for the overflow case here, since in the case
6279 -- of floating-point, we generate infinities anyway as a rule (either
6280 -- that or we automatically trap overflow), and if there is an infinity
6281 -- generated and a range check is required, the check will fail anyway.
6284 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
6285 Etyp
:= Standard_Long_Long_Float
;
6286 Rent
:= RE_Exn_Long_Long_Float
;
6289 -- Common processing for integer cases and floating-point cases.
6290 -- If we are in the right type, we can call runtime routine directly
6293 and then Rtyp
/= Universal_Integer
6294 and then Rtyp
/= Universal_Real
6297 Make_Function_Call
(Loc
,
6298 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
6299 Parameter_Associations
=> New_List
(Base
, Exp
)));
6301 -- Otherwise we have to introduce conversions (conversions are also
6302 -- required in the universal cases, since the runtime routine is
6303 -- typed using one of the standard types).
6308 Make_Function_Call
(Loc
,
6309 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
6310 Parameter_Associations
=> New_List
(
6311 Convert_To
(Etyp
, Base
),
6315 Analyze_And_Resolve
(N
, Typ
);
6319 when RE_Not_Available
=>
6321 end Expand_N_Op_Expon
;
6323 --------------------
6324 -- Expand_N_Op_Ge --
6325 --------------------
6327 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
6328 Typ
: constant Entity_Id
:= Etype
(N
);
6329 Op1
: constant Node_Id
:= Left_Opnd
(N
);
6330 Op2
: constant Node_Id
:= Right_Opnd
(N
);
6331 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
6334 Binary_Op_Validity_Checks
(N
);
6336 if Is_Array_Type
(Typ1
) then
6337 Expand_Array_Comparison
(N
);
6341 if Is_Boolean_Type
(Typ1
) then
6342 Adjust_Condition
(Op1
);
6343 Adjust_Condition
(Op2
);
6344 Set_Etype
(N
, Standard_Boolean
);
6345 Adjust_Result_Type
(N
, Typ
);
6348 Rewrite_Comparison
(N
);
6350 -- If we still have comparison, and Vax_Float type, process it
6352 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
6353 Expand_Vax_Comparison
(N
);
6358 --------------------
6359 -- Expand_N_Op_Gt --
6360 --------------------
6362 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
6363 Typ
: constant Entity_Id
:= Etype
(N
);
6364 Op1
: constant Node_Id
:= Left_Opnd
(N
);
6365 Op2
: constant Node_Id
:= Right_Opnd
(N
);
6366 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
6369 Binary_Op_Validity_Checks
(N
);
6371 if Is_Array_Type
(Typ1
) then
6372 Expand_Array_Comparison
(N
);
6376 if Is_Boolean_Type
(Typ1
) then
6377 Adjust_Condition
(Op1
);
6378 Adjust_Condition
(Op2
);
6379 Set_Etype
(N
, Standard_Boolean
);
6380 Adjust_Result_Type
(N
, Typ
);
6383 Rewrite_Comparison
(N
);
6385 -- If we still have comparison, and Vax_Float type, process it
6387 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
6388 Expand_Vax_Comparison
(N
);
6393 --------------------
6394 -- Expand_N_Op_Le --
6395 --------------------
6397 procedure Expand_N_Op_Le
(N
: Node_Id
) is
6398 Typ
: constant Entity_Id
:= Etype
(N
);
6399 Op1
: constant Node_Id
:= Left_Opnd
(N
);
6400 Op2
: constant Node_Id
:= Right_Opnd
(N
);
6401 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
6404 Binary_Op_Validity_Checks
(N
);
6406 if Is_Array_Type
(Typ1
) then
6407 Expand_Array_Comparison
(N
);
6411 if Is_Boolean_Type
(Typ1
) then
6412 Adjust_Condition
(Op1
);
6413 Adjust_Condition
(Op2
);
6414 Set_Etype
(N
, Standard_Boolean
);
6415 Adjust_Result_Type
(N
, Typ
);
6418 Rewrite_Comparison
(N
);
6420 -- If we still have comparison, and Vax_Float type, process it
6422 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
6423 Expand_Vax_Comparison
(N
);
6428 --------------------
6429 -- Expand_N_Op_Lt --
6430 --------------------
6432 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
6433 Typ
: constant Entity_Id
:= Etype
(N
);
6434 Op1
: constant Node_Id
:= Left_Opnd
(N
);
6435 Op2
: constant Node_Id
:= Right_Opnd
(N
);
6436 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
6439 Binary_Op_Validity_Checks
(N
);
6441 if Is_Array_Type
(Typ1
) then
6442 Expand_Array_Comparison
(N
);
6446 if Is_Boolean_Type
(Typ1
) then
6447 Adjust_Condition
(Op1
);
6448 Adjust_Condition
(Op2
);
6449 Set_Etype
(N
, Standard_Boolean
);
6450 Adjust_Result_Type
(N
, Typ
);
6453 Rewrite_Comparison
(N
);
6455 -- If we still have comparison, and Vax_Float type, process it
6457 if Vax_Float
(Typ1
) and then Nkind
(N
) in N_Op_Compare
then
6458 Expand_Vax_Comparison
(N
);
6463 -----------------------
6464 -- Expand_N_Op_Minus --
6465 -----------------------
6467 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
6468 Loc
: constant Source_Ptr
:= Sloc
(N
);
6469 Typ
: constant Entity_Id
:= Etype
(N
);
6472 Unary_Op_Validity_Checks
(N
);
6474 if not Backend_Overflow_Checks_On_Target
6475 and then Is_Signed_Integer_Type
(Etype
(N
))
6476 and then Do_Overflow_Check
(N
)
6478 -- Software overflow checking expands -expr into (0 - expr)
6481 Make_Op_Subtract
(Loc
,
6482 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
6483 Right_Opnd
=> Right_Opnd
(N
)));
6485 Analyze_And_Resolve
(N
, Typ
);
6487 -- Vax floating-point types case
6489 elsif Vax_Float
(Etype
(N
)) then
6490 Expand_Vax_Arith
(N
);
6492 end Expand_N_Op_Minus
;
6494 ---------------------
6495 -- Expand_N_Op_Mod --
6496 ---------------------
6498 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
6499 Loc
: constant Source_Ptr
:= Sloc
(N
);
6500 Typ
: constant Entity_Id
:= Etype
(N
);
6501 Left
: constant Node_Id
:= Left_Opnd
(N
);
6502 Right
: constant Node_Id
:= Right_Opnd
(N
);
6503 DOC
: constant Boolean := Do_Overflow_Check
(N
);
6504 DDC
: constant Boolean := Do_Division_Check
(N
);
6514 pragma Warnings
(Off
, Lhi
);
6517 Binary_Op_Validity_Checks
(N
);
6519 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
6520 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
6522 -- Convert mod to rem if operands are known non-negative. We do this
6523 -- since it is quite likely that this will improve the quality of code,
6524 -- (the operation now corresponds to the hardware remainder), and it
6525 -- does not seem likely that it could be harmful.
6527 if LOK
and then Llo
>= 0
6529 ROK
and then Rlo
>= 0
6532 Make_Op_Rem
(Sloc
(N
),
6533 Left_Opnd
=> Left_Opnd
(N
),
6534 Right_Opnd
=> Right_Opnd
(N
)));
6536 -- Instead of reanalyzing the node we do the analysis manually. This
6537 -- avoids anomalies when the replacement is done in an instance and
6538 -- is epsilon more efficient.
6540 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
6542 Set_Do_Overflow_Check
(N
, DOC
);
6543 Set_Do_Division_Check
(N
, DDC
);
6544 Expand_N_Op_Rem
(N
);
6547 -- Otherwise, normal mod processing
6550 if Is_Integer_Type
(Etype
(N
)) then
6551 Apply_Divide_Check
(N
);
6554 -- Apply optimization x mod 1 = 0. We don't really need that with
6555 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
6556 -- certainly harmless.
6558 if Is_Integer_Type
(Etype
(N
))
6559 and then Compile_Time_Known_Value
(Right
)
6560 and then Expr_Value
(Right
) = Uint_1
6562 -- Call Remove_Side_Effects to ensure that any side effects in
6563 -- the ignored left operand (in particular function calls to
6564 -- user defined functions) are properly executed.
6566 Remove_Side_Effects
(Left
);
6568 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6569 Analyze_And_Resolve
(N
, Typ
);
6573 -- Deal with annoying case of largest negative number remainder
6574 -- minus one. Gigi does not handle this case correctly, because
6575 -- it generates a divide instruction which may trap in this case.
6577 -- In fact the check is quite easy, if the right operand is -1, then
6578 -- the mod value is always 0, and we can just ignore the left operand
6579 -- completely in this case.
6581 -- The operand type may be private (e.g. in the expansion of an
6582 -- intrinsic operation) so we must use the underlying type to get the
6583 -- bounds, and convert the literals explicitly.
6587 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
6589 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
6591 ((not LOK
) or else (Llo
= LLB
))
6594 Make_Conditional_Expression
(Loc
,
6595 Expressions
=> New_List
(
6597 Left_Opnd
=> Duplicate_Subexpr
(Right
),
6599 Unchecked_Convert_To
(Typ
,
6600 Make_Integer_Literal
(Loc
, -1))),
6601 Unchecked_Convert_To
(Typ
,
6602 Make_Integer_Literal
(Loc
, Uint_0
)),
6603 Relocate_Node
(N
))));
6605 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
6606 Analyze_And_Resolve
(N
, Typ
);
6609 end Expand_N_Op_Mod
;
6611 --------------------------
6612 -- Expand_N_Op_Multiply --
6613 --------------------------
6615 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
6616 Loc
: constant Source_Ptr
:= Sloc
(N
);
6617 Lop
: constant Node_Id
:= Left_Opnd
(N
);
6618 Rop
: constant Node_Id
:= Right_Opnd
(N
);
6620 Lp2
: constant Boolean :=
6621 Nkind
(Lop
) = N_Op_Expon
6622 and then Is_Power_Of_2_For_Shift
(Lop
);
6624 Rp2
: constant Boolean :=
6625 Nkind
(Rop
) = N_Op_Expon
6626 and then Is_Power_Of_2_For_Shift
(Rop
);
6628 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
6629 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
6630 Typ
: Entity_Id
:= Etype
(N
);
6633 Binary_Op_Validity_Checks
(N
);
6635 -- Special optimizations for integer types
6637 if Is_Integer_Type
(Typ
) then
6639 -- N * 0 = 0 for integer types
6641 if Compile_Time_Known_Value
(Rop
)
6642 and then Expr_Value
(Rop
) = Uint_0
6644 -- Call Remove_Side_Effects to ensure that any side effects in
6645 -- the ignored left operand (in particular function calls to
6646 -- user defined functions) are properly executed.
6648 Remove_Side_Effects
(Lop
);
6650 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
6651 Analyze_And_Resolve
(N
, Typ
);
6655 -- Similar handling for 0 * N = 0
6657 if Compile_Time_Known_Value
(Lop
)
6658 and then Expr_Value
(Lop
) = Uint_0
6660 Remove_Side_Effects
(Rop
);
6661 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
6662 Analyze_And_Resolve
(N
, Typ
);
6666 -- N * 1 = 1 * N = N for integer types
6668 -- This optimisation is not done if we are going to
6669 -- rewrite the product 1 * 2 ** N to a shift.
6671 if Compile_Time_Known_Value
(Rop
)
6672 and then Expr_Value
(Rop
) = Uint_1
6678 elsif Compile_Time_Known_Value
(Lop
)
6679 and then Expr_Value
(Lop
) = Uint_1
6687 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
6688 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6689 -- operand is an integer, as required for this to work.
6694 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
6698 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
6701 Left_Opnd
=> Right_Opnd
(Lop
),
6702 Right_Opnd
=> Right_Opnd
(Rop
))));
6703 Analyze_And_Resolve
(N
, Typ
);
6708 Make_Op_Shift_Left
(Loc
,
6711 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
6712 Analyze_And_Resolve
(N
, Typ
);
6716 -- Same processing for the operands the other way round
6720 Make_Op_Shift_Left
(Loc
,
6723 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
6724 Analyze_And_Resolve
(N
, Typ
);
6728 -- Do required fixup of universal fixed operation
6730 if Typ
= Universal_Fixed
then
6731 Fixup_Universal_Fixed_Operation
(N
);
6735 -- Multiplications with fixed-point results
6737 if Is_Fixed_Point_Type
(Typ
) then
6739 -- No special processing if Treat_Fixed_As_Integer is set, since from
6740 -- a semantic point of view such operations are simply integer
6741 -- operations and will be treated that way.
6743 if not Treat_Fixed_As_Integer
(N
) then
6745 -- Case of fixed * integer => fixed
6747 if Is_Integer_Type
(Rtyp
) then
6748 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
6750 -- Case of integer * fixed => fixed
6752 elsif Is_Integer_Type
(Ltyp
) then
6753 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
6755 -- Case of fixed * fixed => fixed
6758 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
6762 -- Other cases of multiplication of fixed-point operands. Again we
6763 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
6765 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
6766 and then not Treat_Fixed_As_Integer
(N
)
6768 if Is_Integer_Type
(Typ
) then
6769 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
6771 pragma Assert
(Is_Floating_Point_Type
(Typ
));
6772 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
6775 -- Mixed-mode operations can appear in a non-static universal context,
6776 -- in which case the integer argument must be converted explicitly.
6778 elsif Typ
= Universal_Real
6779 and then Is_Integer_Type
(Rtyp
)
6781 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
6783 Analyze_And_Resolve
(Rop
, Universal_Real
);
6785 elsif Typ
= Universal_Real
6786 and then Is_Integer_Type
(Ltyp
)
6788 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
6790 Analyze_And_Resolve
(Lop
, Universal_Real
);
6792 -- Non-fixed point cases, check software overflow checking required
6794 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
6795 Apply_Arithmetic_Overflow_Check
(N
);
6797 -- Deal with VAX float case
6799 elsif Vax_Float
(Typ
) then
6800 Expand_Vax_Arith
(N
);
6803 end Expand_N_Op_Multiply
;
6805 --------------------
6806 -- Expand_N_Op_Ne --
6807 --------------------
6809 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
6810 Typ
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
6813 -- Case of elementary type with standard operator
6815 if Is_Elementary_Type
(Typ
)
6816 and then Sloc
(Entity
(N
)) = Standard_Location
6818 Binary_Op_Validity_Checks
(N
);
6820 -- Boolean types (requiring handling of non-standard case)
6822 if Is_Boolean_Type
(Typ
) then
6823 Adjust_Condition
(Left_Opnd
(N
));
6824 Adjust_Condition
(Right_Opnd
(N
));
6825 Set_Etype
(N
, Standard_Boolean
);
6826 Adjust_Result_Type
(N
, Typ
);
6829 Rewrite_Comparison
(N
);
6831 -- If we still have comparison for Vax_Float, process it
6833 if Vax_Float
(Typ
) and then Nkind
(N
) in N_Op_Compare
then
6834 Expand_Vax_Comparison
(N
);
6838 -- For all cases other than elementary types, we rewrite node as the
6839 -- negation of an equality operation, and reanalyze. The equality to be
6840 -- used is defined in the same scope and has the same signature. This
6841 -- signature must be set explicitly since in an instance it may not have
6842 -- the same visibility as in the generic unit. This avoids duplicating
6843 -- or factoring the complex code for record/array equality tests etc.
6847 Loc
: constant Source_Ptr
:= Sloc
(N
);
6849 Ne
: constant Entity_Id
:= Entity
(N
);
6852 Binary_Op_Validity_Checks
(N
);
6858 Left_Opnd
=> Left_Opnd
(N
),
6859 Right_Opnd
=> Right_Opnd
(N
)));
6860 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
6862 if Scope
(Ne
) /= Standard_Standard
then
6863 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
6866 -- For navigation purposes, the inequality is treated as an
6867 -- implicit reference to the corresponding equality. Preserve the
6868 -- Comes_From_ source flag so that the proper Xref entry is
6871 Preserve_Comes_From_Source
(Neg
, N
);
6872 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
6874 Analyze_And_Resolve
(N
, Standard_Boolean
);
6879 ---------------------
6880 -- Expand_N_Op_Not --
6881 ---------------------
6883 -- If the argument is other than a Boolean array type, there is no special
6884 -- expansion required, except for VMS operations on signed integers.
6886 -- For the packed case, we call the special routine in Exp_Pakd, except
6887 -- that if the component size is greater than one, we use the standard
6888 -- routine generating a gruesome loop (it is so peculiar to have packed
6889 -- arrays with non-standard Boolean representations anyway, so it does not
6890 -- matter that we do not handle this case efficiently).
6892 -- For the unpacked case (and for the special packed case where we have non
6893 -- standard Booleans, as discussed above), we generate and insert into the
6894 -- tree the following function definition:
6896 -- function Nnnn (A : arr) is
6899 -- for J in a'range loop
6900 -- B (J) := not A (J);
6905 -- Here arr is the actual subtype of the parameter (and hence always
6906 -- constrained). Then we replace the not with a call to this function.
6908 procedure Expand_N_Op_Not
(N
: Node_Id
) is
6909 Loc
: constant Source_Ptr
:= Sloc
(N
);
6910 Typ
: constant Entity_Id
:= Etype
(N
);
6919 Func_Name
: Entity_Id
;
6920 Loop_Statement
: Node_Id
;
6923 Unary_Op_Validity_Checks
(N
);
6925 -- For boolean operand, deal with non-standard booleans
6927 if Is_Boolean_Type
(Typ
) then
6928 Adjust_Condition
(Right_Opnd
(N
));
6929 Set_Etype
(N
, Standard_Boolean
);
6930 Adjust_Result_Type
(N
, Typ
);
6934 -- For the VMS "not" on signed integer types, use conversion to and
6935 -- from a predefined modular type.
6937 if Is_VMS_Operator
(Entity
(N
)) then
6943 -- If this is a derived type, retrieve original VMS type so that
6944 -- the proper sized type is used for intermediate values.
6946 if Is_Derived_Type
(Typ
) then
6947 Rtyp
:= First_Subtype
(Etype
(Typ
));
6952 -- The proper unsigned type must have a size compatible with the
6953 -- operand, to prevent misalignment.
6955 if RM_Size
(Rtyp
) <= 8 then
6956 Utyp
:= RTE
(RE_Unsigned_8
);
6958 elsif RM_Size
(Rtyp
) <= 16 then
6959 Utyp
:= RTE
(RE_Unsigned_16
);
6961 elsif RM_Size
(Rtyp
) = RM_Size
(Standard_Unsigned
) then
6962 Utyp
:= RTE
(RE_Unsigned_32
);
6965 Utyp
:= RTE
(RE_Long_Long_Unsigned
);
6969 Unchecked_Convert_To
(Typ
,
6971 Unchecked_Convert_To
(Utyp
, Right_Opnd
(N
)))));
6972 Analyze_And_Resolve
(N
, Typ
);
6977 -- Only array types need any other processing
6979 if not Is_Array_Type
(Typ
) then
6983 -- Case of array operand. If bit packed with a component size of 1,
6984 -- handle it in Exp_Pakd if the operand is known to be aligned.
6986 if Is_Bit_Packed_Array
(Typ
)
6987 and then Component_Size
(Typ
) = 1
6988 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
6990 Expand_Packed_Not
(N
);
6994 -- Case of array operand which is not bit-packed. If the context is
6995 -- a safe assignment, call in-place operation, If context is a larger
6996 -- boolean expression in the context of a safe assignment, expansion is
6997 -- done by enclosing operation.
6999 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
7000 Convert_To_Actual_Subtype
(Opnd
);
7001 Arr
:= Etype
(Opnd
);
7002 Ensure_Defined
(Arr
, N
);
7003 Silly_Boolean_Array_Not_Test
(N
, Arr
);
7005 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
7006 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
7007 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
7010 -- Special case the negation of a binary operation
7012 elsif Nkind_In
(Opnd
, N_Op_And
, N_Op_Or
, N_Op_Xor
)
7013 and then Safe_In_Place_Array_Op
7014 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
7016 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
7020 elsif Nkind
(Parent
(N
)) in N_Binary_Op
7021 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
7024 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
7025 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
7026 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
7029 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
7031 -- (not A) op (not B) can be reduced to a single call
7033 if N
= Op1
and then Nkind
(Op2
) = N_Op_Not
then
7036 -- A xor (not B) can also be special-cased
7038 elsif N
= Op2
and then Nkind
(Parent
(N
)) = N_Op_Xor
then
7045 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
7046 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7047 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
7050 Make_Indexed_Component
(Loc
,
7051 Prefix
=> New_Reference_To
(A
, Loc
),
7052 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
7055 Make_Indexed_Component
(Loc
,
7056 Prefix
=> New_Reference_To
(B
, Loc
),
7057 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
7060 Make_Implicit_Loop_Statement
(N
,
7061 Identifier
=> Empty
,
7064 Make_Iteration_Scheme
(Loc
,
7065 Loop_Parameter_Specification
=>
7066 Make_Loop_Parameter_Specification
(Loc
,
7067 Defining_Identifier
=> J
,
7068 Discrete_Subtype_Definition
=>
7069 Make_Attribute_Reference
(Loc
,
7070 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
7071 Attribute_Name
=> Name_Range
))),
7073 Statements
=> New_List
(
7074 Make_Assignment_Statement
(Loc
,
7076 Expression
=> Make_Op_Not
(Loc
, A_J
))));
7078 Func_Name
:= Make_Temporary
(Loc
, 'N');
7079 Set_Is_Inlined
(Func_Name
);
7082 Make_Subprogram_Body
(Loc
,
7084 Make_Function_Specification
(Loc
,
7085 Defining_Unit_Name
=> Func_Name
,
7086 Parameter_Specifications
=> New_List
(
7087 Make_Parameter_Specification
(Loc
,
7088 Defining_Identifier
=> A
,
7089 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))),
7090 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
7092 Declarations
=> New_List
(
7093 Make_Object_Declaration
(Loc
,
7094 Defining_Identifier
=> B
,
7095 Object_Definition
=> New_Reference_To
(Arr
, Loc
))),
7097 Handled_Statement_Sequence
=>
7098 Make_Handled_Sequence_Of_Statements
(Loc
,
7099 Statements
=> New_List
(
7101 Make_Simple_Return_Statement
(Loc
,
7102 Expression
=> Make_Identifier
(Loc
, Chars
(B
)))))));
7105 Make_Function_Call
(Loc
,
7106 Name
=> New_Reference_To
(Func_Name
, Loc
),
7107 Parameter_Associations
=> New_List
(Opnd
)));
7109 Analyze_And_Resolve
(N
, Typ
);
7110 end Expand_N_Op_Not
;
7112 --------------------
7113 -- Expand_N_Op_Or --
7114 --------------------
7116 procedure Expand_N_Op_Or
(N
: Node_Id
) is
7117 Typ
: constant Entity_Id
:= Etype
(N
);
7120 Binary_Op_Validity_Checks
(N
);
7122 if Is_Array_Type
(Etype
(N
)) then
7123 Expand_Boolean_Operator
(N
);
7125 elsif Is_Boolean_Type
(Etype
(N
)) then
7127 -- Replace OR by OR ELSE if Short_Circuit_And_Or active and the type
7128 -- is standard Boolean (do not mess with AND that uses a non-standard
7129 -- Boolean type, because something strange is going on).
7131 if Short_Circuit_And_Or
and then Typ
= Standard_Boolean
then
7133 Make_Or_Else
(Sloc
(N
),
7134 Left_Opnd
=> Relocate_Node
(Left_Opnd
(N
)),
7135 Right_Opnd
=> Relocate_Node
(Right_Opnd
(N
))));
7136 Analyze_And_Resolve
(N
, Typ
);
7138 -- Otherwise, adjust conditions
7141 Adjust_Condition
(Left_Opnd
(N
));
7142 Adjust_Condition
(Right_Opnd
(N
));
7143 Set_Etype
(N
, Standard_Boolean
);
7144 Adjust_Result_Type
(N
, Typ
);
7149 ----------------------
7150 -- Expand_N_Op_Plus --
7151 ----------------------
7153 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
7155 Unary_Op_Validity_Checks
(N
);
7156 end Expand_N_Op_Plus
;
7158 ---------------------
7159 -- Expand_N_Op_Rem --
7160 ---------------------
7162 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
7163 Loc
: constant Source_Ptr
:= Sloc
(N
);
7164 Typ
: constant Entity_Id
:= Etype
(N
);
7166 Left
: constant Node_Id
:= Left_Opnd
(N
);
7167 Right
: constant Node_Id
:= Right_Opnd
(N
);
7175 -- Set if corresponding operand can be negative
7177 pragma Unreferenced
(Hi
);
7180 Binary_Op_Validity_Checks
(N
);
7182 if Is_Integer_Type
(Etype
(N
)) then
7183 Apply_Divide_Check
(N
);
7186 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
7187 -- but it is useful with other back ends (e.g. AAMP), and is certainly
7190 if Is_Integer_Type
(Etype
(N
))
7191 and then Compile_Time_Known_Value
(Right
)
7192 and then Expr_Value
(Right
) = Uint_1
7194 -- Call Remove_Side_Effects to ensure that any side effects in the
7195 -- ignored left operand (in particular function calls to user defined
7196 -- functions) are properly executed.
7198 Remove_Side_Effects
(Left
);
7200 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
7201 Analyze_And_Resolve
(N
, Typ
);
7205 -- Deal with annoying case of largest negative number remainder minus
7206 -- one. Gigi does not handle this case correctly, because it generates
7207 -- a divide instruction which may trap in this case.
7209 -- In fact the check is quite easy, if the right operand is -1, then
7210 -- the remainder is always 0, and we can just ignore the left operand
7211 -- completely in this case.
7213 Determine_Range
(Right
, OK
, Lo
, Hi
, Assume_Valid
=> True);
7214 Lneg
:= (not OK
) or else Lo
< 0;
7216 Determine_Range
(Left
, OK
, Lo
, Hi
, Assume_Valid
=> True);
7217 Rneg
:= (not OK
) or else Lo
< 0;
7219 -- We won't mess with trying to find out if the left operand can really
7220 -- be the largest negative number (that's a pain in the case of private
7221 -- types and this is really marginal). We will just assume that we need
7222 -- the test if the left operand can be negative at all.
7224 if Lneg
and Rneg
then
7226 Make_Conditional_Expression
(Loc
,
7227 Expressions
=> New_List
(
7229 Left_Opnd
=> Duplicate_Subexpr
(Right
),
7231 Unchecked_Convert_To
(Typ
, Make_Integer_Literal
(Loc
, -1))),
7233 Unchecked_Convert_To
(Typ
,
7234 Make_Integer_Literal
(Loc
, Uint_0
)),
7236 Relocate_Node
(N
))));
7238 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
7239 Analyze_And_Resolve
(N
, Typ
);
7241 end Expand_N_Op_Rem
;
7243 -----------------------------
7244 -- Expand_N_Op_Rotate_Left --
7245 -----------------------------
7247 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
7249 Binary_Op_Validity_Checks
(N
);
7250 end Expand_N_Op_Rotate_Left
;
7252 ------------------------------
7253 -- Expand_N_Op_Rotate_Right --
7254 ------------------------------
7256 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
7258 Binary_Op_Validity_Checks
(N
);
7259 end Expand_N_Op_Rotate_Right
;
7261 ----------------------------
7262 -- Expand_N_Op_Shift_Left --
7263 ----------------------------
7265 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
7267 Binary_Op_Validity_Checks
(N
);
7268 end Expand_N_Op_Shift_Left
;
7270 -----------------------------
7271 -- Expand_N_Op_Shift_Right --
7272 -----------------------------
7274 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
7276 Binary_Op_Validity_Checks
(N
);
7277 end Expand_N_Op_Shift_Right
;
7279 ----------------------------------------
7280 -- Expand_N_Op_Shift_Right_Arithmetic --
7281 ----------------------------------------
7283 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
7285 Binary_Op_Validity_Checks
(N
);
7286 end Expand_N_Op_Shift_Right_Arithmetic
;
7288 --------------------------
7289 -- Expand_N_Op_Subtract --
7290 --------------------------
7292 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
7293 Typ
: constant Entity_Id
:= Etype
(N
);
7296 Binary_Op_Validity_Checks
(N
);
7298 -- N - 0 = N for integer types
7300 if Is_Integer_Type
(Typ
)
7301 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
7302 and then Expr_Value
(Right_Opnd
(N
)) = 0
7304 Rewrite
(N
, Left_Opnd
(N
));
7308 -- Arithmetic overflow checks for signed integer/fixed point types
7310 if Is_Signed_Integer_Type
(Typ
)
7312 Is_Fixed_Point_Type
(Typ
)
7314 Apply_Arithmetic_Overflow_Check
(N
);
7316 -- VAX floating-point types case
7318 elsif Vax_Float
(Typ
) then
7319 Expand_Vax_Arith
(N
);
7321 end Expand_N_Op_Subtract
;
7323 ---------------------
7324 -- Expand_N_Op_Xor --
7325 ---------------------
7327 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
7328 Typ
: constant Entity_Id
:= Etype
(N
);
7331 Binary_Op_Validity_Checks
(N
);
7333 if Is_Array_Type
(Etype
(N
)) then
7334 Expand_Boolean_Operator
(N
);
7336 elsif Is_Boolean_Type
(Etype
(N
)) then
7337 Adjust_Condition
(Left_Opnd
(N
));
7338 Adjust_Condition
(Right_Opnd
(N
));
7339 Set_Etype
(N
, Standard_Boolean
);
7340 Adjust_Result_Type
(N
, Typ
);
7342 end Expand_N_Op_Xor
;
7344 ----------------------
7345 -- Expand_N_Or_Else --
7346 ----------------------
7348 procedure Expand_N_Or_Else
(N
: Node_Id
)
7349 renames Expand_Short_Circuit_Operator
;
7351 -----------------------------------
7352 -- Expand_N_Qualified_Expression --
7353 -----------------------------------
7355 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
7356 Operand
: constant Node_Id
:= Expression
(N
);
7357 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
7360 -- Do validity check if validity checking operands
7362 if Validity_Checks_On
7363 and then Validity_Check_Operands
7365 Ensure_Valid
(Operand
);
7368 -- Apply possible constraint check
7370 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
7372 if Do_Range_Check
(Operand
) then
7373 Set_Do_Range_Check
(Operand
, False);
7374 Generate_Range_Check
(Operand
, Target_Type
, CE_Range_Check_Failed
);
7376 end Expand_N_Qualified_Expression
;
7378 ---------------------------------
7379 -- Expand_N_Selected_Component --
7380 ---------------------------------
7382 -- If the selector is a discriminant of a concurrent object, rewrite the
7383 -- prefix to denote the corresponding record type.
7385 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
7386 Loc
: constant Source_Ptr
:= Sloc
(N
);
7387 Par
: constant Node_Id
:= Parent
(N
);
7388 P
: constant Node_Id
:= Prefix
(N
);
7389 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
7395 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
7396 -- Gigi needs a temporary for prefixes that depend on a discriminant,
7397 -- unless the context of an assignment can provide size information.
7398 -- Don't we have a general routine that does this???
7400 -----------------------
7401 -- In_Left_Hand_Side --
7402 -----------------------
7404 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
7406 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
7407 and then Comp
= Name
(Parent
(Comp
)))
7408 or else (Present
(Parent
(Comp
))
7409 and then Nkind
(Parent
(Comp
)) in N_Subexpr
7410 and then In_Left_Hand_Side
(Parent
(Comp
)));
7411 end In_Left_Hand_Side
;
7413 -- Start of processing for Expand_N_Selected_Component
7416 -- Insert explicit dereference if required
7418 if Is_Access_Type
(Ptyp
) then
7419 Insert_Explicit_Dereference
(P
);
7420 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
7422 if Ekind
(Etype
(P
)) = E_Private_Subtype
7423 and then Is_For_Access_Subtype
(Etype
(P
))
7425 Set_Etype
(P
, Base_Type
(Etype
(P
)));
7431 -- Deal with discriminant check required
7433 if Do_Discriminant_Check
(N
) then
7435 -- Present the discriminant checking function to the backend, so that
7436 -- it can inline the call to the function.
7439 (Discriminant_Checking_Func
7440 (Original_Record_Component
(Entity
(Selector_Name
(N
)))));
7442 -- Now reset the flag and generate the call
7444 Set_Do_Discriminant_Check
(N
, False);
7445 Generate_Discriminant_Check
(N
);
7448 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7449 -- function, then additional actuals must be passed.
7451 if Ada_Version
>= Ada_05
7452 and then Is_Build_In_Place_Function_Call
(P
)
7454 Make_Build_In_Place_Call_In_Anonymous_Context
(P
);
7457 -- Gigi cannot handle unchecked conversions that are the prefix of a
7458 -- selected component with discriminants. This must be checked during
7459 -- expansion, because during analysis the type of the selector is not
7460 -- known at the point the prefix is analyzed. If the conversion is the
7461 -- target of an assignment, then we cannot force the evaluation.
7463 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
7464 and then Has_Discriminants
(Etype
(N
))
7465 and then not In_Left_Hand_Side
(N
)
7467 Force_Evaluation
(Prefix
(N
));
7470 -- Remaining processing applies only if selector is a discriminant
7472 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
7474 -- If the selector is a discriminant of a constrained record type,
7475 -- we may be able to rewrite the expression with the actual value
7476 -- of the discriminant, a useful optimization in some cases.
7478 if Is_Record_Type
(Ptyp
)
7479 and then Has_Discriminants
(Ptyp
)
7480 and then Is_Constrained
(Ptyp
)
7482 -- Do this optimization for discrete types only, and not for
7483 -- access types (access discriminants get us into trouble!)
7485 if not Is_Discrete_Type
(Etype
(N
)) then
7488 -- Don't do this on the left hand of an assignment statement.
7489 -- Normally one would think that references like this would not
7490 -- occur, but they do in generated code, and mean that we really
7491 -- do want to assign the discriminant!
7493 elsif Nkind
(Par
) = N_Assignment_Statement
7494 and then Name
(Par
) = N
7498 -- Don't do this optimization for the prefix of an attribute or
7499 -- the name of an object renaming declaration since these are
7500 -- contexts where we do not want the value anyway.
7502 elsif (Nkind
(Par
) = N_Attribute_Reference
7503 and then Prefix
(Par
) = N
)
7504 or else Is_Renamed_Object
(N
)
7508 -- Don't do this optimization if we are within the code for a
7509 -- discriminant check, since the whole point of such a check may
7510 -- be to verify the condition on which the code below depends!
7512 elsif Is_In_Discriminant_Check
(N
) then
7515 -- Green light to see if we can do the optimization. There is
7516 -- still one condition that inhibits the optimization below but
7517 -- now is the time to check the particular discriminant.
7520 -- Loop through discriminants to find the matching discriminant
7521 -- constraint to see if we can copy it.
7523 Disc
:= First_Discriminant
(Ptyp
);
7524 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
7526 Discr_Loop
: while Present
(Dcon
) loop
7527 Dval
:= Node
(Dcon
);
7529 -- Check if this is the matching discriminant
7531 if Disc
= Entity
(Selector_Name
(N
)) then
7533 -- Here we have the matching discriminant. Check for
7534 -- the case of a discriminant of a component that is
7535 -- constrained by an outer discriminant, which cannot
7536 -- be optimized away.
7538 if Denotes_Discriminant
7539 (Dval
, Check_Concurrent
=> True)
7543 elsif Nkind
(Original_Node
(Dval
)) = N_Selected_Component
7545 Denotes_Discriminant
7546 (Selector_Name
(Original_Node
(Dval
)), True)
7550 -- Do not retrieve value if constraint is not static. It
7551 -- is generally not useful, and the constraint may be a
7552 -- rewritten outer discriminant in which case it is in
7555 elsif Is_Entity_Name
(Dval
)
7556 and then Nkind
(Parent
(Entity
(Dval
)))
7557 = N_Object_Declaration
7558 and then Present
(Expression
(Parent
(Entity
(Dval
))))
7560 not Is_Static_Expression
7561 (Expression
(Parent
(Entity
(Dval
))))
7565 -- In the context of a case statement, the expression may
7566 -- have the base type of the discriminant, and we need to
7567 -- preserve the constraint to avoid spurious errors on
7570 elsif Nkind
(Parent
(N
)) = N_Case_Statement
7571 and then Etype
(Dval
) /= Etype
(Disc
)
7574 Make_Qualified_Expression
(Loc
,
7576 New_Occurrence_Of
(Etype
(Disc
), Loc
),
7578 New_Copy_Tree
(Dval
)));
7579 Analyze_And_Resolve
(N
, Etype
(Disc
));
7581 -- In case that comes out as a static expression,
7582 -- reset it (a selected component is never static).
7584 Set_Is_Static_Expression
(N
, False);
7587 -- Otherwise we can just copy the constraint, but the
7588 -- result is certainly not static! In some cases the
7589 -- discriminant constraint has been analyzed in the
7590 -- context of the original subtype indication, but for
7591 -- itypes the constraint might not have been analyzed
7592 -- yet, and this must be done now.
7595 Rewrite
(N
, New_Copy_Tree
(Dval
));
7596 Analyze_And_Resolve
(N
);
7597 Set_Is_Static_Expression
(N
, False);
7603 Next_Discriminant
(Disc
);
7604 end loop Discr_Loop
;
7606 -- Note: the above loop should always find a matching
7607 -- discriminant, but if it does not, we just missed an
7608 -- optimization due to some glitch (perhaps a previous error),
7614 -- The only remaining processing is in the case of a discriminant of
7615 -- a concurrent object, where we rewrite the prefix to denote the
7616 -- corresponding record type. If the type is derived and has renamed
7617 -- discriminants, use corresponding discriminant, which is the one
7618 -- that appears in the corresponding record.
7620 if not Is_Concurrent_Type
(Ptyp
) then
7624 Disc
:= Entity
(Selector_Name
(N
));
7626 if Is_Derived_Type
(Ptyp
)
7627 and then Present
(Corresponding_Discriminant
(Disc
))
7629 Disc
:= Corresponding_Discriminant
(Disc
);
7633 Make_Selected_Component
(Loc
,
7635 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
7637 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
7642 end Expand_N_Selected_Component
;
7644 --------------------
7645 -- Expand_N_Slice --
7646 --------------------
7648 procedure Expand_N_Slice
(N
: Node_Id
) is
7649 Loc
: constant Source_Ptr
:= Sloc
(N
);
7650 Typ
: constant Entity_Id
:= Etype
(N
);
7651 Pfx
: constant Node_Id
:= Prefix
(N
);
7652 Ptp
: Entity_Id
:= Etype
(Pfx
);
7654 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
7655 -- Check whether the argument is an actual for a procedure call, in
7656 -- which case the expansion of a bit-packed slice is deferred until the
7657 -- call itself is expanded. The reason this is required is that we might
7658 -- have an IN OUT or OUT parameter, and the copy out is essential, and
7659 -- that copy out would be missed if we created a temporary here in
7660 -- Expand_N_Slice. Note that we don't bother to test specifically for an
7661 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
7662 -- is harmless to defer expansion in the IN case, since the call
7663 -- processing will still generate the appropriate copy in operation,
7664 -- which will take care of the slice.
7666 procedure Make_Temporary_For_Slice
;
7667 -- Create a named variable for the value of the slice, in cases where
7668 -- the back-end cannot handle it properly, e.g. when packed types or
7669 -- unaligned slices are involved.
7671 -------------------------
7672 -- Is_Procedure_Actual --
7673 -------------------------
7675 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
7676 Par
: Node_Id
:= Parent
(N
);
7680 -- If our parent is a procedure call we can return
7682 if Nkind
(Par
) = N_Procedure_Call_Statement
then
7685 -- If our parent is a type conversion, keep climbing the tree,
7686 -- since a type conversion can be a procedure actual. Also keep
7687 -- climbing if parameter association or a qualified expression,
7688 -- since these are additional cases that do can appear on
7689 -- procedure actuals.
7691 elsif Nkind_In
(Par
, N_Type_Conversion
,
7692 N_Parameter_Association
,
7693 N_Qualified_Expression
)
7695 Par
:= Parent
(Par
);
7697 -- Any other case is not what we are looking for
7703 end Is_Procedure_Actual
;
7705 ------------------------------
7706 -- Make_Temporary_For_Slice --
7707 ------------------------------
7709 procedure Make_Temporary_For_Slice
is
7711 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
7715 Make_Object_Declaration
(Loc
,
7716 Defining_Identifier
=> Ent
,
7717 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
7719 Set_No_Initialization
(Decl
);
7721 Insert_Actions
(N
, New_List
(
7723 Make_Assignment_Statement
(Loc
,
7724 Name
=> New_Occurrence_Of
(Ent
, Loc
),
7725 Expression
=> Relocate_Node
(N
))));
7727 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
7728 Analyze_And_Resolve
(N
, Typ
);
7729 end Make_Temporary_For_Slice
;
7731 -- Start of processing for Expand_N_Slice
7734 -- Special handling for access types
7736 if Is_Access_Type
(Ptp
) then
7738 Ptp
:= Designated_Type
(Ptp
);
7741 Make_Explicit_Dereference
(Sloc
(N
),
7742 Prefix
=> Relocate_Node
(Pfx
)));
7744 Analyze_And_Resolve
(Pfx
, Ptp
);
7747 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7748 -- function, then additional actuals must be passed.
7750 if Ada_Version
>= Ada_05
7751 and then Is_Build_In_Place_Function_Call
(Pfx
)
7753 Make_Build_In_Place_Call_In_Anonymous_Context
(Pfx
);
7756 -- The remaining case to be handled is packed slices. We can leave
7757 -- packed slices as they are in the following situations:
7759 -- 1. Right or left side of an assignment (we can handle this
7760 -- situation correctly in the assignment statement expansion).
7762 -- 2. Prefix of indexed component (the slide is optimized away in this
7763 -- case, see the start of Expand_N_Slice.)
7765 -- 3. Object renaming declaration, since we want the name of the
7766 -- slice, not the value.
7768 -- 4. Argument to procedure call, since copy-in/copy-out handling may
7769 -- be required, and this is handled in the expansion of call
7772 -- 5. Prefix of an address attribute (this is an error which is caught
7773 -- elsewhere, and the expansion would interfere with generating the
7776 if not Is_Packed
(Typ
) then
7778 -- Apply transformation for actuals of a function call, where
7779 -- Expand_Actuals is not used.
7781 if Nkind
(Parent
(N
)) = N_Function_Call
7782 and then Is_Possibly_Unaligned_Slice
(N
)
7784 Make_Temporary_For_Slice
;
7787 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
7788 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
7789 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
7793 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
7794 or else Is_Renamed_Object
(N
)
7795 or else Is_Procedure_Actual
(N
)
7799 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
7800 and then Attribute_Name
(Parent
(N
)) = Name_Address
7805 Make_Temporary_For_Slice
;
7809 ------------------------------
7810 -- Expand_N_Type_Conversion --
7811 ------------------------------
7813 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
7814 Loc
: constant Source_Ptr
:= Sloc
(N
);
7815 Operand
: constant Node_Id
:= Expression
(N
);
7816 Target_Type
: constant Entity_Id
:= Etype
(N
);
7817 Operand_Type
: Entity_Id
:= Etype
(Operand
);
7819 procedure Handle_Changed_Representation
;
7820 -- This is called in the case of record and array type conversions to
7821 -- see if there is a change of representation to be handled. Change of
7822 -- representation is actually handled at the assignment statement level,
7823 -- and what this procedure does is rewrite node N conversion as an
7824 -- assignment to temporary. If there is no change of representation,
7825 -- then the conversion node is unchanged.
7827 procedure Raise_Accessibility_Error
;
7828 -- Called when we know that an accessibility check will fail. Rewrites
7829 -- node N to an appropriate raise statement and outputs warning msgs.
7830 -- The Etype of the raise node is set to Target_Type.
7832 procedure Real_Range_Check
;
7833 -- Handles generation of range check for real target value
7835 -----------------------------------
7836 -- Handle_Changed_Representation --
7837 -----------------------------------
7839 procedure Handle_Changed_Representation
is
7848 -- Nothing else to do if no change of representation
7850 if Same_Representation
(Operand_Type
, Target_Type
) then
7853 -- The real change of representation work is done by the assignment
7854 -- statement processing. So if this type conversion is appearing as
7855 -- the expression of an assignment statement, nothing needs to be
7856 -- done to the conversion.
7858 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
7861 -- Otherwise we need to generate a temporary variable, and do the
7862 -- change of representation assignment into that temporary variable.
7863 -- The conversion is then replaced by a reference to this variable.
7868 -- If type is unconstrained we have to add a constraint, copied
7869 -- from the actual value of the left hand side.
7871 if not Is_Constrained
(Target_Type
) then
7872 if Has_Discriminants
(Operand_Type
) then
7873 Disc
:= First_Discriminant
(Operand_Type
);
7875 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
7876 Disc
:= First_Stored_Discriminant
(Operand_Type
);
7880 while Present
(Disc
) loop
7882 Make_Selected_Component
(Loc
,
7883 Prefix
=> Duplicate_Subexpr_Move_Checks
(Operand
),
7885 Make_Identifier
(Loc
, Chars
(Disc
))));
7886 Next_Discriminant
(Disc
);
7889 elsif Is_Array_Type
(Operand_Type
) then
7890 N_Ix
:= First_Index
(Target_Type
);
7893 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
7895 -- We convert the bounds explicitly. We use an unchecked
7896 -- conversion because bounds checks are done elsewhere.
7901 Unchecked_Convert_To
(Etype
(N_Ix
),
7902 Make_Attribute_Reference
(Loc
,
7904 Duplicate_Subexpr_No_Checks
7905 (Operand
, Name_Req
=> True),
7906 Attribute_Name
=> Name_First
,
7907 Expressions
=> New_List
(
7908 Make_Integer_Literal
(Loc
, J
)))),
7911 Unchecked_Convert_To
(Etype
(N_Ix
),
7912 Make_Attribute_Reference
(Loc
,
7914 Duplicate_Subexpr_No_Checks
7915 (Operand
, Name_Req
=> True),
7916 Attribute_Name
=> Name_Last
,
7917 Expressions
=> New_List
(
7918 Make_Integer_Literal
(Loc
, J
))))));
7925 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
7927 if Present
(Cons
) then
7929 Make_Subtype_Indication
(Loc
,
7930 Subtype_Mark
=> Odef
,
7932 Make_Index_Or_Discriminant_Constraint
(Loc
,
7933 Constraints
=> Cons
));
7936 Temp
:= Make_Temporary
(Loc
, 'C');
7938 Make_Object_Declaration
(Loc
,
7939 Defining_Identifier
=> Temp
,
7940 Object_Definition
=> Odef
);
7942 Set_No_Initialization
(Decl
, True);
7944 -- Insert required actions. It is essential to suppress checks
7945 -- since we have suppressed default initialization, which means
7946 -- that the variable we create may have no discriminants.
7951 Make_Assignment_Statement
(Loc
,
7952 Name
=> New_Occurrence_Of
(Temp
, Loc
),
7953 Expression
=> Relocate_Node
(N
))),
7954 Suppress
=> All_Checks
);
7956 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7959 end Handle_Changed_Representation
;
7961 -------------------------------
7962 -- Raise_Accessibility_Error --
7963 -------------------------------
7965 procedure Raise_Accessibility_Error
is
7968 Make_Raise_Program_Error
(Sloc
(N
),
7969 Reason
=> PE_Accessibility_Check_Failed
));
7970 Set_Etype
(N
, Target_Type
);
7972 Error_Msg_N
("?accessibility check failure", N
);
7974 ("\?& will be raised at run time", N
, Standard_Program_Error
);
7975 end Raise_Accessibility_Error
;
7977 ----------------------
7978 -- Real_Range_Check --
7979 ----------------------
7981 -- Case of conversions to floating-point or fixed-point. If range checks
7982 -- are enabled and the target type has a range constraint, we convert:
7988 -- Tnn : typ'Base := typ'Base (x);
7989 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7992 -- This is necessary when there is a conversion of integer to float or
7993 -- to fixed-point to ensure that the correct checks are made. It is not
7994 -- necessary for float to float where it is enough to simply set the
7995 -- Do_Range_Check flag.
7997 procedure Real_Range_Check
is
7998 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
7999 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
8000 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
8001 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
8006 -- Nothing to do if conversion was rewritten
8008 if Nkind
(N
) /= N_Type_Conversion
then
8012 -- Nothing to do if range checks suppressed, or target has the same
8013 -- range as the base type (or is the base type).
8015 if Range_Checks_Suppressed
(Target_Type
)
8016 or else (Lo
= Type_Low_Bound
(Btyp
)
8018 Hi
= Type_High_Bound
(Btyp
))
8023 -- Nothing to do if expression is an entity on which checks have been
8026 if Is_Entity_Name
(Operand
)
8027 and then Range_Checks_Suppressed
(Entity
(Operand
))
8032 -- Nothing to do if bounds are all static and we can tell that the
8033 -- expression is within the bounds of the target. Note that if the
8034 -- operand is of an unconstrained floating-point type, then we do
8035 -- not trust it to be in range (might be infinite)
8038 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
8039 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
8042 if (not Is_Floating_Point_Type
(Xtyp
)
8043 or else Is_Constrained
(Xtyp
))
8044 and then Compile_Time_Known_Value
(S_Lo
)
8045 and then Compile_Time_Known_Value
(S_Hi
)
8046 and then Compile_Time_Known_Value
(Hi
)
8047 and then Compile_Time_Known_Value
(Lo
)
8050 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
8051 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
8056 if Is_Real_Type
(Xtyp
) then
8057 S_Lov
:= Expr_Value_R
(S_Lo
);
8058 S_Hiv
:= Expr_Value_R
(S_Hi
);
8060 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
8061 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
8065 and then S_Lov
>= D_Lov
8066 and then S_Hiv
<= D_Hiv
8068 Set_Do_Range_Check
(Operand
, False);
8075 -- For float to float conversions, we are done
8077 if Is_Floating_Point_Type
(Xtyp
)
8079 Is_Floating_Point_Type
(Btyp
)
8084 -- Otherwise rewrite the conversion as described above
8086 Conv
:= Relocate_Node
(N
);
8087 Rewrite
(Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
8088 Set_Etype
(Conv
, Btyp
);
8090 -- Enable overflow except for case of integer to float conversions,
8091 -- where it is never required, since we can never have overflow in
8094 if not Is_Integer_Type
(Etype
(Operand
)) then
8095 Enable_Overflow_Check
(Conv
);
8098 Tnn
:= Make_Temporary
(Loc
, 'T', Conv
);
8100 Insert_Actions
(N
, New_List
(
8101 Make_Object_Declaration
(Loc
,
8102 Defining_Identifier
=> Tnn
,
8103 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
8104 Expression
=> Conv
),
8106 Make_Raise_Constraint_Error
(Loc
,
8111 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8113 Make_Attribute_Reference
(Loc
,
8114 Attribute_Name
=> Name_First
,
8116 New_Occurrence_Of
(Target_Type
, Loc
))),
8120 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
8122 Make_Attribute_Reference
(Loc
,
8123 Attribute_Name
=> Name_Last
,
8125 New_Occurrence_Of
(Target_Type
, Loc
)))),
8126 Reason
=> CE_Range_Check_Failed
)));
8128 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
8129 Analyze_And_Resolve
(N
, Btyp
);
8130 end Real_Range_Check
;
8132 -- Start of processing for Expand_N_Type_Conversion
8135 -- Nothing at all to do if conversion is to the identical type so remove
8136 -- the conversion completely, it is useless, except that it may carry
8137 -- an Assignment_OK attribute, which must be propagated to the operand.
8139 if Operand_Type
= Target_Type
then
8140 if Assignment_OK
(N
) then
8141 Set_Assignment_OK
(Operand
);
8144 Rewrite
(N
, Relocate_Node
(Operand
));
8148 -- Nothing to do if this is the second argument of read. This is a
8149 -- "backwards" conversion that will be handled by the specialized code
8150 -- in attribute processing.
8152 if Nkind
(Parent
(N
)) = N_Attribute_Reference
8153 and then Attribute_Name
(Parent
(N
)) = Name_Read
8154 and then Next
(First
(Expressions
(Parent
(N
)))) = N
8159 -- Here if we may need to expand conversion
8161 -- If the operand of the type conversion is an arithmetic operation on
8162 -- signed integers, and the based type of the signed integer type in
8163 -- question is smaller than Standard.Integer, we promote both of the
8164 -- operands to type Integer.
8166 -- For example, if we have
8168 -- target-type (opnd1 + opnd2)
8170 -- and opnd1 and opnd2 are of type short integer, then we rewrite
8173 -- target-type (integer(opnd1) + integer(opnd2))
8175 -- We do this because we are always allowed to compute in a larger type
8176 -- if we do the right thing with the result, and in this case we are
8177 -- going to do a conversion which will do an appropriate check to make
8178 -- sure that things are in range of the target type in any case. This
8179 -- avoids some unnecessary intermediate overflows.
8181 -- We might consider a similar transformation in the case where the
8182 -- target is a real type or a 64-bit integer type, and the operand
8183 -- is an arithmetic operation using a 32-bit integer type. However,
8184 -- we do not bother with this case, because it could cause significant
8185 -- ineffiencies on 32-bit machines. On a 64-bit machine it would be
8186 -- much cheaper, but we don't want different behavior on 32-bit and
8187 -- 64-bit machines. Note that the exclusion of the 64-bit case also
8188 -- handles the configurable run-time cases where 64-bit arithmetic
8189 -- may simply be unavailable.
8191 -- Note: this circuit is partially redundant with respect to the circuit
8192 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
8193 -- the processing here. Also we still need the Checks circuit, since we
8194 -- have to be sure not to generate junk overflow checks in the first
8195 -- place, since it would be trick to remove them here!
8197 if Integer_Promotion_Possible
(N
) then
8199 -- All conditions met, go ahead with transformation
8207 Make_Type_Conversion
(Loc
,
8208 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
8209 Expression
=> Relocate_Node
(Right_Opnd
(Operand
)));
8211 Opnd
:= New_Op_Node
(Nkind
(Operand
), Loc
);
8212 Set_Right_Opnd
(Opnd
, R
);
8214 if Nkind
(Operand
) in N_Binary_Op
then
8216 Make_Type_Conversion
(Loc
,
8217 Subtype_Mark
=> New_Reference_To
(Standard_Integer
, Loc
),
8218 Expression
=> Relocate_Node
(Left_Opnd
(Operand
)));
8220 Set_Left_Opnd
(Opnd
, L
);
8224 Make_Type_Conversion
(Loc
,
8225 Subtype_Mark
=> Relocate_Node
(Subtype_Mark
(N
)),
8226 Expression
=> Opnd
));
8228 Analyze_And_Resolve
(N
, Target_Type
);
8233 -- Do validity check if validity checking operands
8235 if Validity_Checks_On
8236 and then Validity_Check_Operands
8238 Ensure_Valid
(Operand
);
8241 -- Special case of converting from non-standard boolean type
8243 if Is_Boolean_Type
(Operand_Type
)
8244 and then (Nonzero_Is_True
(Operand_Type
))
8246 Adjust_Condition
(Operand
);
8247 Set_Etype
(Operand
, Standard_Boolean
);
8248 Operand_Type
:= Standard_Boolean
;
8251 -- Case of converting to an access type
8253 if Is_Access_Type
(Target_Type
) then
8255 -- Apply an accessibility check when the conversion operand is an
8256 -- access parameter (or a renaming thereof), unless conversion was
8257 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
8258 -- Note that other checks may still need to be applied below (such
8259 -- as tagged type checks).
8261 if Is_Entity_Name
(Operand
)
8263 (Is_Formal
(Entity
(Operand
))
8265 (Present
(Renamed_Object
(Entity
(Operand
)))
8266 and then Is_Entity_Name
(Renamed_Object
(Entity
(Operand
)))
8268 (Entity
(Renamed_Object
(Entity
(Operand
))))))
8269 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
8270 and then (Nkind
(Original_Node
(N
)) /= N_Attribute_Reference
8271 or else Attribute_Name
(Original_Node
(N
)) = Name_Access
)
8273 Apply_Accessibility_Check
8274 (Operand
, Target_Type
, Insert_Node
=> Operand
);
8276 -- If the level of the operand type is statically deeper than the
8277 -- level of the target type, then force Program_Error. Note that this
8278 -- can only occur for cases where the attribute is within the body of
8279 -- an instantiation (otherwise the conversion will already have been
8280 -- rejected as illegal). Note: warnings are issued by the analyzer
8281 -- for the instance cases.
8283 elsif In_Instance_Body
8284 and then Type_Access_Level
(Operand_Type
) >
8285 Type_Access_Level
(Target_Type
)
8287 Raise_Accessibility_Error
;
8289 -- When the operand is a selected access discriminant the check needs
8290 -- to be made against the level of the object denoted by the prefix
8291 -- of the selected name. Force Program_Error for this case as well
8292 -- (this accessibility violation can only happen if within the body
8293 -- of an instantiation).
8295 elsif In_Instance_Body
8296 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
8297 and then Nkind
(Operand
) = N_Selected_Component
8298 and then Object_Access_Level
(Operand
) >
8299 Type_Access_Level
(Target_Type
)
8301 Raise_Accessibility_Error
;
8306 -- Case of conversions of tagged types and access to tagged types
8308 -- When needed, that is to say when the expression is class-wide, Add
8309 -- runtime a tag check for (strict) downward conversion by using the
8310 -- membership test, generating:
8312 -- [constraint_error when Operand not in Target_Type'Class]
8314 -- or in the access type case
8316 -- [constraint_error
8317 -- when Operand /= null
8318 -- and then Operand.all not in
8319 -- Designated_Type (Target_Type)'Class]
8321 if (Is_Access_Type
(Target_Type
)
8322 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
8323 or else Is_Tagged_Type
(Target_Type
)
8325 -- Do not do any expansion in the access type case if the parent is a
8326 -- renaming, since this is an error situation which will be caught by
8327 -- Sem_Ch8, and the expansion can interfere with this error check.
8329 if Is_Access_Type
(Target_Type
) and then Is_Renamed_Object
(N
) then
8333 -- Otherwise, proceed with processing tagged conversion
8335 Tagged_Conversion
: declare
8336 Actual_Op_Typ
: Entity_Id
;
8337 Actual_Targ_Typ
: Entity_Id
;
8338 Make_Conversion
: Boolean := False;
8339 Root_Op_Typ
: Entity_Id
;
8341 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
);
8342 -- Create a membership check to test whether Operand is a member
8343 -- of Targ_Typ. If the original Target_Type is an access, include
8344 -- a test for null value. The check is inserted at N.
8346 --------------------
8347 -- Make_Tag_Check --
8348 --------------------
8350 procedure Make_Tag_Check
(Targ_Typ
: Entity_Id
) is
8355 -- [Constraint_Error
8356 -- when Operand /= null
8357 -- and then Operand.all not in Targ_Typ]
8359 if Is_Access_Type
(Target_Type
) then
8364 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
8365 Right_Opnd
=> Make_Null
(Loc
)),
8370 Make_Explicit_Dereference
(Loc
,
8371 Prefix
=> Duplicate_Subexpr_No_Checks
(Operand
)),
8372 Right_Opnd
=> New_Reference_To
(Targ_Typ
, Loc
)));
8375 -- [Constraint_Error when Operand not in Targ_Typ]
8380 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
8381 Right_Opnd
=> New_Reference_To
(Targ_Typ
, Loc
));
8385 Make_Raise_Constraint_Error
(Loc
,
8387 Reason
=> CE_Tag_Check_Failed
));
8390 -- Start of processing for Tagged_Conversion
8393 if Is_Access_Type
(Target_Type
) then
8395 -- Handle entities from the limited view
8398 Available_View
(Designated_Type
(Operand_Type
));
8400 Available_View
(Designated_Type
(Target_Type
));
8402 Actual_Op_Typ
:= Operand_Type
;
8403 Actual_Targ_Typ
:= Target_Type
;
8406 Root_Op_Typ
:= Root_Type
(Actual_Op_Typ
);
8408 -- Ada 2005 (AI-251): Handle interface type conversion
8410 if Is_Interface
(Actual_Op_Typ
) then
8411 Expand_Interface_Conversion
(N
, Is_Static
=> False);
8415 if not Tag_Checks_Suppressed
(Actual_Targ_Typ
) then
8417 -- Create a runtime tag check for a downward class-wide type
8420 if Is_Class_Wide_Type
(Actual_Op_Typ
)
8421 and then Actual_Op_Typ
/= Actual_Targ_Typ
8422 and then Root_Op_Typ
/= Actual_Targ_Typ
8423 and then Is_Ancestor
(Root_Op_Typ
, Actual_Targ_Typ
)
8425 Make_Tag_Check
(Class_Wide_Type
(Actual_Targ_Typ
));
8426 Make_Conversion
:= True;
8429 -- AI05-0073: If the result subtype of the function is defined
8430 -- by an access_definition designating a specific tagged type
8431 -- T, a check is made that the result value is null or the tag
8432 -- of the object designated by the result value identifies T.
8433 -- Constraint_Error is raised if this check fails.
8435 if Nkind
(Parent
(N
)) = Sinfo
.N_Return_Statement
then
8438 Func_Typ
: Entity_Id
;
8441 -- Climb scope stack looking for the enclosing function
8443 Func
:= Current_Scope
;
8444 while Present
(Func
)
8445 and then Ekind
(Func
) /= E_Function
8447 Func
:= Scope
(Func
);
8450 -- The function's return subtype must be defined using
8451 -- an access definition.
8453 if Nkind
(Result_Definition
(Parent
(Func
))) =
8456 Func_Typ
:= Directly_Designated_Type
(Etype
(Func
));
8458 -- The return subtype denotes a specific tagged type,
8459 -- in other words, a non class-wide type.
8461 if Is_Tagged_Type
(Func_Typ
)
8462 and then not Is_Class_Wide_Type
(Func_Typ
)
8464 Make_Tag_Check
(Actual_Targ_Typ
);
8465 Make_Conversion
:= True;
8471 -- We have generated a tag check for either a class-wide type
8472 -- conversion or for AI05-0073.
8474 if Make_Conversion
then
8479 Make_Unchecked_Type_Conversion
(Loc
,
8480 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
8481 Expression
=> Relocate_Node
(Expression
(N
)));
8483 Analyze_And_Resolve
(N
, Target_Type
);
8487 end Tagged_Conversion
;
8489 -- Case of other access type conversions
8491 elsif Is_Access_Type
(Target_Type
) then
8492 Apply_Constraint_Check
(Operand
, Target_Type
);
8494 -- Case of conversions from a fixed-point type
8496 -- These conversions require special expansion and processing, found in
8497 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
8498 -- since from a semantic point of view, these are simple integer
8499 -- conversions, which do not need further processing.
8501 elsif Is_Fixed_Point_Type
(Operand_Type
)
8502 and then not Conversion_OK
(N
)
8504 -- We should never see universal fixed at this case, since the
8505 -- expansion of the constituent divide or multiply should have
8506 -- eliminated the explicit mention of universal fixed.
8508 pragma Assert
(Operand_Type
/= Universal_Fixed
);
8510 -- Check for special case of the conversion to universal real that
8511 -- occurs as a result of the use of a round attribute. In this case,
8512 -- the real type for the conversion is taken from the target type of
8513 -- the Round attribute and the result must be marked as rounded.
8515 if Target_Type
= Universal_Real
8516 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
8517 and then Attribute_Name
(Parent
(N
)) = Name_Round
8519 Set_Rounded_Result
(N
);
8520 Set_Etype
(N
, Etype
(Parent
(N
)));
8523 -- Otherwise do correct fixed-conversion, but skip these if the
8524 -- Conversion_OK flag is set, because from a semantic point of view
8525 -- these are simple integer conversions needing no further processing
8526 -- (the backend will simply treat them as integers).
8528 if not Conversion_OK
(N
) then
8529 if Is_Fixed_Point_Type
(Etype
(N
)) then
8530 Expand_Convert_Fixed_To_Fixed
(N
);
8533 elsif Is_Integer_Type
(Etype
(N
)) then
8534 Expand_Convert_Fixed_To_Integer
(N
);
8537 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
8538 Expand_Convert_Fixed_To_Float
(N
);
8543 -- Case of conversions to a fixed-point type
8545 -- These conversions require special expansion and processing, found in
8546 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
8547 -- since from a semantic point of view, these are simple integer
8548 -- conversions, which do not need further processing.
8550 elsif Is_Fixed_Point_Type
(Target_Type
)
8551 and then not Conversion_OK
(N
)
8553 if Is_Integer_Type
(Operand_Type
) then
8554 Expand_Convert_Integer_To_Fixed
(N
);
8557 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
8558 Expand_Convert_Float_To_Fixed
(N
);
8562 -- Case of float-to-integer conversions
8564 -- We also handle float-to-fixed conversions with Conversion_OK set
8565 -- since semantically the fixed-point target is treated as though it
8566 -- were an integer in such cases.
8568 elsif Is_Floating_Point_Type
(Operand_Type
)
8570 (Is_Integer_Type
(Target_Type
)
8572 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
8574 -- One more check here, gcc is still not able to do conversions of
8575 -- this type with proper overflow checking, and so gigi is doing an
8576 -- approximation of what is required by doing floating-point compares
8577 -- with the end-point. But that can lose precision in some cases, and
8578 -- give a wrong result. Converting the operand to Universal_Real is
8579 -- helpful, but still does not catch all cases with 64-bit integers
8580 -- on targets with only 64-bit floats.
8582 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
8583 -- Can this code be removed ???
8585 if Do_Range_Check
(Operand
) then
8587 Make_Type_Conversion
(Loc
,
8589 New_Occurrence_Of
(Universal_Real
, Loc
),
8591 Relocate_Node
(Operand
)));
8593 Set_Etype
(Operand
, Universal_Real
);
8594 Enable_Range_Check
(Operand
);
8595 Set_Do_Range_Check
(Expression
(Operand
), False);
8598 -- Case of array conversions
8600 -- Expansion of array conversions, add required length/range checks but
8601 -- only do this if there is no change of representation. For handling of
8602 -- this case, see Handle_Changed_Representation.
8604 elsif Is_Array_Type
(Target_Type
) then
8606 if Is_Constrained
(Target_Type
) then
8607 Apply_Length_Check
(Operand
, Target_Type
);
8609 Apply_Range_Check
(Operand
, Target_Type
);
8612 Handle_Changed_Representation
;
8614 -- Case of conversions of discriminated types
8616 -- Add required discriminant checks if target is constrained. Again this
8617 -- change is skipped if we have a change of representation.
8619 elsif Has_Discriminants
(Target_Type
)
8620 and then Is_Constrained
(Target_Type
)
8622 Apply_Discriminant_Check
(Operand
, Target_Type
);
8623 Handle_Changed_Representation
;
8625 -- Case of all other record conversions. The only processing required
8626 -- is to check for a change of representation requiring the special
8627 -- assignment processing.
8629 elsif Is_Record_Type
(Target_Type
) then
8631 -- Ada 2005 (AI-216): Program_Error is raised when converting from
8632 -- a derived Unchecked_Union type to an unconstrained type that is
8633 -- not Unchecked_Union if the operand lacks inferable discriminants.
8635 if Is_Derived_Type
(Operand_Type
)
8636 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
8637 and then not Is_Constrained
(Target_Type
)
8638 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
8639 and then not Has_Inferable_Discriminants
(Operand
)
8641 -- To prevent Gigi from generating illegal code, we generate a
8642 -- Program_Error node, but we give it the target type of the
8646 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
8647 Reason
=> PE_Unchecked_Union_Restriction
);
8650 Set_Etype
(PE
, Target_Type
);
8655 Handle_Changed_Representation
;
8658 -- Case of conversions of enumeration types
8660 elsif Is_Enumeration_Type
(Target_Type
) then
8662 -- Special processing is required if there is a change of
8663 -- representation (from enumeration representation clauses).
8665 if not Same_Representation
(Target_Type
, Operand_Type
) then
8667 -- Convert: x(y) to x'val (ytyp'val (y))
8670 Make_Attribute_Reference
(Loc
,
8671 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
8672 Attribute_Name
=> Name_Val
,
8673 Expressions
=> New_List
(
8674 Make_Attribute_Reference
(Loc
,
8675 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
8676 Attribute_Name
=> Name_Pos
,
8677 Expressions
=> New_List
(Operand
)))));
8679 Analyze_And_Resolve
(N
, Target_Type
);
8682 -- Case of conversions to floating-point
8684 elsif Is_Floating_Point_Type
(Target_Type
) then
8688 -- At this stage, either the conversion node has been transformed into
8689 -- some other equivalent expression, or left as a conversion that can be
8690 -- handled by Gigi, in the following cases:
8692 -- Conversions with no change of representation or type
8694 -- Numeric conversions involving integer, floating- and fixed-point
8695 -- values. Fixed-point values are allowed only if Conversion_OK is
8696 -- set, i.e. if the fixed-point values are to be treated as integers.
8698 -- No other conversions should be passed to Gigi
8700 -- Check: are these rules stated in sinfo??? if so, why restate here???
8702 -- The only remaining step is to generate a range check if we still have
8703 -- a type conversion at this stage and Do_Range_Check is set. For now we
8704 -- do this only for conversions of discrete types.
8706 if Nkind
(N
) = N_Type_Conversion
8707 and then Is_Discrete_Type
(Etype
(N
))
8710 Expr
: constant Node_Id
:= Expression
(N
);
8715 if Do_Range_Check
(Expr
)
8716 and then Is_Discrete_Type
(Etype
(Expr
))
8718 Set_Do_Range_Check
(Expr
, False);
8720 -- Before we do a range check, we have to deal with treating a
8721 -- fixed-point operand as an integer. The way we do this is
8722 -- simply to do an unchecked conversion to an appropriate
8723 -- integer type large enough to hold the result.
8725 -- This code is not active yet, because we are only dealing
8726 -- with discrete types so far ???
8728 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
8729 and then Treat_Fixed_As_Integer
(Expr
)
8731 Ftyp
:= Base_Type
(Etype
(Expr
));
8733 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
8734 Ityp
:= Standard_Long_Long_Integer
;
8736 Ityp
:= Standard_Integer
;
8739 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
8742 -- Reset overflow flag, since the range check will include
8743 -- dealing with possible overflow, and generate the check. If
8744 -- Address is either a source type or target type, suppress
8745 -- range check to avoid typing anomalies when it is a visible
8748 Set_Do_Overflow_Check
(N
, False);
8749 if not Is_Descendent_Of_Address
(Etype
(Expr
))
8750 and then not Is_Descendent_Of_Address
(Target_Type
)
8752 Generate_Range_Check
8753 (Expr
, Target_Type
, CE_Range_Check_Failed
);
8759 -- Final step, if the result is a type conversion involving Vax_Float
8760 -- types, then it is subject for further special processing.
8762 if Nkind
(N
) = N_Type_Conversion
8763 and then (Vax_Float
(Operand_Type
) or else Vax_Float
(Target_Type
))
8765 Expand_Vax_Conversion
(N
);
8768 end Expand_N_Type_Conversion
;
8770 -----------------------------------
8771 -- Expand_N_Unchecked_Expression --
8772 -----------------------------------
8774 -- Remove the unchecked expression node from the tree. Its job was simply
8775 -- to make sure that its constituent expression was handled with checks
8776 -- off, and now that that is done, we can remove it from the tree, and
8777 -- indeed must, since Gigi does not expect to see these nodes.
8779 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
8780 Exp
: constant Node_Id
:= Expression
(N
);
8782 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or else Assignment_OK
(Exp
));
8784 end Expand_N_Unchecked_Expression
;
8786 ----------------------------------------
8787 -- Expand_N_Unchecked_Type_Conversion --
8788 ----------------------------------------
8790 -- If this cannot be handled by Gigi and we haven't already made a
8791 -- temporary for it, do it now.
8793 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
8794 Target_Type
: constant Entity_Id
:= Etype
(N
);
8795 Operand
: constant Node_Id
:= Expression
(N
);
8796 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
8799 -- Nothing at all to do if conversion is to the identical type so remove
8800 -- the conversion completely, it is useless, except that it may carry
8801 -- an Assignment_OK indication which must be propagated to the operand.
8803 if Operand_Type
= Target_Type
then
8805 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
8807 if Assignment_OK
(N
) then
8808 Set_Assignment_OK
(Operand
);
8811 Rewrite
(N
, Relocate_Node
(Operand
));
8815 -- If we have a conversion of a compile time known value to a target
8816 -- type and the value is in range of the target type, then we can simply
8817 -- replace the construct by an integer literal of the correct type. We
8818 -- only apply this to integer types being converted. Possibly it may
8819 -- apply in other cases, but it is too much trouble to worry about.
8821 -- Note that we do not do this transformation if the Kill_Range_Check
8822 -- flag is set, since then the value may be outside the expected range.
8823 -- This happens in the Normalize_Scalars case.
8825 -- We also skip this if either the target or operand type is biased
8826 -- because in this case, the unchecked conversion is supposed to
8827 -- preserve the bit pattern, not the integer value.
8829 if Is_Integer_Type
(Target_Type
)
8830 and then not Has_Biased_Representation
(Target_Type
)
8831 and then Is_Integer_Type
(Operand_Type
)
8832 and then not Has_Biased_Representation
(Operand_Type
)
8833 and then Compile_Time_Known_Value
(Operand
)
8834 and then not Kill_Range_Check
(N
)
8837 Val
: constant Uint
:= Expr_Value
(Operand
);
8840 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
8842 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
8844 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
8846 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
8848 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
8850 -- If Address is the target type, just set the type to avoid a
8851 -- spurious type error on the literal when Address is a visible
8854 if Is_Descendent_Of_Address
(Target_Type
) then
8855 Set_Etype
(N
, Target_Type
);
8857 Analyze_And_Resolve
(N
, Target_Type
);
8865 -- Nothing to do if conversion is safe
8867 if Safe_Unchecked_Type_Conversion
(N
) then
8871 -- Otherwise force evaluation unless Assignment_OK flag is set (this
8872 -- flag indicates ??? -- more comments needed here)
8874 if Assignment_OK
(N
) then
8877 Force_Evaluation
(N
);
8879 end Expand_N_Unchecked_Type_Conversion
;
8881 ----------------------------
8882 -- Expand_Record_Equality --
8883 ----------------------------
8885 -- For non-variant records, Equality is expanded when needed into:
8887 -- and then Lhs.Discr1 = Rhs.Discr1
8889 -- and then Lhs.Discrn = Rhs.Discrn
8890 -- and then Lhs.Cmp1 = Rhs.Cmp1
8892 -- and then Lhs.Cmpn = Rhs.Cmpn
8894 -- The expression is folded by the back-end for adjacent fields. This
8895 -- function is called for tagged record in only one occasion: for imple-
8896 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
8897 -- otherwise the primitive "=" is used directly.
8899 function Expand_Record_Equality
8904 Bodies
: List_Id
) return Node_Id
8906 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
8911 First_Time
: Boolean := True;
8913 function Suitable_Element
(C
: Entity_Id
) return Entity_Id
;
8914 -- Return the first field to compare beginning with C, skipping the
8915 -- inherited components.
8917 ----------------------
8918 -- Suitable_Element --
8919 ----------------------
8921 function Suitable_Element
(C
: Entity_Id
) return Entity_Id
is
8926 elsif Ekind
(C
) /= E_Discriminant
8927 and then Ekind
(C
) /= E_Component
8929 return Suitable_Element
(Next_Entity
(C
));
8931 elsif Is_Tagged_Type
(Typ
)
8932 and then C
/= Original_Record_Component
(C
)
8934 return Suitable_Element
(Next_Entity
(C
));
8936 elsif Chars
(C
) = Name_uController
8937 or else Chars
(C
) = Name_uTag
8939 return Suitable_Element
(Next_Entity
(C
));
8941 elsif Is_Interface
(Etype
(C
)) then
8942 return Suitable_Element
(Next_Entity
(C
));
8947 end Suitable_Element
;
8949 -- Start of processing for Expand_Record_Equality
8952 -- Generates the following code: (assuming that Typ has one Discr and
8953 -- component C2 is also a record)
8956 -- and then Lhs.Discr1 = Rhs.Discr1
8957 -- and then Lhs.C1 = Rhs.C1
8958 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8960 -- and then Lhs.Cmpn = Rhs.Cmpn
8962 Result
:= New_Reference_To
(Standard_True
, Loc
);
8963 C
:= Suitable_Element
(First_Entity
(Typ
));
8964 while Present
(C
) loop
8972 First_Time
:= False;
8976 New_Lhs
:= New_Copy_Tree
(Lhs
);
8977 New_Rhs
:= New_Copy_Tree
(Rhs
);
8981 Expand_Composite_Equality
(Nod
, Etype
(C
),
8983 Make_Selected_Component
(Loc
,
8985 Selector_Name
=> New_Reference_To
(C
, Loc
)),
8987 Make_Selected_Component
(Loc
,
8989 Selector_Name
=> New_Reference_To
(C
, Loc
)),
8992 -- If some (sub)component is an unchecked_union, the whole
8993 -- operation will raise program error.
8995 if Nkind
(Check
) = N_Raise_Program_Error
then
8997 Set_Etype
(Result
, Standard_Boolean
);
9002 Left_Opnd
=> Result
,
9003 Right_Opnd
=> Check
);
9007 C
:= Suitable_Element
(Next_Entity
(C
));
9011 end Expand_Record_Equality
;
9013 -----------------------------------
9014 -- Expand_Short_Circuit_Operator --
9015 -----------------------------------
9017 -- Deal with special expansion if actions are present for the right operand
9018 -- and deal with optimizing case of arguments being True or False. We also
9019 -- deal with the special case of non-standard boolean values.
9021 procedure Expand_Short_Circuit_Operator
(N
: Node_Id
) is
9022 Loc
: constant Source_Ptr
:= Sloc
(N
);
9023 Typ
: constant Entity_Id
:= Etype
(N
);
9024 Left
: constant Node_Id
:= Left_Opnd
(N
);
9025 Right
: constant Node_Id
:= Right_Opnd
(N
);
9026 LocR
: constant Source_Ptr
:= Sloc
(Right
);
9029 Shortcut_Value
: constant Boolean := Nkind
(N
) = N_Or_Else
;
9030 Shortcut_Ent
: constant Entity_Id
:= Boolean_Literals
(Shortcut_Value
);
9031 -- If Left = Shortcut_Value then Right need not be evaluated
9033 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
;
9034 -- For Opnd a boolean expression, return a Boolean expression equivalent
9035 -- to Opnd /= Shortcut_Value.
9037 --------------------
9038 -- Make_Test_Expr --
9039 --------------------
9041 function Make_Test_Expr
(Opnd
: Node_Id
) return Node_Id
is
9043 if Shortcut_Value
then
9044 return Make_Op_Not
(Sloc
(Opnd
), Opnd
);
9051 -- Entity for a temporary variable holding the value of the operator,
9052 -- used for expansion in the case where actions are present.
9054 -- Start of processing for Expand_Short_Circuit_Operator
9057 -- Deal with non-standard booleans
9059 if Is_Boolean_Type
(Typ
) then
9060 Adjust_Condition
(Left
);
9061 Adjust_Condition
(Right
);
9062 Set_Etype
(N
, Standard_Boolean
);
9065 -- Check for cases where left argument is known to be True or False
9067 if Compile_Time_Known_Value
(Left
) then
9069 -- Mark SCO for left condition as compile time known
9071 if Generate_SCO
and then Comes_From_Source
(Left
) then
9072 Set_SCO_Condition
(Left
, Expr_Value_E
(Left
) = Standard_True
);
9075 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
9076 -- Any actions associated with Right will be executed unconditionally
9077 -- and can thus be inserted into the tree unconditionally.
9079 if Expr_Value_E
(Left
) /= Shortcut_Ent
then
9080 if Present
(Actions
(N
)) then
9081 Insert_Actions
(N
, Actions
(N
));
9086 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
9087 -- In this case we can forget the actions associated with Right,
9088 -- since they will never be executed.
9091 Kill_Dead_Code
(Right
);
9092 Kill_Dead_Code
(Actions
(N
));
9093 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
9096 Adjust_Result_Type
(N
, Typ
);
9100 -- If Actions are present for the right operand, we have to do some
9101 -- special processing. We can't just let these actions filter back into
9102 -- code preceding the short circuit (which is what would have happened
9103 -- if we had not trapped them in the short-circuit form), since they
9104 -- must only be executed if the right operand of the short circuit is
9105 -- executed and not otherwise.
9107 -- the temporary variable C.
9109 if Present
(Actions
(N
)) then
9110 Actlist
:= Actions
(N
);
9112 -- The old approach is to expand:
9114 -- left AND THEN right
9118 -- C : Boolean := False;
9126 -- and finally rewrite the operator into a reference to C. Similarly
9127 -- for left OR ELSE right, with negated values. Note that this
9128 -- rewrite causes some difficulties for coverage analysis because
9129 -- of the introduction of the new variable C, which obscures the
9130 -- structure of the test.
9132 -- We use this "old approach" if use of N_Expression_With_Actions
9133 -- is False (see description in Opt of when this is or is not set).
9135 if not Use_Expression_With_Actions
then
9136 Op_Var
:= Make_Temporary
(Loc
, 'C', Related_Node
=> N
);
9139 Make_Object_Declaration
(Loc
,
9140 Defining_Identifier
=>
9142 Object_Definition
=>
9143 New_Occurrence_Of
(Standard_Boolean
, Loc
),
9145 New_Occurrence_Of
(Shortcut_Ent
, Loc
)));
9148 Make_Implicit_If_Statement
(Right
,
9149 Condition
=> Make_Test_Expr
(Right
),
9150 Then_Statements
=> New_List
(
9151 Make_Assignment_Statement
(LocR
,
9152 Name
=> New_Occurrence_Of
(Op_Var
, LocR
),
9155 (Boolean_Literals
(not Shortcut_Value
), LocR
)))));
9158 Make_Implicit_If_Statement
(Left
,
9159 Condition
=> Make_Test_Expr
(Left
),
9160 Then_Statements
=> Actlist
));
9162 Rewrite
(N
, New_Occurrence_Of
(Op_Var
, Loc
));
9163 Analyze_And_Resolve
(N
, Standard_Boolean
);
9165 -- The new approach, activated for now by the use of debug flag
9166 -- -gnatd.X is to use the new Expression_With_Actions node for the
9167 -- right operand of the short-circuit form. This should solve the
9168 -- traceability problems for coverage analysis.
9172 Make_Expression_With_Actions
(LocR
,
9173 Expression
=> Relocate_Node
(Right
),
9174 Actions
=> Actlist
));
9175 Set_Actions
(N
, No_List
);
9176 Analyze_And_Resolve
(Right
, Standard_Boolean
);
9179 Adjust_Result_Type
(N
, Typ
);
9183 -- No actions present, check for cases of right argument True/False
9185 if Compile_Time_Known_Value
(Right
) then
9187 -- Mark SCO for left condition as compile time known
9189 if Generate_SCO
and then Comes_From_Source
(Right
) then
9190 Set_SCO_Condition
(Right
, Expr_Value_E
(Right
) = Standard_True
);
9193 -- Change (Left and then True), (Left or else False) to Left.
9194 -- Note that we know there are no actions associated with the right
9195 -- operand, since we just checked for this case above.
9197 if Expr_Value_E
(Right
) /= Shortcut_Ent
then
9200 -- Change (Left and then False), (Left or else True) to Right,
9201 -- making sure to preserve any side effects associated with the Left
9205 Remove_Side_Effects
(Left
);
9206 Rewrite
(N
, New_Occurrence_Of
(Shortcut_Ent
, Loc
));
9210 Adjust_Result_Type
(N
, Typ
);
9211 end Expand_Short_Circuit_Operator
;
9213 -------------------------------------
9214 -- Fixup_Universal_Fixed_Operation --
9215 -------------------------------------
9217 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
9218 Conv
: constant Node_Id
:= Parent
(N
);
9221 -- We must have a type conversion immediately above us
9223 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
9225 -- Normally the type conversion gives our target type. The exception
9226 -- occurs in the case of the Round attribute, where the conversion
9227 -- will be to universal real, and our real type comes from the Round
9228 -- attribute (as well as an indication that we must round the result)
9230 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
9231 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
9233 Set_Etype
(N
, Etype
(Parent
(Conv
)));
9234 Set_Rounded_Result
(N
);
9236 -- Normal case where type comes from conversion above us
9239 Set_Etype
(N
, Etype
(Conv
));
9241 end Fixup_Universal_Fixed_Operation
;
9243 ------------------------------
9244 -- Get_Allocator_Final_List --
9245 ------------------------------
9247 function Get_Allocator_Final_List
9250 PtrT
: Entity_Id
) return Entity_Id
9252 Loc
: constant Source_Ptr
:= Sloc
(N
);
9254 Owner
: Entity_Id
:= PtrT
;
9255 -- The entity whose finalization list must be used to attach the
9256 -- allocated object.
9259 if Ekind
(PtrT
) = E_Anonymous_Access_Type
then
9261 -- If the context is an access parameter, we need to create a
9262 -- non-anonymous access type in order to have a usable final list,
9263 -- because there is otherwise no pool to which the allocated object
9264 -- can belong. We create both the type and the finalization chain
9265 -- here, because freezing an internal type does not create such a
9266 -- chain. The Final_Chain that is thus created is shared by the
9267 -- access parameter. The access type is tested against the result
9268 -- type of the function to exclude allocators whose type is an
9269 -- anonymous access result type. We freeze the type at once to
9270 -- ensure that it is properly decorated for the back-end, even
9271 -- if the context and current scope is a loop.
9273 if Nkind
(Associated_Node_For_Itype
(PtrT
))
9274 in N_Subprogram_Specification
9277 Etype
(Defining_Unit_Name
(Associated_Node_For_Itype
(PtrT
)))
9279 Owner
:= Make_Temporary
(Loc
, 'J');
9281 Make_Full_Type_Declaration
(Loc
,
9282 Defining_Identifier
=> Owner
,
9284 Make_Access_To_Object_Definition
(Loc
,
9285 Subtype_Indication
=>
9286 New_Occurrence_Of
(T
, Loc
))));
9288 Freeze_Before
(N
, Owner
);
9289 Build_Final_List
(N
, Owner
);
9290 Set_Associated_Final_Chain
(PtrT
, Associated_Final_Chain
(Owner
));
9292 -- Ada 2005 (AI-318-02): If the context is a return object
9293 -- declaration, then the anonymous return subtype is defined to have
9294 -- the same accessibility level as that of the function's result
9295 -- subtype, which means that we want the scope where the function is
9298 elsif Nkind
(Associated_Node_For_Itype
(PtrT
)) = N_Object_Declaration
9299 and then Ekind
(Scope
(PtrT
)) = E_Return_Statement
9301 Owner
:= Scope
(Return_Applies_To
(Scope
(PtrT
)));
9303 -- Case of an access discriminant, or (Ada 2005) of an anonymous
9304 -- access component or anonymous access function result: find the
9305 -- final list associated with the scope of the type. (In the
9306 -- anonymous access component kind, a list controller will have
9307 -- been allocated when freezing the record type, and PtrT has an
9308 -- Associated_Final_Chain attribute designating it.)
9310 elsif No
(Associated_Final_Chain
(PtrT
)) then
9311 Owner
:= Scope
(PtrT
);
9315 return Find_Final_List
(Owner
);
9316 end Get_Allocator_Final_List
;
9318 ---------------------------------
9319 -- Has_Inferable_Discriminants --
9320 ---------------------------------
9322 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
9324 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
9325 -- Determines whether the left-most prefix of a selected component is a
9326 -- formal parameter in a subprogram. Assumes N is a selected component.
9328 --------------------------------
9329 -- Prefix_Is_Formal_Parameter --
9330 --------------------------------
9332 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
9333 Sel_Comp
: Node_Id
:= N
;
9336 -- Move to the left-most prefix by climbing up the tree
9338 while Present
(Parent
(Sel_Comp
))
9339 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
9341 Sel_Comp
:= Parent
(Sel_Comp
);
9344 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
9345 end Prefix_Is_Formal_Parameter
;
9347 -- Start of processing for Has_Inferable_Discriminants
9350 -- For identifiers and indexed components, it is sufficient to have a
9351 -- constrained Unchecked_Union nominal subtype.
9353 if Nkind_In
(N
, N_Identifier
, N_Indexed_Component
) then
9354 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
9356 Is_Constrained
(Etype
(N
));
9358 -- For selected components, the subtype of the selector must be a
9359 -- constrained Unchecked_Union. If the component is subject to a
9360 -- per-object constraint, then the enclosing object must have inferable
9363 elsif Nkind
(N
) = N_Selected_Component
then
9364 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
9366 -- A small hack. If we have a per-object constrained selected
9367 -- component of a formal parameter, return True since we do not
9368 -- know the actual parameter association yet.
9370 if Prefix_Is_Formal_Parameter
(N
) then
9374 -- Otherwise, check the enclosing object and the selector
9376 return Has_Inferable_Discriminants
(Prefix
(N
))
9378 Has_Inferable_Discriminants
(Selector_Name
(N
));
9381 -- The call to Has_Inferable_Discriminants will determine whether
9382 -- the selector has a constrained Unchecked_Union nominal type.
9384 return Has_Inferable_Discriminants
(Selector_Name
(N
));
9386 -- A qualified expression has inferable discriminants if its subtype
9387 -- mark is a constrained Unchecked_Union subtype.
9389 elsif Nkind
(N
) = N_Qualified_Expression
then
9390 return Is_Unchecked_Union
(Subtype_Mark
(N
))
9392 Is_Constrained
(Subtype_Mark
(N
));
9397 end Has_Inferable_Discriminants
;
9399 -------------------------------
9400 -- Insert_Dereference_Action --
9401 -------------------------------
9403 procedure Insert_Dereference_Action
(N
: Node_Id
) is
9404 Loc
: constant Source_Ptr
:= Sloc
(N
);
9405 Typ
: constant Entity_Id
:= Etype
(N
);
9406 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
9407 Pnod
: constant Node_Id
:= Parent
(N
);
9409 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
9410 -- Return true if type of P is derived from Checked_Pool;
9412 -----------------------------
9413 -- Is_Checked_Storage_Pool --
9414 -----------------------------
9416 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
9425 while T
/= Etype
(T
) loop
9426 if Is_RTE
(T
, RE_Checked_Pool
) then
9434 end Is_Checked_Storage_Pool
;
9436 -- Start of processing for Insert_Dereference_Action
9439 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
9441 if not (Is_Checked_Storage_Pool
(Pool
)
9442 and then Comes_From_Source
(Original_Node
(Pnod
)))
9448 Make_Procedure_Call_Statement
(Loc
,
9449 Name
=> New_Reference_To
(
9450 Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
9452 Parameter_Associations
=> New_List
(
9456 New_Reference_To
(Pool
, Loc
),
9458 -- Storage_Address. We use the attribute Pool_Address, which uses
9459 -- the pointer itself to find the address of the object, and which
9460 -- handles unconstrained arrays properly by computing the address
9461 -- of the template. i.e. the correct address of the corresponding
9464 Make_Attribute_Reference
(Loc
,
9465 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
9466 Attribute_Name
=> Name_Pool_Address
),
9468 -- Size_In_Storage_Elements
9470 Make_Op_Divide
(Loc
,
9472 Make_Attribute_Reference
(Loc
,
9474 Make_Explicit_Dereference
(Loc
,
9475 Duplicate_Subexpr_Move_Checks
(N
)),
9476 Attribute_Name
=> Name_Size
),
9478 Make_Integer_Literal
(Loc
, System_Storage_Unit
)),
9482 Make_Attribute_Reference
(Loc
,
9484 Make_Explicit_Dereference
(Loc
,
9485 Duplicate_Subexpr_Move_Checks
(N
)),
9486 Attribute_Name
=> Name_Alignment
))));
9489 when RE_Not_Available
=>
9491 end Insert_Dereference_Action
;
9493 --------------------------------
9494 -- Integer_Promotion_Possible --
9495 --------------------------------
9497 function Integer_Promotion_Possible
(N
: Node_Id
) return Boolean is
9498 Operand
: constant Node_Id
:= Expression
(N
);
9499 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
9500 Root_Operand_Type
: constant Entity_Id
:= Root_Type
(Operand_Type
);
9503 pragma Assert
(Nkind
(N
) = N_Type_Conversion
);
9507 -- We only do the transformation for source constructs. We assume
9508 -- that the expander knows what it is doing when it generates code.
9510 Comes_From_Source
(N
)
9512 -- If the operand type is Short_Integer or Short_Short_Integer,
9513 -- then we will promote to Integer, which is available on all
9514 -- targets, and is sufficient to ensure no intermediate overflow.
9515 -- Furthermore it is likely to be as efficient or more efficient
9516 -- than using the smaller type for the computation so we do this
9520 (Root_Operand_Type
= Base_Type
(Standard_Short_Integer
)
9522 Root_Operand_Type
= Base_Type
(Standard_Short_Short_Integer
))
9524 -- Test for interesting operation, which includes addition,
9525 -- division, exponentiation, multiplication, subtraction, absolute
9526 -- value and unary negation. Unary "+" is omitted since it is a
9527 -- no-op and thus can't overflow.
9529 and then Nkind_In
(Operand
, N_Op_Abs
,
9536 end Integer_Promotion_Possible
;
9538 ------------------------------
9539 -- Make_Array_Comparison_Op --
9540 ------------------------------
9542 -- This is a hand-coded expansion of the following generic function:
9545 -- type elem is (<>);
9546 -- type index is (<>);
9547 -- type a is array (index range <>) of elem;
9549 -- function Gnnn (X : a; Y: a) return boolean is
9550 -- J : index := Y'first;
9553 -- if X'length = 0 then
9556 -- elsif Y'length = 0 then
9560 -- for I in X'range loop
9561 -- if X (I) = Y (J) then
9562 -- if J = Y'last then
9565 -- J := index'succ (J);
9569 -- return X (I) > Y (J);
9573 -- return X'length > Y'length;
9577 -- Note that since we are essentially doing this expansion by hand, we
9578 -- do not need to generate an actual or formal generic part, just the
9579 -- instantiated function itself.
9581 function Make_Array_Comparison_Op
9583 Nod
: Node_Id
) return Node_Id
9585 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
9587 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
9588 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
9589 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
9590 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
9592 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
9594 Loop_Statement
: Node_Id
;
9595 Loop_Body
: Node_Id
;
9598 Final_Expr
: Node_Id
;
9599 Func_Body
: Node_Id
;
9600 Func_Name
: Entity_Id
;
9606 -- if J = Y'last then
9609 -- J := index'succ (J);
9613 Make_Implicit_If_Statement
(Nod
,
9616 Left_Opnd
=> New_Reference_To
(J
, Loc
),
9618 Make_Attribute_Reference
(Loc
,
9619 Prefix
=> New_Reference_To
(Y
, Loc
),
9620 Attribute_Name
=> Name_Last
)),
9622 Then_Statements
=> New_List
(
9623 Make_Exit_Statement
(Loc
)),
9627 Make_Assignment_Statement
(Loc
,
9628 Name
=> New_Reference_To
(J
, Loc
),
9630 Make_Attribute_Reference
(Loc
,
9631 Prefix
=> New_Reference_To
(Index
, Loc
),
9632 Attribute_Name
=> Name_Succ
,
9633 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))))));
9635 -- if X (I) = Y (J) then
9638 -- return X (I) > Y (J);
9642 Make_Implicit_If_Statement
(Nod
,
9646 Make_Indexed_Component
(Loc
,
9647 Prefix
=> New_Reference_To
(X
, Loc
),
9648 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
9651 Make_Indexed_Component
(Loc
,
9652 Prefix
=> New_Reference_To
(Y
, Loc
),
9653 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)))),
9655 Then_Statements
=> New_List
(Inner_If
),
9657 Else_Statements
=> New_List
(
9658 Make_Simple_Return_Statement
(Loc
,
9662 Make_Indexed_Component
(Loc
,
9663 Prefix
=> New_Reference_To
(X
, Loc
),
9664 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
9667 Make_Indexed_Component
(Loc
,
9668 Prefix
=> New_Reference_To
(Y
, Loc
),
9669 Expressions
=> New_List
(
9670 New_Reference_To
(J
, Loc
)))))));
9672 -- for I in X'range loop
9677 Make_Implicit_Loop_Statement
(Nod
,
9678 Identifier
=> Empty
,
9681 Make_Iteration_Scheme
(Loc
,
9682 Loop_Parameter_Specification
=>
9683 Make_Loop_Parameter_Specification
(Loc
,
9684 Defining_Identifier
=> I
,
9685 Discrete_Subtype_Definition
=>
9686 Make_Attribute_Reference
(Loc
,
9687 Prefix
=> New_Reference_To
(X
, Loc
),
9688 Attribute_Name
=> Name_Range
))),
9690 Statements
=> New_List
(Loop_Body
));
9692 -- if X'length = 0 then
9694 -- elsif Y'length = 0 then
9697 -- for ... loop ... end loop;
9698 -- return X'length > Y'length;
9702 Make_Attribute_Reference
(Loc
,
9703 Prefix
=> New_Reference_To
(X
, Loc
),
9704 Attribute_Name
=> Name_Length
);
9707 Make_Attribute_Reference
(Loc
,
9708 Prefix
=> New_Reference_To
(Y
, Loc
),
9709 Attribute_Name
=> Name_Length
);
9713 Left_Opnd
=> Length1
,
9714 Right_Opnd
=> Length2
);
9717 Make_Implicit_If_Statement
(Nod
,
9721 Make_Attribute_Reference
(Loc
,
9722 Prefix
=> New_Reference_To
(X
, Loc
),
9723 Attribute_Name
=> Name_Length
),
9725 Make_Integer_Literal
(Loc
, 0)),
9729 Make_Simple_Return_Statement
(Loc
,
9730 Expression
=> New_Reference_To
(Standard_False
, Loc
))),
9732 Elsif_Parts
=> New_List
(
9733 Make_Elsif_Part
(Loc
,
9737 Make_Attribute_Reference
(Loc
,
9738 Prefix
=> New_Reference_To
(Y
, Loc
),
9739 Attribute_Name
=> Name_Length
),
9741 Make_Integer_Literal
(Loc
, 0)),
9745 Make_Simple_Return_Statement
(Loc
,
9746 Expression
=> New_Reference_To
(Standard_True
, Loc
))))),
9748 Else_Statements
=> New_List
(
9750 Make_Simple_Return_Statement
(Loc
,
9751 Expression
=> Final_Expr
)));
9755 Formals
:= New_List
(
9756 Make_Parameter_Specification
(Loc
,
9757 Defining_Identifier
=> X
,
9758 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
9760 Make_Parameter_Specification
(Loc
,
9761 Defining_Identifier
=> Y
,
9762 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
9764 -- function Gnnn (...) return boolean is
9765 -- J : index := Y'first;
9770 Func_Name
:= Make_Temporary
(Loc
, 'G');
9773 Make_Subprogram_Body
(Loc
,
9775 Make_Function_Specification
(Loc
,
9776 Defining_Unit_Name
=> Func_Name
,
9777 Parameter_Specifications
=> Formals
,
9778 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
9780 Declarations
=> New_List
(
9781 Make_Object_Declaration
(Loc
,
9782 Defining_Identifier
=> J
,
9783 Object_Definition
=> New_Reference_To
(Index
, Loc
),
9785 Make_Attribute_Reference
(Loc
,
9786 Prefix
=> New_Reference_To
(Y
, Loc
),
9787 Attribute_Name
=> Name_First
))),
9789 Handled_Statement_Sequence
=>
9790 Make_Handled_Sequence_Of_Statements
(Loc
,
9791 Statements
=> New_List
(If_Stat
)));
9794 end Make_Array_Comparison_Op
;
9796 ---------------------------
9797 -- Make_Boolean_Array_Op --
9798 ---------------------------
9800 -- For logical operations on boolean arrays, expand in line the following,
9801 -- replacing 'and' with 'or' or 'xor' where needed:
9803 -- function Annn (A : typ; B: typ) return typ is
9806 -- for J in A'range loop
9807 -- C (J) := A (J) op B (J);
9812 -- Here typ is the boolean array type
9814 function Make_Boolean_Array_Op
9816 N
: Node_Id
) return Node_Id
9818 Loc
: constant Source_Ptr
:= Sloc
(N
);
9820 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
9821 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
9822 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
9823 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
9831 Func_Name
: Entity_Id
;
9832 Func_Body
: Node_Id
;
9833 Loop_Statement
: Node_Id
;
9837 Make_Indexed_Component
(Loc
,
9838 Prefix
=> New_Reference_To
(A
, Loc
),
9839 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
9842 Make_Indexed_Component
(Loc
,
9843 Prefix
=> New_Reference_To
(B
, Loc
),
9844 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
9847 Make_Indexed_Component
(Loc
,
9848 Prefix
=> New_Reference_To
(C
, Loc
),
9849 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
9851 if Nkind
(N
) = N_Op_And
then
9857 elsif Nkind
(N
) = N_Op_Or
then
9871 Make_Implicit_Loop_Statement
(N
,
9872 Identifier
=> Empty
,
9875 Make_Iteration_Scheme
(Loc
,
9876 Loop_Parameter_Specification
=>
9877 Make_Loop_Parameter_Specification
(Loc
,
9878 Defining_Identifier
=> J
,
9879 Discrete_Subtype_Definition
=>
9880 Make_Attribute_Reference
(Loc
,
9881 Prefix
=> New_Reference_To
(A
, Loc
),
9882 Attribute_Name
=> Name_Range
))),
9884 Statements
=> New_List
(
9885 Make_Assignment_Statement
(Loc
,
9887 Expression
=> Op
)));
9889 Formals
:= New_List
(
9890 Make_Parameter_Specification
(Loc
,
9891 Defining_Identifier
=> A
,
9892 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
9894 Make_Parameter_Specification
(Loc
,
9895 Defining_Identifier
=> B
,
9896 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
9898 Func_Name
:= Make_Temporary
(Loc
, 'A');
9899 Set_Is_Inlined
(Func_Name
);
9902 Make_Subprogram_Body
(Loc
,
9904 Make_Function_Specification
(Loc
,
9905 Defining_Unit_Name
=> Func_Name
,
9906 Parameter_Specifications
=> Formals
,
9907 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
9909 Declarations
=> New_List
(
9910 Make_Object_Declaration
(Loc
,
9911 Defining_Identifier
=> C
,
9912 Object_Definition
=> New_Reference_To
(Typ
, Loc
))),
9914 Handled_Statement_Sequence
=>
9915 Make_Handled_Sequence_Of_Statements
(Loc
,
9916 Statements
=> New_List
(
9918 Make_Simple_Return_Statement
(Loc
,
9919 Expression
=> New_Reference_To
(C
, Loc
)))));
9922 end Make_Boolean_Array_Op
;
9924 ------------------------
9925 -- Rewrite_Comparison --
9926 ------------------------
9928 procedure Rewrite_Comparison
(N
: Node_Id
) is
9929 Warning_Generated
: Boolean := False;
9930 -- Set to True if first pass with Assume_Valid generates a warning in
9931 -- which case we skip the second pass to avoid warning overloaded.
9934 -- Set to Standard_True or Standard_False
9937 if Nkind
(N
) = N_Type_Conversion
then
9938 Rewrite_Comparison
(Expression
(N
));
9941 elsif Nkind
(N
) not in N_Op_Compare
then
9945 -- Now start looking at the comparison in detail. We potentially go
9946 -- through this loop twice. The first time, Assume_Valid is set False
9947 -- in the call to Compile_Time_Compare. If this call results in a
9948 -- clear result of always True or Always False, that's decisive and
9949 -- we are done. Otherwise we repeat the processing with Assume_Valid
9950 -- set to True to generate additional warnings. We can skip that step
9951 -- if Constant_Condition_Warnings is False.
9953 for AV
in False .. True loop
9955 Typ
: constant Entity_Id
:= Etype
(N
);
9956 Op1
: constant Node_Id
:= Left_Opnd
(N
);
9957 Op2
: constant Node_Id
:= Right_Opnd
(N
);
9959 Res
: constant Compare_Result
:=
9960 Compile_Time_Compare
(Op1
, Op2
, Assume_Valid
=> AV
);
9961 -- Res indicates if compare outcome can be compile time determined
9963 True_Result
: Boolean;
9964 False_Result
: Boolean;
9967 case N_Op_Compare
(Nkind
(N
)) is
9969 True_Result
:= Res
= EQ
;
9970 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
9973 True_Result
:= Res
in Compare_GE
;
9974 False_Result
:= Res
= LT
;
9977 and then Constant_Condition_Warnings
9978 and then Comes_From_Source
(Original_Node
(N
))
9979 and then Nkind
(Original_Node
(N
)) = N_Op_Ge
9980 and then not In_Instance
9981 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
9982 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
9985 ("can never be greater than, could replace by ""'=""?", N
);
9986 Warning_Generated
:= True;
9990 True_Result
:= Res
= GT
;
9991 False_Result
:= Res
in Compare_LE
;
9994 True_Result
:= Res
= LT
;
9995 False_Result
:= Res
in Compare_GE
;
9998 True_Result
:= Res
in Compare_LE
;
9999 False_Result
:= Res
= GT
;
10002 and then Constant_Condition_Warnings
10003 and then Comes_From_Source
(Original_Node
(N
))
10004 and then Nkind
(Original_Node
(N
)) = N_Op_Le
10005 and then not In_Instance
10006 and then Is_Integer_Type
(Etype
(Left_Opnd
(N
)))
10007 and then not Has_Warnings_Off
(Etype
(Left_Opnd
(N
)))
10010 ("can never be less than, could replace by ""'=""?", N
);
10011 Warning_Generated
:= True;
10015 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
10016 False_Result
:= Res
= EQ
;
10019 -- If this is the first iteration, then we actually convert the
10020 -- comparison into True or False, if the result is certain.
10023 if True_Result
or False_Result
then
10024 if True_Result
then
10025 Result
:= Standard_True
;
10027 Result
:= Standard_False
;
10032 New_Occurrence_Of
(Result
, Sloc
(N
))));
10033 Analyze_And_Resolve
(N
, Typ
);
10034 Warn_On_Known_Condition
(N
);
10038 -- If this is the second iteration (AV = True), and the original
10039 -- node comes from source and we are not in an instance, then give
10040 -- a warning if we know result would be True or False. Note: we
10041 -- know Constant_Condition_Warnings is set if we get here.
10043 elsif Comes_From_Source
(Original_Node
(N
))
10044 and then not In_Instance
10046 if True_Result
then
10048 ("condition can only be False if invalid values present?",
10050 elsif False_Result
then
10052 ("condition can only be True if invalid values present?",
10058 -- Skip second iteration if not warning on constant conditions or
10059 -- if the first iteration already generated a warning of some kind or
10060 -- if we are in any case assuming all values are valid (so that the
10061 -- first iteration took care of the valid case).
10063 exit when not Constant_Condition_Warnings
;
10064 exit when Warning_Generated
;
10065 exit when Assume_No_Invalid_Values
;
10067 end Rewrite_Comparison
;
10069 ----------------------------
10070 -- Safe_In_Place_Array_Op --
10071 ----------------------------
10073 function Safe_In_Place_Array_Op
10076 Op2
: Node_Id
) return Boolean
10078 Target
: Entity_Id
;
10080 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
10081 -- Operand is safe if it cannot overlap part of the target of the
10082 -- operation. If the operand and the target are identical, the operand
10083 -- is safe. The operand can be empty in the case of negation.
10085 function Is_Unaliased
(N
: Node_Id
) return Boolean;
10086 -- Check that N is a stand-alone entity
10092 function Is_Unaliased
(N
: Node_Id
) return Boolean is
10096 and then No
(Address_Clause
(Entity
(N
)))
10097 and then No
(Renamed_Object
(Entity
(N
)));
10100 ---------------------
10101 -- Is_Safe_Operand --
10102 ---------------------
10104 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
10109 elsif Is_Entity_Name
(Op
) then
10110 return Is_Unaliased
(Op
);
10112 elsif Nkind_In
(Op
, N_Indexed_Component
, N_Selected_Component
) then
10113 return Is_Unaliased
(Prefix
(Op
));
10115 elsif Nkind
(Op
) = N_Slice
then
10117 Is_Unaliased
(Prefix
(Op
))
10118 and then Entity
(Prefix
(Op
)) /= Target
;
10120 elsif Nkind
(Op
) = N_Op_Not
then
10121 return Is_Safe_Operand
(Right_Opnd
(Op
));
10126 end Is_Safe_Operand
;
10128 -- Start of processing for Is_Safe_In_Place_Array_Op
10131 -- Skip this processing if the component size is different from system
10132 -- storage unit (since at least for NOT this would cause problems).
10134 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
10137 -- Cannot do in place stuff on VM_Target since cannot pass addresses
10139 elsif VM_Target
/= No_VM
then
10142 -- Cannot do in place stuff if non-standard Boolean representation
10144 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
10147 elsif not Is_Unaliased
(Lhs
) then
10151 Target
:= Entity
(Lhs
);
10152 return Is_Safe_Operand
(Op1
) and then Is_Safe_Operand
(Op2
);
10154 end Safe_In_Place_Array_Op
;
10156 -----------------------
10157 -- Tagged_Membership --
10158 -----------------------
10160 -- There are two different cases to consider depending on whether the right
10161 -- operand is a class-wide type or not. If not we just compare the actual
10162 -- tag of the left expr to the target type tag:
10164 -- Left_Expr.Tag = Right_Type'Tag;
10166 -- If it is a class-wide type we use the RT function CW_Membership which is
10167 -- usually implemented by looking in the ancestor tables contained in the
10168 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
10170 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
10171 -- function IW_Membership which is usually implemented by looking in the
10172 -- table of abstract interface types plus the ancestor table contained in
10173 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
10175 procedure Tagged_Membership
10177 SCIL_Node
: out Node_Id
;
10178 Result
: out Node_Id
)
10180 Left
: constant Node_Id
:= Left_Opnd
(N
);
10181 Right
: constant Node_Id
:= Right_Opnd
(N
);
10182 Loc
: constant Source_Ptr
:= Sloc
(N
);
10184 Left_Type
: Entity_Id
;
10185 New_Node
: Node_Id
;
10186 Right_Type
: Entity_Id
;
10190 SCIL_Node
:= Empty
;
10192 -- Handle entities from the limited view
10194 Left_Type
:= Available_View
(Etype
(Left
));
10195 Right_Type
:= Available_View
(Etype
(Right
));
10197 if Is_Class_Wide_Type
(Left_Type
) then
10198 Left_Type
:= Root_Type
(Left_Type
);
10202 Make_Selected_Component
(Loc
,
10203 Prefix
=> Relocate_Node
(Left
),
10205 New_Reference_To
(First_Tag_Component
(Left_Type
), Loc
));
10207 if Is_Class_Wide_Type
(Right_Type
) then
10209 -- No need to issue a run-time check if we statically know that the
10210 -- result of this membership test is always true. For example,
10211 -- considering the following declarations:
10213 -- type Iface is interface;
10214 -- type T is tagged null record;
10215 -- type DT is new T and Iface with null record;
10220 -- These membership tests are always true:
10223 -- Obj2 in T'Class;
10224 -- Obj2 in Iface'Class;
10226 -- We do not need to handle cases where the membership is illegal.
10229 -- Obj1 in DT'Class; -- Compile time error
10230 -- Obj1 in Iface'Class; -- Compile time error
10232 if not Is_Class_Wide_Type
(Left_Type
)
10233 and then (Is_Ancestor
(Etype
(Right_Type
), Left_Type
)
10234 or else (Is_Interface
(Etype
(Right_Type
))
10235 and then Interface_Present_In_Ancestor
10237 Iface
=> Etype
(Right_Type
))))
10239 Result
:= New_Reference_To
(Standard_True
, Loc
);
10243 -- Ada 2005 (AI-251): Class-wide applied to interfaces
10245 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
10247 -- Support to: "Iface_CW_Typ in Typ'Class"
10249 or else Is_Interface
(Left_Type
)
10251 -- Issue error if IW_Membership operation not available in a
10252 -- configurable run time setting.
10254 if not RTE_Available
(RE_IW_Membership
) then
10256 ("dynamic membership test on interface types", N
);
10262 Make_Function_Call
(Loc
,
10263 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
10264 Parameter_Associations
=> New_List
(
10265 Make_Attribute_Reference
(Loc
,
10267 Attribute_Name
=> Name_Address
),
10270 (Access_Disp_Table
(Root_Type
(Right_Type
)))),
10273 -- Ada 95: Normal case
10276 Build_CW_Membership
(Loc
,
10277 Obj_Tag_Node
=> Obj_Tag
,
10281 (Access_Disp_Table
(Root_Type
(Right_Type
)))),
10284 New_Node
=> New_Node
);
10286 -- Generate the SCIL node for this class-wide membership test.
10287 -- Done here because the previous call to Build_CW_Membership
10288 -- relocates Obj_Tag.
10290 if Generate_SCIL
then
10291 SCIL_Node
:= Make_SCIL_Membership_Test
(Sloc
(N
));
10292 Set_SCIL_Entity
(SCIL_Node
, Etype
(Right_Type
));
10293 Set_SCIL_Tag_Value
(SCIL_Node
, Obj_Tag
);
10296 Result
:= New_Node
;
10299 -- Right_Type is not a class-wide type
10302 -- No need to check the tag of the object if Right_Typ is abstract
10304 if Is_Abstract_Type
(Right_Type
) then
10305 Result
:= New_Reference_To
(Standard_False
, Loc
);
10310 Left_Opnd
=> Obj_Tag
,
10313 (Node
(First_Elmt
(Access_Disp_Table
(Right_Type
))), Loc
));
10316 end Tagged_Membership
;
10318 ------------------------------
10319 -- Unary_Op_Validity_Checks --
10320 ------------------------------
10322 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
10324 if Validity_Checks_On
and Validity_Check_Operands
then
10325 Ensure_Valid
(Right_Opnd
(N
));
10327 end Unary_Op_Validity_Checks
;