1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
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_Ch3
; use Exp_Ch3
;
34 with Exp_Ch7
; use Exp_Ch7
;
35 with Exp_Ch9
; use Exp_Ch9
;
36 with Exp_Fixd
; use Exp_Fixd
;
37 with Exp_Pakd
; use Exp_Pakd
;
38 with Exp_Tss
; use Exp_Tss
;
39 with Exp_Util
; use Exp_Util
;
40 with Exp_VFpt
; use Exp_VFpt
;
41 with Hostparm
; use Hostparm
;
42 with Inline
; use Inline
;
43 with Nlists
; use Nlists
;
44 with Nmake
; use Nmake
;
46 with Rtsfind
; use Rtsfind
;
48 with Sem_Cat
; use Sem_Cat
;
49 with Sem_Ch3
; use Sem_Ch3
;
50 with Sem_Ch13
; use Sem_Ch13
;
51 with Sem_Eval
; use Sem_Eval
;
52 with Sem_Res
; use Sem_Res
;
53 with Sem_Type
; use Sem_Type
;
54 with Sem_Util
; use Sem_Util
;
55 with Sem_Warn
; use Sem_Warn
;
56 with Sinfo
; use Sinfo
;
57 with Snames
; use Snames
;
58 with Stand
; use Stand
;
59 with Targparm
; use Targparm
;
60 with Tbuild
; use Tbuild
;
61 with Ttypes
; use Ttypes
;
62 with Uintp
; use Uintp
;
63 with Urealp
; use Urealp
;
64 with Validsw
; use Validsw
;
66 package body Exp_Ch4
is
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
73 pragma Inline
(Binary_Op_Validity_Checks
);
74 -- Performs validity checks for a binary operator
76 procedure Build_Boolean_Array_Proc_Call
80 -- If an boolean array assignment can be done in place, build call to
81 -- corresponding library procedure.
83 procedure Expand_Allocator_Expression
(N
: Node_Id
);
84 -- Subsidiary to Expand_N_Allocator, for the case when the expression
85 -- is a qualified expression or an aggregate.
87 procedure Expand_Array_Comparison
(N
: Node_Id
);
88 -- This routine handles expansion of the comparison operators (N_Op_Lt,
89 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
90 -- code for these operators is similar, differing only in the details of
91 -- the actual comparison call that is made. Special processing (call a
94 function Expand_Array_Equality
99 Typ
: Entity_Id
) return Node_Id
;
100 -- Expand an array equality into a call to a function implementing this
101 -- equality, and a call to it. Loc is the location for the generated
102 -- nodes. Lhs and Rhs are the array expressions to be compared.
103 -- Bodies is a list on which to attach bodies of local functions that
104 -- are created in the process. It is the responsibility of the
105 -- caller to insert those bodies at the right place. Nod provides
106 -- the Sloc value for the generated code. Normally the types used
107 -- for the generated equality routine are taken from Lhs and Rhs.
108 -- However, in some situations of generated code, the Etype fields
109 -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
110 -- type to be used for the formal parameters.
112 procedure Expand_Boolean_Operator
(N
: Node_Id
);
113 -- Common expansion processing for Boolean operators (And, Or, Xor)
114 -- for the case of array type arguments.
116 function Expand_Composite_Equality
121 Bodies
: List_Id
) return Node_Id
;
122 -- Local recursive function used to expand equality for nested
123 -- composite types. Used by Expand_Record/Array_Equality, Bodies
124 -- is a list on which to attach bodies of local functions that are
125 -- created in the process. This is the responsability of the caller
126 -- to insert those bodies at the right place. Nod provides the Sloc
127 -- value for generated code. Lhs and Rhs are the left and right sides
128 -- for the comparison, and Typ is the type of the arrays to compare.
130 procedure Expand_Concatenate_Other
(Cnode
: Node_Id
; Opnds
: List_Id
);
131 -- This routine handles expansion of concatenation operations, where
132 -- N is the N_Op_Concat node being expanded and Operands is the list
133 -- of operands (at least two are present). The caller has dealt with
134 -- converting any singleton operands into singleton aggregates.
136 procedure Expand_Concatenate_String
(Cnode
: Node_Id
; Opnds
: List_Id
);
137 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
138 -- and replace node Cnode with the result of the contatenation. If there
139 -- are two operands, they can be string or character. If there are more
140 -- than two operands, then are always of type string (i.e. the caller has
141 -- already converted character operands to strings in this case).
143 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
144 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
145 -- universal fixed. We do not have such a type at runtime, so the
146 -- purpose of this routine is to find the real type by looking up
147 -- the tree. We also determine if the operation must be rounded.
149 function Get_Allocator_Final_List
152 PtrT
: Entity_Id
) return Entity_Id
;
153 -- If the designated type is controlled, build final_list expression
154 -- for created object. If context is an access parameter, create a
155 -- local access type to have a usable finalization list.
157 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean;
158 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
159 -- discriminants if it has a constrained nominal type, unless the object
160 -- is a component of an enclosing Unchecked_Union object that is subject
161 -- to a per-object constraint and the enclosing object lacks inferable
164 -- An expression of an Unchecked_Union type has inferable discriminants
165 -- if it is either a name of an object with inferable discriminants or a
166 -- qualified expression whose subtype mark denotes a constrained subtype.
168 procedure Insert_Dereference_Action
(N
: Node_Id
);
169 -- N is an expression whose type is an access. When the type of the
170 -- associated storage pool is derived from Checked_Pool, generate a
171 -- call to the 'Dereference' primitive operation.
173 function Make_Array_Comparison_Op
175 Nod
: Node_Id
) return Node_Id
;
176 -- Comparisons between arrays are expanded in line. This function
177 -- produces the body of the implementation of (a > b), where a and b
178 -- are one-dimensional arrays of some discrete type. The original
179 -- node is then expanded into the appropriate call to this function.
180 -- Nod provides the Sloc value for the generated code.
182 function Make_Boolean_Array_Op
184 N
: Node_Id
) return Node_Id
;
185 -- Boolean operations on boolean arrays are expanded in line. This
186 -- function produce the body for the node N, which is (a and b),
187 -- (a or b), or (a xor b). It is used only the normal case and not
188 -- the packed case. The type involved, Typ, is the Boolean array type,
189 -- and the logical operations in the body are simple boolean operations.
190 -- Note that Typ is always a constrained type (the caller has ensured
191 -- this by using Convert_To_Actual_Subtype if necessary).
193 procedure Rewrite_Comparison
(N
: Node_Id
);
194 -- N is the node for a compile time comparison. If this outcome of this
195 -- comparison can be determined at compile time, then the node N can be
196 -- rewritten with True or False. If the outcome cannot be determined at
197 -- compile time, the call has no effect.
199 function Tagged_Membership
(N
: Node_Id
) return Node_Id
;
200 -- Construct the expression corresponding to the tagged membership test.
201 -- Deals with a second operand being (or not) a class-wide type.
203 function Safe_In_Place_Array_Op
206 Op2
: Node_Id
) return Boolean;
207 -- In the context of an assignment, where the right-hand side is a
208 -- boolean operation on arrays, check whether operation can be performed
211 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
212 pragma Inline
(Unary_Op_Validity_Checks
);
213 -- Performs validity checks for a unary operator
215 -------------------------------
216 -- Binary_Op_Validity_Checks --
217 -------------------------------
219 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
221 if Validity_Checks_On
and Validity_Check_Operands
then
222 Ensure_Valid
(Left_Opnd
(N
));
223 Ensure_Valid
(Right_Opnd
(N
));
225 end Binary_Op_Validity_Checks
;
227 ------------------------------------
228 -- Build_Boolean_Array_Proc_Call --
229 ------------------------------------
231 procedure Build_Boolean_Array_Proc_Call
236 Loc
: constant Source_Ptr
:= Sloc
(N
);
237 Kind
: constant Node_Kind
:= Nkind
(Expression
(N
));
238 Target
: constant Node_Id
:=
239 Make_Attribute_Reference
(Loc
,
241 Attribute_Name
=> Name_Address
);
243 Arg1
: constant Node_Id
:= Op1
;
244 Arg2
: Node_Id
:= Op2
;
246 Proc_Name
: Entity_Id
;
249 if Kind
= N_Op_Not
then
250 if Nkind
(Op1
) in N_Binary_Op
then
252 -- Use negated version of the binary operators
254 if Nkind
(Op1
) = N_Op_And
then
255 Proc_Name
:= RTE
(RE_Vector_Nand
);
257 elsif Nkind
(Op1
) = N_Op_Or
then
258 Proc_Name
:= RTE
(RE_Vector_Nor
);
260 else pragma Assert
(Nkind
(Op1
) = N_Op_Xor
);
261 Proc_Name
:= RTE
(RE_Vector_Xor
);
265 Make_Procedure_Call_Statement
(Loc
,
266 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
268 Parameter_Associations
=> New_List
(
270 Make_Attribute_Reference
(Loc
,
271 Prefix
=> Left_Opnd
(Op1
),
272 Attribute_Name
=> Name_Address
),
274 Make_Attribute_Reference
(Loc
,
275 Prefix
=> Right_Opnd
(Op1
),
276 Attribute_Name
=> Name_Address
),
278 Make_Attribute_Reference
(Loc
,
279 Prefix
=> Left_Opnd
(Op1
),
280 Attribute_Name
=> Name_Length
)));
283 Proc_Name
:= RTE
(RE_Vector_Not
);
286 Make_Procedure_Call_Statement
(Loc
,
287 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
288 Parameter_Associations
=> New_List
(
291 Make_Attribute_Reference
(Loc
,
293 Attribute_Name
=> Name_Address
),
295 Make_Attribute_Reference
(Loc
,
297 Attribute_Name
=> Name_Length
)));
301 -- We use the following equivalences:
303 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
304 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
305 -- (not X) xor (not Y) = X xor Y
306 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
308 if Nkind
(Op1
) = N_Op_Not
then
309 if Kind
= N_Op_And
then
310 Proc_Name
:= RTE
(RE_Vector_Nor
);
312 elsif Kind
= N_Op_Or
then
313 Proc_Name
:= RTE
(RE_Vector_Nand
);
316 Proc_Name
:= RTE
(RE_Vector_Xor
);
320 if Kind
= N_Op_And
then
321 Proc_Name
:= RTE
(RE_Vector_And
);
323 elsif Kind
= N_Op_Or
then
324 Proc_Name
:= RTE
(RE_Vector_Or
);
326 elsif Nkind
(Op2
) = N_Op_Not
then
327 Proc_Name
:= RTE
(RE_Vector_Nxor
);
328 Arg2
:= Right_Opnd
(Op2
);
331 Proc_Name
:= RTE
(RE_Vector_Xor
);
336 Make_Procedure_Call_Statement
(Loc
,
337 Name
=> New_Occurrence_Of
(Proc_Name
, Loc
),
338 Parameter_Associations
=> New_List
(
340 Make_Attribute_Reference
(Loc
,
342 Attribute_Name
=> Name_Address
),
343 Make_Attribute_Reference
(Loc
,
345 Attribute_Name
=> Name_Address
),
346 Make_Attribute_Reference
(Loc
,
348 Attribute_Name
=> Name_Length
)));
351 Rewrite
(N
, Call_Node
);
355 when RE_Not_Available
=>
357 end Build_Boolean_Array_Proc_Call
;
359 ---------------------------------
360 -- Expand_Allocator_Expression --
361 ---------------------------------
363 procedure Expand_Allocator_Expression
(N
: Node_Id
) is
364 Loc
: constant Source_Ptr
:= Sloc
(N
);
365 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
366 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
367 PtrT
: constant Entity_Id
:= Etype
(N
);
368 T
: constant Entity_Id
:= Entity
(Indic
);
373 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
375 Tag_Assign
: Node_Id
;
379 if Is_Tagged_Type
(T
) or else Controlled_Type
(T
) then
381 -- Actions inserted before:
382 -- Temp : constant ptr_T := new T'(Expression);
383 -- <no CW> Temp._tag := T'tag;
384 -- <CTRL> Adjust (Finalizable (Temp.all));
385 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
387 -- We analyze by hand the new internal allocator to avoid
388 -- any recursion and inappropriate call to Initialize
390 if not Aggr_In_Place
then
391 Remove_Side_Effects
(Exp
);
395 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
397 -- For a class wide allocation generate the following code:
399 -- type Equiv_Record is record ... end record;
400 -- implicit subtype CW is <Class_Wide_Subytpe>;
401 -- temp : PtrT := new CW'(CW!(expr));
403 if Is_Class_Wide_Type
(T
) then
404 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
406 Set_Expression
(Expression
(N
),
407 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
409 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
412 if Aggr_In_Place
then
414 Make_Object_Declaration
(Loc
,
415 Defining_Identifier
=> Temp
,
416 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
419 New_Reference_To
(Etype
(Exp
), Loc
)));
421 Set_Comes_From_Source
422 (Expression
(Tmp_Node
), Comes_From_Source
(N
));
424 Set_No_Initialization
(Expression
(Tmp_Node
));
425 Insert_Action
(N
, Tmp_Node
);
427 if Controlled_Type
(T
)
428 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
430 -- Create local finalization list for access parameter
432 Flist
:= Get_Allocator_Final_List
(N
, Base_Type
(T
), PtrT
);
435 Convert_Aggr_In_Allocator
(Tmp_Node
, Exp
);
437 Node
:= Relocate_Node
(N
);
440 Make_Object_Declaration
(Loc
,
441 Defining_Identifier
=> Temp
,
442 Constant_Present
=> True,
443 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
444 Expression
=> Node
));
447 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
448 -- type, generate an accessibility check to verify that the level of
449 -- the type of the created object is not deeper than the level of the
450 -- access type. If the type of the qualified expression is class-
451 -- wide, then always generate the check. Otherwise, only generate the
452 -- check if the level of the qualified expression type is statically
453 -- deeper than the access type. Although the static accessibility
454 -- will generally have been performed as a legality check, it won't
455 -- have been done in cases where the allocator appears in generic
456 -- body, so a run-time check is needed in general.
458 if Ada_Version
>= Ada_05
459 and then Is_Class_Wide_Type
(Designated_Type
(PtrT
))
460 and then not Scope_Suppress
(Accessibility_Check
)
462 (Is_Class_Wide_Type
(Etype
(Exp
))
464 Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
))
467 Make_Raise_Program_Error
(Loc
,
471 Make_Function_Call
(Loc
,
473 New_Reference_To
(RTE
(RE_Get_Access_Level
), Loc
),
474 Parameter_Associations
=>
475 New_List
(Make_Attribute_Reference
(Loc
,
477 New_Reference_To
(Temp
, Loc
),
481 Make_Integer_Literal
(Loc
, Type_Access_Level
(PtrT
))),
482 Reason
=> PE_Accessibility_Check_Failed
));
485 -- Suppress the tag assignment when Java_VM because JVM tags
486 -- are represented implicitly in objects.
488 if Is_Tagged_Type
(T
)
489 and then not Is_Class_Wide_Type
(T
)
493 Make_Assignment_Statement
(Loc
,
495 Make_Selected_Component
(Loc
,
496 Prefix
=> New_Reference_To
(Temp
, Loc
),
498 New_Reference_To
(First_Tag_Component
(T
), Loc
)),
501 Unchecked_Convert_To
(RTE
(RE_Tag
),
503 (Elists
.Node
(First_Elmt
(Access_Disp_Table
(T
))),
506 -- The previous assignment has to be done in any case
508 Set_Assignment_OK
(Name
(Tag_Assign
));
509 Insert_Action
(N
, Tag_Assign
);
511 elsif Is_Private_Type
(T
)
512 and then Is_Tagged_Type
(Underlying_Type
(T
))
516 Utyp
: constant Entity_Id
:= Underlying_Type
(T
);
517 Ref
: constant Node_Id
:=
518 Unchecked_Convert_To
(Utyp
,
519 Make_Explicit_Dereference
(Loc
,
520 New_Reference_To
(Temp
, Loc
)));
524 Make_Assignment_Statement
(Loc
,
526 Make_Selected_Component
(Loc
,
529 New_Reference_To
(First_Tag_Component
(Utyp
), Loc
)),
532 Unchecked_Convert_To
(RTE
(RE_Tag
),
534 Elists
.Node
(First_Elmt
(Access_Disp_Table
(Utyp
))),
537 Set_Assignment_OK
(Name
(Tag_Assign
));
538 Insert_Action
(N
, Tag_Assign
);
542 if Controlled_Type
(Designated_Type
(PtrT
))
543 and then Controlled_Type
(T
)
547 Apool
: constant Entity_Id
:=
548 Associated_Storage_Pool
(PtrT
);
551 -- If it is an allocation on the secondary stack
552 -- (i.e. a value returned from a function), the object
553 -- is attached on the caller side as soon as the call
554 -- is completed (see Expand_Ctrl_Function_Call)
556 if Is_RTE
(Apool
, RE_SS_Pool
) then
558 F
: constant Entity_Id
:=
559 Make_Defining_Identifier
(Loc
,
560 New_Internal_Name
('F'));
563 Make_Object_Declaration
(Loc
,
564 Defining_Identifier
=> F
,
565 Object_Definition
=> New_Reference_To
(RTE
566 (RE_Finalizable_Ptr
), Loc
)));
568 Flist
:= New_Reference_To
(F
, Loc
);
569 Attach
:= Make_Integer_Literal
(Loc
, 1);
572 -- Normal case, not a secondary stack allocation
575 if Controlled_Type
(T
)
576 and then Ekind
(PtrT
) = E_Anonymous_Access_Type
578 -- Create local finalization list for access parameter
581 Get_Allocator_Final_List
(N
, Base_Type
(T
), PtrT
);
583 Flist
:= Find_Final_List
(PtrT
);
586 Attach
:= Make_Integer_Literal
(Loc
, 2);
589 if not Aggr_In_Place
then
594 -- An unchecked conversion is needed in the
595 -- classwide case because the designated type
596 -- can be an ancestor of the subtype mark of
599 Unchecked_Convert_To
(T
,
600 Make_Explicit_Dereference
(Loc
,
601 New_Reference_To
(Temp
, Loc
))),
605 With_Attach
=> Attach
));
610 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
611 Analyze_And_Resolve
(N
, PtrT
);
613 elsif Aggr_In_Place
then
615 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
617 Make_Object_Declaration
(Loc
,
618 Defining_Identifier
=> Temp
,
619 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
620 Expression
=> Make_Allocator
(Loc
,
621 New_Reference_To
(Etype
(Exp
), Loc
)));
623 Set_Comes_From_Source
624 (Expression
(Tmp_Node
), Comes_From_Source
(N
));
626 Set_No_Initialization
(Expression
(Tmp_Node
));
627 Insert_Action
(N
, Tmp_Node
);
628 Convert_Aggr_In_Allocator
(Tmp_Node
, Exp
);
629 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
630 Analyze_And_Resolve
(N
, PtrT
);
632 elsif Is_Access_Type
(Designated_Type
(PtrT
))
633 and then Nkind
(Exp
) = N_Allocator
634 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
636 -- Apply constraint to designated subtype indication
638 Apply_Constraint_Check
(Expression
(Exp
),
639 Designated_Type
(Designated_Type
(PtrT
)),
642 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
644 -- Propagate constraint_error to enclosing allocator
646 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
649 -- First check against the type of the qualified expression
651 -- NOTE: The commented call should be correct, but for
652 -- some reason causes the compiler to bomb (sigsegv) on
653 -- ACVC test c34007g, so for now we just perform the old
654 -- (incorrect) test against the designated subtype with
655 -- no sliding in the else part of the if statement below.
658 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
660 -- A check is also needed in cases where the designated
661 -- subtype is constrained and differs from the subtype
662 -- given in the qualified expression. Note that the check
663 -- on the qualified expression does not allow sliding,
664 -- but this check does (a relaxation from Ada 83).
666 if Is_Constrained
(Designated_Type
(PtrT
))
667 and then not Subtypes_Statically_Match
668 (T
, Designated_Type
(PtrT
))
670 Apply_Constraint_Check
671 (Exp
, Designated_Type
(PtrT
), No_Sliding
=> False);
673 -- The nonsliding check should really be performed
674 -- (unconditionally) against the subtype of the
675 -- qualified expression, but that causes a problem
676 -- with c34007g (see above), so for now we retain this.
679 Apply_Constraint_Check
680 (Exp
, Designated_Type
(PtrT
), No_Sliding
=> True);
685 when RE_Not_Available
=>
687 end Expand_Allocator_Expression
;
689 -----------------------------
690 -- Expand_Array_Comparison --
691 -----------------------------
693 -- Expansion is only required in the case of array types. For the
694 -- unpacked case, an appropriate runtime routine is called. For
695 -- packed cases, and also in some other cases where a runtime
696 -- routine cannot be called, the form of the expansion is:
698 -- [body for greater_nn; boolean_expression]
700 -- The body is built by Make_Array_Comparison_Op, and the form of the
701 -- Boolean expression depends on the operator involved.
703 procedure Expand_Array_Comparison
(N
: Node_Id
) is
704 Loc
: constant Source_Ptr
:= Sloc
(N
);
705 Op1
: Node_Id
:= Left_Opnd
(N
);
706 Op2
: Node_Id
:= Right_Opnd
(N
);
707 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
708 Ctyp
: constant Entity_Id
:= Component_Type
(Typ1
);
712 Func_Name
: Entity_Id
;
716 Byte_Addressable
: constant Boolean := System_Storage_Unit
= Byte
'Size;
717 -- True for byte addressable target
719 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean;
720 -- Returns True if the length of the given operand is known to be
721 -- less than 4. Returns False if this length is known to be four
722 -- or greater or is not known at compile time.
724 ------------------------
725 -- Length_Less_Than_4 --
726 ------------------------
728 function Length_Less_Than_4
(Opnd
: Node_Id
) return Boolean is
729 Otyp
: constant Entity_Id
:= Etype
(Opnd
);
732 if Ekind
(Otyp
) = E_String_Literal_Subtype
then
733 return String_Literal_Length
(Otyp
) < 4;
737 Ityp
: constant Entity_Id
:= Etype
(First_Index
(Otyp
));
738 Lo
: constant Node_Id
:= Type_Low_Bound
(Ityp
);
739 Hi
: constant Node_Id
:= Type_High_Bound
(Ityp
);
744 if Compile_Time_Known_Value
(Lo
) then
745 Lov
:= Expr_Value
(Lo
);
750 if Compile_Time_Known_Value
(Hi
) then
751 Hiv
:= Expr_Value
(Hi
);
756 return Hiv
< Lov
+ 3;
759 end Length_Less_Than_4
;
761 -- Start of processing for Expand_Array_Comparison
764 -- Deal first with unpacked case, where we can call a runtime routine
765 -- except that we avoid this for targets for which are not addressable
766 -- by bytes, and for the JVM, since the JVM does not support direct
767 -- addressing of array components.
769 if not Is_Bit_Packed_Array
(Typ1
)
770 and then Byte_Addressable
773 -- The call we generate is:
775 -- Compare_Array_xn[_Unaligned]
776 -- (left'address, right'address, left'length, right'length) <op> 0
778 -- x = U for unsigned, S for signed
779 -- n = 8,16,32,64 for component size
780 -- Add _Unaligned if length < 4 and component size is 8.
781 -- <op> is the standard comparison operator
783 if Component_Size
(Typ1
) = 8 then
784 if Length_Less_Than_4
(Op1
)
786 Length_Less_Than_4
(Op2
)
788 if Is_Unsigned_Type
(Ctyp
) then
789 Comp
:= RE_Compare_Array_U8_Unaligned
;
791 Comp
:= RE_Compare_Array_S8_Unaligned
;
795 if Is_Unsigned_Type
(Ctyp
) then
796 Comp
:= RE_Compare_Array_U8
;
798 Comp
:= RE_Compare_Array_S8
;
802 elsif Component_Size
(Typ1
) = 16 then
803 if Is_Unsigned_Type
(Ctyp
) then
804 Comp
:= RE_Compare_Array_U16
;
806 Comp
:= RE_Compare_Array_S16
;
809 elsif Component_Size
(Typ1
) = 32 then
810 if Is_Unsigned_Type
(Ctyp
) then
811 Comp
:= RE_Compare_Array_U32
;
813 Comp
:= RE_Compare_Array_S32
;
816 else pragma Assert
(Component_Size
(Typ1
) = 64);
817 if Is_Unsigned_Type
(Ctyp
) then
818 Comp
:= RE_Compare_Array_U64
;
820 Comp
:= RE_Compare_Array_S64
;
824 Remove_Side_Effects
(Op1
, Name_Req
=> True);
825 Remove_Side_Effects
(Op2
, Name_Req
=> True);
828 Make_Function_Call
(Sloc
(Op1
),
829 Name
=> New_Occurrence_Of
(RTE
(Comp
), Loc
),
831 Parameter_Associations
=> New_List
(
832 Make_Attribute_Reference
(Loc
,
833 Prefix
=> Relocate_Node
(Op1
),
834 Attribute_Name
=> Name_Address
),
836 Make_Attribute_Reference
(Loc
,
837 Prefix
=> Relocate_Node
(Op2
),
838 Attribute_Name
=> Name_Address
),
840 Make_Attribute_Reference
(Loc
,
841 Prefix
=> Relocate_Node
(Op1
),
842 Attribute_Name
=> Name_Length
),
844 Make_Attribute_Reference
(Loc
,
845 Prefix
=> Relocate_Node
(Op2
),
846 Attribute_Name
=> Name_Length
))));
849 Make_Integer_Literal
(Sloc
(Op2
),
852 Analyze_And_Resolve
(Op1
, Standard_Integer
);
853 Analyze_And_Resolve
(Op2
, Standard_Integer
);
857 -- Cases where we cannot make runtime call
859 -- For (a <= b) we convert to not (a > b)
861 if Chars
(N
) = Name_Op_Le
then
867 Right_Opnd
=> Op2
)));
868 Analyze_And_Resolve
(N
, Standard_Boolean
);
871 -- For < the Boolean expression is
872 -- greater__nn (op2, op1)
874 elsif Chars
(N
) = Name_Op_Lt
then
875 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
879 Op1
:= Right_Opnd
(N
);
880 Op2
:= Left_Opnd
(N
);
882 -- For (a >= b) we convert to not (a < b)
884 elsif Chars
(N
) = Name_Op_Ge
then
890 Right_Opnd
=> Op2
)));
891 Analyze_And_Resolve
(N
, Standard_Boolean
);
894 -- For > the Boolean expression is
895 -- greater__nn (op1, op2)
898 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
899 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
902 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
904 Make_Function_Call
(Loc
,
905 Name
=> New_Reference_To
(Func_Name
, Loc
),
906 Parameter_Associations
=> New_List
(Op1
, Op2
));
908 Insert_Action
(N
, Func_Body
);
910 Analyze_And_Resolve
(N
, Standard_Boolean
);
913 when RE_Not_Available
=>
915 end Expand_Array_Comparison
;
917 ---------------------------
918 -- Expand_Array_Equality --
919 ---------------------------
921 -- Expand an equality function for multi-dimensional arrays. Here is
922 -- an example of such a function for Nb_Dimension = 2
924 -- function Enn (A : atyp; B : btyp) return boolean is
926 -- if (A'length (1) = 0 or else A'length (2) = 0)
928 -- (B'length (1) = 0 or else B'length (2) = 0)
930 -- return True; -- RM 4.5.2(22)
933 -- if A'length (1) /= B'length (1)
935 -- A'length (2) /= B'length (2)
937 -- return False; -- RM 4.5.2(23)
941 -- A1 : Index_T1 := A'first (1);
942 -- B1 : Index_T1 := B'first (1);
946 -- A2 : Index_T2 := A'first (2);
947 -- B2 : Index_T2 := B'first (2);
950 -- if A (A1, A2) /= B (B1, B2) then
954 -- exit when A2 = A'last (2);
955 -- A2 := Index_T2'succ (A2);
956 -- B2 := Index_T2'succ (B2);
960 -- exit when A1 = A'last (1);
961 -- A1 := Index_T1'succ (A1);
962 -- B1 := Index_T1'succ (B1);
969 -- Note on the formal types used (atyp and btyp). If either of the
970 -- arrays is of a private type, we use the underlying type, and
971 -- do an unchecked conversion of the actual. If either of the arrays
972 -- has a bound depending on a discriminant, then we use the base type
973 -- since otherwise we have an escaped discriminant in the function.
975 -- If both arrays are constrained and have the same bounds, we can
976 -- generate a loop with an explicit iteration scheme using a 'Range
977 -- attribute over the first array.
979 function Expand_Array_Equality
984 Typ
: Entity_Id
) return Node_Id
986 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
987 Decls
: constant List_Id
:= New_List
;
988 Index_List1
: constant List_Id
:= New_List
;
989 Index_List2
: constant List_Id
:= New_List
;
993 Func_Name
: Entity_Id
;
996 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
997 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
1001 -- The parameter types to be used for the formals
1006 Num
: Int
) return Node_Id
;
1007 -- This builds the attribute reference Arr'Nam (Expr)
1009 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
1010 -- Create one statement to compare corresponding components,
1011 -- designated by a full set of indices.
1013 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
;
1014 -- Given one of the arguments, computes the appropriate type to
1015 -- be used for that argument in the corresponding function formal
1017 function Handle_One_Dimension
1019 Index
: Node_Id
) return Node_Id
;
1020 -- This procedure returns the following code
1023 -- Bn : Index_T := B'First (N);
1027 -- exit when An = A'Last (N);
1028 -- An := Index_T'Succ (An)
1029 -- Bn := Index_T'Succ (Bn)
1033 -- If both indices are constrained and identical, the procedure
1034 -- returns a simpler loop:
1036 -- for An in A'Range (N) loop
1040 -- N is the dimension for which we are generating a loop. Index is the
1041 -- N'th index node, whose Etype is Index_Type_n in the above code.
1042 -- The xxx statement is either the loop or declare for the next
1043 -- dimension or if this is the last dimension the comparison
1044 -- of corresponding components of the arrays.
1046 -- The actual way the code works is to return the comparison
1047 -- of corresponding components for the N+1 call. That's neater!
1049 function Test_Empty_Arrays
return Node_Id
;
1050 -- This function constructs the test for both arrays being empty
1051 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1053 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1055 function Test_Lengths_Correspond
return Node_Id
;
1056 -- This function constructs the test for arrays having different
1057 -- lengths in at least one index position, in which case resull
1059 -- A'length (1) /= B'length (1)
1061 -- A'length (2) /= B'length (2)
1072 Num
: Int
) return Node_Id
1076 Make_Attribute_Reference
(Loc
,
1077 Attribute_Name
=> Nam
,
1078 Prefix
=> New_Reference_To
(Arr
, Loc
),
1079 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Num
)));
1082 ------------------------
1083 -- Component_Equality --
1084 ------------------------
1086 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
1091 -- if a(i1...) /= b(j1...) then return false; end if;
1094 Make_Indexed_Component
(Loc
,
1095 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
1096 Expressions
=> Index_List1
);
1099 Make_Indexed_Component
(Loc
,
1100 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
1101 Expressions
=> Index_List2
);
1103 Test
:= Expand_Composite_Equality
1104 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
1106 -- If some (sub)component is an unchecked_union, the whole operation
1107 -- will raise program error.
1109 if Nkind
(Test
) = N_Raise_Program_Error
then
1111 -- This node is going to be inserted at a location where a
1112 -- statement is expected: clear its Etype so analysis will
1113 -- set it to the expected Standard_Void_Type.
1115 Set_Etype
(Test
, Empty
);
1120 Make_Implicit_If_Statement
(Nod
,
1121 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
1122 Then_Statements
=> New_List
(
1123 Make_Return_Statement
(Loc
,
1124 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
1126 end Component_Equality
;
1132 function Get_Arg_Type
(N
: Node_Id
) return Entity_Id
is
1143 T
:= Underlying_Type
(T
);
1145 X
:= First_Index
(T
);
1146 while Present
(X
) loop
1147 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(X
)))
1149 Denotes_Discriminant
(Type_High_Bound
(Etype
(X
)))
1162 --------------------------
1163 -- Handle_One_Dimension --
1164 ---------------------------
1166 function Handle_One_Dimension
1168 Index
: Node_Id
) return Node_Id
1170 Need_Separate_Indexes
: constant Boolean :=
1172 or else not Is_Constrained
(Ltyp
);
1173 -- If the index types are identical, and we are working with
1174 -- constrained types, then we can use the same index for both of
1177 An
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
1178 Chars
=> New_Internal_Name
('A'));
1181 Index_T
: Entity_Id
;
1186 if N
> Number_Dimensions
(Ltyp
) then
1187 return Component_Equality
(Ltyp
);
1190 -- Case where we generate a loop
1192 Index_T
:= Base_Type
(Etype
(Index
));
1194 if Need_Separate_Indexes
then
1196 Make_Defining_Identifier
(Loc
,
1197 Chars
=> New_Internal_Name
('B'));
1202 Append
(New_Reference_To
(An
, Loc
), Index_List1
);
1203 Append
(New_Reference_To
(Bn
, Loc
), Index_List2
);
1205 Stm_List
:= New_List
(
1206 Handle_One_Dimension
(N
+ 1, Next_Index
(Index
)));
1208 if Need_Separate_Indexes
then
1210 -- Generate guard for loop, followed by increments of indices
1212 Append_To
(Stm_List
,
1213 Make_Exit_Statement
(Loc
,
1216 Left_Opnd
=> New_Reference_To
(An
, Loc
),
1217 Right_Opnd
=> Arr_Attr
(A
, Name_Last
, N
))));
1219 Append_To
(Stm_List
,
1220 Make_Assignment_Statement
(Loc
,
1221 Name
=> New_Reference_To
(An
, Loc
),
1223 Make_Attribute_Reference
(Loc
,
1224 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1225 Attribute_Name
=> Name_Succ
,
1226 Expressions
=> New_List
(New_Reference_To
(An
, Loc
)))));
1228 Append_To
(Stm_List
,
1229 Make_Assignment_Statement
(Loc
,
1230 Name
=> New_Reference_To
(Bn
, Loc
),
1232 Make_Attribute_Reference
(Loc
,
1233 Prefix
=> New_Reference_To
(Index_T
, Loc
),
1234 Attribute_Name
=> Name_Succ
,
1235 Expressions
=> New_List
(New_Reference_To
(Bn
, Loc
)))));
1238 -- If separate indexes, we need a declare block for An and Bn, and a
1239 -- loop without an iteration scheme.
1241 if Need_Separate_Indexes
then
1243 Make_Implicit_Loop_Statement
(Nod
, Statements
=> Stm_List
);
1246 Make_Block_Statement
(Loc
,
1247 Declarations
=> New_List
(
1248 Make_Object_Declaration
(Loc
,
1249 Defining_Identifier
=> An
,
1250 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1251 Expression
=> Arr_Attr
(A
, Name_First
, N
)),
1253 Make_Object_Declaration
(Loc
,
1254 Defining_Identifier
=> Bn
,
1255 Object_Definition
=> New_Reference_To
(Index_T
, Loc
),
1256 Expression
=> Arr_Attr
(B
, Name_First
, N
))),
1258 Handled_Statement_Sequence
=>
1259 Make_Handled_Sequence_Of_Statements
(Loc
,
1260 Statements
=> New_List
(Loop_Stm
)));
1262 -- If no separate indexes, return loop statement with explicit
1263 -- iteration scheme on its own
1267 Make_Implicit_Loop_Statement
(Nod
,
1268 Statements
=> Stm_List
,
1270 Make_Iteration_Scheme
(Loc
,
1271 Loop_Parameter_Specification
=>
1272 Make_Loop_Parameter_Specification
(Loc
,
1273 Defining_Identifier
=> An
,
1274 Discrete_Subtype_Definition
=>
1275 Arr_Attr
(A
, Name_Range
, N
))));
1278 end Handle_One_Dimension
;
1280 -----------------------
1281 -- Test_Empty_Arrays --
1282 -----------------------
1284 function Test_Empty_Arrays
return Node_Id
is
1294 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1297 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1298 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1302 Left_Opnd
=> Arr_Attr
(B
, Name_Length
, J
),
1303 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1312 Left_Opnd
=> Relocate_Node
(Alist
),
1313 Right_Opnd
=> Atest
);
1317 Left_Opnd
=> Relocate_Node
(Blist
),
1318 Right_Opnd
=> Btest
);
1325 Right_Opnd
=> Blist
);
1326 end Test_Empty_Arrays
;
1328 -----------------------------
1329 -- Test_Lengths_Correspond --
1330 -----------------------------
1332 function Test_Lengths_Correspond
return Node_Id
is
1338 for J
in 1 .. Number_Dimensions
(Ltyp
) loop
1341 Left_Opnd
=> Arr_Attr
(A
, Name_Length
, J
),
1342 Right_Opnd
=> Arr_Attr
(B
, Name_Length
, J
));
1349 Left_Opnd
=> Relocate_Node
(Result
),
1350 Right_Opnd
=> Rtest
);
1355 end Test_Lengths_Correspond
;
1357 -- Start of processing for Expand_Array_Equality
1360 Ltyp
:= Get_Arg_Type
(Lhs
);
1361 Rtyp
:= Get_Arg_Type
(Rhs
);
1363 -- For now, if the argument types are not the same, go to the
1364 -- base type, since the code assumes that the formals have the
1365 -- same type. This is fixable in future ???
1367 if Ltyp
/= Rtyp
then
1368 Ltyp
:= Base_Type
(Ltyp
);
1369 Rtyp
:= Base_Type
(Rtyp
);
1370 pragma Assert
(Ltyp
= Rtyp
);
1373 -- Build list of formals for function
1375 Formals
:= New_List
(
1376 Make_Parameter_Specification
(Loc
,
1377 Defining_Identifier
=> A
,
1378 Parameter_Type
=> New_Reference_To
(Ltyp
, Loc
)),
1380 Make_Parameter_Specification
(Loc
,
1381 Defining_Identifier
=> B
,
1382 Parameter_Type
=> New_Reference_To
(Rtyp
, Loc
)));
1384 Func_Name
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
1386 -- Build statement sequence for function
1389 Make_Subprogram_Body
(Loc
,
1391 Make_Function_Specification
(Loc
,
1392 Defining_Unit_Name
=> Func_Name
,
1393 Parameter_Specifications
=> Formals
,
1394 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
1396 Declarations
=> Decls
,
1398 Handled_Statement_Sequence
=>
1399 Make_Handled_Sequence_Of_Statements
(Loc
,
1400 Statements
=> New_List
(
1402 Make_Implicit_If_Statement
(Nod
,
1403 Condition
=> Test_Empty_Arrays
,
1404 Then_Statements
=> New_List
(
1405 Make_Return_Statement
(Loc
,
1407 New_Occurrence_Of
(Standard_True
, Loc
)))),
1409 Make_Implicit_If_Statement
(Nod
,
1410 Condition
=> Test_Lengths_Correspond
,
1411 Then_Statements
=> New_List
(
1412 Make_Return_Statement
(Loc
,
1414 New_Occurrence_Of
(Standard_False
, Loc
)))),
1416 Handle_One_Dimension
(1, First_Index
(Ltyp
)),
1418 Make_Return_Statement
(Loc
,
1419 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1421 Set_Has_Completion
(Func_Name
, True);
1422 Set_Is_Inlined
(Func_Name
);
1424 -- If the array type is distinct from the type of the arguments,
1425 -- it is the full view of a private type. Apply an unchecked
1426 -- conversion to insure that analysis of the call succeeds.
1436 or else Base_Type
(Etype
(Lhs
)) /= Base_Type
(Ltyp
)
1438 L
:= OK_Convert_To
(Ltyp
, Lhs
);
1442 or else Base_Type
(Etype
(Rhs
)) /= Base_Type
(Rtyp
)
1444 R
:= OK_Convert_To
(Rtyp
, Rhs
);
1447 Actuals
:= New_List
(L
, R
);
1450 Append_To
(Bodies
, Func_Body
);
1453 Make_Function_Call
(Loc
,
1454 Name
=> New_Reference_To
(Func_Name
, Loc
),
1455 Parameter_Associations
=> Actuals
);
1456 end Expand_Array_Equality
;
1458 -----------------------------
1459 -- Expand_Boolean_Operator --
1460 -----------------------------
1462 -- Note that we first get the actual subtypes of the operands,
1463 -- since we always want to deal with types that have bounds.
1465 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
1466 Typ
: constant Entity_Id
:= Etype
(N
);
1469 -- Special case of bit packed array where both operands are known
1470 -- to be properly aligned. In this case we use an efficient run time
1471 -- routine to carry out the operation (see System.Bit_Ops).
1473 if Is_Bit_Packed_Array
(Typ
)
1474 and then not Is_Possibly_Unaligned_Object
(Left_Opnd
(N
))
1475 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
1477 Expand_Packed_Boolean_Operator
(N
);
1481 -- For the normal non-packed case, the general expansion is to build
1482 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
1483 -- and then inserting it into the tree. The original operator node is
1484 -- then rewritten as a call to this function. We also use this in the
1485 -- packed case if either operand is a possibly unaligned object.
1488 Loc
: constant Source_Ptr
:= Sloc
(N
);
1489 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
1490 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
1491 Func_Body
: Node_Id
;
1492 Func_Name
: Entity_Id
;
1495 Convert_To_Actual_Subtype
(L
);
1496 Convert_To_Actual_Subtype
(R
);
1497 Ensure_Defined
(Etype
(L
), N
);
1498 Ensure_Defined
(Etype
(R
), N
);
1499 Apply_Length_Check
(R
, Etype
(L
));
1501 if Nkind
(Parent
(N
)) = N_Assignment_Statement
1502 and then Safe_In_Place_Array_Op
(Name
(Parent
(N
)), L
, R
)
1504 Build_Boolean_Array_Proc_Call
(Parent
(N
), L
, R
);
1506 elsif Nkind
(Parent
(N
)) = N_Op_Not
1507 and then Nkind
(N
) = N_Op_And
1509 Safe_In_Place_Array_Op
(Name
(Parent
(Parent
(N
))), L
, R
)
1514 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
1515 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
1516 Insert_Action
(N
, Func_Body
);
1518 -- Now rewrite the expression with a call
1521 Make_Function_Call
(Loc
,
1522 Name
=> New_Reference_To
(Func_Name
, Loc
),
1523 Parameter_Associations
=>
1526 Make_Type_Conversion
1527 (Loc
, New_Reference_To
(Etype
(L
), Loc
), R
))));
1529 Analyze_And_Resolve
(N
, Typ
);
1532 end Expand_Boolean_Operator
;
1534 -------------------------------
1535 -- Expand_Composite_Equality --
1536 -------------------------------
1538 -- This function is only called for comparing internal fields of composite
1539 -- types when these fields are themselves composites. This is a special
1540 -- case because it is not possible to respect normal Ada visibility rules.
1542 function Expand_Composite_Equality
1547 Bodies
: List_Id
) return Node_Id
1549 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
1550 Full_Type
: Entity_Id
;
1555 if Is_Private_Type
(Typ
) then
1556 Full_Type
:= Underlying_Type
(Typ
);
1561 -- Defense against malformed private types with no completion
1562 -- the error will be diagnosed later by check_completion
1564 if No
(Full_Type
) then
1565 return New_Reference_To
(Standard_False
, Loc
);
1568 Full_Type
:= Base_Type
(Full_Type
);
1570 if Is_Array_Type
(Full_Type
) then
1572 -- If the operand is an elementary type other than a floating-point
1573 -- type, then we can simply use the built-in block bitwise equality,
1574 -- since the predefined equality operators always apply and bitwise
1575 -- equality is fine for all these cases.
1577 if Is_Elementary_Type
(Component_Type
(Full_Type
))
1578 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
1580 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
1582 -- For composite component types, and floating-point types, use
1583 -- the expansion. This deals with tagged component types (where
1584 -- we use the applicable equality routine) and floating-point,
1585 -- (where we need to worry about negative zeroes), and also the
1586 -- case of any composite type recursively containing such fields.
1589 return Expand_Array_Equality
(Nod
, Lhs
, Rhs
, Bodies
, Full_Type
);
1592 elsif Is_Tagged_Type
(Full_Type
) then
1594 -- Call the primitive operation "=" of this type
1596 if Is_Class_Wide_Type
(Full_Type
) then
1597 Full_Type
:= Root_Type
(Full_Type
);
1600 -- If this is derived from an untagged private type completed
1601 -- with a tagged type, it does not have a full view, so we
1602 -- use the primitive operations of the private type.
1603 -- This check should no longer be necessary when these
1604 -- types receive their full views ???
1606 if Is_Private_Type
(Typ
)
1607 and then not Is_Tagged_Type
(Typ
)
1608 and then not Is_Controlled
(Typ
)
1609 and then Is_Derived_Type
(Typ
)
1610 and then No
(Full_View
(Typ
))
1612 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
1614 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
1618 Eq_Op
:= Node
(Prim
);
1619 exit when Chars
(Eq_Op
) = Name_Op_Eq
1620 and then Etype
(First_Formal
(Eq_Op
)) =
1621 Etype
(Next_Formal
(First_Formal
(Eq_Op
)))
1622 and then Base_Type
(Etype
(Eq_Op
)) = Standard_Boolean
;
1624 pragma Assert
(Present
(Prim
));
1627 Eq_Op
:= Node
(Prim
);
1630 Make_Function_Call
(Loc
,
1631 Name
=> New_Reference_To
(Eq_Op
, Loc
),
1632 Parameter_Associations
=>
1634 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
1635 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
1637 elsif Is_Record_Type
(Full_Type
) then
1638 Eq_Op
:= TSS
(Full_Type
, TSS_Composite_Equality
);
1640 if Present
(Eq_Op
) then
1641 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
1643 -- Inherited equality from parent type. Convert the actuals
1644 -- to match signature of operation.
1647 T
: constant Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
1651 Make_Function_Call
(Loc
,
1652 Name
=> New_Reference_To
(Eq_Op
, Loc
),
1653 Parameter_Associations
=>
1654 New_List
(OK_Convert_To
(T
, Lhs
),
1655 OK_Convert_To
(T
, Rhs
)));
1659 -- Comparison between Unchecked_Union components
1661 if Is_Unchecked_Union
(Full_Type
) then
1663 Lhs_Type
: Node_Id
:= Full_Type
;
1664 Rhs_Type
: Node_Id
:= Full_Type
;
1665 Lhs_Discr_Val
: Node_Id
;
1666 Rhs_Discr_Val
: Node_Id
;
1671 if Nkind
(Lhs
) = N_Selected_Component
then
1672 Lhs_Type
:= Etype
(Entity
(Selector_Name
(Lhs
)));
1677 if Nkind
(Rhs
) = N_Selected_Component
then
1678 Rhs_Type
:= Etype
(Entity
(Selector_Name
(Rhs
)));
1681 -- Lhs of the composite equality
1683 if Is_Constrained
(Lhs_Type
) then
1685 -- Since the enclosing record can never be an
1686 -- Unchecked_Union (this code is executed for records
1687 -- that do not have variants), we may reference its
1690 if Nkind
(Lhs
) = N_Selected_Component
1691 and then Has_Per_Object_Constraint
(
1692 Entity
(Selector_Name
(Lhs
)))
1695 Make_Selected_Component
(Loc
,
1696 Prefix
=> Prefix
(Lhs
),
1699 Get_Discriminant_Value
(
1700 First_Discriminant
(Lhs_Type
),
1702 Stored_Constraint
(Lhs_Type
))));
1705 Lhs_Discr_Val
:= New_Copy
(
1706 Get_Discriminant_Value
(
1707 First_Discriminant
(Lhs_Type
),
1709 Stored_Constraint
(Lhs_Type
)));
1713 -- It is not possible to infer the discriminant since
1714 -- the subtype is not constrained.
1717 Make_Raise_Program_Error
(Loc
,
1718 Reason
=> PE_Unchecked_Union_Restriction
);
1721 -- Rhs of the composite equality
1723 if Is_Constrained
(Rhs_Type
) then
1724 if Nkind
(Rhs
) = N_Selected_Component
1725 and then Has_Per_Object_Constraint
(
1726 Entity
(Selector_Name
(Rhs
)))
1729 Make_Selected_Component
(Loc
,
1730 Prefix
=> Prefix
(Rhs
),
1733 Get_Discriminant_Value
(
1734 First_Discriminant
(Rhs_Type
),
1736 Stored_Constraint
(Rhs_Type
))));
1739 Rhs_Discr_Val
:= New_Copy
(
1740 Get_Discriminant_Value
(
1741 First_Discriminant
(Rhs_Type
),
1743 Stored_Constraint
(Rhs_Type
)));
1748 Make_Raise_Program_Error
(Loc
,
1749 Reason
=> PE_Unchecked_Union_Restriction
);
1752 -- Call the TSS equality function with the inferred
1753 -- discriminant values.
1756 Make_Function_Call
(Loc
,
1757 Name
=> New_Reference_To
(Eq_Op
, Loc
),
1758 Parameter_Associations
=> New_List
(
1766 -- Shouldn't this be an else, we can't fall through
1767 -- the above IF, right???
1770 Make_Function_Call
(Loc
,
1771 Name
=> New_Reference_To
(Eq_Op
, Loc
),
1772 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
1776 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
1780 -- It can be a simple record or the full view of a scalar private
1782 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
1784 end Expand_Composite_Equality
;
1786 ------------------------------
1787 -- Expand_Concatenate_Other --
1788 ------------------------------
1790 -- Let n be the number of array operands to be concatenated, Base_Typ
1791 -- their base type, Ind_Typ their index type, and Arr_Typ the original
1792 -- array type to which the concatenantion operator applies, then the
1793 -- following subprogram is constructed:
1795 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1798 -- if S1'Length /= 0 then
1799 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
1800 -- XXX = Arr_Typ'First otherwise
1801 -- elsif S2'Length /= 0 then
1802 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
1803 -- YYY = Arr_Typ'First otherwise
1805 -- elsif Sn-1'Length /= 0 then
1806 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
1807 -- ZZZ = Arr_Typ'First otherwise
1815 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1816 -- + Ind_Typ'Pos (L));
1817 -- R : Base_Typ (L .. H);
1819 -- if S1'Length /= 0 then
1823 -- L := Ind_Typ'Succ (L);
1824 -- exit when P = S1'Last;
1825 -- P := Ind_Typ'Succ (P);
1829 -- if S2'Length /= 0 then
1830 -- L := Ind_Typ'Succ (L);
1833 -- L := Ind_Typ'Succ (L);
1834 -- exit when P = S2'Last;
1835 -- P := Ind_Typ'Succ (P);
1841 -- if Sn'Length /= 0 then
1845 -- L := Ind_Typ'Succ (L);
1846 -- exit when P = Sn'Last;
1847 -- P := Ind_Typ'Succ (P);
1855 procedure Expand_Concatenate_Other
(Cnode
: Node_Id
; Opnds
: List_Id
) is
1856 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
1857 Nb_Opnds
: constant Nat
:= List_Length
(Opnds
);
1859 Arr_Typ
: constant Entity_Id
:= Etype
(Entity
(Cnode
));
1860 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
1861 Ind_Typ
: constant Entity_Id
:= Etype
(First_Index
(Base_Typ
));
1864 Func_Spec
: Node_Id
;
1865 Param_Specs
: List_Id
;
1867 Func_Body
: Node_Id
;
1868 Func_Decls
: List_Id
;
1869 Func_Stmts
: List_Id
;
1874 Elsif_List
: List_Id
;
1876 Declare_Block
: Node_Id
;
1877 Declare_Decls
: List_Id
;
1878 Declare_Stmts
: List_Id
;
1890 function Copy_Into_R_S
(I
: Nat
; Last
: Boolean) return List_Id
;
1891 -- Builds the sequence of statement:
1895 -- L := Ind_Typ'Succ (L);
1896 -- exit when P = Si'Last;
1897 -- P := Ind_Typ'Succ (P);
1900 -- where i is the input parameter I given.
1901 -- If the flag Last is true, the exit statement is emitted before
1902 -- incrementing the lower bound, to prevent the creation out of
1905 function Init_L
(I
: Nat
) return Node_Id
;
1906 -- Builds the statement:
1907 -- L := Arr_Typ'First; If Arr_Typ is constrained
1908 -- L := Si'First; otherwise (where I is the input param given)
1910 function H
return Node_Id
;
1911 -- Builds reference to identifier H
1913 function Ind_Val
(E
: Node_Id
) return Node_Id
;
1914 -- Builds expression Ind_Typ'Val (E);
1916 function L
return Node_Id
;
1917 -- Builds reference to identifier L
1919 function L_Pos
return Node_Id
;
1920 -- Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1921 -- expression to avoid universal_integer computations whenever possible,
1922 -- in the expression for the upper bound H.
1924 function L_Succ
return Node_Id
;
1925 -- Builds expression Ind_Typ'Succ (L)
1927 function One
return Node_Id
;
1928 -- Builds integer literal one
1930 function P
return Node_Id
;
1931 -- Builds reference to identifier P
1933 function P_Succ
return Node_Id
;
1934 -- Builds expression Ind_Typ'Succ (P)
1936 function R
return Node_Id
;
1937 -- Builds reference to identifier R
1939 function S
(I
: Nat
) return Node_Id
;
1940 -- Builds reference to identifier Si, where I is the value given
1942 function S_First
(I
: Nat
) return Node_Id
;
1943 -- Builds expression Si'First, where I is the value given
1945 function S_Last
(I
: Nat
) return Node_Id
;
1946 -- Builds expression Si'Last, where I is the value given
1948 function S_Length
(I
: Nat
) return Node_Id
;
1949 -- Builds expression Si'Length, where I is the value given
1951 function S_Length_Test
(I
: Nat
) return Node_Id
;
1952 -- Builds expression Si'Length /= 0, where I is the value given
1958 function Copy_Into_R_S
(I
: Nat
; Last
: Boolean) return List_Id
is
1959 Stmts
: constant List_Id
:= New_List
;
1961 Loop_Stmt
: Node_Id
;
1963 Exit_Stmt
: Node_Id
;
1968 -- First construct the initializations
1970 P_Start
:= Make_Assignment_Statement
(Loc
,
1972 Expression
=> S_First
(I
));
1973 Append_To
(Stmts
, P_Start
);
1975 -- Then build the loop
1977 R_Copy
:= Make_Assignment_Statement
(Loc
,
1978 Name
=> Make_Indexed_Component
(Loc
,
1980 Expressions
=> New_List
(L
)),
1981 Expression
=> Make_Indexed_Component
(Loc
,
1983 Expressions
=> New_List
(P
)));
1985 L_Inc
:= Make_Assignment_Statement
(Loc
,
1987 Expression
=> L_Succ
);
1989 Exit_Stmt
:= Make_Exit_Statement
(Loc
,
1990 Condition
=> Make_Op_Eq
(Loc
, P
, S_Last
(I
)));
1992 P_Inc
:= Make_Assignment_Statement
(Loc
,
1994 Expression
=> P_Succ
);
1998 Make_Implicit_Loop_Statement
(Cnode
,
1999 Statements
=> New_List
(R_Copy
, Exit_Stmt
, L_Inc
, P_Inc
));
2002 Make_Implicit_Loop_Statement
(Cnode
,
2003 Statements
=> New_List
(R_Copy
, L_Inc
, Exit_Stmt
, P_Inc
));
2006 Append_To
(Stmts
, Loop_Stmt
);
2015 function H
return Node_Id
is
2017 return Make_Identifier
(Loc
, Name_uH
);
2024 function Ind_Val
(E
: Node_Id
) return Node_Id
is
2027 Make_Attribute_Reference
(Loc
,
2028 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
2029 Attribute_Name
=> Name_Val
,
2030 Expressions
=> New_List
(E
));
2037 function Init_L
(I
: Nat
) return Node_Id
is
2041 if Is_Constrained
(Arr_Typ
) then
2042 E
:= Make_Attribute_Reference
(Loc
,
2043 Prefix
=> New_Reference_To
(Arr_Typ
, Loc
),
2044 Attribute_Name
=> Name_First
);
2050 return Make_Assignment_Statement
(Loc
, Name
=> L
, Expression
=> E
);
2057 function L
return Node_Id
is
2059 return Make_Identifier
(Loc
, Name_uL
);
2066 function L_Pos
return Node_Id
is
2067 Target_Type
: Entity_Id
;
2070 -- If the index type is an enumeration type, the computation
2071 -- can be done in standard integer. Otherwise, choose a large
2072 -- enough integer type.
2074 if Is_Enumeration_Type
(Ind_Typ
)
2075 or else Root_Type
(Ind_Typ
) = Standard_Integer
2076 or else Root_Type
(Ind_Typ
) = Standard_Short_Integer
2077 or else Root_Type
(Ind_Typ
) = Standard_Short_Short_Integer
2079 Target_Type
:= Standard_Integer
;
2081 Target_Type
:= Root_Type
(Ind_Typ
);
2085 Make_Qualified_Expression
(Loc
,
2086 Subtype_Mark
=> New_Reference_To
(Target_Type
, Loc
),
2088 Make_Attribute_Reference
(Loc
,
2089 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
2090 Attribute_Name
=> Name_Pos
,
2091 Expressions
=> New_List
(L
)));
2098 function L_Succ
return Node_Id
is
2101 Make_Attribute_Reference
(Loc
,
2102 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
2103 Attribute_Name
=> Name_Succ
,
2104 Expressions
=> New_List
(L
));
2111 function One
return Node_Id
is
2113 return Make_Integer_Literal
(Loc
, 1);
2120 function P
return Node_Id
is
2122 return Make_Identifier
(Loc
, Name_uP
);
2129 function P_Succ
return Node_Id
is
2132 Make_Attribute_Reference
(Loc
,
2133 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
2134 Attribute_Name
=> Name_Succ
,
2135 Expressions
=> New_List
(P
));
2142 function R
return Node_Id
is
2144 return Make_Identifier
(Loc
, Name_uR
);
2151 function S
(I
: Nat
) return Node_Id
is
2153 return Make_Identifier
(Loc
, New_External_Name
('S', I
));
2160 function S_First
(I
: Nat
) return Node_Id
is
2162 return Make_Attribute_Reference
(Loc
,
2164 Attribute_Name
=> Name_First
);
2171 function S_Last
(I
: Nat
) return Node_Id
is
2173 return Make_Attribute_Reference
(Loc
,
2175 Attribute_Name
=> Name_Last
);
2182 function S_Length
(I
: Nat
) return Node_Id
is
2184 return Make_Attribute_Reference
(Loc
,
2186 Attribute_Name
=> Name_Length
);
2193 function S_Length_Test
(I
: Nat
) return Node_Id
is
2197 Left_Opnd
=> S_Length
(I
),
2198 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
2201 -- Start of processing for Expand_Concatenate_Other
2204 -- Construct the parameter specs and the overall function spec
2206 Param_Specs
:= New_List
;
2207 for I
in 1 .. Nb_Opnds
loop
2210 Make_Parameter_Specification
(Loc
,
2211 Defining_Identifier
=>
2212 Make_Defining_Identifier
(Loc
, New_External_Name
('S', I
)),
2213 Parameter_Type
=> New_Reference_To
(Base_Typ
, Loc
)));
2216 Func_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2218 Make_Function_Specification
(Loc
,
2219 Defining_Unit_Name
=> Func_Id
,
2220 Parameter_Specifications
=> Param_Specs
,
2221 Result_Definition
=> New_Reference_To
(Base_Typ
, Loc
));
2223 -- Construct L's object declaration
2226 Make_Object_Declaration
(Loc
,
2227 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uL
),
2228 Object_Definition
=> New_Reference_To
(Ind_Typ
, Loc
));
2230 Func_Decls
:= New_List
(L_Decl
);
2232 -- Construct the if-then-elsif statements
2234 Elsif_List
:= New_List
;
2235 for I
in 2 .. Nb_Opnds
- 1 loop
2236 Append_To
(Elsif_List
, Make_Elsif_Part
(Loc
,
2237 Condition
=> S_Length_Test
(I
),
2238 Then_Statements
=> New_List
(Init_L
(I
))));
2242 Make_Implicit_If_Statement
(Cnode
,
2243 Condition
=> S_Length_Test
(1),
2244 Then_Statements
=> New_List
(Init_L
(1)),
2245 Elsif_Parts
=> Elsif_List
,
2246 Else_Statements
=> New_List
(Make_Return_Statement
(Loc
,
2247 Expression
=> S
(Nb_Opnds
))));
2249 -- Construct the declaration for H
2252 Make_Object_Declaration
(Loc
,
2253 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
2254 Object_Definition
=> New_Reference_To
(Ind_Typ
, Loc
));
2256 H_Init
:= Make_Op_Subtract
(Loc
, S_Length
(1), One
);
2257 for I
in 2 .. Nb_Opnds
loop
2258 H_Init
:= Make_Op_Add
(Loc
, H_Init
, S_Length
(I
));
2260 H_Init
:= Ind_Val
(Make_Op_Add
(Loc
, H_Init
, L_Pos
));
2263 Make_Object_Declaration
(Loc
,
2264 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uH
),
2265 Object_Definition
=> New_Reference_To
(Ind_Typ
, Loc
),
2266 Expression
=> H_Init
);
2268 -- Construct the declaration for R
2270 R_Range
:= Make_Range
(Loc
, Low_Bound
=> L
, High_Bound
=> H
);
2272 Make_Index_Or_Discriminant_Constraint
(Loc
,
2273 Constraints
=> New_List
(R_Range
));
2276 Make_Object_Declaration
(Loc
,
2277 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uR
),
2278 Object_Definition
=>
2279 Make_Subtype_Indication
(Loc
,
2280 Subtype_Mark
=> New_Reference_To
(Base_Typ
, Loc
),
2281 Constraint
=> R_Constr
));
2283 -- Construct the declarations for the declare block
2285 Declare_Decls
:= New_List
(P_Decl
, H_Decl
, R_Decl
);
2287 -- Construct list of statements for the declare block
2289 Declare_Stmts
:= New_List
;
2290 for I
in 1 .. Nb_Opnds
loop
2291 Append_To
(Declare_Stmts
,
2292 Make_Implicit_If_Statement
(Cnode
,
2293 Condition
=> S_Length_Test
(I
),
2294 Then_Statements
=> Copy_Into_R_S
(I
, I
= Nb_Opnds
)));
2297 Append_To
(Declare_Stmts
, Make_Return_Statement
(Loc
, Expression
=> R
));
2299 -- Construct the declare block
2301 Declare_Block
:= Make_Block_Statement
(Loc
,
2302 Declarations
=> Declare_Decls
,
2303 Handled_Statement_Sequence
=>
2304 Make_Handled_Sequence_Of_Statements
(Loc
, Declare_Stmts
));
2306 -- Construct the list of function statements
2308 Func_Stmts
:= New_List
(If_Stmt
, Declare_Block
);
2310 -- Construct the function body
2313 Make_Subprogram_Body
(Loc
,
2314 Specification
=> Func_Spec
,
2315 Declarations
=> Func_Decls
,
2316 Handled_Statement_Sequence
=>
2317 Make_Handled_Sequence_Of_Statements
(Loc
, Func_Stmts
));
2319 -- Insert the newly generated function in the code. This is analyzed
2320 -- with all checks off, since we have completed all the checks.
2322 -- Note that this does *not* fix the array concatenation bug when the
2323 -- low bound is Integer'first sibce that bug comes from the pointer
2324 -- dereferencing an unconstrained array. An there we need a constraint
2325 -- check to make sure the length of the concatenated array is ok. ???
2327 Insert_Action
(Cnode
, Func_Body
, Suppress
=> All_Checks
);
2329 -- Construct list of arguments for the function call
2332 Operand
:= First
(Opnds
);
2333 for I
in 1 .. Nb_Opnds
loop
2334 Append_To
(Params
, Relocate_Node
(Operand
));
2338 -- Insert the function call
2342 Make_Function_Call
(Loc
, New_Reference_To
(Func_Id
, Loc
), Params
));
2344 Analyze_And_Resolve
(Cnode
, Base_Typ
);
2345 Set_Is_Inlined
(Func_Id
);
2346 end Expand_Concatenate_Other
;
2348 -------------------------------
2349 -- Expand_Concatenate_String --
2350 -------------------------------
2352 procedure Expand_Concatenate_String
(Cnode
: Node_Id
; Opnds
: List_Id
) is
2353 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
2354 Opnd1
: constant Node_Id
:= First
(Opnds
);
2355 Opnd2
: constant Node_Id
:= Next
(Opnd1
);
2356 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Opnd1
));
2357 Typ2
: constant Entity_Id
:= Base_Type
(Etype
(Opnd2
));
2360 -- RE_Id value for function to be called
2363 -- In all cases, we build a call to a routine giving the list of
2364 -- arguments as the parameter list to the routine.
2366 case List_Length
(Opnds
) is
2368 if Typ1
= Standard_Character
then
2369 if Typ2
= Standard_Character
then
2370 R
:= RE_Str_Concat_CC
;
2373 pragma Assert
(Typ2
= Standard_String
);
2374 R
:= RE_Str_Concat_CS
;
2377 elsif Typ1
= Standard_String
then
2378 if Typ2
= Standard_Character
then
2379 R
:= RE_Str_Concat_SC
;
2382 pragma Assert
(Typ2
= Standard_String
);
2386 -- If we have anything other than Standard_Character or
2387 -- Standard_String, then we must have had a serious error
2388 -- earlier, so we just abandon the attempt at expansion.
2391 pragma Assert
(Serious_Errors_Detected
> 0);
2396 R
:= RE_Str_Concat_3
;
2399 R
:= RE_Str_Concat_4
;
2402 R
:= RE_Str_Concat_5
;
2406 raise Program_Error
;
2409 -- Now generate the appropriate call
2412 Make_Function_Call
(Sloc
(Cnode
),
2413 Name
=> New_Occurrence_Of
(RTE
(R
), Loc
),
2414 Parameter_Associations
=> Opnds
));
2416 Analyze_And_Resolve
(Cnode
, Standard_String
);
2419 when RE_Not_Available
=>
2421 end Expand_Concatenate_String
;
2423 ------------------------
2424 -- Expand_N_Allocator --
2425 ------------------------
2427 procedure Expand_N_Allocator
(N
: Node_Id
) is
2428 PtrT
: constant Entity_Id
:= Etype
(N
);
2429 Dtyp
: constant Entity_Id
:= Designated_Type
(PtrT
);
2431 Loc
: constant Source_Ptr
:= Sloc
(N
);
2436 -- RM E.2.3(22). We enforce that the expected type of an allocator
2437 -- shall not be a remote access-to-class-wide-limited-private type
2439 -- Why is this being done at expansion time, seems clearly wrong ???
2441 Validate_Remote_Access_To_Class_Wide_Type
(N
);
2443 -- Set the Storage Pool
2445 Set_Storage_Pool
(N
, Associated_Storage_Pool
(Root_Type
(PtrT
)));
2447 if Present
(Storage_Pool
(N
)) then
2448 if Is_RTE
(Storage_Pool
(N
), RE_SS_Pool
) then
2450 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
2453 elsif Is_Class_Wide_Type
(Etype
(Storage_Pool
(N
))) then
2454 Set_Procedure_To_Call
(N
, RTE
(RE_Allocate_Any
));
2457 Set_Procedure_To_Call
(N
,
2458 Find_Prim_Op
(Etype
(Storage_Pool
(N
)), Name_Allocate
));
2462 -- Under certain circumstances we can replace an allocator by an
2463 -- access to statically allocated storage. The conditions, as noted
2464 -- in AARM 3.10 (10c) are as follows:
2466 -- Size and initial value is known at compile time
2467 -- Access type is access-to-constant
2469 -- The allocator is not part of a constraint on a record component,
2470 -- because in that case the inserted actions are delayed until the
2471 -- record declaration is fully analyzed, which is too late for the
2472 -- analysis of the rewritten allocator.
2474 if Is_Access_Constant
(PtrT
)
2475 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
2476 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
2477 and then Size_Known_At_Compile_Time
(Etype
(Expression
2479 and then not Is_Record_Type
(Current_Scope
)
2481 -- Here we can do the optimization. For the allocator
2485 -- We insert an object declaration
2487 -- Tnn : aliased x := y;
2489 -- and replace the allocator by Tnn'Unrestricted_Access.
2490 -- Tnn is marked as requiring static allocation.
2493 Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
2495 Desig
:= Subtype_Mark
(Expression
(N
));
2497 -- If context is constrained, use constrained subtype directly,
2498 -- so that the constant is not labelled as having a nomimally
2499 -- unconstrained subtype.
2501 if Entity
(Desig
) = Base_Type
(Dtyp
) then
2502 Desig
:= New_Occurrence_Of
(Dtyp
, Loc
);
2506 Make_Object_Declaration
(Loc
,
2507 Defining_Identifier
=> Temp
,
2508 Aliased_Present
=> True,
2509 Constant_Present
=> Is_Access_Constant
(PtrT
),
2510 Object_Definition
=> Desig
,
2511 Expression
=> Expression
(Expression
(N
))));
2514 Make_Attribute_Reference
(Loc
,
2515 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
2516 Attribute_Name
=> Name_Unrestricted_Access
));
2518 Analyze_And_Resolve
(N
, PtrT
);
2520 -- We set the variable as statically allocated, since we don't
2521 -- want it going on the stack of the current procedure!
2523 Set_Is_Statically_Allocated
(Temp
);
2527 -- Handle case of qualified expression (other than optimization above)
2529 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
2530 Expand_Allocator_Expression
(N
);
2532 -- If the allocator is for a type which requires initialization, and
2533 -- there is no initial value (i.e. operand is a subtype indication
2534 -- rather than a qualifed expression), then we must generate a call
2535 -- to the initialization routine. This is done using an expression
2538 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2540 -- Here ptr_T is the pointer type for the allocator, and T is the
2541 -- subtype of the allocator. A special case arises if the designated
2542 -- type of the access type is a task or contains tasks. In this case
2543 -- the call to Init (Temp.all ...) is replaced by code that ensures
2544 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2545 -- for details). In addition, if the type T is a task T, then the
2546 -- first argument to Init must be converted to the task record type.
2550 T
: constant Entity_Id
:= Entity
(Expression
(N
));
2558 Temp_Decl
: Node_Id
;
2559 Temp_Type
: Entity_Id
;
2560 Attach_Level
: Uint
;
2563 if No_Initialization
(N
) then
2566 -- Case of no initialization procedure present
2568 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
2570 -- Case of simple initialization required
2572 if Needs_Simple_Initialization
(T
) then
2573 Rewrite
(Expression
(N
),
2574 Make_Qualified_Expression
(Loc
,
2575 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
2576 Expression
=> Get_Simple_Init_Val
(T
, Loc
)));
2578 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
2579 Analyze_And_Resolve
(Expression
(N
), T
);
2580 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
2581 Expand_N_Allocator
(N
);
2583 -- No initialization required
2589 -- Case of initialization procedure present, must be called
2592 Init
:= Base_Init_Proc
(T
);
2595 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
2597 -- Construct argument list for the initialization routine call
2598 -- The CPP constructor needs the address directly
2600 if Is_CPP_Class
(T
) then
2601 Arg1
:= New_Reference_To
(Temp
, Loc
);
2606 Make_Explicit_Dereference
(Loc
,
2607 Prefix
=> New_Reference_To
(Temp
, Loc
));
2608 Set_Assignment_OK
(Arg1
);
2611 -- The initialization procedure expects a specific type.
2612 -- if the context is access to class wide, indicate that
2613 -- the object being allocated has the right specific type.
2615 if Is_Class_Wide_Type
(Dtyp
) then
2616 Arg1
:= Unchecked_Convert_To
(T
, Arg1
);
2620 -- If designated type is a concurrent type or if it is a
2621 -- private type whose definition is a concurrent type,
2622 -- the first argument in the Init routine has to be
2623 -- unchecked conversion to the corresponding record type.
2624 -- If the designated type is a derived type, we also
2625 -- convert the argument to its root type.
2627 if Is_Concurrent_Type
(T
) then
2629 Unchecked_Convert_To
(Corresponding_Record_Type
(T
), Arg1
);
2631 elsif Is_Private_Type
(T
)
2632 and then Present
(Full_View
(T
))
2633 and then Is_Concurrent_Type
(Full_View
(T
))
2636 Unchecked_Convert_To
2637 (Corresponding_Record_Type
(Full_View
(T
)), Arg1
);
2639 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
2642 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
2645 Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Arg1
);
2646 Set_Etype
(Arg1
, Ftyp
);
2650 Args
:= New_List
(Arg1
);
2652 -- For the task case, pass the Master_Id of the access type
2653 -- as the value of the _Master parameter, and _Chain as the
2654 -- value of the _Chain parameter (_Chain will be defined as
2655 -- part of the generated code for the allocator).
2657 if Has_Task
(T
) then
2658 if No
(Master_Id
(Base_Type
(PtrT
))) then
2660 -- The designated type was an incomplete type, and
2661 -- the access type did not get expanded. Salvage
2664 Expand_N_Full_Type_Declaration
2665 (Parent
(Base_Type
(PtrT
)));
2668 -- If the context of the allocator is a declaration or
2669 -- an assignment, we can generate a meaningful image for
2670 -- it, even though subsequent assignments might remove
2671 -- the connection between task and entity. We build this
2672 -- image when the left-hand side is a simple variable,
2673 -- a simple indexed assignment or a simple selected
2676 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
2678 Nam
: constant Node_Id
:= Name
(Parent
(N
));
2681 if Is_Entity_Name
(Nam
) then
2683 Build_Task_Image_Decls
(
2686 (Entity
(Nam
), Sloc
(Nam
)), T
);
2688 elsif (Nkind
(Nam
) = N_Indexed_Component
2689 or else Nkind
(Nam
) = N_Selected_Component
)
2690 and then Is_Entity_Name
(Prefix
(Nam
))
2693 Build_Task_Image_Decls
2694 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
2696 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
2700 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2702 Build_Task_Image_Decls
(
2703 Loc
, Defining_Identifier
(Parent
(N
)), T
);
2706 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
2711 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
2712 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
2714 Decl
:= Last
(Decls
);
2716 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
2718 -- Has_Task is false, Decls not used
2724 -- Add discriminants if discriminated type
2726 if Has_Discriminants
(T
) then
2727 Discr
:= First_Elmt
(Discriminant_Constraint
(T
));
2729 while Present
(Discr
) loop
2730 Append
(New_Copy_Tree
(Elists
.Node
(Discr
)), Args
);
2734 elsif Is_Private_Type
(T
)
2735 and then Present
(Full_View
(T
))
2736 and then Has_Discriminants
(Full_View
(T
))
2739 First_Elmt
(Discriminant_Constraint
(Full_View
(T
)));
2741 while Present
(Discr
) loop
2742 Append
(New_Copy_Tree
(Elists
.Node
(Discr
)), Args
);
2747 -- We set the allocator as analyzed so that when we analyze the
2748 -- expression actions node, we do not get an unwanted recursive
2749 -- expansion of the allocator expression.
2751 Set_Analyzed
(N
, True);
2752 Node
:= Relocate_Node
(N
);
2754 -- Here is the transformation:
2756 -- output: Temp : constant ptr_T := new T;
2757 -- Init (Temp.all, ...);
2758 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
2759 -- <CTRL> Initialize (Finalizable (Temp.all));
2761 -- Here ptr_T is the pointer type for the allocator, and T
2762 -- is the subtype of the allocator.
2765 Make_Object_Declaration
(Loc
,
2766 Defining_Identifier
=> Temp
,
2767 Constant_Present
=> True,
2768 Object_Definition
=> New_Reference_To
(Temp_Type
, Loc
),
2769 Expression
=> Node
);
2771 Set_Assignment_OK
(Temp_Decl
);
2773 if Is_CPP_Class
(T
) then
2774 Set_Aliased_Present
(Temp_Decl
);
2777 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
2779 -- If the designated type is task type or contains tasks,
2780 -- Create block to activate created tasks, and insert
2781 -- declaration for Task_Image variable ahead of call.
2783 if Has_Task
(T
) then
2785 L
: constant List_Id
:= New_List
;
2789 Build_Task_Allocate_Block
(L
, Node
, Args
);
2792 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
2793 Insert_Actions
(N
, L
);
2798 Make_Procedure_Call_Statement
(Loc
,
2799 Name
=> New_Reference_To
(Init
, Loc
),
2800 Parameter_Associations
=> Args
));
2803 if Controlled_Type
(T
) then
2804 Flist
:= Get_Allocator_Final_List
(N
, Base_Type
(T
), PtrT
);
2805 if Ekind
(PtrT
) = E_Anonymous_Access_Type
then
2806 Attach_Level
:= Uint_1
;
2808 Attach_Level
:= Uint_2
;
2812 Ref
=> New_Copy_Tree
(Arg1
),
2815 With_Attach
=> Make_Integer_Literal
(Loc
,
2819 if Is_CPP_Class
(T
) then
2821 Make_Attribute_Reference
(Loc
,
2822 Prefix
=> New_Reference_To
(Temp
, Loc
),
2823 Attribute_Name
=> Name_Unchecked_Access
));
2825 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
2828 Analyze_And_Resolve
(N
, PtrT
);
2834 when RE_Not_Available
=>
2836 end Expand_N_Allocator
;
2838 -----------------------
2839 -- Expand_N_And_Then --
2840 -----------------------
2842 -- Expand into conditional expression if Actions present, and also
2843 -- deal with optimizing case of arguments being True or False.
2845 procedure Expand_N_And_Then
(N
: Node_Id
) is
2846 Loc
: constant Source_Ptr
:= Sloc
(N
);
2847 Typ
: constant Entity_Id
:= Etype
(N
);
2848 Left
: constant Node_Id
:= Left_Opnd
(N
);
2849 Right
: constant Node_Id
:= Right_Opnd
(N
);
2853 -- Deal with non-standard booleans
2855 if Is_Boolean_Type
(Typ
) then
2856 Adjust_Condition
(Left
);
2857 Adjust_Condition
(Right
);
2858 Set_Etype
(N
, Standard_Boolean
);
2861 -- Check for cases of left argument is True or False
2863 if Nkind
(Left
) = N_Identifier
then
2865 -- If left argument is True, change (True and then Right) to Right.
2866 -- Any actions associated with Right will be executed unconditionally
2867 -- and can thus be inserted into the tree unconditionally.
2869 if Entity
(Left
) = Standard_True
then
2870 if Present
(Actions
(N
)) then
2871 Insert_Actions
(N
, Actions
(N
));
2875 Adjust_Result_Type
(N
, Typ
);
2878 -- If left argument is False, change (False and then Right) to
2879 -- False. In this case we can forget the actions associated with
2880 -- Right, since they will never be executed.
2882 elsif Entity
(Left
) = Standard_False
then
2883 Kill_Dead_Code
(Right
);
2884 Kill_Dead_Code
(Actions
(N
));
2885 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2886 Adjust_Result_Type
(N
, Typ
);
2891 -- If Actions are present, we expand
2893 -- left and then right
2897 -- if left then right else false end
2899 -- with the actions becoming the Then_Actions of the conditional
2900 -- expression. This conditional expression is then further expanded
2901 -- (and will eventually disappear)
2903 if Present
(Actions
(N
)) then
2904 Actlist
:= Actions
(N
);
2906 Make_Conditional_Expression
(Loc
,
2907 Expressions
=> New_List
(
2910 New_Occurrence_Of
(Standard_False
, Loc
))));
2912 Set_Then_Actions
(N
, Actlist
);
2913 Analyze_And_Resolve
(N
, Standard_Boolean
);
2914 Adjust_Result_Type
(N
, Typ
);
2918 -- No actions present, check for cases of right argument True/False
2920 if Nkind
(Right
) = N_Identifier
then
2922 -- Change (Left and then True) to Left. Note that we know there
2923 -- are no actions associated with the True operand, since we
2924 -- just checked for this case above.
2926 if Entity
(Right
) = Standard_True
then
2929 -- Change (Left and then False) to False, making sure to preserve
2930 -- any side effects associated with the Left operand.
2932 elsif Entity
(Right
) = Standard_False
then
2933 Remove_Side_Effects
(Left
);
2935 (N
, New_Occurrence_Of
(Standard_False
, Loc
));
2939 Adjust_Result_Type
(N
, Typ
);
2940 end Expand_N_And_Then
;
2942 -------------------------------------
2943 -- Expand_N_Conditional_Expression --
2944 -------------------------------------
2946 -- Expand into expression actions if then/else actions present
2948 procedure Expand_N_Conditional_Expression
(N
: Node_Id
) is
2949 Loc
: constant Source_Ptr
:= Sloc
(N
);
2950 Cond
: constant Node_Id
:= First
(Expressions
(N
));
2951 Thenx
: constant Node_Id
:= Next
(Cond
);
2952 Elsex
: constant Node_Id
:= Next
(Thenx
);
2953 Typ
: constant Entity_Id
:= Etype
(N
);
2958 -- If either then or else actions are present, then given:
2960 -- if cond then then-expr else else-expr end
2962 -- we insert the following sequence of actions (using Insert_Actions):
2967 -- Cnn := then-expr;
2973 -- and replace the conditional expression by a reference to Cnn
2975 if Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
2976 Cnn
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2979 Make_Implicit_If_Statement
(N
,
2980 Condition
=> Relocate_Node
(Cond
),
2982 Then_Statements
=> New_List
(
2983 Make_Assignment_Statement
(Sloc
(Thenx
),
2984 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
2985 Expression
=> Relocate_Node
(Thenx
))),
2987 Else_Statements
=> New_List
(
2988 Make_Assignment_Statement
(Sloc
(Elsex
),
2989 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
2990 Expression
=> Relocate_Node
(Elsex
))));
2992 Set_Assignment_OK
(Name
(First
(Then_Statements
(New_If
))));
2993 Set_Assignment_OK
(Name
(First
(Else_Statements
(New_If
))));
2995 if Present
(Then_Actions
(N
)) then
2997 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
3000 if Present
(Else_Actions
(N
)) then
3002 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
3005 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
3008 Make_Object_Declaration
(Loc
,
3009 Defining_Identifier
=> Cnn
,
3010 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)));
3012 Insert_Action
(N
, New_If
);
3013 Analyze_And_Resolve
(N
, Typ
);
3015 end Expand_N_Conditional_Expression
;
3017 -----------------------------------
3018 -- Expand_N_Explicit_Dereference --
3019 -----------------------------------
3021 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
3023 -- The only processing required is an insertion of an explicit
3024 -- dereference call for the checked storage pool case.
3026 Insert_Dereference_Action
(Prefix
(N
));
3027 end Expand_N_Explicit_Dereference
;
3033 procedure Expand_N_In
(N
: Node_Id
) is
3034 Loc
: constant Source_Ptr
:= Sloc
(N
);
3035 Rtyp
: constant Entity_Id
:= Etype
(N
);
3036 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3037 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3038 Static
: constant Boolean := Is_OK_Static_Expression
(N
);
3040 procedure Substitute_Valid_Check
;
3041 -- Replaces node N by Lop'Valid. This is done when we have an explicit
3042 -- test for the left operand being in range of its subtype.
3044 ----------------------------
3045 -- Substitute_Valid_Check --
3046 ----------------------------
3048 procedure Substitute_Valid_Check
is
3051 Make_Attribute_Reference
(Loc
,
3052 Prefix
=> Relocate_Node
(Lop
),
3053 Attribute_Name
=> Name_Valid
));
3055 Analyze_And_Resolve
(N
, Rtyp
);
3057 Error_Msg_N
("?explicit membership test may be optimized away", N
);
3058 Error_Msg_N
("\?use ''Valid attribute instead", N
);
3060 end Substitute_Valid_Check
;
3062 -- Start of processing for Expand_N_In
3065 -- Check case of explicit test for an expression in range of its
3066 -- subtype. This is suspicious usage and we replace it with a 'Valid
3067 -- test and give a warning.
3069 if Is_Scalar_Type
(Etype
(Lop
))
3070 and then Nkind
(Rop
) in N_Has_Entity
3071 and then Etype
(Lop
) = Entity
(Rop
)
3072 and then Comes_From_Source
(N
)
3074 Substitute_Valid_Check
;
3078 -- Case of explicit range
3080 if Nkind
(Rop
) = N_Range
then
3082 Lo
: constant Node_Id
:= Low_Bound
(Rop
);
3083 Hi
: constant Node_Id
:= High_Bound
(Rop
);
3085 Lo_Orig
: constant Node_Id
:= Original_Node
(Lo
);
3086 Hi_Orig
: constant Node_Id
:= Original_Node
(Hi
);
3088 Lcheck
: constant Compare_Result
:= Compile_Time_Compare
(Lop
, Lo
);
3089 Ucheck
: constant Compare_Result
:= Compile_Time_Compare
(Lop
, Hi
);
3092 -- If test is explicit x'first .. x'last, replace by valid check
3094 if Is_Scalar_Type
(Etype
(Lop
))
3095 and then Nkind
(Lo_Orig
) = N_Attribute_Reference
3096 and then Attribute_Name
(Lo_Orig
) = Name_First
3097 and then Nkind
(Prefix
(Lo_Orig
)) in N_Has_Entity
3098 and then Entity
(Prefix
(Lo_Orig
)) = Etype
(Lop
)
3099 and then Nkind
(Hi_Orig
) = N_Attribute_Reference
3100 and then Attribute_Name
(Hi_Orig
) = Name_Last
3101 and then Nkind
(Prefix
(Hi_Orig
)) in N_Has_Entity
3102 and then Entity
(Prefix
(Hi_Orig
)) = Etype
(Lop
)
3103 and then Comes_From_Source
(N
)
3105 Substitute_Valid_Check
;
3109 -- If we have an explicit range, do a bit of optimization based
3110 -- on range analysis (we may be able to kill one or both checks).
3112 -- If either check is known to fail, replace result by False since
3113 -- the other check does not matter. Preserve the static flag for
3114 -- legality checks, because we are constant-folding beyond RM 4.9.
3116 if Lcheck
= LT
or else Ucheck
= GT
then
3118 New_Reference_To
(Standard_False
, Loc
));
3119 Analyze_And_Resolve
(N
, Rtyp
);
3120 Set_Is_Static_Expression
(N
, Static
);
3123 -- If both checks are known to succeed, replace result
3124 -- by True, since we know we are in range.
3126 elsif Lcheck
in Compare_GE
and then Ucheck
in Compare_LE
then
3128 New_Reference_To
(Standard_True
, Loc
));
3129 Analyze_And_Resolve
(N
, Rtyp
);
3130 Set_Is_Static_Expression
(N
, Static
);
3133 -- If lower bound check succeeds and upper bound check is
3134 -- not known to succeed or fail, then replace the range check
3135 -- with a comparison against the upper bound.
3137 elsif Lcheck
in Compare_GE
then
3141 Right_Opnd
=> High_Bound
(Rop
)));
3142 Analyze_And_Resolve
(N
, Rtyp
);
3145 -- If upper bound check succeeds and lower bound check is
3146 -- not known to succeed or fail, then replace the range check
3147 -- with a comparison against the lower bound.
3149 elsif Ucheck
in Compare_LE
then
3153 Right_Opnd
=> Low_Bound
(Rop
)));
3154 Analyze_And_Resolve
(N
, Rtyp
);
3159 -- For all other cases of an explicit range, nothing to be done
3163 -- Here right operand is a subtype mark
3167 Typ
: Entity_Id
:= Etype
(Rop
);
3168 Is_Acc
: constant Boolean := Is_Access_Type
(Typ
);
3169 Obj
: Node_Id
:= Lop
;
3170 Cond
: Node_Id
:= Empty
;
3173 Remove_Side_Effects
(Obj
);
3175 -- For tagged type, do tagged membership operation
3177 if Is_Tagged_Type
(Typ
) then
3179 -- No expansion will be performed when Java_VM, as the
3180 -- JVM back end will handle the membership tests directly
3181 -- (tags are not explicitly represented in Java objects,
3182 -- so the normal tagged membership expansion is not what
3186 Rewrite
(N
, Tagged_Membership
(N
));
3187 Analyze_And_Resolve
(N
, Rtyp
);
3192 -- If type is scalar type, rewrite as x in t'first .. t'last
3193 -- This reason we do this is that the bounds may have the wrong
3194 -- type if they come from the original type definition.
3196 elsif Is_Scalar_Type
(Typ
) then
3200 Make_Attribute_Reference
(Loc
,
3201 Attribute_Name
=> Name_First
,
3202 Prefix
=> New_Reference_To
(Typ
, Loc
)),
3205 Make_Attribute_Reference
(Loc
,
3206 Attribute_Name
=> Name_Last
,
3207 Prefix
=> New_Reference_To
(Typ
, Loc
))));
3208 Analyze_And_Resolve
(N
, Rtyp
);
3211 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
3212 -- a membership test if the subtype mark denotes a constrained
3213 -- Unchecked_Union subtype and the expression lacks inferable
3216 elsif Is_Unchecked_Union
(Base_Type
(Typ
))
3217 and then Is_Constrained
(Typ
)
3218 and then not Has_Inferable_Discriminants
(Lop
)
3221 Make_Raise_Program_Error
(Loc
,
3222 Reason
=> PE_Unchecked_Union_Restriction
));
3224 -- Prevent Gigi from generating incorrect code by rewriting
3225 -- the test as a standard False.
3228 New_Occurrence_Of
(Standard_False
, Loc
));
3233 -- Here we have a non-scalar type
3236 Typ
:= Designated_Type
(Typ
);
3239 if not Is_Constrained
(Typ
) then
3241 New_Reference_To
(Standard_True
, Loc
));
3242 Analyze_And_Resolve
(N
, Rtyp
);
3244 -- For the constrained array case, we have to check the
3245 -- subscripts for an exact match if the lengths are
3246 -- non-zero (the lengths must match in any case).
3248 elsif Is_Array_Type
(Typ
) then
3250 Check_Subscripts
: declare
3251 function Construct_Attribute_Reference
3254 Dim
: Nat
) return Node_Id
;
3255 -- Build attribute reference E'Nam(Dim)
3257 -----------------------------------
3258 -- Construct_Attribute_Reference --
3259 -----------------------------------
3261 function Construct_Attribute_Reference
3264 Dim
: Nat
) return Node_Id
3268 Make_Attribute_Reference
(Loc
,
3270 Attribute_Name
=> Nam
,
3271 Expressions
=> New_List
(
3272 Make_Integer_Literal
(Loc
, Dim
)));
3273 end Construct_Attribute_Reference
;
3275 -- Start processing for Check_Subscripts
3278 for J
in 1 .. Number_Dimensions
(Typ
) loop
3279 Evolve_And_Then
(Cond
,
3282 Construct_Attribute_Reference
3283 (Duplicate_Subexpr_No_Checks
(Obj
),
3286 Construct_Attribute_Reference
3287 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
3289 Evolve_And_Then
(Cond
,
3292 Construct_Attribute_Reference
3293 (Duplicate_Subexpr_No_Checks
(Obj
),
3296 Construct_Attribute_Reference
3297 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
3306 Right_Opnd
=> Make_Null
(Loc
)),
3307 Right_Opnd
=> Cond
);
3311 Analyze_And_Resolve
(N
, Rtyp
);
3312 end Check_Subscripts
;
3314 -- These are the cases where constraint checks may be
3315 -- required, e.g. records with possible discriminants
3318 -- Expand the test into a series of discriminant comparisons.
3319 -- The expression that is built is the negation of the one
3320 -- that is used for checking discriminant constraints.
3322 Obj
:= Relocate_Node
(Left_Opnd
(N
));
3324 if Has_Discriminants
(Typ
) then
3325 Cond
:= Make_Op_Not
(Loc
,
3326 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
3329 Cond
:= Make_Or_Else
(Loc
,
3333 Right_Opnd
=> Make_Null
(Loc
)),
3334 Right_Opnd
=> Cond
);
3338 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
3342 Analyze_And_Resolve
(N
, Rtyp
);
3348 --------------------------------
3349 -- Expand_N_Indexed_Component --
3350 --------------------------------
3352 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
3353 Loc
: constant Source_Ptr
:= Sloc
(N
);
3354 Typ
: constant Entity_Id
:= Etype
(N
);
3355 P
: constant Node_Id
:= Prefix
(N
);
3356 T
: constant Entity_Id
:= Etype
(P
);
3359 -- A special optimization, if we have an indexed component that
3360 -- is selecting from a slice, then we can eliminate the slice,
3361 -- since, for example, x (i .. j)(k) is identical to x(k). The
3362 -- only difference is the range check required by the slice. The
3363 -- range check for the slice itself has already been generated.
3364 -- The range check for the subscripting operation is ensured
3365 -- by converting the subject to the subtype of the slice.
3367 -- This optimization not only generates better code, avoiding
3368 -- slice messing especially in the packed case, but more importantly
3369 -- bypasses some problems in handling this peculiar case, for
3370 -- example, the issue of dealing specially with object renamings.
3372 if Nkind
(P
) = N_Slice
then
3374 Make_Indexed_Component
(Loc
,
3375 Prefix
=> Prefix
(P
),
3376 Expressions
=> New_List
(
3378 (Etype
(First_Index
(Etype
(P
))),
3379 First
(Expressions
(N
))))));
3380 Analyze_And_Resolve
(N
, Typ
);
3384 -- If the prefix is an access type, then we unconditionally rewrite
3385 -- if as an explicit deference. This simplifies processing for several
3386 -- cases, including packed array cases and certain cases in which
3387 -- checks must be generated. We used to try to do this only when it
3388 -- was necessary, but it cleans up the code to do it all the time.
3390 if Is_Access_Type
(T
) then
3391 Insert_Explicit_Dereference
(P
);
3392 Analyze_And_Resolve
(P
, Designated_Type
(T
));
3395 -- Generate index and validity checks
3397 Generate_Index_Checks
(N
);
3399 if Validity_Checks_On
and then Validity_Check_Subscripts
then
3400 Apply_Subscript_Validity_Checks
(N
);
3403 -- All done for the non-packed case
3405 if not Is_Packed
(Etype
(Prefix
(N
))) then
3409 -- For packed arrays that are not bit-packed (i.e. the case of an array
3410 -- with one or more index types with a non-coniguous enumeration type),
3411 -- we can always use the normal packed element get circuit.
3413 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
3414 Expand_Packed_Element_Reference
(N
);
3418 -- For a reference to a component of a bit packed array, we have to
3419 -- convert it to a reference to the corresponding Packed_Array_Type.
3420 -- We only want to do this for simple references, and not for:
3422 -- Left side of assignment, or prefix of left side of assignment,
3423 -- or prefix of the prefix, to handle packed arrays of packed arrays,
3424 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3426 -- Renaming objects in renaming associations
3427 -- This case is handled when a use of the renamed variable occurs
3429 -- Actual parameters for a procedure call
3430 -- This case is handled in Exp_Ch6.Expand_Actuals
3432 -- The second expression in a 'Read attribute reference
3434 -- The prefix of an address or size attribute reference
3436 -- The following circuit detects these exceptions
3439 Child
: Node_Id
:= N
;
3440 Parnt
: Node_Id
:= Parent
(N
);
3444 if Nkind
(Parnt
) = N_Unchecked_Expression
then
3447 elsif Nkind
(Parnt
) = N_Object_Renaming_Declaration
3448 or else Nkind
(Parnt
) = N_Procedure_Call_Statement
3449 or else (Nkind
(Parnt
) = N_Parameter_Association
3451 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
3455 elsif Nkind
(Parnt
) = N_Attribute_Reference
3456 and then (Attribute_Name
(Parnt
) = Name_Address
3458 Attribute_Name
(Parnt
) = Name_Size
)
3459 and then Prefix
(Parnt
) = Child
3463 elsif Nkind
(Parnt
) = N_Assignment_Statement
3464 and then Name
(Parnt
) = Child
3468 -- If the expression is an index of an indexed component,
3469 -- it must be expanded regardless of context.
3471 elsif Nkind
(Parnt
) = N_Indexed_Component
3472 and then Child
/= Prefix
(Parnt
)
3474 Expand_Packed_Element_Reference
(N
);
3477 elsif Nkind
(Parent
(Parnt
)) = N_Assignment_Statement
3478 and then Name
(Parent
(Parnt
)) = Parnt
3482 elsif Nkind
(Parnt
) = N_Attribute_Reference
3483 and then Attribute_Name
(Parnt
) = Name_Read
3484 and then Next
(First
(Expressions
(Parnt
))) = Child
3488 elsif (Nkind
(Parnt
) = N_Indexed_Component
3489 or else Nkind
(Parnt
) = N_Selected_Component
)
3490 and then Prefix
(Parnt
) = Child
3495 Expand_Packed_Element_Reference
(N
);
3499 -- Keep looking up tree for unchecked expression, or if we are
3500 -- the prefix of a possible assignment left side.
3503 Parnt
:= Parent
(Child
);
3507 end Expand_N_Indexed_Component
;
3509 ---------------------
3510 -- Expand_N_Not_In --
3511 ---------------------
3513 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
3514 -- can be done. This avoids needing to duplicate this expansion code.
3516 procedure Expand_N_Not_In
(N
: Node_Id
) is
3517 Loc
: constant Source_Ptr
:= Sloc
(N
);
3518 Typ
: constant Entity_Id
:= Etype
(N
);
3519 Cfs
: constant Boolean := Comes_From_Source
(N
);
3526 Left_Opnd
=> Left_Opnd
(N
),
3527 Right_Opnd
=> Right_Opnd
(N
))));
3529 -- We want this tp appear as coming from source if original does (see
3530 -- tranformations in Expand_N_In).
3532 Set_Comes_From_Source
(N
, Cfs
);
3533 Set_Comes_From_Source
(Right_Opnd
(N
), Cfs
);
3535 -- Now analyze tranformed node
3537 Analyze_And_Resolve
(N
, Typ
);
3538 end Expand_N_Not_In
;
3544 -- The only replacement required is for the case of a null of type
3545 -- that is an access to protected subprogram. We represent such
3546 -- access values as a record, and so we must replace the occurrence
3547 -- of null by the equivalent record (with a null address and a null
3548 -- pointer in it), so that the backend creates the proper value.
3550 procedure Expand_N_Null
(N
: Node_Id
) is
3551 Loc
: constant Source_Ptr
:= Sloc
(N
);
3552 Typ
: constant Entity_Id
:= Etype
(N
);
3556 if Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
3558 Make_Aggregate
(Loc
,
3559 Expressions
=> New_List
(
3560 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
3564 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
3566 -- For subsequent semantic analysis, the node must retain its
3567 -- type. Gigi in any case replaces this type by the corresponding
3568 -- record type before processing the node.
3574 when RE_Not_Available
=>
3578 ---------------------
3579 -- Expand_N_Op_Abs --
3580 ---------------------
3582 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
3583 Loc
: constant Source_Ptr
:= Sloc
(N
);
3584 Expr
: constant Node_Id
:= Right_Opnd
(N
);
3587 Unary_Op_Validity_Checks
(N
);
3589 -- Deal with software overflow checking
3591 if not Backend_Overflow_Checks_On_Target
3592 and then Is_Signed_Integer_Type
(Etype
(N
))
3593 and then Do_Overflow_Check
(N
)
3595 -- The only case to worry about is when the argument is
3596 -- equal to the largest negative number, so what we do is
3597 -- to insert the check:
3599 -- [constraint_error when Expr = typ'Base'First]
3601 -- with the usual Duplicate_Subexpr use coding for expr
3604 Make_Raise_Constraint_Error
(Loc
,
3607 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
3609 Make_Attribute_Reference
(Loc
,
3611 New_Occurrence_Of
(Base_Type
(Etype
(Expr
)), Loc
),
3612 Attribute_Name
=> Name_First
)),
3613 Reason
=> CE_Overflow_Check_Failed
));
3616 -- Vax floating-point types case
3618 if Vax_Float
(Etype
(N
)) then
3619 Expand_Vax_Arith
(N
);
3621 end Expand_N_Op_Abs
;
3623 ---------------------
3624 -- Expand_N_Op_Add --
3625 ---------------------
3627 procedure Expand_N_Op_Add
(N
: Node_Id
) is
3628 Typ
: constant Entity_Id
:= Etype
(N
);
3631 Binary_Op_Validity_Checks
(N
);
3633 -- N + 0 = 0 + N = N for integer types
3635 if Is_Integer_Type
(Typ
) then
3636 if Compile_Time_Known_Value
(Right_Opnd
(N
))
3637 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
3639 Rewrite
(N
, Left_Opnd
(N
));
3642 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
3643 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
3645 Rewrite
(N
, Right_Opnd
(N
));
3650 -- Arithmetic overflow checks for signed integer/fixed point types
3652 if Is_Signed_Integer_Type
(Typ
)
3653 or else Is_Fixed_Point_Type
(Typ
)
3655 Apply_Arithmetic_Overflow_Check
(N
);
3658 -- Vax floating-point types case
3660 elsif Vax_Float
(Typ
) then
3661 Expand_Vax_Arith
(N
);
3663 end Expand_N_Op_Add
;
3665 ---------------------
3666 -- Expand_N_Op_And --
3667 ---------------------
3669 procedure Expand_N_Op_And
(N
: Node_Id
) is
3670 Typ
: constant Entity_Id
:= Etype
(N
);
3673 Binary_Op_Validity_Checks
(N
);
3675 if Is_Array_Type
(Etype
(N
)) then
3676 Expand_Boolean_Operator
(N
);
3678 elsif Is_Boolean_Type
(Etype
(N
)) then
3679 Adjust_Condition
(Left_Opnd
(N
));
3680 Adjust_Condition
(Right_Opnd
(N
));
3681 Set_Etype
(N
, Standard_Boolean
);
3682 Adjust_Result_Type
(N
, Typ
);
3684 end Expand_N_Op_And
;
3686 ------------------------
3687 -- Expand_N_Op_Concat --
3688 ------------------------
3690 Max_Available_String_Operands
: Int
:= -1;
3691 -- This is initialized the first time this routine is called. It records
3692 -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3693 -- available in the run-time:
3696 -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
3697 -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3698 -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3699 -- 5 All routines including RE_Str_Concat_5 available
3701 Char_Concat_Available
: Boolean;
3702 -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3703 -- all three are available, False if any one of these is unavailable.
3705 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
3707 -- List of operands to be concatenated
3710 -- Single operand for concatenation
3713 -- Node which is to be replaced by the result of concatenating
3714 -- the nodes in the list Opnds.
3717 -- Array type of concatenation result type
3720 -- Component type of concatenation represented by Cnode
3723 -- Initialize global variables showing run-time status
3725 if Max_Available_String_Operands
< 1 then
3726 if not RTE_Available
(RE_Str_Concat
) then
3727 Max_Available_String_Operands
:= 0;
3728 elsif not RTE_Available
(RE_Str_Concat_3
) then
3729 Max_Available_String_Operands
:= 2;
3730 elsif not RTE_Available
(RE_Str_Concat_4
) then
3731 Max_Available_String_Operands
:= 3;
3732 elsif not RTE_Available
(RE_Str_Concat_5
) then
3733 Max_Available_String_Operands
:= 4;
3735 Max_Available_String_Operands
:= 5;
3738 Char_Concat_Available
:=
3739 RTE_Available
(RE_Str_Concat_CC
)
3741 RTE_Available
(RE_Str_Concat_CS
)
3743 RTE_Available
(RE_Str_Concat_SC
);
3746 -- Ensure validity of both operands
3748 Binary_Op_Validity_Checks
(N
);
3750 -- If we are the left operand of a concatenation higher up the
3751 -- tree, then do nothing for now, since we want to deal with a
3752 -- series of concatenations as a unit.
3754 if Nkind
(Parent
(N
)) = N_Op_Concat
3755 and then N
= Left_Opnd
(Parent
(N
))
3760 -- We get here with a concatenation whose left operand may be a
3761 -- concatenation itself with a consistent type. We need to process
3762 -- these concatenation operands from left to right, which means
3763 -- from the deepest node in the tree to the highest node.
3766 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
3767 Cnode
:= Left_Opnd
(Cnode
);
3770 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
3771 -- nodes above, so now we process bottom up, doing the operations. We
3772 -- gather a string that is as long as possible up to five operands
3774 -- The outer loop runs more than once if there are more than five
3775 -- concatenations of type Standard.String, the most we handle for
3776 -- this case, or if more than one concatenation type is involved.
3779 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
3780 Set_Parent
(Opnds
, N
);
3782 -- The inner loop gathers concatenation operands. We gather any
3783 -- number of these in the non-string case, or if no concatenation
3784 -- routines are available for string (since in that case we will
3785 -- treat string like any other non-string case). Otherwise we only
3786 -- gather as many operands as can be handled by the available
3787 -- procedures in the run-time library (normally 5, but may be
3788 -- less for the configurable run-time case).
3790 Inner
: while Cnode
/= N
3791 and then (Base_Type
(Etype
(Cnode
)) /= Standard_String
3793 Max_Available_String_Operands
= 0
3795 List_Length
(Opnds
) <
3796 Max_Available_String_Operands
)
3797 and then Base_Type
(Etype
(Cnode
)) =
3798 Base_Type
(Etype
(Parent
(Cnode
)))
3800 Cnode
:= Parent
(Cnode
);
3801 Append
(Right_Opnd
(Cnode
), Opnds
);
3804 -- Here we process the collected operands. First we convert
3805 -- singleton operands to singleton aggregates. This is skipped
3806 -- however for the case of two operands of type String, since
3807 -- we have special routines for these cases.
3809 Atyp
:= Base_Type
(Etype
(Cnode
));
3810 Ctyp
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
3812 if (List_Length
(Opnds
) > 2 or else Atyp
/= Standard_String
)
3813 or else not Char_Concat_Available
3815 Opnd
:= First
(Opnds
);
3817 if Base_Type
(Etype
(Opnd
)) = Ctyp
then
3819 Make_Aggregate
(Sloc
(Cnode
),
3820 Expressions
=> New_List
(Relocate_Node
(Opnd
))));
3821 Analyze_And_Resolve
(Opnd
, Atyp
);
3825 exit when No
(Opnd
);
3829 -- Now call appropriate continuation routine
3831 if Atyp
= Standard_String
3832 and then Max_Available_String_Operands
> 0
3834 Expand_Concatenate_String
(Cnode
, Opnds
);
3836 Expand_Concatenate_Other
(Cnode
, Opnds
);
3839 exit Outer
when Cnode
= N
;
3840 Cnode
:= Parent
(Cnode
);
3842 end Expand_N_Op_Concat
;
3844 ------------------------
3845 -- Expand_N_Op_Divide --
3846 ------------------------
3848 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
3849 Loc
: constant Source_Ptr
:= Sloc
(N
);
3850 Ltyp
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
3851 Rtyp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
3852 Typ
: Entity_Id
:= Etype
(N
);
3855 Binary_Op_Validity_Checks
(N
);
3857 -- Vax_Float is a special case
3859 if Vax_Float
(Typ
) then
3860 Expand_Vax_Arith
(N
);
3864 -- N / 1 = N for integer types
3866 if Is_Integer_Type
(Typ
)
3867 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
3868 and then Expr_Value
(Right_Opnd
(N
)) = Uint_1
3870 Rewrite
(N
, Left_Opnd
(N
));
3874 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3875 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3876 -- operand is an unsigned integer, as required for this to work.
3878 if Nkind
(Right_Opnd
(N
)) = N_Op_Expon
3879 and then Is_Power_Of_2_For_Shift
(Right_Opnd
(N
))
3881 -- We cannot do this transformation in configurable run time mode if we
3882 -- have 64-bit -- integers and long shifts are not available.
3886 or else Support_Long_Shifts_On_Target
)
3889 Make_Op_Shift_Right
(Loc
,
3890 Left_Opnd
=> Left_Opnd
(N
),
3892 Convert_To
(Standard_Natural
, Right_Opnd
(Right_Opnd
(N
)))));
3893 Analyze_And_Resolve
(N
, Typ
);
3897 -- Do required fixup of universal fixed operation
3899 if Typ
= Universal_Fixed
then
3900 Fixup_Universal_Fixed_Operation
(N
);
3904 -- Divisions with fixed-point results
3906 if Is_Fixed_Point_Type
(Typ
) then
3908 -- No special processing if Treat_Fixed_As_Integer is set,
3909 -- since from a semantic point of view such operations are
3910 -- simply integer operations and will be treated that way.
3912 if not Treat_Fixed_As_Integer
(N
) then
3913 if Is_Integer_Type
(Rtyp
) then
3914 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
3916 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
3920 -- Other cases of division of fixed-point operands. Again we
3921 -- exclude the case where Treat_Fixed_As_Integer is set.
3923 elsif (Is_Fixed_Point_Type
(Ltyp
) or else
3924 Is_Fixed_Point_Type
(Rtyp
))
3925 and then not Treat_Fixed_As_Integer
(N
)
3927 if Is_Integer_Type
(Typ
) then
3928 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
3930 pragma Assert
(Is_Floating_Point_Type
(Typ
));
3931 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
3934 -- Mixed-mode operations can appear in a non-static universal
3935 -- context, in which case the integer argument must be converted
3938 elsif Typ
= Universal_Real
3939 and then Is_Integer_Type
(Rtyp
)
3941 Rewrite
(Right_Opnd
(N
),
3942 Convert_To
(Universal_Real
, Relocate_Node
(Right_Opnd
(N
))));
3944 Analyze_And_Resolve
(Right_Opnd
(N
), Universal_Real
);
3946 elsif Typ
= Universal_Real
3947 and then Is_Integer_Type
(Ltyp
)
3949 Rewrite
(Left_Opnd
(N
),
3950 Convert_To
(Universal_Real
, Relocate_Node
(Left_Opnd
(N
))));
3952 Analyze_And_Resolve
(Left_Opnd
(N
), Universal_Real
);
3954 -- Non-fixed point cases, do zero divide and overflow checks
3956 elsif Is_Integer_Type
(Typ
) then
3957 Apply_Divide_Check
(N
);
3959 -- Check for 64-bit division available
3961 if Esize
(Ltyp
) > 32
3962 and then not Support_64_Bit_Divides_On_Target
3964 Error_Msg_CRT
("64-bit division", N
);
3967 end Expand_N_Op_Divide
;
3969 --------------------
3970 -- Expand_N_Op_Eq --
3971 --------------------
3973 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
3974 Loc
: constant Source_Ptr
:= Sloc
(N
);
3975 Typ
: constant Entity_Id
:= Etype
(N
);
3976 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
3977 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
3978 Bodies
: constant List_Id
:= New_List
;
3979 A_Typ
: constant Entity_Id
:= Etype
(Lhs
);
3981 Typl
: Entity_Id
:= A_Typ
;
3982 Op_Name
: Entity_Id
;
3985 procedure Build_Equality_Call
(Eq
: Entity_Id
);
3986 -- If a constructed equality exists for the type or for its parent,
3987 -- build and analyze call, adding conversions if the operation is
3990 function Has_Unconstrained_UU_Component
(Typ
: Node_Id
) return Boolean;
3991 -- Determines whether a type has a subcompoment of an unconstrained
3992 -- Unchecked_Union subtype. Typ is a record type.
3994 -------------------------
3995 -- Build_Equality_Call --
3996 -------------------------
3998 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
3999 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
4000 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
4001 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
4004 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
4005 and then not Is_Class_Wide_Type
(A_Typ
)
4007 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
4008 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
4011 -- If we have an Unchecked_Union, we need to add the inferred
4012 -- discriminant values as actuals in the function call. At this
4013 -- point, the expansion has determined that both operands have
4014 -- inferable discriminants.
4016 if Is_Unchecked_Union
(Op_Type
) then
4018 Lhs_Type
: constant Node_Id
:= Etype
(L_Exp
);
4019 Rhs_Type
: constant Node_Id
:= Etype
(R_Exp
);
4020 Lhs_Discr_Val
: Node_Id
;
4021 Rhs_Discr_Val
: Node_Id
;
4024 -- Per-object constrained selected components require special
4025 -- attention. If the enclosing scope of the component is an
4026 -- Unchecked_Union, we can not reference its discriminants
4027 -- directly. This is why we use the two extra parameters of
4028 -- the equality function of the enclosing Unchecked_Union.
4030 -- type UU_Type (Discr : Integer := 0) is
4033 -- pragma Unchecked_Union (UU_Type);
4035 -- 1. Unchecked_Union enclosing record:
4037 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
4039 -- Comp : UU_Type (Discr);
4041 -- end Enclosing_UU_Type;
4042 -- pragma Unchecked_Union (Enclosing_UU_Type);
4044 -- Obj1 : Enclosing_UU_Type;
4045 -- Obj2 : Enclosing_UU_Type (1);
4047 -- [. . .] Obj1 = Obj2 [. . .]
4051 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4053 -- A and B are the formal parameters of the equality function
4054 -- of Enclosing_UU_Type. The function always has two extra
4055 -- formals to capture the inferred discriminant values.
4057 -- 2. Non-Unchecked_Union enclosing record:
4060 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
4063 -- Comp : UU_Type (Discr);
4065 -- end Enclosing_Non_UU_Type;
4067 -- Obj1 : Enclosing_Non_UU_Type;
4068 -- Obj2 : Enclosing_Non_UU_Type (1);
4070 -- ... Obj1 = Obj2 ...
4074 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
4075 -- obj1.discr, obj2.discr)) then
4077 -- In this case we can directly reference the discriminants of
4078 -- the enclosing record.
4082 if Nkind
(Lhs
) = N_Selected_Component
4083 and then Has_Per_Object_Constraint
4084 (Entity
(Selector_Name
(Lhs
)))
4086 -- Enclosing record is an Unchecked_Union, use formal A
4088 if Is_Unchecked_Union
(Scope
4089 (Entity
(Selector_Name
(Lhs
))))
4092 Make_Identifier
(Loc
,
4095 -- Enclosing record is of a non-Unchecked_Union type, it is
4096 -- possible to reference the discriminant.
4100 Make_Selected_Component
(Loc
,
4101 Prefix
=> Prefix
(Lhs
),
4104 (Get_Discriminant_Value
4105 (First_Discriminant
(Lhs_Type
),
4107 Stored_Constraint
(Lhs_Type
))));
4110 -- Comment needed here ???
4113 -- Infer the discriminant value
4117 (Get_Discriminant_Value
4118 (First_Discriminant
(Lhs_Type
),
4120 Stored_Constraint
(Lhs_Type
)));
4125 if Nkind
(Rhs
) = N_Selected_Component
4126 and then Has_Per_Object_Constraint
4127 (Entity
(Selector_Name
(Rhs
)))
4129 if Is_Unchecked_Union
4130 (Scope
(Entity
(Selector_Name
(Rhs
))))
4133 Make_Identifier
(Loc
,
4138 Make_Selected_Component
(Loc
,
4139 Prefix
=> Prefix
(Rhs
),
4141 New_Copy
(Get_Discriminant_Value
(
4142 First_Discriminant
(Rhs_Type
),
4144 Stored_Constraint
(Rhs_Type
))));
4149 New_Copy
(Get_Discriminant_Value
(
4150 First_Discriminant
(Rhs_Type
),
4152 Stored_Constraint
(Rhs_Type
)));
4157 Make_Function_Call
(Loc
,
4158 Name
=> New_Reference_To
(Eq
, Loc
),
4159 Parameter_Associations
=> New_List
(
4166 -- Normal case, not an unchecked union
4170 Make_Function_Call
(Loc
,
4171 Name
=> New_Reference_To
(Eq
, Loc
),
4172 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
4175 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
4176 end Build_Equality_Call
;
4178 ------------------------------------
4179 -- Has_Unconstrained_UU_Component --
4180 ------------------------------------
4182 function Has_Unconstrained_UU_Component
4183 (Typ
: Node_Id
) return Boolean
4185 Tdef
: constant Node_Id
:=
4186 Type_Definition
(Declaration_Node
(Base_Type
(Typ
)));
4190 function Component_Is_Unconstrained_UU
4191 (Comp
: Node_Id
) return Boolean;
4192 -- Determines whether the subtype of the component is an
4193 -- unconstrained Unchecked_Union.
4195 function Variant_Is_Unconstrained_UU
4196 (Variant
: Node_Id
) return Boolean;
4197 -- Determines whether a component of the variant has an unconstrained
4198 -- Unchecked_Union subtype.
4200 -----------------------------------
4201 -- Component_Is_Unconstrained_UU --
4202 -----------------------------------
4204 function Component_Is_Unconstrained_UU
4205 (Comp
: Node_Id
) return Boolean
4208 if Nkind
(Comp
) /= N_Component_Declaration
then
4213 Sindic
: constant Node_Id
:=
4214 Subtype_Indication
(Component_Definition
(Comp
));
4217 -- Unconstrained nominal type. In the case of a constraint
4218 -- present, the node kind would have been N_Subtype_Indication.
4220 if Nkind
(Sindic
) = N_Identifier
then
4221 return Is_Unchecked_Union
(Base_Type
(Etype
(Sindic
)));
4226 end Component_Is_Unconstrained_UU
;
4228 ---------------------------------
4229 -- Variant_Is_Unconstrained_UU --
4230 ---------------------------------
4232 function Variant_Is_Unconstrained_UU
4233 (Variant
: Node_Id
) return Boolean
4235 Clist
: constant Node_Id
:= Component_List
(Variant
);
4238 if Is_Empty_List
(Component_Items
(Clist
)) then
4243 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
4246 while Present
(Comp
) loop
4248 -- One component is sufficent
4250 if Component_Is_Unconstrained_UU
(Comp
) then
4258 -- None of the components withing the variant were of
4259 -- unconstrained Unchecked_Union type.
4262 end Variant_Is_Unconstrained_UU
;
4264 -- Start of processing for Has_Unconstrained_UU_Component
4267 if Null_Present
(Tdef
) then
4271 Clist
:= Component_List
(Tdef
);
4272 Vpart
:= Variant_Part
(Clist
);
4274 -- Inspect available components
4276 if Present
(Component_Items
(Clist
)) then
4278 Comp
: Node_Id
:= First
(Component_Items
(Clist
));
4281 while Present
(Comp
) loop
4283 -- One component is sufficent
4285 if Component_Is_Unconstrained_UU
(Comp
) then
4294 -- Inspect available components withing variants
4296 if Present
(Vpart
) then
4298 Variant
: Node_Id
:= First
(Variants
(Vpart
));
4301 while Present
(Variant
) loop
4303 -- One component within a variant is sufficent
4305 if Variant_Is_Unconstrained_UU
(Variant
) then
4314 -- Neither the available components, nor the components inside the
4315 -- variant parts were of an unconstrained Unchecked_Union subtype.
4318 end Has_Unconstrained_UU_Component
;
4320 -- Start of processing for Expand_N_Op_Eq
4323 Binary_Op_Validity_Checks
(N
);
4325 if Ekind
(Typl
) = E_Private_Type
then
4326 Typl
:= Underlying_Type
(Typl
);
4328 elsif Ekind
(Typl
) = E_Private_Subtype
then
4329 Typl
:= Underlying_Type
(Base_Type
(Typl
));
4332 -- It may happen in error situations that the underlying type is not
4333 -- set. The error will be detected later, here we just defend the
4340 Typl
:= Base_Type
(Typl
);
4344 if Vax_Float
(Typl
) then
4345 Expand_Vax_Comparison
(N
);
4348 -- Boolean types (requiring handling of non-standard case)
4350 elsif Is_Boolean_Type
(Typl
) then
4351 Adjust_Condition
(Left_Opnd
(N
));
4352 Adjust_Condition
(Right_Opnd
(N
));
4353 Set_Etype
(N
, Standard_Boolean
);
4354 Adjust_Result_Type
(N
, Typ
);
4358 elsif Is_Array_Type
(Typl
) then
4360 -- If we are doing full validity checking, then expand out array
4361 -- comparisons to make sure that we check the array elements.
4363 if Validity_Check_Operands
then
4365 Save_Force_Validity_Checks
: constant Boolean :=
4366 Force_Validity_Checks
;
4368 Force_Validity_Checks
:= True;
4370 Expand_Array_Equality
4372 Relocate_Node
(Lhs
),
4373 Relocate_Node
(Rhs
),
4376 Insert_Actions
(N
, Bodies
);
4377 Analyze_And_Resolve
(N
, Standard_Boolean
);
4378 Force_Validity_Checks
:= Save_Force_Validity_Checks
;
4381 -- Packed case where both operands are known aligned
4383 elsif Is_Bit_Packed_Array
(Typl
)
4384 and then not Is_Possibly_Unaligned_Object
(Lhs
)
4385 and then not Is_Possibly_Unaligned_Object
(Rhs
)
4387 Expand_Packed_Eq
(N
);
4389 -- Where the component type is elementary we can use a block bit
4390 -- comparison (if supported on the target) exception in the case
4391 -- of floating-point (negative zero issues require element by
4392 -- element comparison), and atomic types (where we must be sure
4393 -- to load elements independently) and possibly unaligned arrays.
4395 elsif Is_Elementary_Type
(Component_Type
(Typl
))
4396 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
4397 and then not Is_Atomic
(Component_Type
(Typl
))
4398 and then not Is_Possibly_Unaligned_Object
(Lhs
)
4399 and then not Is_Possibly_Unaligned_Object
(Rhs
)
4400 and then Support_Composite_Compare_On_Target
4404 -- For composite and floating-point cases, expand equality loop
4405 -- to make sure of using proper comparisons for tagged types,
4406 -- and correctly handling the floating-point case.
4410 Expand_Array_Equality
4412 Relocate_Node
(Lhs
),
4413 Relocate_Node
(Rhs
),
4416 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
4417 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
4422 elsif Is_Record_Type
(Typl
) then
4424 -- For tagged types, use the primitive "="
4426 if Is_Tagged_Type
(Typl
) then
4428 -- If this is derived from an untagged private type completed
4429 -- with a tagged type, it does not have a full view, so we
4430 -- use the primitive operations of the private type.
4431 -- This check should no longer be necessary when these
4432 -- types receive their full views ???
4434 if Is_Private_Type
(A_Typ
)
4435 and then not Is_Tagged_Type
(A_Typ
)
4436 and then Is_Derived_Type
(A_Typ
)
4437 and then No
(Full_View
(A_Typ
))
4439 -- Search for equality operation, checking that the
4440 -- operands have the same type. Note that we must find
4441 -- a matching entry, or something is very wrong!
4443 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
4445 while Present
(Prim
) loop
4446 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
4447 and then Etype
(First_Formal
(Node
(Prim
))) =
4448 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
4450 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
4455 pragma Assert
(Present
(Prim
));
4456 Op_Name
:= Node
(Prim
);
4458 -- Find the type's predefined equality or an overriding
4459 -- user-defined equality. The reason for not simply calling
4460 -- Find_Prim_Op here is that there may be a user-defined
4461 -- overloaded equality op that precedes the equality that
4462 -- we want, so we have to explicitly search (e.g., there
4463 -- could be an equality with two different parameter types).
4466 if Is_Class_Wide_Type
(Typl
) then
4467 Typl
:= Root_Type
(Typl
);
4470 Prim
:= First_Elmt
(Primitive_Operations
(Typl
));
4471 while Present
(Prim
) loop
4472 exit when Chars
(Node
(Prim
)) = Name_Op_Eq
4473 and then Etype
(First_Formal
(Node
(Prim
))) =
4474 Etype
(Next_Formal
(First_Formal
(Node
(Prim
))))
4476 Base_Type
(Etype
(Node
(Prim
))) = Standard_Boolean
;
4481 pragma Assert
(Present
(Prim
));
4482 Op_Name
:= Node
(Prim
);
4485 Build_Equality_Call
(Op_Name
);
4487 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
4488 -- predefined equality operator for a type which has a subcomponent
4489 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
4491 elsif Has_Unconstrained_UU_Component
(Typl
) then
4493 Make_Raise_Program_Error
(Loc
,
4494 Reason
=> PE_Unchecked_Union_Restriction
));
4496 -- Prevent Gigi from generating incorrect code by rewriting the
4497 -- equality as a standard False.
4500 New_Occurrence_Of
(Standard_False
, Loc
));
4502 elsif Is_Unchecked_Union
(Typl
) then
4504 -- If we can infer the discriminants of the operands, we make a
4505 -- call to the TSS equality function.
4507 if Has_Inferable_Discriminants
(Lhs
)
4509 Has_Inferable_Discriminants
(Rhs
)
4512 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
4515 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
4516 -- the predefined equality operator for an Unchecked_Union type
4517 -- if either of the operands lack inferable discriminants.
4520 Make_Raise_Program_Error
(Loc
,
4521 Reason
=> PE_Unchecked_Union_Restriction
));
4523 -- Prevent Gigi from generating incorrect code by rewriting
4524 -- the equality as a standard False.
4527 New_Occurrence_Of
(Standard_False
, Loc
));
4531 -- If a type support function is present (for complex cases), use it
4533 elsif Present
(TSS
(Root_Type
(Typl
), TSS_Composite_Equality
)) then
4535 (TSS
(Root_Type
(Typl
), TSS_Composite_Equality
));
4537 -- Otherwise expand the component by component equality. Note that
4538 -- we never use block-bit coparisons for records, because of the
4539 -- problems with gaps. The backend will often be able to recombine
4540 -- the separate comparisons that we generate here.
4543 Remove_Side_Effects
(Lhs
);
4544 Remove_Side_Effects
(Rhs
);
4546 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
4548 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
4549 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
4553 -- If we still have an equality comparison (i.e. it was not rewritten
4554 -- in some way), then we can test if result is needed at compile time).
4556 if Nkind
(N
) = N_Op_Eq
then
4557 Rewrite_Comparison
(N
);
4561 -----------------------
4562 -- Expand_N_Op_Expon --
4563 -----------------------
4565 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
4566 Loc
: constant Source_Ptr
:= Sloc
(N
);
4567 Typ
: constant Entity_Id
:= Etype
(N
);
4568 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
4569 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
4570 Bastyp
: constant Node_Id
:= Etype
(Base
);
4571 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
4572 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
4573 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
4582 Binary_Op_Validity_Checks
(N
);
4584 -- If either operand is of a private type, then we have the use of
4585 -- an intrinsic operator, and we get rid of the privateness, by using
4586 -- root types of underlying types for the actual operation. Otherwise
4587 -- the private types will cause trouble if we expand multiplications
4588 -- or shifts etc. We also do this transformation if the result type
4589 -- is different from the base type.
4591 if Is_Private_Type
(Etype
(Base
))
4593 Is_Private_Type
(Typ
)
4595 Is_Private_Type
(Exptyp
)
4597 Rtyp
/= Root_Type
(Bastyp
)
4600 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
4601 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
4605 Unchecked_Convert_To
(Typ
,
4607 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
4608 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
4609 Analyze_And_Resolve
(N
, Typ
);
4614 -- Test for case of known right argument
4616 if Compile_Time_Known_Value
(Exp
) then
4617 Expv
:= Expr_Value
(Exp
);
4619 -- We only fold small non-negative exponents. You might think we
4620 -- could fold small negative exponents for the real case, but we
4621 -- can't because we are required to raise Constraint_Error for
4622 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
4623 -- See ACVC test C4A012B.
4625 if Expv
>= 0 and then Expv
<= 4 then
4627 -- X ** 0 = 1 (or 1.0)
4630 if Ekind
(Typ
) in Integer_Kind
then
4631 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
4633 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
4645 Make_Op_Multiply
(Loc
,
4646 Left_Opnd
=> Duplicate_Subexpr
(Base
),
4647 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
4649 -- X ** 3 = X * X * X
4653 Make_Op_Multiply
(Loc
,
4655 Make_Op_Multiply
(Loc
,
4656 Left_Opnd
=> Duplicate_Subexpr
(Base
),
4657 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)),
4658 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
));
4661 -- En : constant base'type := base * base;
4667 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
4669 Insert_Actions
(N
, New_List
(
4670 Make_Object_Declaration
(Loc
,
4671 Defining_Identifier
=> Temp
,
4672 Constant_Present
=> True,
4673 Object_Definition
=> New_Reference_To
(Typ
, Loc
),
4675 Make_Op_Multiply
(Loc
,
4676 Left_Opnd
=> Duplicate_Subexpr
(Base
),
4677 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(Base
)))));
4680 Make_Op_Multiply
(Loc
,
4681 Left_Opnd
=> New_Reference_To
(Temp
, Loc
),
4682 Right_Opnd
=> New_Reference_To
(Temp
, Loc
));
4686 Analyze_And_Resolve
(N
, Typ
);
4691 -- Case of (2 ** expression) appearing as an argument of an integer
4692 -- multiplication, or as the right argument of a division of a non-
4693 -- negative integer. In such cases we leave the node untouched, setting
4694 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4695 -- of the higher level node converts it into a shift.
4697 if Nkind
(Base
) = N_Integer_Literal
4698 and then Intval
(Base
) = 2
4699 and then Is_Integer_Type
(Root_Type
(Exptyp
))
4700 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
4701 and then Is_Unsigned_Type
(Exptyp
)
4703 and then Nkind
(Parent
(N
)) in N_Binary_Op
4706 P
: constant Node_Id
:= Parent
(N
);
4707 L
: constant Node_Id
:= Left_Opnd
(P
);
4708 R
: constant Node_Id
:= Right_Opnd
(P
);
4711 if (Nkind
(P
) = N_Op_Multiply
4713 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
4715 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
4716 and then not Do_Overflow_Check
(P
))
4719 (Nkind
(P
) = N_Op_Divide
4720 and then Is_Integer_Type
(Etype
(L
))
4721 and then Is_Unsigned_Type
(Etype
(L
))
4723 and then not Do_Overflow_Check
(P
))
4725 Set_Is_Power_Of_2_For_Shift
(N
);
4731 -- Fall through if exponentiation must be done using a runtime routine
4733 -- First deal with modular case
4735 if Is_Modular_Integer_Type
(Rtyp
) then
4737 -- Non-binary case, we call the special exponentiation routine for
4738 -- the non-binary case, converting the argument to Long_Long_Integer
4739 -- and passing the modulus value. Then the result is converted back
4740 -- to the base type.
4742 if Non_Binary_Modulus
(Rtyp
) then
4745 Make_Function_Call
(Loc
,
4746 Name
=> New_Reference_To
(RTE
(RE_Exp_Modular
), Loc
),
4747 Parameter_Associations
=> New_List
(
4748 Convert_To
(Standard_Integer
, Base
),
4749 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
4752 -- Binary case, in this case, we call one of two routines, either
4753 -- the unsigned integer case, or the unsigned long long integer
4754 -- case, with a final "and" operation to do the required mod.
4757 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
4758 Ent
:= RTE
(RE_Exp_Unsigned
);
4760 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
4767 Make_Function_Call
(Loc
,
4768 Name
=> New_Reference_To
(Ent
, Loc
),
4769 Parameter_Associations
=> New_List
(
4770 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
4773 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
4777 -- Common exit point for modular type case
4779 Analyze_And_Resolve
(N
, Typ
);
4782 -- Signed integer cases, done using either Integer or Long_Long_Integer.
4783 -- It is not worth having routines for Short_[Short_]Integer, since for
4784 -- most machines it would not help, and it would generate more code that
4785 -- might need certification in the HI-E case.
4787 -- In the integer cases, we have two routines, one for when overflow
4788 -- checks are required, and one when they are not required, since
4789 -- there is a real gain in ommitting checks on many machines.
4791 elsif Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
4792 or else (Rtyp
= Base_Type
(Standard_Long_Integer
)
4794 Esize
(Standard_Long_Integer
) > Esize
(Standard_Integer
))
4795 or else (Rtyp
= Universal_Integer
)
4797 Etyp
:= Standard_Long_Long_Integer
;
4800 Rent
:= RE_Exp_Long_Long_Integer
;
4802 Rent
:= RE_Exn_Long_Long_Integer
;
4805 elsif Is_Signed_Integer_Type
(Rtyp
) then
4806 Etyp
:= Standard_Integer
;
4809 Rent
:= RE_Exp_Integer
;
4811 Rent
:= RE_Exn_Integer
;
4814 -- Floating-point cases, always done using Long_Long_Float. We do not
4815 -- need separate routines for the overflow case here, since in the case
4816 -- of floating-point, we generate infinities anyway as a rule (either
4817 -- that or we automatically trap overflow), and if there is an infinity
4818 -- generated and a range check is required, the check will fail anyway.
4821 pragma Assert
(Is_Floating_Point_Type
(Rtyp
));
4822 Etyp
:= Standard_Long_Long_Float
;
4823 Rent
:= RE_Exn_Long_Long_Float
;
4826 -- Common processing for integer cases and floating-point cases.
4827 -- If we are in the right type, we can call runtime routine directly
4830 and then Rtyp
/= Universal_Integer
4831 and then Rtyp
/= Universal_Real
4834 Make_Function_Call
(Loc
,
4835 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
4836 Parameter_Associations
=> New_List
(Base
, Exp
)));
4838 -- Otherwise we have to introduce conversions (conversions are also
4839 -- required in the universal cases, since the runtime routine is
4840 -- typed using one of the standard types.
4845 Make_Function_Call
(Loc
,
4846 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
4847 Parameter_Associations
=> New_List
(
4848 Convert_To
(Etyp
, Base
),
4852 Analyze_And_Resolve
(N
, Typ
);
4856 when RE_Not_Available
=>
4858 end Expand_N_Op_Expon
;
4860 --------------------
4861 -- Expand_N_Op_Ge --
4862 --------------------
4864 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
4865 Typ
: constant Entity_Id
:= Etype
(N
);
4866 Op1
: constant Node_Id
:= Left_Opnd
(N
);
4867 Op2
: constant Node_Id
:= Right_Opnd
(N
);
4868 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
4871 Binary_Op_Validity_Checks
(N
);
4873 if Vax_Float
(Typ1
) then
4874 Expand_Vax_Comparison
(N
);
4877 elsif Is_Array_Type
(Typ1
) then
4878 Expand_Array_Comparison
(N
);
4882 if Is_Boolean_Type
(Typ1
) then
4883 Adjust_Condition
(Op1
);
4884 Adjust_Condition
(Op2
);
4885 Set_Etype
(N
, Standard_Boolean
);
4886 Adjust_Result_Type
(N
, Typ
);
4889 Rewrite_Comparison
(N
);
4892 --------------------
4893 -- Expand_N_Op_Gt --
4894 --------------------
4896 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
4897 Typ
: constant Entity_Id
:= Etype
(N
);
4898 Op1
: constant Node_Id
:= Left_Opnd
(N
);
4899 Op2
: constant Node_Id
:= Right_Opnd
(N
);
4900 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
4903 Binary_Op_Validity_Checks
(N
);
4905 if Vax_Float
(Typ1
) then
4906 Expand_Vax_Comparison
(N
);
4909 elsif Is_Array_Type
(Typ1
) then
4910 Expand_Array_Comparison
(N
);
4914 if Is_Boolean_Type
(Typ1
) then
4915 Adjust_Condition
(Op1
);
4916 Adjust_Condition
(Op2
);
4917 Set_Etype
(N
, Standard_Boolean
);
4918 Adjust_Result_Type
(N
, Typ
);
4921 Rewrite_Comparison
(N
);
4924 --------------------
4925 -- Expand_N_Op_Le --
4926 --------------------
4928 procedure Expand_N_Op_Le
(N
: Node_Id
) is
4929 Typ
: constant Entity_Id
:= Etype
(N
);
4930 Op1
: constant Node_Id
:= Left_Opnd
(N
);
4931 Op2
: constant Node_Id
:= Right_Opnd
(N
);
4932 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
4935 Binary_Op_Validity_Checks
(N
);
4937 if Vax_Float
(Typ1
) then
4938 Expand_Vax_Comparison
(N
);
4941 elsif Is_Array_Type
(Typ1
) then
4942 Expand_Array_Comparison
(N
);
4946 if Is_Boolean_Type
(Typ1
) then
4947 Adjust_Condition
(Op1
);
4948 Adjust_Condition
(Op2
);
4949 Set_Etype
(N
, Standard_Boolean
);
4950 Adjust_Result_Type
(N
, Typ
);
4953 Rewrite_Comparison
(N
);
4956 --------------------
4957 -- Expand_N_Op_Lt --
4958 --------------------
4960 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
4961 Typ
: constant Entity_Id
:= Etype
(N
);
4962 Op1
: constant Node_Id
:= Left_Opnd
(N
);
4963 Op2
: constant Node_Id
:= Right_Opnd
(N
);
4964 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
4967 Binary_Op_Validity_Checks
(N
);
4969 if Vax_Float
(Typ1
) then
4970 Expand_Vax_Comparison
(N
);
4973 elsif Is_Array_Type
(Typ1
) then
4974 Expand_Array_Comparison
(N
);
4978 if Is_Boolean_Type
(Typ1
) then
4979 Adjust_Condition
(Op1
);
4980 Adjust_Condition
(Op2
);
4981 Set_Etype
(N
, Standard_Boolean
);
4982 Adjust_Result_Type
(N
, Typ
);
4985 Rewrite_Comparison
(N
);
4988 -----------------------
4989 -- Expand_N_Op_Minus --
4990 -----------------------
4992 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
4993 Loc
: constant Source_Ptr
:= Sloc
(N
);
4994 Typ
: constant Entity_Id
:= Etype
(N
);
4997 Unary_Op_Validity_Checks
(N
);
4999 if not Backend_Overflow_Checks_On_Target
5000 and then Is_Signed_Integer_Type
(Etype
(N
))
5001 and then Do_Overflow_Check
(N
)
5003 -- Software overflow checking expands -expr into (0 - expr)
5006 Make_Op_Subtract
(Loc
,
5007 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
5008 Right_Opnd
=> Right_Opnd
(N
)));
5010 Analyze_And_Resolve
(N
, Typ
);
5012 -- Vax floating-point types case
5014 elsif Vax_Float
(Etype
(N
)) then
5015 Expand_Vax_Arith
(N
);
5017 end Expand_N_Op_Minus
;
5019 ---------------------
5020 -- Expand_N_Op_Mod --
5021 ---------------------
5023 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
5024 Loc
: constant Source_Ptr
:= Sloc
(N
);
5025 Typ
: constant Entity_Id
:= Etype
(N
);
5026 Left
: constant Node_Id
:= Left_Opnd
(N
);
5027 Right
: constant Node_Id
:= Right_Opnd
(N
);
5028 DOC
: constant Boolean := Do_Overflow_Check
(N
);
5029 DDC
: constant Boolean := Do_Division_Check
(N
);
5040 Binary_Op_Validity_Checks
(N
);
5042 Determine_Range
(Right
, ROK
, Rlo
, Rhi
);
5043 Determine_Range
(Left
, LOK
, Llo
, Lhi
);
5045 -- Convert mod to rem if operands are known non-negative. We do this
5046 -- since it is quite likely that this will improve the quality of code,
5047 -- (the operation now corresponds to the hardware remainder), and it
5048 -- does not seem likely that it could be harmful.
5050 if LOK
and then Llo
>= 0
5052 ROK
and then Rlo
>= 0
5055 Make_Op_Rem
(Sloc
(N
),
5056 Left_Opnd
=> Left_Opnd
(N
),
5057 Right_Opnd
=> Right_Opnd
(N
)));
5059 -- Instead of reanalyzing the node we do the analysis manually.
5060 -- This avoids anomalies when the replacement is done in an
5061 -- instance and is epsilon more efficient.
5063 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
5065 Set_Do_Overflow_Check
(N
, DOC
);
5066 Set_Do_Division_Check
(N
, DDC
);
5067 Expand_N_Op_Rem
(N
);
5070 -- Otherwise, normal mod processing
5073 if Is_Integer_Type
(Etype
(N
)) then
5074 Apply_Divide_Check
(N
);
5077 -- Apply optimization x mod 1 = 0. We don't really need that with
5078 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5079 -- certainly harmless.
5081 if Is_Integer_Type
(Etype
(N
))
5082 and then Compile_Time_Known_Value
(Right
)
5083 and then Expr_Value
(Right
) = Uint_1
5085 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5086 Analyze_And_Resolve
(N
, Typ
);
5090 -- Deal with annoying case of largest negative number remainder
5091 -- minus one. Gigi does not handle this case correctly, because
5092 -- it generates a divide instruction which may trap in this case.
5094 -- In fact the check is quite easy, if the right operand is -1,
5095 -- then the mod value is always 0, and we can just ignore the
5096 -- left operand completely in this case.
5098 -- The operand type may be private (e.g. in the expansion of an
5099 -- an intrinsic operation) so we must use the underlying type to
5100 -- get the bounds, and convert the literals explicitly.
5104 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
5106 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
5108 ((not LOK
) or else (Llo
= LLB
))
5111 Make_Conditional_Expression
(Loc
,
5112 Expressions
=> New_List
(
5114 Left_Opnd
=> Duplicate_Subexpr
(Right
),
5116 Unchecked_Convert_To
(Typ
,
5117 Make_Integer_Literal
(Loc
, -1))),
5118 Unchecked_Convert_To
(Typ
,
5119 Make_Integer_Literal
(Loc
, Uint_0
)),
5120 Relocate_Node
(N
))));
5122 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
5123 Analyze_And_Resolve
(N
, Typ
);
5126 end Expand_N_Op_Mod
;
5128 --------------------------
5129 -- Expand_N_Op_Multiply --
5130 --------------------------
5132 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
5133 Loc
: constant Source_Ptr
:= Sloc
(N
);
5134 Lop
: constant Node_Id
:= Left_Opnd
(N
);
5135 Rop
: constant Node_Id
:= Right_Opnd
(N
);
5137 Lp2
: constant Boolean :=
5138 Nkind
(Lop
) = N_Op_Expon
5139 and then Is_Power_Of_2_For_Shift
(Lop
);
5141 Rp2
: constant Boolean :=
5142 Nkind
(Rop
) = N_Op_Expon
5143 and then Is_Power_Of_2_For_Shift
(Rop
);
5145 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
5146 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
5147 Typ
: Entity_Id
:= Etype
(N
);
5150 Binary_Op_Validity_Checks
(N
);
5152 -- Special optimizations for integer types
5154 if Is_Integer_Type
(Typ
) then
5156 -- N * 0 = 0 * N = 0 for integer types
5158 if (Compile_Time_Known_Value
(Rop
)
5159 and then Expr_Value
(Rop
) = Uint_0
)
5161 (Compile_Time_Known_Value
(Lop
)
5162 and then Expr_Value
(Lop
) = Uint_0
)
5164 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
5165 Analyze_And_Resolve
(N
, Typ
);
5169 -- N * 1 = 1 * N = N for integer types
5171 -- This optimisation is not done if we are going to
5172 -- rewrite the product 1 * 2 ** N to a shift.
5174 if Compile_Time_Known_Value
(Rop
)
5175 and then Expr_Value
(Rop
) = Uint_1
5181 elsif Compile_Time_Known_Value
(Lop
)
5182 and then Expr_Value
(Lop
) = Uint_1
5190 -- Deal with VAX float case
5192 if Vax_Float
(Typ
) then
5193 Expand_Vax_Arith
(N
);
5197 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5198 -- Is_Power_Of_2_For_Shift is set means that we know that our left
5199 -- operand is an integer, as required for this to work.
5204 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
5208 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
5211 Left_Opnd
=> Right_Opnd
(Lop
),
5212 Right_Opnd
=> Right_Opnd
(Rop
))));
5213 Analyze_And_Resolve
(N
, Typ
);
5218 Make_Op_Shift_Left
(Loc
,
5221 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
5222 Analyze_And_Resolve
(N
, Typ
);
5226 -- Same processing for the operands the other way round
5230 Make_Op_Shift_Left
(Loc
,
5233 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
5234 Analyze_And_Resolve
(N
, Typ
);
5238 -- Do required fixup of universal fixed operation
5240 if Typ
= Universal_Fixed
then
5241 Fixup_Universal_Fixed_Operation
(N
);
5245 -- Multiplications with fixed-point results
5247 if Is_Fixed_Point_Type
(Typ
) then
5249 -- No special processing if Treat_Fixed_As_Integer is set,
5250 -- since from a semantic point of view such operations are
5251 -- simply integer operations and will be treated that way.
5253 if not Treat_Fixed_As_Integer
(N
) then
5255 -- Case of fixed * integer => fixed
5257 if Is_Integer_Type
(Rtyp
) then
5258 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
5260 -- Case of integer * fixed => fixed
5262 elsif Is_Integer_Type
(Ltyp
) then
5263 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
5265 -- Case of fixed * fixed => fixed
5268 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
5272 -- Other cases of multiplication of fixed-point operands. Again
5273 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
5275 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
5276 and then not Treat_Fixed_As_Integer
(N
)
5278 if Is_Integer_Type
(Typ
) then
5279 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
5281 pragma Assert
(Is_Floating_Point_Type
(Typ
));
5282 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
5285 -- Mixed-mode operations can appear in a non-static universal
5286 -- context, in which case the integer argument must be converted
5289 elsif Typ
= Universal_Real
5290 and then Is_Integer_Type
(Rtyp
)
5292 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
5294 Analyze_And_Resolve
(Rop
, Universal_Real
);
5296 elsif Typ
= Universal_Real
5297 and then Is_Integer_Type
(Ltyp
)
5299 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
5301 Analyze_And_Resolve
(Lop
, Universal_Real
);
5303 -- Non-fixed point cases, check software overflow checking required
5305 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
5306 Apply_Arithmetic_Overflow_Check
(N
);
5308 end Expand_N_Op_Multiply
;
5310 --------------------
5311 -- Expand_N_Op_Ne --
5312 --------------------
5314 -- Rewrite node as the negation of an equality operation, and reanalyze.
5315 -- The equality to be used is defined in the same scope and has the same
5316 -- signature. It must be set explicitly because in an instance it may not
5317 -- have the same visibility as in the generic unit.
5319 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
5320 Loc
: constant Source_Ptr
:= Sloc
(N
);
5322 Ne
: constant Entity_Id
:= Entity
(N
);
5325 Binary_Op_Validity_Checks
(N
);
5331 Left_Opnd
=> Left_Opnd
(N
),
5332 Right_Opnd
=> Right_Opnd
(N
)));
5333 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
5335 if Scope
(Ne
) /= Standard_Standard
then
5336 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
5339 -- For navigation purposes, the inequality is treated as an implicit
5340 -- reference to the corresponding equality. Preserve the Comes_From_
5341 -- source flag so that the proper Xref entry is generated.
5343 Preserve_Comes_From_Source
(Neg
, N
);
5344 Preserve_Comes_From_Source
(Right_Opnd
(Neg
), N
);
5346 Analyze_And_Resolve
(N
, Standard_Boolean
);
5349 ---------------------
5350 -- Expand_N_Op_Not --
5351 ---------------------
5353 -- If the argument is other than a Boolean array type, there is no
5354 -- special expansion required.
5356 -- For the packed case, we call the special routine in Exp_Pakd, except
5357 -- that if the component size is greater than one, we use the standard
5358 -- routine generating a gruesome loop (it is so peculiar to have packed
5359 -- arrays with non-standard Boolean representations anyway, so it does
5360 -- not matter that we do not handle this case efficiently).
5362 -- For the unpacked case (and for the special packed case where we have
5363 -- non standard Booleans, as discussed above), we generate and insert
5364 -- into the tree the following function definition:
5366 -- function Nnnn (A : arr) is
5369 -- for J in a'range loop
5370 -- B (J) := not A (J);
5375 -- Here arr is the actual subtype of the parameter (and hence always
5376 -- constrained). Then we replace the not with a call to this function.
5378 procedure Expand_N_Op_Not
(N
: Node_Id
) is
5379 Loc
: constant Source_Ptr
:= Sloc
(N
);
5380 Typ
: constant Entity_Id
:= Etype
(N
);
5389 Func_Name
: Entity_Id
;
5390 Loop_Statement
: Node_Id
;
5393 Unary_Op_Validity_Checks
(N
);
5395 -- For boolean operand, deal with non-standard booleans
5397 if Is_Boolean_Type
(Typ
) then
5398 Adjust_Condition
(Right_Opnd
(N
));
5399 Set_Etype
(N
, Standard_Boolean
);
5400 Adjust_Result_Type
(N
, Typ
);
5404 -- Only array types need any other processing
5406 if not Is_Array_Type
(Typ
) then
5410 -- Case of array operand. If bit packed with a component size of 1,
5411 -- handle it in Exp_Pakd if the operand is known to be aligned.
5413 if Is_Bit_Packed_Array
(Typ
)
5414 and then Component_Size
(Typ
) = 1
5415 and then not Is_Possibly_Unaligned_Object
(Right_Opnd
(N
))
5417 Expand_Packed_Not
(N
);
5421 -- Case of array operand which is not bit-packed. If the context is
5422 -- a safe assignment, call in-place operation, If context is a larger
5423 -- boolean expression in the context of a safe assignment, expansion is
5424 -- done by enclosing operation.
5426 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
5427 Convert_To_Actual_Subtype
(Opnd
);
5428 Arr
:= Etype
(Opnd
);
5429 Ensure_Defined
(Arr
, N
);
5431 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
5432 if Safe_In_Place_Array_Op
(Name
(Parent
(N
)), N
, Empty
) then
5433 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
5436 -- Special case the negation of a binary operation
5438 elsif (Nkind
(Opnd
) = N_Op_And
5439 or else Nkind
(Opnd
) = N_Op_Or
5440 or else Nkind
(Opnd
) = N_Op_Xor
)
5441 and then Safe_In_Place_Array_Op
5442 (Name
(Parent
(N
)), Left_Opnd
(Opnd
), Right_Opnd
(Opnd
))
5444 Build_Boolean_Array_Proc_Call
(Parent
(N
), Opnd
, Empty
);
5448 elsif Nkind
(Parent
(N
)) in N_Binary_Op
5449 and then Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
5452 Op1
: constant Node_Id
:= Left_Opnd
(Parent
(N
));
5453 Op2
: constant Node_Id
:= Right_Opnd
(Parent
(N
));
5454 Lhs
: constant Node_Id
:= Name
(Parent
(Parent
(N
)));
5457 if Safe_In_Place_Array_Op
(Lhs
, Op1
, Op2
) then
5459 and then Nkind
(Op2
) = N_Op_Not
5461 -- (not A) op (not B) can be reduced to a single call
5466 and then Nkind
(Parent
(N
)) = N_Op_Xor
5468 -- A xor (not B) can also be special-cased
5476 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
5477 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
5478 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
5481 Make_Indexed_Component
(Loc
,
5482 Prefix
=> New_Reference_To
(A
, Loc
),
5483 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
5486 Make_Indexed_Component
(Loc
,
5487 Prefix
=> New_Reference_To
(B
, Loc
),
5488 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
5491 Make_Implicit_Loop_Statement
(N
,
5492 Identifier
=> Empty
,
5495 Make_Iteration_Scheme
(Loc
,
5496 Loop_Parameter_Specification
=>
5497 Make_Loop_Parameter_Specification
(Loc
,
5498 Defining_Identifier
=> J
,
5499 Discrete_Subtype_Definition
=>
5500 Make_Attribute_Reference
(Loc
,
5501 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
5502 Attribute_Name
=> Name_Range
))),
5504 Statements
=> New_List
(
5505 Make_Assignment_Statement
(Loc
,
5507 Expression
=> Make_Op_Not
(Loc
, A_J
))));
5509 Func_Name
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('N'));
5510 Set_Is_Inlined
(Func_Name
);
5513 Make_Subprogram_Body
(Loc
,
5515 Make_Function_Specification
(Loc
,
5516 Defining_Unit_Name
=> Func_Name
,
5517 Parameter_Specifications
=> New_List
(
5518 Make_Parameter_Specification
(Loc
,
5519 Defining_Identifier
=> A
,
5520 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))),
5521 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
5523 Declarations
=> New_List
(
5524 Make_Object_Declaration
(Loc
,
5525 Defining_Identifier
=> B
,
5526 Object_Definition
=> New_Reference_To
(Arr
, Loc
))),
5528 Handled_Statement_Sequence
=>
5529 Make_Handled_Sequence_Of_Statements
(Loc
,
5530 Statements
=> New_List
(
5532 Make_Return_Statement
(Loc
,
5534 Make_Identifier
(Loc
, Chars
(B
)))))));
5537 Make_Function_Call
(Loc
,
5538 Name
=> New_Reference_To
(Func_Name
, Loc
),
5539 Parameter_Associations
=> New_List
(Opnd
)));
5541 Analyze_And_Resolve
(N
, Typ
);
5542 end Expand_N_Op_Not
;
5544 --------------------
5545 -- Expand_N_Op_Or --
5546 --------------------
5548 procedure Expand_N_Op_Or
(N
: Node_Id
) is
5549 Typ
: constant Entity_Id
:= Etype
(N
);
5552 Binary_Op_Validity_Checks
(N
);
5554 if Is_Array_Type
(Etype
(N
)) then
5555 Expand_Boolean_Operator
(N
);
5557 elsif Is_Boolean_Type
(Etype
(N
)) then
5558 Adjust_Condition
(Left_Opnd
(N
));
5559 Adjust_Condition
(Right_Opnd
(N
));
5560 Set_Etype
(N
, Standard_Boolean
);
5561 Adjust_Result_Type
(N
, Typ
);
5565 ----------------------
5566 -- Expand_N_Op_Plus --
5567 ----------------------
5569 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
5571 Unary_Op_Validity_Checks
(N
);
5572 end Expand_N_Op_Plus
;
5574 ---------------------
5575 -- Expand_N_Op_Rem --
5576 ---------------------
5578 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
5579 Loc
: constant Source_Ptr
:= Sloc
(N
);
5580 Typ
: constant Entity_Id
:= Etype
(N
);
5582 Left
: constant Node_Id
:= Left_Opnd
(N
);
5583 Right
: constant Node_Id
:= Right_Opnd
(N
);
5594 Binary_Op_Validity_Checks
(N
);
5596 if Is_Integer_Type
(Etype
(N
)) then
5597 Apply_Divide_Check
(N
);
5600 -- Apply optimization x rem 1 = 0. We don't really need that with
5601 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
5602 -- certainly harmless.
5604 if Is_Integer_Type
(Etype
(N
))
5605 and then Compile_Time_Known_Value
(Right
)
5606 and then Expr_Value
(Right
) = Uint_1
5608 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5609 Analyze_And_Resolve
(N
, Typ
);
5613 -- Deal with annoying case of largest negative number remainder
5614 -- minus one. Gigi does not handle this case correctly, because
5615 -- it generates a divide instruction which may trap in this case.
5617 -- In fact the check is quite easy, if the right operand is -1,
5618 -- then the remainder is always 0, and we can just ignore the
5619 -- left operand completely in this case.
5621 Determine_Range
(Right
, ROK
, Rlo
, Rhi
);
5622 Determine_Range
(Left
, LOK
, Llo
, Lhi
);
5624 -- The operand type may be private (e.g. in the expansion of an
5625 -- an intrinsic operation) so we must use the underlying type to
5626 -- get the bounds, and convert the literals explicitly.
5630 (Type_Low_Bound
(Base_Type
(Underlying_Type
(Etype
(Left
)))));
5632 -- Now perform the test, generating code only if needed
5634 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
5636 ((not LOK
) or else (Llo
= LLB
))
5639 Make_Conditional_Expression
(Loc
,
5640 Expressions
=> New_List
(
5642 Left_Opnd
=> Duplicate_Subexpr
(Right
),
5644 Unchecked_Convert_To
(Typ
,
5645 Make_Integer_Literal
(Loc
, -1))),
5647 Unchecked_Convert_To
(Typ
,
5648 Make_Integer_Literal
(Loc
, Uint_0
)),
5650 Relocate_Node
(N
))));
5652 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
5653 Analyze_And_Resolve
(N
, Typ
);
5655 end Expand_N_Op_Rem
;
5657 -----------------------------
5658 -- Expand_N_Op_Rotate_Left --
5659 -----------------------------
5661 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
5663 Binary_Op_Validity_Checks
(N
);
5664 end Expand_N_Op_Rotate_Left
;
5666 ------------------------------
5667 -- Expand_N_Op_Rotate_Right --
5668 ------------------------------
5670 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
5672 Binary_Op_Validity_Checks
(N
);
5673 end Expand_N_Op_Rotate_Right
;
5675 ----------------------------
5676 -- Expand_N_Op_Shift_Left --
5677 ----------------------------
5679 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
5681 Binary_Op_Validity_Checks
(N
);
5682 end Expand_N_Op_Shift_Left
;
5684 -----------------------------
5685 -- Expand_N_Op_Shift_Right --
5686 -----------------------------
5688 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
5690 Binary_Op_Validity_Checks
(N
);
5691 end Expand_N_Op_Shift_Right
;
5693 ----------------------------------------
5694 -- Expand_N_Op_Shift_Right_Arithmetic --
5695 ----------------------------------------
5697 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
5699 Binary_Op_Validity_Checks
(N
);
5700 end Expand_N_Op_Shift_Right_Arithmetic
;
5702 --------------------------
5703 -- Expand_N_Op_Subtract --
5704 --------------------------
5706 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
5707 Typ
: constant Entity_Id
:= Etype
(N
);
5710 Binary_Op_Validity_Checks
(N
);
5712 -- N - 0 = N for integer types
5714 if Is_Integer_Type
(Typ
)
5715 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
5716 and then Expr_Value
(Right_Opnd
(N
)) = 0
5718 Rewrite
(N
, Left_Opnd
(N
));
5722 -- Arithemtic overflow checks for signed integer/fixed point types
5724 if Is_Signed_Integer_Type
(Typ
)
5725 or else Is_Fixed_Point_Type
(Typ
)
5727 Apply_Arithmetic_Overflow_Check
(N
);
5729 -- Vax floating-point types case
5731 elsif Vax_Float
(Typ
) then
5732 Expand_Vax_Arith
(N
);
5734 end Expand_N_Op_Subtract
;
5736 ---------------------
5737 -- Expand_N_Op_Xor --
5738 ---------------------
5740 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
5741 Typ
: constant Entity_Id
:= Etype
(N
);
5744 Binary_Op_Validity_Checks
(N
);
5746 if Is_Array_Type
(Etype
(N
)) then
5747 Expand_Boolean_Operator
(N
);
5749 elsif Is_Boolean_Type
(Etype
(N
)) then
5750 Adjust_Condition
(Left_Opnd
(N
));
5751 Adjust_Condition
(Right_Opnd
(N
));
5752 Set_Etype
(N
, Standard_Boolean
);
5753 Adjust_Result_Type
(N
, Typ
);
5755 end Expand_N_Op_Xor
;
5757 ----------------------
5758 -- Expand_N_Or_Else --
5759 ----------------------
5761 -- Expand into conditional expression if Actions present, and also
5762 -- deal with optimizing case of arguments being True or False.
5764 procedure Expand_N_Or_Else
(N
: Node_Id
) is
5765 Loc
: constant Source_Ptr
:= Sloc
(N
);
5766 Typ
: constant Entity_Id
:= Etype
(N
);
5767 Left
: constant Node_Id
:= Left_Opnd
(N
);
5768 Right
: constant Node_Id
:= Right_Opnd
(N
);
5772 -- Deal with non-standard booleans
5774 if Is_Boolean_Type
(Typ
) then
5775 Adjust_Condition
(Left
);
5776 Adjust_Condition
(Right
);
5777 Set_Etype
(N
, Standard_Boolean
);
5780 -- Check for cases of left argument is True or False
5782 if Nkind
(Left
) = N_Identifier
then
5784 -- If left argument is False, change (False or else Right) to Right.
5785 -- Any actions associated with Right will be executed unconditionally
5786 -- and can thus be inserted into the tree unconditionally.
5788 if Entity
(Left
) = Standard_False
then
5789 if Present
(Actions
(N
)) then
5790 Insert_Actions
(N
, Actions
(N
));
5794 Adjust_Result_Type
(N
, Typ
);
5797 -- If left argument is True, change (True and then Right) to
5798 -- True. In this case we can forget the actions associated with
5799 -- Right, since they will never be executed.
5801 elsif Entity
(Left
) = Standard_True
then
5802 Kill_Dead_Code
(Right
);
5803 Kill_Dead_Code
(Actions
(N
));
5804 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5805 Adjust_Result_Type
(N
, Typ
);
5810 -- If Actions are present, we expand
5812 -- left or else right
5816 -- if left then True else right end
5818 -- with the actions becoming the Else_Actions of the conditional
5819 -- expression. This conditional expression is then further expanded
5820 -- (and will eventually disappear)
5822 if Present
(Actions
(N
)) then
5823 Actlist
:= Actions
(N
);
5825 Make_Conditional_Expression
(Loc
,
5826 Expressions
=> New_List
(
5828 New_Occurrence_Of
(Standard_True
, Loc
),
5831 Set_Else_Actions
(N
, Actlist
);
5832 Analyze_And_Resolve
(N
, Standard_Boolean
);
5833 Adjust_Result_Type
(N
, Typ
);
5837 -- No actions present, check for cases of right argument True/False
5839 if Nkind
(Right
) = N_Identifier
then
5841 -- Change (Left or else False) to Left. Note that we know there
5842 -- are no actions associated with the True operand, since we
5843 -- just checked for this case above.
5845 if Entity
(Right
) = Standard_False
then
5848 -- Change (Left or else True) to True, making sure to preserve
5849 -- any side effects associated with the Left operand.
5851 elsif Entity
(Right
) = Standard_True
then
5852 Remove_Side_Effects
(Left
);
5854 (N
, New_Occurrence_Of
(Standard_True
, Loc
));
5858 Adjust_Result_Type
(N
, Typ
);
5859 end Expand_N_Or_Else
;
5861 -----------------------------------
5862 -- Expand_N_Qualified_Expression --
5863 -----------------------------------
5865 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
5866 Operand
: constant Node_Id
:= Expression
(N
);
5867 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
5870 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
5871 end Expand_N_Qualified_Expression
;
5873 ---------------------------------
5874 -- Expand_N_Selected_Component --
5875 ---------------------------------
5877 -- If the selector is a discriminant of a concurrent object, rewrite the
5878 -- prefix to denote the corresponding record type.
5880 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
5881 Loc
: constant Source_Ptr
:= Sloc
(N
);
5882 Par
: constant Node_Id
:= Parent
(N
);
5883 P
: constant Node_Id
:= Prefix
(N
);
5884 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
5889 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
5890 -- Gigi needs a temporary for prefixes that depend on a discriminant,
5891 -- unless the context of an assignment can provide size information.
5892 -- Don't we have a general routine that does this???
5894 -----------------------
5895 -- In_Left_Hand_Side --
5896 -----------------------
5898 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
5900 return (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
5901 and then Comp
= Name
(Parent
(Comp
)))
5902 or else (Present
(Parent
(Comp
))
5903 and then Nkind
(Parent
(Comp
)) in N_Subexpr
5904 and then In_Left_Hand_Side
(Parent
(Comp
)));
5905 end In_Left_Hand_Side
;
5907 -- Start of processing for Expand_N_Selected_Component
5910 -- Insert explicit dereference if required
5912 if Is_Access_Type
(Ptyp
) then
5913 Insert_Explicit_Dereference
(P
);
5914 Analyze_And_Resolve
(P
, Designated_Type
(Ptyp
));
5916 if Ekind
(Etype
(P
)) = E_Private_Subtype
5917 and then Is_For_Access_Subtype
(Etype
(P
))
5919 Set_Etype
(P
, Base_Type
(Etype
(P
)));
5925 -- Deal with discriminant check required
5927 if Do_Discriminant_Check
(N
) then
5929 -- Present the discrminant checking function to the backend,
5930 -- so that it can inline the call to the function.
5933 (Discriminant_Checking_Func
5934 (Original_Record_Component
(Entity
(Selector_Name
(N
)))));
5936 -- Now reset the flag and generate the call
5938 Set_Do_Discriminant_Check
(N
, False);
5939 Generate_Discriminant_Check
(N
);
5942 -- Gigi cannot handle unchecked conversions that are the prefix of a
5943 -- selected component with discriminants. This must be checked during
5944 -- expansion, because during analysis the type of the selector is not
5945 -- known at the point the prefix is analyzed. If the conversion is the
5946 -- target of an assignment, then we cannot force the evaluation.
5948 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
5949 and then Has_Discriminants
(Etype
(N
))
5950 and then not In_Left_Hand_Side
(N
)
5952 Force_Evaluation
(Prefix
(N
));
5955 -- Remaining processing applies only if selector is a discriminant
5957 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
5959 -- If the selector is a discriminant of a constrained record type,
5960 -- we may be able to rewrite the expression with the actual value
5961 -- of the discriminant, a useful optimization in some cases.
5963 if Is_Record_Type
(Ptyp
)
5964 and then Has_Discriminants
(Ptyp
)
5965 and then Is_Constrained
(Ptyp
)
5967 -- Do this optimization for discrete types only, and not for
5968 -- access types (access discriminants get us into trouble!)
5970 if not Is_Discrete_Type
(Etype
(N
)) then
5973 -- Don't do this on the left hand of an assignment statement.
5974 -- Normally one would think that references like this would
5975 -- not occur, but they do in generated code, and mean that
5976 -- we really do want to assign the discriminant!
5978 elsif Nkind
(Par
) = N_Assignment_Statement
5979 and then Name
(Par
) = N
5983 -- Don't do this optimization for the prefix of an attribute
5984 -- or the operand of an object renaming declaration since these
5985 -- are contexts where we do not want the value anyway.
5987 elsif (Nkind
(Par
) = N_Attribute_Reference
5988 and then Prefix
(Par
) = N
)
5989 or else Is_Renamed_Object
(N
)
5993 -- Don't do this optimization if we are within the code for a
5994 -- discriminant check, since the whole point of such a check may
5995 -- be to verify the condition on which the code below depends!
5997 elsif Is_In_Discriminant_Check
(N
) then
6000 -- Green light to see if we can do the optimization. There is
6001 -- still one condition that inhibits the optimization below
6002 -- but now is the time to check the particular discriminant.
6005 -- Loop through discriminants to find the matching
6006 -- discriminant constraint to see if we can copy it.
6008 Disc
:= First_Discriminant
(Ptyp
);
6009 Dcon
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
6010 Discr_Loop
: while Present
(Dcon
) loop
6012 -- Check if this is the matching discriminant
6014 if Disc
= Entity
(Selector_Name
(N
)) then
6016 -- Here we have the matching discriminant. Check for
6017 -- the case of a discriminant of a component that is
6018 -- constrained by an outer discriminant, which cannot
6019 -- be optimized away.
6022 Denotes_Discriminant
6023 (Node
(Dcon
), Check_Protected
=> True)
6027 -- In the context of a case statement, the expression
6028 -- may have the base type of the discriminant, and we
6029 -- need to preserve the constraint to avoid spurious
6030 -- errors on missing cases.
6032 elsif Nkind
(Parent
(N
)) = N_Case_Statement
6033 and then Etype
(Node
(Dcon
)) /= Etype
(Disc
)
6036 Make_Qualified_Expression
(Loc
,
6038 New_Occurrence_Of
(Etype
(Disc
), Loc
),
6040 New_Copy_Tree
(Node
(Dcon
))));
6041 Analyze_And_Resolve
(N
, Etype
(Disc
));
6043 -- In case that comes out as a static expression,
6044 -- reset it (a selected component is never static).
6046 Set_Is_Static_Expression
(N
, False);
6049 -- Otherwise we can just copy the constraint, but the
6050 -- result is certainly not static! In some cases the
6051 -- discriminant constraint has been analyzed in the
6052 -- context of the original subtype indication, but for
6053 -- itypes the constraint might not have been analyzed
6054 -- yet, and this must be done now.
6057 Rewrite
(N
, New_Copy_Tree
(Node
(Dcon
)));
6058 Analyze_And_Resolve
(N
);
6059 Set_Is_Static_Expression
(N
, False);
6065 Next_Discriminant
(Disc
);
6066 end loop Discr_Loop
;
6068 -- Note: the above loop should always find a matching
6069 -- discriminant, but if it does not, we just missed an
6070 -- optimization due to some glitch (perhaps a previous
6071 -- error), so ignore.
6076 -- The only remaining processing is in the case of a discriminant of
6077 -- a concurrent object, where we rewrite the prefix to denote the
6078 -- corresponding record type. If the type is derived and has renamed
6079 -- discriminants, use corresponding discriminant, which is the one
6080 -- that appears in the corresponding record.
6082 if not Is_Concurrent_Type
(Ptyp
) then
6086 Disc
:= Entity
(Selector_Name
(N
));
6088 if Is_Derived_Type
(Ptyp
)
6089 and then Present
(Corresponding_Discriminant
(Disc
))
6091 Disc
:= Corresponding_Discriminant
(Disc
);
6095 Make_Selected_Component
(Loc
,
6097 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
6099 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
6104 end Expand_N_Selected_Component
;
6106 --------------------
6107 -- Expand_N_Slice --
6108 --------------------
6110 procedure Expand_N_Slice
(N
: Node_Id
) is
6111 Loc
: constant Source_Ptr
:= Sloc
(N
);
6112 Typ
: constant Entity_Id
:= Etype
(N
);
6113 Pfx
: constant Node_Id
:= Prefix
(N
);
6114 Ptp
: Entity_Id
:= Etype
(Pfx
);
6116 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean;
6117 -- Check whether the argument is an actual for a procedure call,
6118 -- in which case the expansion of a bit-packed slice is deferred
6119 -- until the call itself is expanded. The reason this is required
6120 -- is that we might have an IN OUT or OUT parameter, and the copy out
6121 -- is essential, and that copy out would be missed if we created a
6122 -- temporary here in Expand_N_Slice. Note that we don't bother
6123 -- to test specifically for an IN OUT or OUT mode parameter, since it
6124 -- is a bit tricky to do, and it is harmless to defer expansion
6125 -- in the IN case, since the call processing will still generate the
6126 -- appropriate copy in operation, which will take care of the slice.
6128 procedure Make_Temporary
;
6129 -- Create a named variable for the value of the slice, in
6130 -- cases where the back-end cannot handle it properly, e.g.
6131 -- when packed types or unaligned slices are involved.
6133 -------------------------
6134 -- Is_Procedure_Actual --
6135 -------------------------
6137 function Is_Procedure_Actual
(N
: Node_Id
) return Boolean is
6138 Par
: Node_Id
:= Parent
(N
);
6142 -- If our parent is a procedure call we can return
6144 if Nkind
(Par
) = N_Procedure_Call_Statement
then
6147 -- If our parent is a type conversion, keep climbing the
6148 -- tree, since a type conversion can be a procedure actual.
6149 -- Also keep climbing if parameter association or a qualified
6150 -- expression, since these are additional cases that do can
6151 -- appear on procedure actuals.
6153 elsif Nkind
(Par
) = N_Type_Conversion
6154 or else Nkind
(Par
) = N_Parameter_Association
6155 or else Nkind
(Par
) = N_Qualified_Expression
6157 Par
:= Parent
(Par
);
6159 -- Any other case is not what we are looking for
6165 end Is_Procedure_Actual
;
6167 --------------------
6168 -- Make_Temporary --
6169 --------------------
6171 procedure Make_Temporary
is
6173 Ent
: constant Entity_Id
:=
6174 Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
6177 Make_Object_Declaration
(Loc
,
6178 Defining_Identifier
=> Ent
,
6179 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
6181 Set_No_Initialization
(Decl
);
6183 Insert_Actions
(N
, New_List
(
6185 Make_Assignment_Statement
(Loc
,
6186 Name
=> New_Occurrence_Of
(Ent
, Loc
),
6187 Expression
=> Relocate_Node
(N
))));
6189 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
6190 Analyze_And_Resolve
(N
, Typ
);
6193 -- Start of processing for Expand_N_Slice
6196 -- Special handling for access types
6198 if Is_Access_Type
(Ptp
) then
6200 Ptp
:= Designated_Type
(Ptp
);
6203 Make_Explicit_Dereference
(Sloc
(N
),
6204 Prefix
=> Relocate_Node
(Pfx
)));
6206 Analyze_And_Resolve
(Pfx
, Ptp
);
6209 -- Range checks are potentially also needed for cases involving
6210 -- a slice indexed by a subtype indication, but Do_Range_Check
6211 -- can currently only be set for expressions ???
6213 if not Index_Checks_Suppressed
(Ptp
)
6214 and then (not Is_Entity_Name
(Pfx
)
6215 or else not Index_Checks_Suppressed
(Entity
(Pfx
)))
6216 and then Nkind
(Discrete_Range
(N
)) /= N_Subtype_Indication
6218 Enable_Range_Check
(Discrete_Range
(N
));
6221 -- The remaining case to be handled is packed slices. We can leave
6222 -- packed slices as they are in the following situations:
6224 -- 1. Right or left side of an assignment (we can handle this
6225 -- situation correctly in the assignment statement expansion).
6227 -- 2. Prefix of indexed component (the slide is optimized away
6228 -- in this case, see the start of Expand_N_Slice.
6230 -- 3. Object renaming declaration, since we want the name of
6231 -- the slice, not the value.
6233 -- 4. Argument to procedure call, since copy-in/copy-out handling
6234 -- may be required, and this is handled in the expansion of
6237 -- 5. Prefix of an address attribute (this is an error which
6238 -- is caught elsewhere, and the expansion would intefere
6239 -- with generating the error message).
6241 if not Is_Packed
(Typ
) then
6243 -- Apply transformation for actuals of a function call,
6244 -- where Expand_Actuals is not used.
6246 if Nkind
(Parent
(N
)) = N_Function_Call
6247 and then Is_Possibly_Unaligned_Slice
(N
)
6252 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
6253 or else (Nkind
(Parent
(Parent
(N
))) = N_Assignment_Statement
6254 and then Parent
(N
) = Name
(Parent
(Parent
(N
))))
6258 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
6259 or else Is_Renamed_Object
(N
)
6260 or else Is_Procedure_Actual
(N
)
6264 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
6265 and then Attribute_Name
(Parent
(N
)) = Name_Address
6274 ------------------------------
6275 -- Expand_N_Type_Conversion --
6276 ------------------------------
6278 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
6279 Loc
: constant Source_Ptr
:= Sloc
(N
);
6280 Operand
: constant Node_Id
:= Expression
(N
);
6281 Target_Type
: constant Entity_Id
:= Etype
(N
);
6282 Operand_Type
: Entity_Id
:= Etype
(Operand
);
6284 procedure Handle_Changed_Representation
;
6285 -- This is called in the case of record and array type conversions
6286 -- to see if there is a change of representation to be handled.
6287 -- Change of representation is actually handled at the assignment
6288 -- statement level, and what this procedure does is rewrite node N
6289 -- conversion as an assignment to temporary. If there is no change
6290 -- of representation, then the conversion node is unchanged.
6292 procedure Real_Range_Check
;
6293 -- Handles generation of range check for real target value
6295 -----------------------------------
6296 -- Handle_Changed_Representation --
6297 -----------------------------------
6299 procedure Handle_Changed_Representation
is
6308 -- Nothing to do if no change of representation
6310 if Same_Representation
(Operand_Type
, Target_Type
) then
6313 -- The real change of representation work is done by the assignment
6314 -- statement processing. So if this type conversion is appearing as
6315 -- the expression of an assignment statement, nothing needs to be
6316 -- done to the conversion.
6318 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
6321 -- Otherwise we need to generate a temporary variable, and do the
6322 -- change of representation assignment into that temporary variable.
6323 -- The conversion is then replaced by a reference to this variable.
6328 -- If type is unconstrained we have to add a constraint,
6329 -- copied from the actual value of the left hand side.
6331 if not Is_Constrained
(Target_Type
) then
6332 if Has_Discriminants
(Operand_Type
) then
6333 Disc
:= First_Discriminant
(Operand_Type
);
6335 if Disc
/= First_Stored_Discriminant
(Operand_Type
) then
6336 Disc
:= First_Stored_Discriminant
(Operand_Type
);
6340 while Present
(Disc
) loop
6342 Make_Selected_Component
(Loc
,
6343 Prefix
=> Duplicate_Subexpr_Move_Checks
(Operand
),
6345 Make_Identifier
(Loc
, Chars
(Disc
))));
6346 Next_Discriminant
(Disc
);
6349 elsif Is_Array_Type
(Operand_Type
) then
6350 N_Ix
:= First_Index
(Target_Type
);
6353 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
6355 -- We convert the bounds explicitly. We use an unchecked
6356 -- conversion because bounds checks are done elsewhere.
6361 Unchecked_Convert_To
(Etype
(N_Ix
),
6362 Make_Attribute_Reference
(Loc
,
6364 Duplicate_Subexpr_No_Checks
6365 (Operand
, Name_Req
=> True),
6366 Attribute_Name
=> Name_First
,
6367 Expressions
=> New_List
(
6368 Make_Integer_Literal
(Loc
, J
)))),
6371 Unchecked_Convert_To
(Etype
(N_Ix
),
6372 Make_Attribute_Reference
(Loc
,
6374 Duplicate_Subexpr_No_Checks
6375 (Operand
, Name_Req
=> True),
6376 Attribute_Name
=> Name_Last
,
6377 Expressions
=> New_List
(
6378 Make_Integer_Literal
(Loc
, J
))))));
6385 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
6387 if Present
(Cons
) then
6389 Make_Subtype_Indication
(Loc
,
6390 Subtype_Mark
=> Odef
,
6392 Make_Index_Or_Discriminant_Constraint
(Loc
,
6393 Constraints
=> Cons
));
6396 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
6398 Make_Object_Declaration
(Loc
,
6399 Defining_Identifier
=> Temp
,
6400 Object_Definition
=> Odef
);
6402 Set_No_Initialization
(Decl
, True);
6404 -- Insert required actions. It is essential to suppress checks
6405 -- since we have suppressed default initialization, which means
6406 -- that the variable we create may have no discriminants.
6411 Make_Assignment_Statement
(Loc
,
6412 Name
=> New_Occurrence_Of
(Temp
, Loc
),
6413 Expression
=> Relocate_Node
(N
))),
6414 Suppress
=> All_Checks
);
6416 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
6419 end Handle_Changed_Representation
;
6421 ----------------------
6422 -- Real_Range_Check --
6423 ----------------------
6425 -- Case of conversions to floating-point or fixed-point. If range
6426 -- checks are enabled and the target type has a range constraint,
6433 -- Tnn : typ'Base := typ'Base (x);
6434 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6437 -- This is necessary when there is a conversion of integer to float
6438 -- or to fixed-point to ensure that the correct checks are made. It
6439 -- is not necessary for float to float where it is enough to simply
6440 -- set the Do_Range_Check flag.
6442 procedure Real_Range_Check
is
6443 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
6444 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
6445 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
6446 Xtyp
: constant Entity_Id
:= Etype
(Operand
);
6451 -- Nothing to do if conversion was rewritten
6453 if Nkind
(N
) /= N_Type_Conversion
then
6457 -- Nothing to do if range checks suppressed, or target has the
6458 -- same range as the base type (or is the base type).
6460 if Range_Checks_Suppressed
(Target_Type
)
6461 or else (Lo
= Type_Low_Bound
(Btyp
)
6463 Hi
= Type_High_Bound
(Btyp
))
6468 -- Nothing to do if expression is an entity on which checks
6469 -- have been suppressed.
6471 if Is_Entity_Name
(Operand
)
6472 and then Range_Checks_Suppressed
(Entity
(Operand
))
6477 -- Nothing to do if bounds are all static and we can tell that
6478 -- the expression is within the bounds of the target. Note that
6479 -- if the operand is of an unconstrained floating-point type,
6480 -- then we do not trust it to be in range (might be infinite)
6483 S_Lo
: constant Node_Id
:= Type_Low_Bound
(Xtyp
);
6484 S_Hi
: constant Node_Id
:= Type_High_Bound
(Xtyp
);
6487 if (not Is_Floating_Point_Type
(Xtyp
)
6488 or else Is_Constrained
(Xtyp
))
6489 and then Compile_Time_Known_Value
(S_Lo
)
6490 and then Compile_Time_Known_Value
(S_Hi
)
6491 and then Compile_Time_Known_Value
(Hi
)
6492 and then Compile_Time_Known_Value
(Lo
)
6495 D_Lov
: constant Ureal
:= Expr_Value_R
(Lo
);
6496 D_Hiv
: constant Ureal
:= Expr_Value_R
(Hi
);
6501 if Is_Real_Type
(Xtyp
) then
6502 S_Lov
:= Expr_Value_R
(S_Lo
);
6503 S_Hiv
:= Expr_Value_R
(S_Hi
);
6505 S_Lov
:= UR_From_Uint
(Expr_Value
(S_Lo
));
6506 S_Hiv
:= UR_From_Uint
(Expr_Value
(S_Hi
));
6510 and then S_Lov
>= D_Lov
6511 and then S_Hiv
<= D_Hiv
6513 Set_Do_Range_Check
(Operand
, False);
6520 -- For float to float conversions, we are done
6522 if Is_Floating_Point_Type
(Xtyp
)
6524 Is_Floating_Point_Type
(Btyp
)
6529 -- Otherwise rewrite the conversion as described above
6531 Conv
:= Relocate_Node
(N
);
6533 (Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
6534 Set_Etype
(Conv
, Btyp
);
6536 -- Enable overflow except in the case of integer to float
6537 -- conversions, where it is never required, since we can
6538 -- never have overflow in this case.
6540 if not Is_Integer_Type
(Etype
(Operand
)) then
6541 Enable_Overflow_Check
(Conv
);
6545 Make_Defining_Identifier
(Loc
,
6546 Chars
=> New_Internal_Name
('T'));
6548 Insert_Actions
(N
, New_List
(
6549 Make_Object_Declaration
(Loc
,
6550 Defining_Identifier
=> Tnn
,
6551 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
6552 Expression
=> Conv
),
6554 Make_Raise_Constraint_Error
(Loc
,
6559 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6561 Make_Attribute_Reference
(Loc
,
6562 Attribute_Name
=> Name_First
,
6564 New_Occurrence_Of
(Target_Type
, Loc
))),
6568 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6570 Make_Attribute_Reference
(Loc
,
6571 Attribute_Name
=> Name_Last
,
6573 New_Occurrence_Of
(Target_Type
, Loc
)))),
6574 Reason
=> CE_Range_Check_Failed
)));
6576 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6577 Analyze_And_Resolve
(N
, Btyp
);
6578 end Real_Range_Check
;
6580 -- Start of processing for Expand_N_Type_Conversion
6583 -- Nothing at all to do if conversion is to the identical type
6584 -- so remove the conversion completely, it is useless.
6586 if Operand_Type
= Target_Type
then
6587 Rewrite
(N
, Relocate_Node
(Operand
));
6591 -- Deal with Vax floating-point cases
6593 if Vax_Float
(Operand_Type
) or else Vax_Float
(Target_Type
) then
6594 Expand_Vax_Conversion
(N
);
6598 -- Nothing to do if this is the second argument of read. This
6599 -- is a "backwards" conversion that will be handled by the
6600 -- specialized code in attribute processing.
6602 if Nkind
(Parent
(N
)) = N_Attribute_Reference
6603 and then Attribute_Name
(Parent
(N
)) = Name_Read
6604 and then Next
(First
(Expressions
(Parent
(N
)))) = N
6609 -- Here if we may need to expand conversion
6611 -- Special case of converting from non-standard boolean type
6613 if Is_Boolean_Type
(Operand_Type
)
6614 and then (Nonzero_Is_True
(Operand_Type
))
6616 Adjust_Condition
(Operand
);
6617 Set_Etype
(Operand
, Standard_Boolean
);
6618 Operand_Type
:= Standard_Boolean
;
6621 -- Case of converting to an access type
6623 if Is_Access_Type
(Target_Type
) then
6625 -- Apply an accessibility check if the operand is an
6626 -- access parameter. Note that other checks may still
6627 -- need to be applied below (such as tagged type checks).
6629 if Is_Entity_Name
(Operand
)
6630 and then Ekind
(Entity
(Operand
)) in Formal_Kind
6631 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
6633 Apply_Accessibility_Check
(Operand
, Target_Type
);
6635 -- If the level of the operand type is statically deeper
6636 -- then the level of the target type, then force Program_Error.
6637 -- Note that this can only occur for cases where the attribute
6638 -- is within the body of an instantiation (otherwise the
6639 -- conversion will already have been rejected as illegal).
6640 -- Note: warnings are issued by the analyzer for the instance
6643 elsif In_Instance_Body
6644 and then Type_Access_Level
(Operand_Type
) >
6645 Type_Access_Level
(Target_Type
)
6648 Make_Raise_Program_Error
(Sloc
(N
),
6649 Reason
=> PE_Accessibility_Check_Failed
));
6650 Set_Etype
(N
, Target_Type
);
6652 -- When the operand is a selected access discriminant
6653 -- the check needs to be made against the level of the
6654 -- object denoted by the prefix of the selected name.
6655 -- Force Program_Error for this case as well (this
6656 -- accessibility violation can only happen if within
6657 -- the body of an instantiation).
6659 elsif In_Instance_Body
6660 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
6661 and then Nkind
(Operand
) = N_Selected_Component
6662 and then Object_Access_Level
(Operand
) >
6663 Type_Access_Level
(Target_Type
)
6666 Make_Raise_Program_Error
(Sloc
(N
),
6667 Reason
=> PE_Accessibility_Check_Failed
));
6668 Set_Etype
(N
, Target_Type
);
6672 -- Case of conversions of tagged types and access to tagged types
6674 -- When needed, that is to say when the expression is class-wide,
6675 -- Add runtime a tag check for (strict) downward conversion by using
6676 -- the membership test, generating:
6678 -- [constraint_error when Operand not in Target_Type'Class]
6680 -- or in the access type case
6682 -- [constraint_error
6683 -- when Operand /= null
6684 -- and then Operand.all not in
6685 -- Designated_Type (Target_Type)'Class]
6687 if (Is_Access_Type
(Target_Type
)
6688 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
6689 or else Is_Tagged_Type
(Target_Type
)
6691 -- Do not do any expansion in the access type case if the
6692 -- parent is a renaming, since this is an error situation
6693 -- which will be caught by Sem_Ch8, and the expansion can
6694 -- intefere with this error check.
6696 if Is_Access_Type
(Target_Type
)
6697 and then Is_Renamed_Object
(N
)
6702 -- Oherwise, proceed with processing tagged conversion
6705 Actual_Operand_Type
: Entity_Id
;
6706 Actual_Target_Type
: Entity_Id
;
6711 if Is_Access_Type
(Target_Type
) then
6712 Actual_Operand_Type
:= Designated_Type
(Operand_Type
);
6713 Actual_Target_Type
:= Designated_Type
(Target_Type
);
6716 Actual_Operand_Type
:= Operand_Type
;
6717 Actual_Target_Type
:= Target_Type
;
6720 if Is_Class_Wide_Type
(Actual_Operand_Type
)
6721 and then Root_Type
(Actual_Operand_Type
) /= Actual_Target_Type
6722 and then Is_Ancestor
6723 (Root_Type
(Actual_Operand_Type
),
6725 and then not Tag_Checks_Suppressed
(Actual_Target_Type
)
6727 -- The conversion is valid for any descendant of the
6730 Actual_Target_Type
:= Class_Wide_Type
(Actual_Target_Type
);
6732 if Is_Access_Type
(Target_Type
) then
6737 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
6738 Right_Opnd
=> Make_Null
(Loc
)),
6743 Make_Explicit_Dereference
(Loc
,
6745 Duplicate_Subexpr_No_Checks
(Operand
)),
6747 New_Reference_To
(Actual_Target_Type
, Loc
)));
6752 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Operand
),
6754 New_Reference_To
(Actual_Target_Type
, Loc
));
6758 Make_Raise_Constraint_Error
(Loc
,
6760 Reason
=> CE_Tag_Check_Failed
));
6766 Make_Unchecked_Type_Conversion
(Loc
,
6767 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
6768 Expression
=> Relocate_Node
(Expression
(N
)));
6770 Analyze_And_Resolve
(N
, Target_Type
);
6775 -- Case of other access type conversions
6777 elsif Is_Access_Type
(Target_Type
) then
6778 Apply_Constraint_Check
(Operand
, Target_Type
);
6780 -- Case of conversions from a fixed-point type
6782 -- These conversions require special expansion and processing, found
6783 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
6784 -- set, since from a semantic point of view, these are simple integer
6785 -- conversions, which do not need further processing.
6787 elsif Is_Fixed_Point_Type
(Operand_Type
)
6788 and then not Conversion_OK
(N
)
6790 -- We should never see universal fixed at this case, since the
6791 -- expansion of the constituent divide or multiply should have
6792 -- eliminated the explicit mention of universal fixed.
6794 pragma Assert
(Operand_Type
/= Universal_Fixed
);
6796 -- Check for special case of the conversion to universal real
6797 -- that occurs as a result of the use of a round attribute.
6798 -- In this case, the real type for the conversion is taken
6799 -- from the target type of the Round attribute and the
6800 -- result must be marked as rounded.
6802 if Target_Type
= Universal_Real
6803 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
6804 and then Attribute_Name
(Parent
(N
)) = Name_Round
6806 Set_Rounded_Result
(N
);
6807 Set_Etype
(N
, Etype
(Parent
(N
)));
6810 -- Otherwise do correct fixed-conversion, but skip these if the
6811 -- Conversion_OK flag is set, because from a semantic point of
6812 -- view these are simple integer conversions needing no further
6813 -- processing (the backend will simply treat them as integers)
6815 if not Conversion_OK
(N
) then
6816 if Is_Fixed_Point_Type
(Etype
(N
)) then
6817 Expand_Convert_Fixed_To_Fixed
(N
);
6820 elsif Is_Integer_Type
(Etype
(N
)) then
6821 Expand_Convert_Fixed_To_Integer
(N
);
6824 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
6825 Expand_Convert_Fixed_To_Float
(N
);
6830 -- Case of conversions to a fixed-point type
6832 -- These conversions require special expansion and processing, found
6833 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6834 -- is set, since from a semantic point of view, these are simple
6835 -- integer conversions, which do not need further processing.
6837 elsif Is_Fixed_Point_Type
(Target_Type
)
6838 and then not Conversion_OK
(N
)
6840 if Is_Integer_Type
(Operand_Type
) then
6841 Expand_Convert_Integer_To_Fixed
(N
);
6844 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
6845 Expand_Convert_Float_To_Fixed
(N
);
6849 -- Case of float-to-integer conversions
6851 -- We also handle float-to-fixed conversions with Conversion_OK set
6852 -- since semantically the fixed-point target is treated as though it
6853 -- were an integer in such cases.
6855 elsif Is_Floating_Point_Type
(Operand_Type
)
6857 (Is_Integer_Type
(Target_Type
)
6859 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
6861 -- Special processing required if the conversion is the expression
6862 -- of a Truncation attribute reference. In this case we replace:
6864 -- ityp (ftyp'Truncation (x))
6870 -- with the Float_Truncate flag set. This is clearly more efficient
6872 if Nkind
(Operand
) = N_Attribute_Reference
6873 and then Attribute_Name
(Operand
) = Name_Truncation
6876 Relocate_Node
(First
(Expressions
(Operand
))));
6877 Set_Float_Truncate
(N
, True);
6880 -- One more check here, gcc is still not able to do conversions of
6881 -- this type with proper overflow checking, and so gigi is doing an
6882 -- approximation of what is required by doing floating-point compares
6883 -- with the end-point. But that can lose precision in some cases, and
6884 -- give a wrong result. Converting the operand to Long_Long_Float is
6885 -- helpful, but still does not catch all cases with 64-bit integers
6886 -- on targets with only 64-bit floats ???
6888 if Do_Range_Check
(Operand
) then
6890 Make_Type_Conversion
(Loc
,
6892 New_Occurrence_Of
(Standard_Long_Long_Float
, Loc
),
6894 Relocate_Node
(Operand
)));
6896 Set_Etype
(Operand
, Standard_Long_Long_Float
);
6897 Enable_Range_Check
(Operand
);
6898 Set_Do_Range_Check
(Expression
(Operand
), False);
6901 -- Case of array conversions
6903 -- Expansion of array conversions, add required length/range checks
6904 -- but only do this if there is no change of representation. For
6905 -- handling of this case, see Handle_Changed_Representation.
6907 elsif Is_Array_Type
(Target_Type
) then
6909 if Is_Constrained
(Target_Type
) then
6910 Apply_Length_Check
(Operand
, Target_Type
);
6912 Apply_Range_Check
(Operand
, Target_Type
);
6915 Handle_Changed_Representation
;
6917 -- Case of conversions of discriminated types
6919 -- Add required discriminant checks if target is constrained. Again
6920 -- this change is skipped if we have a change of representation.
6922 elsif Has_Discriminants
(Target_Type
)
6923 and then Is_Constrained
(Target_Type
)
6925 Apply_Discriminant_Check
(Operand
, Target_Type
);
6926 Handle_Changed_Representation
;
6928 -- Case of all other record conversions. The only processing required
6929 -- is to check for a change of representation requiring the special
6930 -- assignment processing.
6932 elsif Is_Record_Type
(Target_Type
) then
6934 -- Ada 2005 (AI-216): Program_Error is raised when converting from
6935 -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
6936 -- Union type if the operand lacks inferable discriminants.
6938 if Is_Derived_Type
(Operand_Type
)
6939 and then Is_Unchecked_Union
(Base_Type
(Operand_Type
))
6940 and then not Is_Constrained
(Target_Type
)
6941 and then not Is_Unchecked_Union
(Base_Type
(Target_Type
))
6942 and then not Has_Inferable_Discriminants
(Operand
)
6944 -- To prevent Gigi from generating illegal code, we make a
6945 -- Program_Error node, but we give it the target type of the
6949 PE
: constant Node_Id
:= Make_Raise_Program_Error
(Loc
,
6950 Reason
=> PE_Unchecked_Union_Restriction
);
6953 Set_Etype
(PE
, Target_Type
);
6958 Handle_Changed_Representation
;
6961 -- Case of conversions of enumeration types
6963 elsif Is_Enumeration_Type
(Target_Type
) then
6965 -- Special processing is required if there is a change of
6966 -- representation (from enumeration representation clauses)
6968 if not Same_Representation
(Target_Type
, Operand_Type
) then
6970 -- Convert: x(y) to x'val (ytyp'val (y))
6973 Make_Attribute_Reference
(Loc
,
6974 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6975 Attribute_Name
=> Name_Val
,
6976 Expressions
=> New_List
(
6977 Make_Attribute_Reference
(Loc
,
6978 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
6979 Attribute_Name
=> Name_Pos
,
6980 Expressions
=> New_List
(Operand
)))));
6982 Analyze_And_Resolve
(N
, Target_Type
);
6985 -- Case of conversions to floating-point
6987 elsif Is_Floating_Point_Type
(Target_Type
) then
6990 -- The remaining cases require no front end processing
6996 -- At this stage, either the conversion node has been transformed
6997 -- into some other equivalent expression, or left as a conversion
6998 -- that can be handled by Gigi. The conversions that Gigi can handle
6999 -- are the following:
7001 -- Conversions with no change of representation or type
7003 -- Numeric conversions involving integer values, floating-point
7004 -- values, and fixed-point values. Fixed-point values are allowed
7005 -- only if Conversion_OK is set, i.e. if the fixed-point values
7006 -- are to be treated as integers.
7008 -- No other conversions should be passed to Gigi
7010 -- Check: are these rules stated in sinfo??? if so, why restate here???
7012 -- The only remaining step is to generate a range check if we still
7013 -- have a type conversion at this stage and Do_Range_Check is set.
7014 -- For now we do this only for conversions of discrete types.
7016 if Nkind
(N
) = N_Type_Conversion
7017 and then Is_Discrete_Type
(Etype
(N
))
7020 Expr
: constant Node_Id
:= Expression
(N
);
7025 if Do_Range_Check
(Expr
)
7026 and then Is_Discrete_Type
(Etype
(Expr
))
7028 Set_Do_Range_Check
(Expr
, False);
7030 -- Before we do a range check, we have to deal with treating
7031 -- a fixed-point operand as an integer. The way we do this
7032 -- is simply to do an unchecked conversion to an appropriate
7033 -- integer type large enough to hold the result.
7035 -- This code is not active yet, because we are only dealing
7036 -- with discrete types so far ???
7038 if Nkind
(Expr
) in N_Has_Treat_Fixed_As_Integer
7039 and then Treat_Fixed_As_Integer
(Expr
)
7041 Ftyp
:= Base_Type
(Etype
(Expr
));
7043 if Esize
(Ftyp
) >= Esize
(Standard_Integer
) then
7044 Ityp
:= Standard_Long_Long_Integer
;
7046 Ityp
:= Standard_Integer
;
7049 Rewrite
(Expr
, Unchecked_Convert_To
(Ityp
, Expr
));
7052 -- Reset overflow flag, since the range check will include
7053 -- dealing with possible overflow, and generate the check
7054 -- If Address is either source or target type, suppress
7055 -- range check to avoid typing anomalies when it is a visible
7058 Set_Do_Overflow_Check
(N
, False);
7059 if not Is_Descendent_Of_Address
(Etype
(Expr
))
7060 and then not Is_Descendent_Of_Address
(Target_Type
)
7062 Generate_Range_Check
7063 (Expr
, Target_Type
, CE_Range_Check_Failed
);
7068 end Expand_N_Type_Conversion
;
7070 -----------------------------------
7071 -- Expand_N_Unchecked_Expression --
7072 -----------------------------------
7074 -- Remove the unchecked expression node from the tree. It's job was simply
7075 -- to make sure that its constituent expression was handled with checks
7076 -- off, and now that that is done, we can remove it from the tree, and
7077 -- indeed must, since gigi does not expect to see these nodes.
7079 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
7080 Exp
: constant Node_Id
:= Expression
(N
);
7083 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or Assignment_OK
(Exp
));
7085 end Expand_N_Unchecked_Expression
;
7087 ----------------------------------------
7088 -- Expand_N_Unchecked_Type_Conversion --
7089 ----------------------------------------
7091 -- If this cannot be handled by Gigi and we haven't already made
7092 -- a temporary for it, do it now.
7094 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
7095 Target_Type
: constant Entity_Id
:= Etype
(N
);
7096 Operand
: constant Node_Id
:= Expression
(N
);
7097 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
7100 -- If we have a conversion of a compile time known value to a target
7101 -- type and the value is in range of the target type, then we can simply
7102 -- replace the construct by an integer literal of the correct type. We
7103 -- only apply this to integer types being converted. Possibly it may
7104 -- apply in other cases, but it is too much trouble to worry about.
7106 -- Note that we do not do this transformation if the Kill_Range_Check
7107 -- flag is set, since then the value may be outside the expected range.
7108 -- This happens in the Normalize_Scalars case.
7110 if Is_Integer_Type
(Target_Type
)
7111 and then Is_Integer_Type
(Operand_Type
)
7112 and then Compile_Time_Known_Value
(Operand
)
7113 and then not Kill_Range_Check
(N
)
7116 Val
: constant Uint
:= Expr_Value
(Operand
);
7119 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
7121 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
7123 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
7125 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
7127 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
7129 -- If Address is the target type, just set the type
7130 -- to avoid a spurious type error on the literal when
7131 -- Address is a visible integer type.
7133 if Is_Descendent_Of_Address
(Target_Type
) then
7134 Set_Etype
(N
, Target_Type
);
7136 Analyze_And_Resolve
(N
, Target_Type
);
7144 -- Nothing to do if conversion is safe
7146 if Safe_Unchecked_Type_Conversion
(N
) then
7150 -- Otherwise force evaluation unless Assignment_OK flag is set (this
7151 -- flag indicates ??? -- more comments needed here)
7153 if Assignment_OK
(N
) then
7156 Force_Evaluation
(N
);
7158 end Expand_N_Unchecked_Type_Conversion
;
7160 ----------------------------
7161 -- Expand_Record_Equality --
7162 ----------------------------
7164 -- For non-variant records, Equality is expanded when needed into:
7166 -- and then Lhs.Discr1 = Rhs.Discr1
7168 -- and then Lhs.Discrn = Rhs.Discrn
7169 -- and then Lhs.Cmp1 = Rhs.Cmp1
7171 -- and then Lhs.Cmpn = Rhs.Cmpn
7173 -- The expression is folded by the back-end for adjacent fields. This
7174 -- function is called for tagged record in only one occasion: for imple-
7175 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
7176 -- otherwise the primitive "=" is used directly.
7178 function Expand_Record_Equality
7183 Bodies
: List_Id
) return Node_Id
7185 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7190 First_Time
: Boolean := True;
7192 function Suitable_Element
(C
: Entity_Id
) return Entity_Id
;
7193 -- Return the first field to compare beginning with C, skipping the
7194 -- inherited components.
7196 ----------------------
7197 -- Suitable_Element --
7198 ----------------------
7200 function Suitable_Element
(C
: Entity_Id
) return Entity_Id
is
7205 elsif Ekind
(C
) /= E_Discriminant
7206 and then Ekind
(C
) /= E_Component
7208 return Suitable_Element
(Next_Entity
(C
));
7210 elsif Is_Tagged_Type
(Typ
)
7211 and then C
/= Original_Record_Component
(C
)
7213 return Suitable_Element
(Next_Entity
(C
));
7215 elsif Chars
(C
) = Name_uController
7216 or else Chars
(C
) = Name_uTag
7218 return Suitable_Element
(Next_Entity
(C
));
7223 end Suitable_Element
;
7225 -- Start of processing for Expand_Record_Equality
7228 -- Generates the following code: (assuming that Typ has one Discr and
7229 -- component C2 is also a record)
7232 -- and then Lhs.Discr1 = Rhs.Discr1
7233 -- and then Lhs.C1 = Rhs.C1
7234 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7236 -- and then Lhs.Cmpn = Rhs.Cmpn
7238 Result
:= New_Reference_To
(Standard_True
, Loc
);
7239 C
:= Suitable_Element
(First_Entity
(Typ
));
7241 while Present
(C
) loop
7249 First_Time
:= False;
7253 New_Lhs
:= New_Copy_Tree
(Lhs
);
7254 New_Rhs
:= New_Copy_Tree
(Rhs
);
7258 Expand_Composite_Equality
(Nod
, Etype
(C
),
7260 Make_Selected_Component
(Loc
,
7262 Selector_Name
=> New_Reference_To
(C
, Loc
)),
7264 Make_Selected_Component
(Loc
,
7266 Selector_Name
=> New_Reference_To
(C
, Loc
)),
7269 -- If some (sub)component is an unchecked_union, the whole
7270 -- operation will raise program error.
7272 if Nkind
(Check
) = N_Raise_Program_Error
then
7274 Set_Etype
(Result
, Standard_Boolean
);
7279 Left_Opnd
=> Result
,
7280 Right_Opnd
=> Check
);
7284 C
:= Suitable_Element
(Next_Entity
(C
));
7288 end Expand_Record_Equality
;
7290 -------------------------------------
7291 -- Fixup_Universal_Fixed_Operation --
7292 -------------------------------------
7294 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
7295 Conv
: constant Node_Id
:= Parent
(N
);
7298 -- We must have a type conversion immediately above us
7300 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
7302 -- Normally the type conversion gives our target type. The exception
7303 -- occurs in the case of the Round attribute, where the conversion
7304 -- will be to universal real, and our real type comes from the Round
7305 -- attribute (as well as an indication that we must round the result)
7307 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
7308 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
7310 Set_Etype
(N
, Etype
(Parent
(Conv
)));
7311 Set_Rounded_Result
(N
);
7313 -- Normal case where type comes from conversion above us
7316 Set_Etype
(N
, Etype
(Conv
));
7318 end Fixup_Universal_Fixed_Operation
;
7320 ------------------------------
7321 -- Get_Allocator_Final_List --
7322 ------------------------------
7324 function Get_Allocator_Final_List
7327 PtrT
: Entity_Id
) return Entity_Id
7329 Loc
: constant Source_Ptr
:= Sloc
(N
);
7331 Owner
: Entity_Id
:= PtrT
;
7332 -- The entity whose finalisation list must be used to attach the
7333 -- allocated object.
7336 if Ekind
(PtrT
) = E_Anonymous_Access_Type
then
7337 if Nkind
(Associated_Node_For_Itype
(PtrT
))
7338 in N_Subprogram_Specification
7340 -- If the context is an access parameter, we need to create
7341 -- a non-anonymous access type in order to have a usable
7342 -- final list, because there is otherwise no pool to which
7343 -- the allocated object can belong. We create both the type
7344 -- and the finalization chain here, because freezing an
7345 -- internal type does not create such a chain. The Final_Chain
7346 -- that is thus created is shared by the access parameter.
7348 Owner
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
7350 Make_Full_Type_Declaration
(Loc
,
7351 Defining_Identifier
=> Owner
,
7353 Make_Access_To_Object_Definition
(Loc
,
7354 Subtype_Indication
=>
7355 New_Occurrence_Of
(T
, Loc
))));
7357 Build_Final_List
(N
, Owner
);
7358 Set_Associated_Final_Chain
(PtrT
, Associated_Final_Chain
(Owner
));
7361 -- Case of an access discriminant, or (Ada 2005) of
7362 -- an anonymous access component: find the final list
7363 -- associated with the scope of the type.
7365 Owner
:= Scope
(PtrT
);
7369 return Find_Final_List
(Owner
);
7370 end Get_Allocator_Final_List
;
7372 ---------------------------------
7373 -- Has_Inferable_Discriminants --
7374 ---------------------------------
7376 function Has_Inferable_Discriminants
(N
: Node_Id
) return Boolean is
7378 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean;
7379 -- Determines whether the left-most prefix of a selected component is a
7380 -- formal parameter in a subprogram. Assumes N is a selected component.
7382 --------------------------------
7383 -- Prefix_Is_Formal_Parameter --
7384 --------------------------------
7386 function Prefix_Is_Formal_Parameter
(N
: Node_Id
) return Boolean is
7387 Sel_Comp
: Node_Id
:= N
;
7390 -- Move to the left-most prefix by climbing up the tree
7392 while Present
(Parent
(Sel_Comp
))
7393 and then Nkind
(Parent
(Sel_Comp
)) = N_Selected_Component
7395 Sel_Comp
:= Parent
(Sel_Comp
);
7398 return Ekind
(Entity
(Prefix
(Sel_Comp
))) in Formal_Kind
;
7399 end Prefix_Is_Formal_Parameter
;
7401 -- Start of processing for Has_Inferable_Discriminants
7404 -- For identifiers and indexed components, it is sufficent to have a
7405 -- constrained Unchecked_Union nominal subtype.
7407 if Nkind
(N
) = N_Identifier
7409 Nkind
(N
) = N_Indexed_Component
7411 return Is_Unchecked_Union
(Base_Type
(Etype
(N
)))
7413 Is_Constrained
(Etype
(N
));
7415 -- For selected components, the subtype of the selector must be a
7416 -- constrained Unchecked_Union. If the component is subject to a
7417 -- per-object constraint, then the enclosing object must have inferable
7420 elsif Nkind
(N
) = N_Selected_Component
then
7421 if Has_Per_Object_Constraint
(Entity
(Selector_Name
(N
))) then
7423 -- A small hack. If we have a per-object constrained selected
7424 -- component of a formal parameter, return True since we do not
7425 -- know the actual parameter association yet.
7427 if Prefix_Is_Formal_Parameter
(N
) then
7431 -- Otherwise, check the enclosing object and the selector
7433 return Has_Inferable_Discriminants
(Prefix
(N
))
7435 Has_Inferable_Discriminants
(Selector_Name
(N
));
7438 -- The call to Has_Inferable_Discriminants will determine whether
7439 -- the selector has a constrained Unchecked_Union nominal type.
7441 return Has_Inferable_Discriminants
(Selector_Name
(N
));
7443 -- A qualified expression has inferable discriminants if its subtype
7444 -- mark is a constrained Unchecked_Union subtype.
7446 elsif Nkind
(N
) = N_Qualified_Expression
then
7447 return Is_Unchecked_Union
(Subtype_Mark
(N
))
7449 Is_Constrained
(Subtype_Mark
(N
));
7454 end Has_Inferable_Discriminants
;
7456 -------------------------------
7457 -- Insert_Dereference_Action --
7458 -------------------------------
7460 procedure Insert_Dereference_Action
(N
: Node_Id
) is
7461 Loc
: constant Source_Ptr
:= Sloc
(N
);
7462 Typ
: constant Entity_Id
:= Etype
(N
);
7463 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
7464 Pnod
: constant Node_Id
:= Parent
(N
);
7466 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
7467 -- Return true if type of P is derived from Checked_Pool;
7469 -----------------------------
7470 -- Is_Checked_Storage_Pool --
7471 -----------------------------
7473 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
7482 while T
/= Etype
(T
) loop
7483 if Is_RTE
(T
, RE_Checked_Pool
) then
7491 end Is_Checked_Storage_Pool
;
7493 -- Start of processing for Insert_Dereference_Action
7496 pragma Assert
(Nkind
(Pnod
) = N_Explicit_Dereference
);
7498 if not (Is_Checked_Storage_Pool
(Pool
)
7499 and then Comes_From_Source
(Original_Node
(Pnod
)))
7505 Make_Procedure_Call_Statement
(Loc
,
7506 Name
=> New_Reference_To
(
7507 Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
7509 Parameter_Associations
=> New_List
(
7513 New_Reference_To
(Pool
, Loc
),
7515 -- Storage_Address. We use the attribute Pool_Address,
7516 -- which uses the pointer itself to find the address of
7517 -- the object, and which handles unconstrained arrays
7518 -- properly by computing the address of the template.
7519 -- i.e. the correct address of the corresponding allocation.
7521 Make_Attribute_Reference
(Loc
,
7522 Prefix
=> Duplicate_Subexpr_Move_Checks
(N
),
7523 Attribute_Name
=> Name_Pool_Address
),
7525 -- Size_In_Storage_Elements
7527 Make_Op_Divide
(Loc
,
7529 Make_Attribute_Reference
(Loc
,
7531 Make_Explicit_Dereference
(Loc
,
7532 Duplicate_Subexpr_Move_Checks
(N
)),
7533 Attribute_Name
=> Name_Size
),
7535 Make_Integer_Literal
(Loc
, System_Storage_Unit
)),
7539 Make_Attribute_Reference
(Loc
,
7541 Make_Explicit_Dereference
(Loc
,
7542 Duplicate_Subexpr_Move_Checks
(N
)),
7543 Attribute_Name
=> Name_Alignment
))));
7546 when RE_Not_Available
=>
7548 end Insert_Dereference_Action
;
7550 ------------------------------
7551 -- Make_Array_Comparison_Op --
7552 ------------------------------
7554 -- This is a hand-coded expansion of the following generic function:
7557 -- type elem is (<>);
7558 -- type index is (<>);
7559 -- type a is array (index range <>) of elem;
7561 -- function Gnnn (X : a; Y: a) return boolean is
7562 -- J : index := Y'first;
7565 -- if X'length = 0 then
7568 -- elsif Y'length = 0 then
7572 -- for I in X'range loop
7573 -- if X (I) = Y (J) then
7574 -- if J = Y'last then
7577 -- J := index'succ (J);
7581 -- return X (I) > Y (J);
7585 -- return X'length > Y'length;
7589 -- Note that since we are essentially doing this expansion by hand, we
7590 -- do not need to generate an actual or formal generic part, just the
7591 -- instantiated function itself.
7593 function Make_Array_Comparison_Op
7595 Nod
: Node_Id
) return Node_Id
7597 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7599 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
7600 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
7601 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
7602 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
7604 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
7606 Loop_Statement
: Node_Id
;
7607 Loop_Body
: Node_Id
;
7610 Final_Expr
: Node_Id
;
7611 Func_Body
: Node_Id
;
7612 Func_Name
: Entity_Id
;
7618 -- if J = Y'last then
7621 -- J := index'succ (J);
7625 Make_Implicit_If_Statement
(Nod
,
7628 Left_Opnd
=> New_Reference_To
(J
, Loc
),
7630 Make_Attribute_Reference
(Loc
,
7631 Prefix
=> New_Reference_To
(Y
, Loc
),
7632 Attribute_Name
=> Name_Last
)),
7634 Then_Statements
=> New_List
(
7635 Make_Exit_Statement
(Loc
)),
7639 Make_Assignment_Statement
(Loc
,
7640 Name
=> New_Reference_To
(J
, Loc
),
7642 Make_Attribute_Reference
(Loc
,
7643 Prefix
=> New_Reference_To
(Index
, Loc
),
7644 Attribute_Name
=> Name_Succ
,
7645 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))))));
7647 -- if X (I) = Y (J) then
7650 -- return X (I) > Y (J);
7654 Make_Implicit_If_Statement
(Nod
,
7658 Make_Indexed_Component
(Loc
,
7659 Prefix
=> New_Reference_To
(X
, Loc
),
7660 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
7663 Make_Indexed_Component
(Loc
,
7664 Prefix
=> New_Reference_To
(Y
, Loc
),
7665 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)))),
7667 Then_Statements
=> New_List
(Inner_If
),
7669 Else_Statements
=> New_List
(
7670 Make_Return_Statement
(Loc
,
7674 Make_Indexed_Component
(Loc
,
7675 Prefix
=> New_Reference_To
(X
, Loc
),
7676 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
7679 Make_Indexed_Component
(Loc
,
7680 Prefix
=> New_Reference_To
(Y
, Loc
),
7681 Expressions
=> New_List
(
7682 New_Reference_To
(J
, Loc
)))))));
7684 -- for I in X'range loop
7689 Make_Implicit_Loop_Statement
(Nod
,
7690 Identifier
=> Empty
,
7693 Make_Iteration_Scheme
(Loc
,
7694 Loop_Parameter_Specification
=>
7695 Make_Loop_Parameter_Specification
(Loc
,
7696 Defining_Identifier
=> I
,
7697 Discrete_Subtype_Definition
=>
7698 Make_Attribute_Reference
(Loc
,
7699 Prefix
=> New_Reference_To
(X
, Loc
),
7700 Attribute_Name
=> Name_Range
))),
7702 Statements
=> New_List
(Loop_Body
));
7704 -- if X'length = 0 then
7706 -- elsif Y'length = 0 then
7709 -- for ... loop ... end loop;
7710 -- return X'length > Y'length;
7714 Make_Attribute_Reference
(Loc
,
7715 Prefix
=> New_Reference_To
(X
, Loc
),
7716 Attribute_Name
=> Name_Length
);
7719 Make_Attribute_Reference
(Loc
,
7720 Prefix
=> New_Reference_To
(Y
, Loc
),
7721 Attribute_Name
=> Name_Length
);
7725 Left_Opnd
=> Length1
,
7726 Right_Opnd
=> Length2
);
7729 Make_Implicit_If_Statement
(Nod
,
7733 Make_Attribute_Reference
(Loc
,
7734 Prefix
=> New_Reference_To
(X
, Loc
),
7735 Attribute_Name
=> Name_Length
),
7737 Make_Integer_Literal
(Loc
, 0)),
7741 Make_Return_Statement
(Loc
,
7742 Expression
=> New_Reference_To
(Standard_False
, Loc
))),
7744 Elsif_Parts
=> New_List
(
7745 Make_Elsif_Part
(Loc
,
7749 Make_Attribute_Reference
(Loc
,
7750 Prefix
=> New_Reference_To
(Y
, Loc
),
7751 Attribute_Name
=> Name_Length
),
7753 Make_Integer_Literal
(Loc
, 0)),
7757 Make_Return_Statement
(Loc
,
7758 Expression
=> New_Reference_To
(Standard_True
, Loc
))))),
7760 Else_Statements
=> New_List
(
7762 Make_Return_Statement
(Loc
,
7763 Expression
=> Final_Expr
)));
7767 Formals
:= New_List
(
7768 Make_Parameter_Specification
(Loc
,
7769 Defining_Identifier
=> X
,
7770 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
7772 Make_Parameter_Specification
(Loc
,
7773 Defining_Identifier
=> Y
,
7774 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
7776 -- function Gnnn (...) return boolean is
7777 -- J : index := Y'first;
7782 Func_Name
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('G'));
7785 Make_Subprogram_Body
(Loc
,
7787 Make_Function_Specification
(Loc
,
7788 Defining_Unit_Name
=> Func_Name
,
7789 Parameter_Specifications
=> Formals
,
7790 Result_Definition
=> New_Reference_To
(Standard_Boolean
, Loc
)),
7792 Declarations
=> New_List
(
7793 Make_Object_Declaration
(Loc
,
7794 Defining_Identifier
=> J
,
7795 Object_Definition
=> New_Reference_To
(Index
, Loc
),
7797 Make_Attribute_Reference
(Loc
,
7798 Prefix
=> New_Reference_To
(Y
, Loc
),
7799 Attribute_Name
=> Name_First
))),
7801 Handled_Statement_Sequence
=>
7802 Make_Handled_Sequence_Of_Statements
(Loc
,
7803 Statements
=> New_List
(If_Stat
)));
7807 end Make_Array_Comparison_Op
;
7809 ---------------------------
7810 -- Make_Boolean_Array_Op --
7811 ---------------------------
7813 -- For logical operations on boolean arrays, expand in line the
7814 -- following, replacing 'and' with 'or' or 'xor' where needed:
7816 -- function Annn (A : typ; B: typ) return typ is
7819 -- for J in A'range loop
7820 -- C (J) := A (J) op B (J);
7825 -- Here typ is the boolean array type
7827 function Make_Boolean_Array_Op
7829 N
: Node_Id
) return Node_Id
7831 Loc
: constant Source_Ptr
:= Sloc
(N
);
7833 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
7834 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
7835 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
7836 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
7844 Func_Name
: Entity_Id
;
7845 Func_Body
: Node_Id
;
7846 Loop_Statement
: Node_Id
;
7850 Make_Indexed_Component
(Loc
,
7851 Prefix
=> New_Reference_To
(A
, Loc
),
7852 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
7855 Make_Indexed_Component
(Loc
,
7856 Prefix
=> New_Reference_To
(B
, Loc
),
7857 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
7860 Make_Indexed_Component
(Loc
,
7861 Prefix
=> New_Reference_To
(C
, Loc
),
7862 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
7864 if Nkind
(N
) = N_Op_And
then
7870 elsif Nkind
(N
) = N_Op_Or
then
7884 Make_Implicit_Loop_Statement
(N
,
7885 Identifier
=> Empty
,
7888 Make_Iteration_Scheme
(Loc
,
7889 Loop_Parameter_Specification
=>
7890 Make_Loop_Parameter_Specification
(Loc
,
7891 Defining_Identifier
=> J
,
7892 Discrete_Subtype_Definition
=>
7893 Make_Attribute_Reference
(Loc
,
7894 Prefix
=> New_Reference_To
(A
, Loc
),
7895 Attribute_Name
=> Name_Range
))),
7897 Statements
=> New_List
(
7898 Make_Assignment_Statement
(Loc
,
7900 Expression
=> Op
)));
7902 Formals
:= New_List
(
7903 Make_Parameter_Specification
(Loc
,
7904 Defining_Identifier
=> A
,
7905 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
7907 Make_Parameter_Specification
(Loc
,
7908 Defining_Identifier
=> B
,
7909 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
7912 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
7913 Set_Is_Inlined
(Func_Name
);
7916 Make_Subprogram_Body
(Loc
,
7918 Make_Function_Specification
(Loc
,
7919 Defining_Unit_Name
=> Func_Name
,
7920 Parameter_Specifications
=> Formals
,
7921 Result_Definition
=> New_Reference_To
(Typ
, Loc
)),
7923 Declarations
=> New_List
(
7924 Make_Object_Declaration
(Loc
,
7925 Defining_Identifier
=> C
,
7926 Object_Definition
=> New_Reference_To
(Typ
, Loc
))),
7928 Handled_Statement_Sequence
=>
7929 Make_Handled_Sequence_Of_Statements
(Loc
,
7930 Statements
=> New_List
(
7932 Make_Return_Statement
(Loc
,
7933 Expression
=> New_Reference_To
(C
, Loc
)))));
7936 end Make_Boolean_Array_Op
;
7938 ------------------------
7939 -- Rewrite_Comparison --
7940 ------------------------
7942 procedure Rewrite_Comparison
(N
: Node_Id
) is
7943 Typ
: constant Entity_Id
:= Etype
(N
);
7944 Op1
: constant Node_Id
:= Left_Opnd
(N
);
7945 Op2
: constant Node_Id
:= Right_Opnd
(N
);
7947 Res
: constant Compare_Result
:= Compile_Time_Compare
(Op1
, Op2
);
7948 -- Res indicates if compare outcome can be determined at compile time
7950 True_Result
: Boolean;
7951 False_Result
: Boolean;
7954 case N_Op_Compare
(Nkind
(N
)) is
7956 True_Result
:= Res
= EQ
;
7957 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
7960 True_Result
:= Res
in Compare_GE
;
7961 False_Result
:= Res
= LT
;
7964 True_Result
:= Res
= GT
;
7965 False_Result
:= Res
in Compare_LE
;
7968 True_Result
:= Res
= LT
;
7969 False_Result
:= Res
in Compare_GE
;
7972 True_Result
:= Res
in Compare_LE
;
7973 False_Result
:= Res
= GT
;
7976 True_Result
:= Res
= NE
;
7977 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= EQ
;
7982 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Sloc
(N
))));
7983 Analyze_And_Resolve
(N
, Typ
);
7984 Warn_On_Known_Condition
(N
);
7986 elsif False_Result
then
7988 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Sloc
(N
))));
7989 Analyze_And_Resolve
(N
, Typ
);
7990 Warn_On_Known_Condition
(N
);
7992 end Rewrite_Comparison
;
7994 ----------------------------
7995 -- Safe_In_Place_Array_Op --
7996 ----------------------------
7998 function Safe_In_Place_Array_Op
8001 Op2
: Node_Id
) return Boolean
8005 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean;
8006 -- Operand is safe if it cannot overlap part of the target of the
8007 -- operation. If the operand and the target are identical, the operand
8008 -- is safe. The operand can be empty in the case of negation.
8010 function Is_Unaliased
(N
: Node_Id
) return Boolean;
8011 -- Check that N is a stand-alone entity
8017 function Is_Unaliased
(N
: Node_Id
) return Boolean is
8021 and then No
(Address_Clause
(Entity
(N
)))
8022 and then No
(Renamed_Object
(Entity
(N
)));
8025 ---------------------
8026 -- Is_Safe_Operand --
8027 ---------------------
8029 function Is_Safe_Operand
(Op
: Node_Id
) return Boolean is
8034 elsif Is_Entity_Name
(Op
) then
8035 return Is_Unaliased
(Op
);
8037 elsif Nkind
(Op
) = N_Indexed_Component
8038 or else Nkind
(Op
) = N_Selected_Component
8040 return Is_Unaliased
(Prefix
(Op
));
8042 elsif Nkind
(Op
) = N_Slice
then
8044 Is_Unaliased
(Prefix
(Op
))
8045 and then Entity
(Prefix
(Op
)) /= Target
;
8047 elsif Nkind
(Op
) = N_Op_Not
then
8048 return Is_Safe_Operand
(Right_Opnd
(Op
));
8053 end Is_Safe_Operand
;
8055 -- Start of processing for Is_Safe_In_Place_Array_Op
8058 -- We skip this processing if the component size is not the
8059 -- same as a system storage unit (since at least for NOT
8060 -- this would cause problems).
8062 if Component_Size
(Etype
(Lhs
)) /= System_Storage_Unit
then
8065 -- Cannot do in place stuff on Java_VM since cannot pass addresses
8070 -- Cannot do in place stuff if non-standard Boolean representation
8072 elsif Has_Non_Standard_Rep
(Component_Type
(Etype
(Lhs
))) then
8075 elsif not Is_Unaliased
(Lhs
) then
8078 Target
:= Entity
(Lhs
);
8081 Is_Safe_Operand
(Op1
)
8082 and then Is_Safe_Operand
(Op2
);
8084 end Safe_In_Place_Array_Op
;
8086 -----------------------
8087 -- Tagged_Membership --
8088 -----------------------
8090 -- There are two different cases to consider depending on whether
8091 -- the right operand is a class-wide type or not. If not we just
8092 -- compare the actual tag of the left expr to the target type tag:
8094 -- Left_Expr.Tag = Right_Type'Tag;
8096 -- If it is a class-wide type we use the RT function CW_Membership which
8097 -- is usually implemented by looking in the ancestor tables contained in
8098 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
8100 function Tagged_Membership
(N
: Node_Id
) return Node_Id
is
8101 Left
: constant Node_Id
:= Left_Opnd
(N
);
8102 Right
: constant Node_Id
:= Right_Opnd
(N
);
8103 Loc
: constant Source_Ptr
:= Sloc
(N
);
8105 Left_Type
: Entity_Id
;
8106 Right_Type
: Entity_Id
;
8110 Left_Type
:= Etype
(Left
);
8111 Right_Type
:= Etype
(Right
);
8113 if Is_Class_Wide_Type
(Left_Type
) then
8114 Left_Type
:= Root_Type
(Left_Type
);
8118 Make_Selected_Component
(Loc
,
8119 Prefix
=> Relocate_Node
(Left
),
8121 New_Reference_To
(First_Tag_Component
(Left_Type
), Loc
));
8123 if Is_Class_Wide_Type
(Right_Type
) then
8125 -- Ada 2005 (AI-251): Class-wide applied to interfaces
8127 if Is_Interface
(Etype
(Class_Wide_Type
(Right_Type
)))
8129 -- Give support to: "Iface_CW_Typ in Typ'Class"
8131 or else Is_Interface
(Left_Type
)
8134 Make_Function_Call
(Loc
,
8135 Name
=> New_Occurrence_Of
(RTE
(RE_IW_Membership
), Loc
),
8136 Parameter_Associations
=> New_List
(
8137 Make_Attribute_Reference
(Loc
,
8139 Attribute_Name
=> Name_Address
),
8142 (Access_Disp_Table
(Root_Type
(Right_Type
)))),
8145 -- Ada 95: Normal case
8149 Make_Function_Call
(Loc
,
8150 Name
=> New_Occurrence_Of
(RTE
(RE_CW_Membership
), Loc
),
8151 Parameter_Associations
=> New_List
(
8155 (Access_Disp_Table
(Root_Type
(Right_Type
)))),
8162 Left_Opnd
=> Obj_Tag
,
8165 (Node
(First_Elmt
(Access_Disp_Table
(Right_Type
))), Loc
));
8167 end Tagged_Membership
;
8169 ------------------------------
8170 -- Unary_Op_Validity_Checks --
8171 ------------------------------
8173 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
8175 if Validity_Checks_On
and Validity_Check_Operands
then
8176 Ensure_Valid
(Right_Opnd
(N
));
8178 end Unary_Op_Validity_Checks
;