1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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_Disp
; use Exp_Disp
;
37 with Exp_Fixd
; use Exp_Fixd
;
38 with Exp_Pakd
; use Exp_Pakd
;
39 with Exp_Tss
; use Exp_Tss
;
40 with Exp_Util
; use Exp_Util
;
41 with Exp_VFpt
; use Exp_VFpt
;
42 with Hostparm
; use Hostparm
;
43 with Inline
; use Inline
;
44 with Nlists
; use Nlists
;
45 with Nmake
; use Nmake
;
47 with Restrict
; use Restrict
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch13
; use Sem_Ch13
;
52 with Sem_Eval
; use Sem_Eval
;
53 with Sem_Res
; use Sem_Res
;
54 with Sem_Type
; use Sem_Type
;
55 with Sem_Util
; use Sem_Util
;
56 with Sem_Warn
; use Sem_Warn
;
57 with Sinfo
; use Sinfo
;
58 with Sinfo
.CN
; use Sinfo
.CN
;
59 with Snames
; use Snames
;
60 with Stand
; use Stand
;
61 with Targparm
; use Targparm
;
62 with Tbuild
; use Tbuild
;
63 with Ttypes
; use Ttypes
;
64 with Uintp
; use Uintp
;
65 with Urealp
; use Urealp
;
66 with Validsw
; use Validsw
;
68 package body Exp_Ch4
is
70 ------------------------
71 -- Local Subprograms --
72 ------------------------
74 procedure Binary_Op_Validity_Checks
(N
: Node_Id
);
75 pragma Inline
(Binary_Op_Validity_Checks
);
76 -- Performs validity checks for a binary operator
78 procedure Expand_Array_Comparison
(N
: Node_Id
);
79 -- This routine handles expansion of the comparison operators (N_Op_Lt,
80 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
81 -- code for these operators is similar, differing only in the details of
82 -- the actual comparison call that is made.
84 function Expand_Array_Equality
92 -- Expand an array equality into a call to a function implementing this
93 -- equality, and a call to it. Loc is the location for the generated
94 -- nodes. Typ is the type of the array, and Lhs, Rhs are the array
95 -- expressions to be compared. A_Typ is the type of the arguments,
96 -- which may be a private type, in which case Typ is its full view.
97 -- Bodies is a list on which to attach bodies of local functions that
98 -- are created in the process. This is the responsability of the
99 -- caller to insert those bodies at the right place. Nod provides
100 -- the Sloc value for the generated code.
102 procedure Expand_Boolean_Operator
(N
: Node_Id
);
103 -- Common expansion processing for Boolean operators (And, Or, Xor)
104 -- for the case of array type arguments.
106 function Expand_Composite_Equality
113 -- Local recursive function used to expand equality for nested
114 -- composite types. Used by Expand_Record/Array_Equality, Bodies
115 -- is a list on which to attach bodies of local functions that are
116 -- created in the process. This is the responsability of the caller
117 -- to insert those bodies at the right place. Nod provides the Sloc
118 -- value for generated code.
120 procedure Expand_Concatenate_Other
(Cnode
: Node_Id
; Opnds
: List_Id
);
121 -- This routine handles expansion of concatenation operations, where
122 -- N is the N_Op_Concat node being expanded and Operands is the list
123 -- of operands (at least two are present). The caller has dealt with
124 -- converting any singleton operands into singleton aggregates.
126 procedure Expand_Concatenate_String
(Cnode
: Node_Id
; Opnds
: List_Id
);
127 -- Routine to expand concatenation of 2-5 operands (in the list Operands)
128 -- and replace node Cnode with the result of the contatenation. If there
129 -- are two operands, they can be string or character. If there are more
130 -- than two operands, then are always of type string (i.e. the caller has
131 -- already converted character operands to strings in this case).
133 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
);
134 -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
135 -- universal fixed. We do not have such a type at runtime, so the
136 -- purpose of this routine is to find the real type by looking up
137 -- the tree. We also determine if the operation must be rounded.
139 procedure Insert_Dereference_Action
(N
: Node_Id
);
140 -- N is an expression whose type is an access. When the type is derived
141 -- from Checked_Pool, expands a call to the primitive 'dereference'.
143 function Make_Array_Comparison_Op
147 -- Comparisons between arrays are expanded in line. This function
148 -- produces the body of the implementation of (a > b), where a and b
149 -- are one-dimensional arrays of some discrete type. The original
150 -- node is then expanded into the appropriate call to this function.
151 -- Nod provides the Sloc value for the generated code.
153 function Make_Boolean_Array_Op
157 -- Boolean operations on boolean arrays are expanded in line. This
158 -- function produce the body for the node N, which is (a and b),
159 -- (a or b), or (a xor b). It is used only the normal case and not
160 -- the packed case. The type involved, Typ, is the Boolean array type,
161 -- and the logical operations in the body are simple boolean operations.
162 -- Note that Typ is always a constrained type (the caller has ensured
163 -- this by using Convert_To_Actual_Subtype if necessary).
165 procedure Rewrite_Comparison
(N
: Node_Id
);
166 -- N is the node for a compile time comparison. If this outcome of this
167 -- comparison can be determined at compile time, then the node N can be
168 -- rewritten with True or False. If the outcome cannot be determined at
169 -- compile time, the call has no effect.
171 function Tagged_Membership
(N
: Node_Id
) return Node_Id
;
172 -- Construct the expression corresponding to the tagged membership test.
173 -- Deals with a second operand being (or not) a class-wide type.
175 procedure Unary_Op_Validity_Checks
(N
: Node_Id
);
176 pragma Inline
(Unary_Op_Validity_Checks
);
177 -- Performs validity checks for a unary operator
179 -------------------------------
180 -- Binary_Op_Validity_Checks --
181 -------------------------------
183 procedure Binary_Op_Validity_Checks
(N
: Node_Id
) is
185 if Validity_Checks_On
and Validity_Check_Operands
then
186 Ensure_Valid
(Left_Opnd
(N
));
187 Ensure_Valid
(Right_Opnd
(N
));
189 end Binary_Op_Validity_Checks
;
191 -----------------------------
192 -- Expand_Array_Comparison --
193 -----------------------------
195 -- Expansion is only required in the case of array types. The form of
198 -- [body for greater_nn; boolean_expression]
200 -- The body is built by Make_Array_Comparison_Op, and the form of the
201 -- Boolean expression depends on the operator involved.
203 procedure Expand_Array_Comparison
(N
: Node_Id
) is
204 Loc
: constant Source_Ptr
:= Sloc
(N
);
205 Op1
: Node_Id
:= Left_Opnd
(N
);
206 Op2
: Node_Id
:= Right_Opnd
(N
);
207 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
211 Func_Name
: Entity_Id
;
214 -- For (a <= b) we convert to not (a > b)
216 if Chars
(N
) = Name_Op_Le
then
222 Right_Opnd
=> Op2
)));
223 Analyze_And_Resolve
(N
, Standard_Boolean
);
226 -- For < the Boolean expression is
227 -- greater__nn (op2, op1)
229 elsif Chars
(N
) = Name_Op_Lt
then
230 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
234 Op1
:= Right_Opnd
(N
);
235 Op2
:= Left_Opnd
(N
);
237 -- For (a >= b) we convert to not (a < b)
239 elsif Chars
(N
) = Name_Op_Ge
then
245 Right_Opnd
=> Op2
)));
246 Analyze_And_Resolve
(N
, Standard_Boolean
);
249 -- For > the Boolean expression is
250 -- greater__nn (op1, op2)
253 pragma Assert
(Chars
(N
) = Name_Op_Gt
);
254 Func_Body
:= Make_Array_Comparison_Op
(Typ1
, N
);
257 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
259 Make_Function_Call
(Loc
,
260 Name
=> New_Reference_To
(Func_Name
, Loc
),
261 Parameter_Associations
=> New_List
(Op1
, Op2
));
263 Insert_Action
(N
, Func_Body
);
265 Analyze_And_Resolve
(N
, Standard_Boolean
);
267 end Expand_Array_Comparison
;
269 ---------------------------
270 -- Expand_Array_Equality --
271 ---------------------------
273 -- Expand an equality function for multi-dimensional arrays. Here is
274 -- an example of such a function for Nb_Dimension = 2
276 -- function Enn (A : arr; B : arr) return boolean is
281 -- if A'length (1) /= B'length (1) then
284 -- J1 := B'first (1);
285 -- for I1 in A'first (1) .. A'last (1) loop
286 -- if A'length (2) /= B'length (2) then
289 -- J2 := B'first (2);
290 -- for I2 in A'first (2) .. A'last (2) loop
291 -- if A (I1, I2) /= B (J1, J2) then
294 -- J2 := Integer'succ (J2);
297 -- J1 := Integer'succ (J1);
303 function Expand_Array_Equality
312 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
314 Decls
: List_Id
:= New_List
;
315 Index_List1
: List_Id
:= New_List
;
316 Index_List2
: List_Id
:= New_List
;
319 Func_Name
: Entity_Id
;
322 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
323 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
325 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
;
326 -- Create one statement to compare corresponding components, designated
327 -- by a full set of indices.
329 function Loop_One_Dimension
333 -- Loop over the n'th dimension of the arrays. The single statement
334 -- in the body of the loop is a loop over the next dimension, or
335 -- the comparison of corresponding components.
337 ------------------------
338 -- Component_Equality --
339 ------------------------
341 function Component_Equality
(Typ
: Entity_Id
) return Node_Id
is
346 -- if a(i1...) /= b(j1...) then return false; end if;
349 Make_Indexed_Component
(Loc
,
350 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
351 Expressions
=> Index_List1
);
354 Make_Indexed_Component
(Loc
,
355 Prefix
=> Make_Identifier
(Loc
, Chars
(B
)),
356 Expressions
=> Index_List2
);
358 Test
:= Expand_Composite_Equality
359 (Nod
, Component_Type
(Typ
), L
, R
, Decls
);
362 Make_Implicit_If_Statement
(Nod
,
363 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Test
),
364 Then_Statements
=> New_List
(
365 Make_Return_Statement
(Loc
,
366 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
368 end Component_Equality
;
370 ------------------------
371 -- Loop_One_Dimension --
372 ------------------------
374 function Loop_One_Dimension
379 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
380 New_Internal_Name
('I'));
381 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
382 New_Internal_Name
('J'));
383 Index_Type
: Entity_Id
;
387 if N
> Number_Dimensions
(Typ
) then
388 return Component_Equality
(Typ
);
391 -- Generate the following:
396 -- if a'length (n) /= b'length (n) then
400 -- for i in a'range (n) loop
401 -- -- loop over remaining dimensions.
402 -- j := index_type'succ (j);
406 -- retrieve index type for current dimension.
408 Index_Type
:= Base_Type
(Etype
(Index
));
409 Append
(New_Reference_To
(I
, Loc
), Index_List1
);
410 Append
(New_Reference_To
(J
, Loc
), Index_List2
);
412 -- Declare index for j as a local variable to the function.
413 -- Index i is a loop variable.
416 Make_Object_Declaration
(Loc
,
417 Defining_Identifier
=> J
,
418 Object_Definition
=> New_Reference_To
(Index_Type
, Loc
)));
421 Make_Implicit_If_Statement
(Nod
,
425 Make_Attribute_Reference
(Loc
,
426 Prefix
=> New_Reference_To
(A
, Loc
),
427 Attribute_Name
=> Name_Length
,
428 Expressions
=> New_List
(
429 Make_Integer_Literal
(Loc
, N
))),
431 Make_Attribute_Reference
(Loc
,
432 Prefix
=> New_Reference_To
(B
, Loc
),
433 Attribute_Name
=> Name_Length
,
434 Expressions
=> New_List
(
435 Make_Integer_Literal
(Loc
, N
)))),
437 Then_Statements
=> New_List
(
438 Make_Return_Statement
(Loc
,
439 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))),
441 Else_Statements
=> New_List
(
443 Make_Assignment_Statement
(Loc
,
444 Name
=> New_Reference_To
(J
, Loc
),
446 Make_Attribute_Reference
(Loc
,
447 Prefix
=> New_Reference_To
(B
, Loc
),
448 Attribute_Name
=> Name_First
,
449 Expressions
=> New_List
(
450 Make_Integer_Literal
(Loc
, N
)))),
452 Make_Implicit_Loop_Statement
(Nod
,
455 Make_Iteration_Scheme
(Loc
,
456 Loop_Parameter_Specification
=>
457 Make_Loop_Parameter_Specification
(Loc
,
458 Defining_Identifier
=> I
,
459 Discrete_Subtype_Definition
=>
460 Make_Attribute_Reference
(Loc
,
461 Prefix
=> New_Reference_To
(A
, Loc
),
462 Attribute_Name
=> Name_Range
,
463 Expressions
=> New_List
(
464 Make_Integer_Literal
(Loc
, N
))))),
466 Statements
=> New_List
(
467 Loop_One_Dimension
(N
+ 1, Next_Index
(Index
)),
468 Make_Assignment_Statement
(Loc
,
469 Name
=> New_Reference_To
(J
, Loc
),
471 Make_Attribute_Reference
(Loc
,
472 Prefix
=> New_Reference_To
(Index_Type
, Loc
),
473 Attribute_Name
=> Name_Succ
,
474 Expressions
=> New_List
(
475 New_Reference_To
(J
, Loc
))))))));
479 end Loop_One_Dimension
;
481 -- Start of processing for Expand_Array_Equality
484 Formals
:= New_List
(
485 Make_Parameter_Specification
(Loc
,
486 Defining_Identifier
=> A
,
487 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
489 Make_Parameter_Specification
(Loc
,
490 Defining_Identifier
=> B
,
491 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
493 Func_Name
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
495 Stats
:= Loop_One_Dimension
(1, First_Index
(Typ
));
498 Make_Subprogram_Body
(Loc
,
500 Make_Function_Specification
(Loc
,
501 Defining_Unit_Name
=> Func_Name
,
502 Parameter_Specifications
=> Formals
,
503 Subtype_Mark
=> New_Reference_To
(Standard_Boolean
, Loc
)),
504 Declarations
=> Decls
,
505 Handled_Statement_Sequence
=>
506 Make_Handled_Sequence_Of_Statements
(Loc
,
507 Statements
=> New_List
(
509 Make_Return_Statement
(Loc
,
510 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
512 Set_Has_Completion
(Func_Name
, True);
514 -- If the array type is distinct from the type of the arguments,
515 -- it is the full view of a private type. Apply an unchecked
516 -- conversion to insure that analysis of the call succeeds.
518 if Base_Type
(A_Typ
) /= Base_Type
(Typ
) then
519 Actuals
:= New_List
(
520 OK_Convert_To
(Typ
, Lhs
),
521 OK_Convert_To
(Typ
, Rhs
));
523 Actuals
:= New_List
(Lhs
, Rhs
);
526 Append_To
(Bodies
, Func_Body
);
529 Make_Function_Call
(Loc
,
530 Name
=> New_Reference_To
(Func_Name
, Loc
),
531 Parameter_Associations
=> Actuals
);
532 end Expand_Array_Equality
;
534 -----------------------------
535 -- Expand_Boolean_Operator --
536 -----------------------------
538 -- Note that we first get the actual subtypes of the operands,
539 -- since we always want to deal with types that have bounds.
541 procedure Expand_Boolean_Operator
(N
: Node_Id
) is
542 Typ
: constant Entity_Id
:= Etype
(N
);
545 if Is_Bit_Packed_Array
(Typ
) then
546 Expand_Packed_Boolean_Operator
(N
);
550 -- For the normal non-packed case, the expansion is
551 -- to build a function for carrying out the comparison
552 -- (using Make_Boolean_Array_Op) and then inserting it
553 -- into the tree. The original operator node is then
554 -- rewritten as a call to this function.
557 Loc
: constant Source_Ptr
:= Sloc
(N
);
558 L
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
559 R
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
561 Func_Name
: Entity_Id
;
563 Convert_To_Actual_Subtype
(L
);
564 Convert_To_Actual_Subtype
(R
);
565 Ensure_Defined
(Etype
(L
), N
);
566 Ensure_Defined
(Etype
(R
), N
);
567 Apply_Length_Check
(R
, Etype
(L
));
569 Func_Body
:= Make_Boolean_Array_Op
(Etype
(L
), N
);
570 Func_Name
:= Defining_Unit_Name
(Specification
(Func_Body
));
571 Insert_Action
(N
, Func_Body
);
573 -- Now rewrite the expression with a call
576 Make_Function_Call
(Loc
,
577 Name
=> New_Reference_To
(Func_Name
, Loc
),
578 Parameter_Associations
=>
580 (L
, Make_Type_Conversion
581 (Loc
, New_Reference_To
(Etype
(L
), Loc
), R
))));
583 Analyze_And_Resolve
(N
, Typ
);
586 end Expand_Boolean_Operator
;
588 -------------------------------
589 -- Expand_Composite_Equality --
590 -------------------------------
592 -- This function is only called for comparing internal fields of composite
593 -- types when these fields are themselves composites. This is a special
594 -- case because it is not possible to respect normal Ada visibility rules.
596 function Expand_Composite_Equality
604 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
605 Full_Type
: Entity_Id
;
610 if Is_Private_Type
(Typ
) then
611 Full_Type
:= Underlying_Type
(Typ
);
616 -- Defense against malformed private types with no completion
617 -- the error will be diagnosed later by check_completion
619 if No
(Full_Type
) then
620 return New_Reference_To
(Standard_False
, Loc
);
623 Full_Type
:= Base_Type
(Full_Type
);
625 if Is_Array_Type
(Full_Type
) then
627 -- If the operand is an elementary type other than a floating-point
628 -- type, then we can simply use the built-in block bitwise equality,
629 -- since the predefined equality operators always apply and bitwise
630 -- equality is fine for all these cases.
632 if Is_Elementary_Type
(Component_Type
(Full_Type
))
633 and then not Is_Floating_Point_Type
(Component_Type
(Full_Type
))
635 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
637 -- For composite component types, and floating-point types, use
638 -- the expansion. This deals with tagged component types (where
639 -- we use the applicable equality routine) and floating-point,
640 -- (where we need to worry about negative zeroes), and also the
641 -- case of any composite type recursively containing such fields.
644 return Expand_Array_Equality
645 (Nod
, Full_Type
, Typ
, Lhs
, Rhs
, Bodies
);
648 elsif Is_Tagged_Type
(Full_Type
) then
650 -- Call the primitive operation "=" of this type
652 if Is_Class_Wide_Type
(Full_Type
) then
653 Full_Type
:= Root_Type
(Full_Type
);
656 -- If this is derived from an untagged private type completed
657 -- with a tagged type, it does not have a full view, so we
658 -- use the primitive operations of the private type.
659 -- This check should no longer be necessary when these
660 -- types receive their full views ???
662 if Is_Private_Type
(Typ
)
663 and then not Is_Tagged_Type
(Typ
)
664 and then not Is_Controlled
(Typ
)
665 and then Is_Derived_Type
(Typ
)
666 and then No
(Full_View
(Typ
))
668 Prim
:= First_Elmt
(Collect_Primitive_Operations
(Typ
));
670 Prim
:= First_Elmt
(Primitive_Operations
(Full_Type
));
674 Eq_Op
:= Node
(Prim
);
675 exit when Chars
(Eq_Op
) = Name_Op_Eq
676 and then Etype
(First_Formal
(Eq_Op
)) =
677 Etype
(Next_Formal
(First_Formal
(Eq_Op
)));
679 pragma Assert
(Present
(Prim
));
682 Eq_Op
:= Node
(Prim
);
685 Make_Function_Call
(Loc
,
686 Name
=> New_Reference_To
(Eq_Op
, Loc
),
687 Parameter_Associations
=>
689 (Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Lhs
),
690 Unchecked_Convert_To
(Etype
(First_Formal
(Eq_Op
)), Rhs
)));
692 elsif Is_Record_Type
(Full_Type
) then
693 Eq_Op
:= TSS
(Full_Type
, Name_uEquality
);
695 if Present
(Eq_Op
) then
696 if Etype
(First_Formal
(Eq_Op
)) /= Full_Type
then
698 -- Inherited equality from parent type. Convert the actuals
699 -- to match signature of operation.
702 T
: Entity_Id
:= Etype
(First_Formal
(Eq_Op
));
706 Make_Function_Call
(Loc
,
707 Name
=> New_Reference_To
(Eq_Op
, Loc
),
708 Parameter_Associations
=>
709 New_List
(OK_Convert_To
(T
, Lhs
),
710 OK_Convert_To
(T
, Rhs
)));
715 Make_Function_Call
(Loc
,
716 Name
=> New_Reference_To
(Eq_Op
, Loc
),
717 Parameter_Associations
=> New_List
(Lhs
, Rhs
));
721 return Expand_Record_Equality
(Nod
, Full_Type
, Lhs
, Rhs
, Bodies
);
725 -- It can be a simple record or the full view of a scalar private
727 return Make_Op_Eq
(Loc
, Left_Opnd
=> Lhs
, Right_Opnd
=> Rhs
);
729 end Expand_Composite_Equality
;
731 ------------------------------
732 -- Expand_Concatenate_Other --
733 ------------------------------
735 -- Let n be the number of array operands to be concatenated, Base_Typ
736 -- their base type, Ind_Typ their index type, and Arr_Typ the original
737 -- array type to which the concatenantion operator applies, then the
738 -- following subprogram is constructed:
740 -- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
743 -- if S1'Length /= 0 then
744 -- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
745 -- XXX = Arr_Typ'First otherwise
746 -- elsif S2'Length /= 0 then
747 -- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
748 -- YYY = Arr_Typ'First otherwise
750 -- elsif Sn-1'Length /= 0 then
751 -- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
752 -- ZZZ = Arr_Typ'First otherwise
760 -- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
761 -- + Ind_Typ'Pos (L));
762 -- R : Base_Typ (L .. H);
764 -- if S1'Length /= 0 then
768 -- L := Ind_Typ'Succ (L);
769 -- exit when P = S1'Last;
770 -- P := Ind_Typ'Succ (P);
774 -- if S2'Length /= 0 then
775 -- L := Ind_Typ'Succ (L);
778 -- L := Ind_Typ'Succ (L);
779 -- exit when P = S2'Last;
780 -- P := Ind_Typ'Succ (P);
786 -- if Sn'Length /= 0 then
790 -- L := Ind_Typ'Succ (L);
791 -- exit when P = Sn'Last;
792 -- P := Ind_Typ'Succ (P);
800 procedure Expand_Concatenate_Other
(Cnode
: Node_Id
; Opnds
: List_Id
) is
801 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
802 Nb_Opnds
: constant Nat
:= List_Length
(Opnds
);
804 Arr_Typ
: constant Entity_Id
:= Etype
(Entity
(Cnode
));
805 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Cnode
));
806 Ind_Typ
: constant Entity_Id
:= Etype
(First_Index
(Base_Typ
));
810 Param_Specs
: List_Id
;
813 Func_Decls
: List_Id
;
814 Func_Stmts
: List_Id
;
819 Elsif_List
: List_Id
;
821 Declare_Block
: Node_Id
;
822 Declare_Decls
: List_Id
;
823 Declare_Stmts
: List_Id
;
835 function Copy_Into_R_S
(I
: Nat
) return List_Id
;
836 -- Builds the sequence of statement:
840 -- L := Ind_Typ'Succ (L);
841 -- exit when P = Si'Last;
842 -- P := Ind_Typ'Succ (P);
845 -- where i is the input parameter I given.
847 function Init_L
(I
: Nat
) return Node_Id
;
848 -- Builds the statement:
849 -- L := Arr_Typ'First; If Arr_Typ is constrained
850 -- L := Si'First; otherwise (where I is the input param given)
852 function H
return Node_Id
;
853 -- Builds reference to identifier H.
855 function Ind_Val
(E
: Node_Id
) return Node_Id
;
856 -- Builds expression Ind_Typ'Val (E);
858 function L
return Node_Id
;
859 -- Builds reference to identifier L.
861 function L_Pos
return Node_Id
;
862 -- Builds expression Ind_Typ'Pos (L).
864 function L_Succ
return Node_Id
;
865 -- Builds expression Ind_Typ'Succ (L).
867 function One
return Node_Id
;
868 -- Builds integer literal one.
870 function P
return Node_Id
;
871 -- Builds reference to identifier P.
873 function P_Succ
return Node_Id
;
874 -- Builds expression Ind_Typ'Succ (P).
876 function R
return Node_Id
;
877 -- Builds reference to identifier R.
879 function S
(I
: Nat
) return Node_Id
;
880 -- Builds reference to identifier Si, where I is the value given.
882 function S_First
(I
: Nat
) return Node_Id
;
883 -- Builds expression Si'First, where I is the value given.
885 function S_Last
(I
: Nat
) return Node_Id
;
886 -- Builds expression Si'Last, where I is the value given.
888 function S_Length
(I
: Nat
) return Node_Id
;
889 -- Builds expression Si'Length, where I is the value given.
891 function S_Length_Test
(I
: Nat
) return Node_Id
;
892 -- Builds expression Si'Length /= 0, where I is the value given.
898 function Copy_Into_R_S
(I
: Nat
) return List_Id
is
899 Stmts
: List_Id
:= New_List
;
908 -- First construct the initializations
910 P_Start
:= Make_Assignment_Statement
(Loc
,
912 Expression
=> S_First
(I
));
913 Append_To
(Stmts
, P_Start
);
915 -- Then build the loop
917 R_Copy
:= Make_Assignment_Statement
(Loc
,
918 Name
=> Make_Indexed_Component
(Loc
,
920 Expressions
=> New_List
(L
)),
921 Expression
=> Make_Indexed_Component
(Loc
,
923 Expressions
=> New_List
(P
)));
925 L_Inc
:= Make_Assignment_Statement
(Loc
,
927 Expression
=> L_Succ
);
929 Exit_Stmt
:= Make_Exit_Statement
(Loc
,
930 Condition
=> Make_Op_Eq
(Loc
, P
, S_Last
(I
)));
932 P_Inc
:= Make_Assignment_Statement
(Loc
,
934 Expression
=> P_Succ
);
937 Make_Implicit_Loop_Statement
(Cnode
,
938 Statements
=> New_List
(R_Copy
, L_Inc
, Exit_Stmt
, P_Inc
));
940 Append_To
(Stmts
, Loop_Stmt
);
949 function H
return Node_Id
is
951 return Make_Identifier
(Loc
, Name_uH
);
958 function Ind_Val
(E
: Node_Id
) return Node_Id
is
961 Make_Attribute_Reference
(Loc
,
962 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
963 Attribute_Name
=> Name_Val
,
964 Expressions
=> New_List
(E
));
971 function Init_L
(I
: Nat
) return Node_Id
is
975 if Is_Constrained
(Arr_Typ
) then
976 E
:= Make_Attribute_Reference
(Loc
,
977 Prefix
=> New_Reference_To
(Arr_Typ
, Loc
),
978 Attribute_Name
=> Name_First
);
984 return Make_Assignment_Statement
(Loc
, Name
=> L
, Expression
=> E
);
991 function L
return Node_Id
is
993 return Make_Identifier
(Loc
, Name_uL
);
1000 function L_Pos
return Node_Id
is
1003 Make_Attribute_Reference
(Loc
,
1004 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
1005 Attribute_Name
=> Name_Pos
,
1006 Expressions
=> New_List
(L
));
1013 function L_Succ
return Node_Id
is
1016 Make_Attribute_Reference
(Loc
,
1017 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
1018 Attribute_Name
=> Name_Succ
,
1019 Expressions
=> New_List
(L
));
1026 function One
return Node_Id
is
1028 return Make_Integer_Literal
(Loc
, 1);
1035 function P
return Node_Id
is
1037 return Make_Identifier
(Loc
, Name_uP
);
1044 function P_Succ
return Node_Id
is
1047 Make_Attribute_Reference
(Loc
,
1048 Prefix
=> New_Reference_To
(Ind_Typ
, Loc
),
1049 Attribute_Name
=> Name_Succ
,
1050 Expressions
=> New_List
(P
));
1057 function R
return Node_Id
is
1059 return Make_Identifier
(Loc
, Name_uR
);
1066 function S
(I
: Nat
) return Node_Id
is
1068 return Make_Identifier
(Loc
, New_External_Name
('S', I
));
1075 function S_First
(I
: Nat
) return Node_Id
is
1077 return Make_Attribute_Reference
(Loc
,
1079 Attribute_Name
=> Name_First
);
1086 function S_Last
(I
: Nat
) return Node_Id
is
1088 return Make_Attribute_Reference
(Loc
,
1090 Attribute_Name
=> Name_Last
);
1097 function S_Length
(I
: Nat
) return Node_Id
is
1099 return Make_Attribute_Reference
(Loc
,
1101 Attribute_Name
=> Name_Length
);
1108 function S_Length_Test
(I
: Nat
) return Node_Id
is
1112 Left_Opnd
=> S_Length
(I
),
1113 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
1116 -- Start of processing for Expand_Concatenate_Other
1119 -- Construct the parameter specs and the overall function spec
1121 Param_Specs
:= New_List
;
1122 for I
in 1 .. Nb_Opnds
loop
1125 Make_Parameter_Specification
(Loc
,
1126 Defining_Identifier
=>
1127 Make_Defining_Identifier
(Loc
, New_External_Name
('S', I
)),
1128 Parameter_Type
=> New_Reference_To
(Base_Typ
, Loc
)));
1131 Func_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
1133 Make_Function_Specification
(Loc
,
1134 Defining_Unit_Name
=> Func_Id
,
1135 Parameter_Specifications
=> Param_Specs
,
1136 Subtype_Mark
=> New_Reference_To
(Base_Typ
, Loc
));
1138 -- Construct L's object declaration
1141 Make_Object_Declaration
(Loc
,
1142 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uL
),
1143 Object_Definition
=> New_Reference_To
(Ind_Typ
, Loc
));
1145 Func_Decls
:= New_List
(L_Decl
);
1147 -- Construct the if-then-elsif statements
1149 Elsif_List
:= New_List
;
1150 for I
in 2 .. Nb_Opnds
- 1 loop
1151 Append_To
(Elsif_List
, Make_Elsif_Part
(Loc
,
1152 Condition
=> S_Length_Test
(I
),
1153 Then_Statements
=> New_List
(Init_L
(I
))));
1157 Make_Implicit_If_Statement
(Cnode
,
1158 Condition
=> S_Length_Test
(1),
1159 Then_Statements
=> New_List
(Init_L
(1)),
1160 Elsif_Parts
=> Elsif_List
,
1161 Else_Statements
=> New_List
(Make_Return_Statement
(Loc
,
1162 Expression
=> S
(Nb_Opnds
))));
1164 -- Construct the declaration for H
1167 Make_Object_Declaration
(Loc
,
1168 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uP
),
1169 Object_Definition
=> New_Reference_To
(Ind_Typ
, Loc
));
1171 H_Init
:= Make_Op_Subtract
(Loc
, S_Length
(1), One
);
1172 for I
in 2 .. Nb_Opnds
loop
1173 H_Init
:= Make_Op_Add
(Loc
, H_Init
, S_Length
(I
));
1175 H_Init
:= Ind_Val
(Make_Op_Add
(Loc
, H_Init
, L_Pos
));
1178 Make_Object_Declaration
(Loc
,
1179 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uH
),
1180 Object_Definition
=> New_Reference_To
(Ind_Typ
, Loc
),
1181 Expression
=> H_Init
);
1183 -- Construct the declaration for R
1185 R_Range
:= Make_Range
(Loc
, Low_Bound
=> L
, High_Bound
=> H
);
1187 Make_Index_Or_Discriminant_Constraint
(Loc
,
1188 Constraints
=> New_List
(R_Range
));
1191 Make_Object_Declaration
(Loc
,
1192 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uR
),
1193 Object_Definition
=>
1194 Make_Subtype_Indication
(Loc
,
1195 Subtype_Mark
=> New_Reference_To
(Base_Typ
, Loc
),
1196 Constraint
=> R_Constr
));
1198 -- Construct the declarations for the declare block
1200 Declare_Decls
:= New_List
(P_Decl
, H_Decl
, R_Decl
);
1202 -- Construct list of statements for the declare block
1204 Declare_Stmts
:= New_List
;
1205 for I
in 1 .. Nb_Opnds
loop
1206 Append_To
(Declare_Stmts
,
1207 Make_Implicit_If_Statement
(Cnode
,
1208 Condition
=> S_Length_Test
(I
),
1209 Then_Statements
=> Copy_Into_R_S
(I
)));
1212 Append_To
(Declare_Stmts
, Make_Return_Statement
(Loc
, Expression
=> R
));
1214 -- Construct the declare block
1216 Declare_Block
:= Make_Block_Statement
(Loc
,
1217 Declarations
=> Declare_Decls
,
1218 Handled_Statement_Sequence
=>
1219 Make_Handled_Sequence_Of_Statements
(Loc
, Declare_Stmts
));
1221 -- Construct the list of function statements
1223 Func_Stmts
:= New_List
(If_Stmt
, Declare_Block
);
1225 -- Construct the function body
1228 Make_Subprogram_Body
(Loc
,
1229 Specification
=> Func_Spec
,
1230 Declarations
=> Func_Decls
,
1231 Handled_Statement_Sequence
=>
1232 Make_Handled_Sequence_Of_Statements
(Loc
, Func_Stmts
));
1234 -- Insert the newly generated function in the code. This is analyzed
1235 -- with all checks off, since we have completed all the checks.
1237 -- Note that this does *not* fix the array concatenation bug when the
1238 -- low bound is Integer'first sibce that bug comes from the pointer
1239 -- dereferencing an unconstrained array. An there we need a constraint
1240 -- check to make sure the length of the concatenated array is ok. ???
1242 Insert_Action
(Cnode
, Func_Body
, Suppress
=> All_Checks
);
1244 -- Construct list of arguments for the function call
1247 Operand
:= First
(Opnds
);
1248 for I
in 1 .. Nb_Opnds
loop
1249 Append_To
(Params
, Relocate_Node
(Operand
));
1253 -- Insert the function call
1257 Make_Function_Call
(Loc
, New_Reference_To
(Func_Id
, Loc
), Params
));
1259 Analyze_And_Resolve
(Cnode
, Base_Typ
);
1260 Set_Is_Inlined
(Func_Id
);
1261 end Expand_Concatenate_Other
;
1263 -------------------------------
1264 -- Expand_Concatenate_String --
1265 -------------------------------
1267 procedure Expand_Concatenate_String
(Cnode
: Node_Id
; Opnds
: List_Id
) is
1268 Loc
: constant Source_Ptr
:= Sloc
(Cnode
);
1269 Opnd1
: constant Node_Id
:= First
(Opnds
);
1270 Opnd2
: constant Node_Id
:= Next
(Opnd1
);
1271 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Opnd1
));
1272 Typ2
: constant Entity_Id
:= Base_Type
(Etype
(Opnd2
));
1275 -- RE_Id value for function to be called
1278 -- In all cases, we build a call to a routine giving the list of
1279 -- arguments as the parameter list to the routine.
1281 case List_Length
(Opnds
) is
1283 if Typ1
= Standard_Character
then
1284 if Typ2
= Standard_Character
then
1285 R
:= RE_Str_Concat_CC
;
1288 pragma Assert
(Typ2
= Standard_String
);
1289 R
:= RE_Str_Concat_CS
;
1292 elsif Typ1
= Standard_String
then
1293 if Typ2
= Standard_Character
then
1294 R
:= RE_Str_Concat_SC
;
1297 pragma Assert
(Typ2
= Standard_String
);
1301 -- If we have anything other than Standard_Character or
1302 -- Standard_String, then we must have had a serious error
1303 -- earlier, so we just abandon the attempt at expansion.
1306 pragma Assert
(Serious_Errors_Detected
> 0);
1311 R
:= RE_Str_Concat_3
;
1314 R
:= RE_Str_Concat_4
;
1317 R
:= RE_Str_Concat_5
;
1321 raise Program_Error
;
1324 -- Now generate the appropriate call
1327 Make_Function_Call
(Sloc
(Cnode
),
1328 Name
=> New_Occurrence_Of
(RTE
(R
), Loc
),
1329 Parameter_Associations
=> Opnds
));
1331 Analyze_And_Resolve
(Cnode
, Standard_String
);
1332 end Expand_Concatenate_String
;
1334 ------------------------
1335 -- Expand_N_Allocator --
1336 ------------------------
1338 procedure Expand_N_Allocator
(N
: Node_Id
) is
1339 PtrT
: constant Entity_Id
:= Etype
(N
);
1341 Loc
: constant Source_Ptr
:= Sloc
(N
);
1346 -- RM E.2.3(22). We enforce that the expected type of an allocator
1347 -- shall not be a remote access-to-class-wide-limited-private type
1349 -- Why is this being done at expansion time, seems clearly wrong ???
1351 Validate_Remote_Access_To_Class_Wide_Type
(N
);
1353 -- Set the Storage Pool
1355 Set_Storage_Pool
(N
, Associated_Storage_Pool
(Root_Type
(PtrT
)));
1357 if Present
(Storage_Pool
(N
)) then
1358 if Is_RTE
(Storage_Pool
(N
), RE_SS_Pool
) then
1360 Set_Procedure_To_Call
(N
, RTE
(RE_SS_Allocate
));
1363 Set_Procedure_To_Call
(N
,
1364 Find_Prim_Op
(Etype
(Storage_Pool
(N
)), Name_Allocate
));
1368 -- Under certain circumstances we can replace an allocator by an
1369 -- access to statically allocated storage. The conditions, as noted
1370 -- in AARM 3.10 (10c) are as follows:
1372 -- Size and initial value is known at compile time
1373 -- Access type is access-to-constant
1375 if Is_Access_Constant
(PtrT
)
1376 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
1377 and then Compile_Time_Known_Value
(Expression
(Expression
(N
)))
1378 and then Size_Known_At_Compile_Time
(Etype
(Expression
1381 -- Here we can do the optimization. For the allocator
1385 -- We insert an object declaration
1387 -- Tnn : aliased x := y;
1389 -- and replace the allocator by Tnn'Unrestricted_Access.
1390 -- Tnn is marked as requiring static allocation.
1393 Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
1395 Desig
:= Subtype_Mark
(Expression
(N
));
1397 -- If context is constrained, use constrained subtype directly,
1398 -- so that the constant is not labelled as having a nomimally
1399 -- unconstrained subtype.
1401 if Entity
(Desig
) = Base_Type
(Designated_Type
(PtrT
)) then
1402 Desig
:= New_Occurrence_Of
(Designated_Type
(PtrT
), Loc
);
1406 Make_Object_Declaration
(Loc
,
1407 Defining_Identifier
=> Temp
,
1408 Aliased_Present
=> True,
1409 Constant_Present
=> Is_Access_Constant
(PtrT
),
1410 Object_Definition
=> Desig
,
1411 Expression
=> Expression
(Expression
(N
))));
1414 Make_Attribute_Reference
(Loc
,
1415 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
1416 Attribute_Name
=> Name_Unrestricted_Access
));
1418 Analyze_And_Resolve
(N
, PtrT
);
1420 -- We set the variable as statically allocated, since we don't
1421 -- want it going on the stack of the current procedure!
1423 Set_Is_Statically_Allocated
(Temp
);
1427 -- If the allocator is for a type which requires initialization, and
1428 -- there is no initial value (i.e. the operand is a subtype indication
1429 -- rather than a qualifed expression), then we must generate a call to
1430 -- the initialization routine. This is done using an expression actions
1433 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
1435 -- Here ptr_T is the pointer type for the allocator, and T is the
1436 -- subtype of the allocator. A special case arises if the designated
1437 -- type of the access type is a task or contains tasks. In this case
1438 -- the call to Init (Temp.all ...) is replaced by code that ensures
1439 -- that the tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
1440 -- for details). In addition, if the type T is a task T, then the first
1441 -- argument to Init must be converted to the task record type.
1443 if Nkind
(Expression
(N
)) = N_Qualified_Expression
then
1445 Indic
: constant Node_Id
:= Subtype_Mark
(Expression
(N
));
1446 T
: constant Entity_Id
:= Entity
(Indic
);
1447 Exp
: constant Node_Id
:= Expression
(Expression
(N
));
1449 Aggr_In_Place
: constant Boolean := Is_Delayed_Aggregate
(Exp
);
1451 Tag_Assign
: Node_Id
;
1455 if Is_Tagged_Type
(T
) or else Controlled_Type
(T
) then
1457 -- Actions inserted before:
1458 -- Temp : constant ptr_T := new T'(Expression);
1459 -- <no CW> Temp._tag := T'tag;
1460 -- <CTRL> Adjust (Finalizable (Temp.all));
1461 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
1463 -- We analyze by hand the new internal allocator to avoid
1464 -- any recursion and inappropriate call to Initialize
1465 if not Aggr_In_Place
then
1466 Remove_Side_Effects
(Exp
);
1470 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1472 -- For a class wide allocation generate the following code:
1474 -- type Equiv_Record is record ... end record;
1475 -- implicit subtype CW is <Class_Wide_Subytpe>;
1476 -- temp : PtrT := new CW'(CW!(expr));
1478 if Is_Class_Wide_Type
(T
) then
1479 Expand_Subtype_From_Expr
(Empty
, T
, Indic
, Exp
);
1481 Set_Expression
(Expression
(N
),
1482 Unchecked_Convert_To
(Entity
(Indic
), Exp
));
1484 Analyze_And_Resolve
(Expression
(N
), Entity
(Indic
));
1487 if Aggr_In_Place
then
1489 Make_Object_Declaration
(Loc
,
1490 Defining_Identifier
=> Temp
,
1491 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1492 Expression
=> Make_Allocator
(Loc
,
1493 New_Reference_To
(Etype
(Exp
), Loc
)));
1495 Set_No_Initialization
(Expression
(Tmp_Node
));
1496 Insert_Action
(N
, Tmp_Node
);
1497 Convert_Aggr_In_Allocator
(Tmp_Node
, Exp
);
1499 Node
:= Relocate_Node
(N
);
1500 Set_Analyzed
(Node
);
1502 Make_Object_Declaration
(Loc
,
1503 Defining_Identifier
=> Temp
,
1504 Constant_Present
=> True,
1505 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1506 Expression
=> Node
));
1509 -- Suppress the tag assignment when Java_VM because JVM tags
1510 -- are represented implicitly in objects.
1512 if Is_Tagged_Type
(T
)
1513 and then not Is_Class_Wide_Type
(T
)
1514 and then not Java_VM
1517 Make_Assignment_Statement
(Loc
,
1519 Make_Selected_Component
(Loc
,
1520 Prefix
=> New_Reference_To
(Temp
, Loc
),
1522 New_Reference_To
(Tag_Component
(T
), Loc
)),
1525 Unchecked_Convert_To
(RTE
(RE_Tag
),
1526 New_Reference_To
(Access_Disp_Table
(T
), Loc
)));
1528 -- The previous assignment has to be done in any case
1530 Set_Assignment_OK
(Name
(Tag_Assign
));
1531 Insert_Action
(N
, Tag_Assign
);
1533 elsif Is_Private_Type
(T
)
1534 and then Is_Tagged_Type
(Underlying_Type
(T
))
1535 and then not Java_VM
1538 Utyp
: constant Entity_Id
:= Underlying_Type
(T
);
1539 Ref
: constant Node_Id
:=
1540 Unchecked_Convert_To
(Utyp
,
1541 Make_Explicit_Dereference
(Loc
,
1542 New_Reference_To
(Temp
, Loc
)));
1546 Make_Assignment_Statement
(Loc
,
1548 Make_Selected_Component
(Loc
,
1551 New_Reference_To
(Tag_Component
(Utyp
), Loc
)),
1554 Unchecked_Convert_To
(RTE
(RE_Tag
),
1556 Access_Disp_Table
(Utyp
), Loc
)));
1558 Set_Assignment_OK
(Name
(Tag_Assign
));
1559 Insert_Action
(N
, Tag_Assign
);
1563 if Controlled_Type
(Designated_Type
(PtrT
))
1564 and then Controlled_Type
(T
)
1569 Apool
: constant Entity_Id
:=
1570 Associated_Storage_Pool
(PtrT
);
1573 -- If it is an allocation on the secondary stack
1574 -- (i.e. a value returned from a function), the object
1575 -- is attached on the caller side as soon as the call
1576 -- is completed (see Expand_Ctrl_Function_Call)
1578 if Is_RTE
(Apool
, RE_SS_Pool
) then
1580 F
: constant Entity_Id
:=
1581 Make_Defining_Identifier
(Loc
,
1582 New_Internal_Name
('F'));
1585 Make_Object_Declaration
(Loc
,
1586 Defining_Identifier
=> F
,
1587 Object_Definition
=> New_Reference_To
(RTE
1588 (RE_Finalizable_Ptr
), Loc
)));
1590 Flist
:= New_Reference_To
(F
, Loc
);
1591 Attach
:= Make_Integer_Literal
(Loc
, 1);
1594 -- Normal case, not a secondary stack allocation
1597 Flist
:= Find_Final_List
(PtrT
);
1598 Attach
:= Make_Integer_Literal
(Loc
, 2);
1601 if not Aggr_In_Place
then
1606 -- An unchecked conversion is needed in the
1607 -- classwide case because the designated type
1608 -- can be an ancestor of the subtype mark of
1611 Unchecked_Convert_To
(T
,
1612 Make_Explicit_Dereference
(Loc
,
1613 New_Reference_To
(Temp
, Loc
))),
1617 With_Attach
=> Attach
));
1622 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1623 Analyze_And_Resolve
(N
, PtrT
);
1625 elsif Aggr_In_Place
then
1627 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1629 Make_Object_Declaration
(Loc
,
1630 Defining_Identifier
=> Temp
,
1631 Object_Definition
=> New_Reference_To
(PtrT
, Loc
),
1632 Expression
=> Make_Allocator
(Loc
,
1633 New_Reference_To
(Etype
(Exp
), Loc
)));
1635 Set_No_Initialization
(Expression
(Tmp_Node
));
1636 Insert_Action
(N
, Tmp_Node
);
1637 Convert_Aggr_In_Allocator
(Tmp_Node
, Exp
);
1638 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
1639 Analyze_And_Resolve
(N
, PtrT
);
1641 elsif Is_Access_Type
(Designated_Type
(PtrT
))
1642 and then Nkind
(Exp
) = N_Allocator
1643 and then Nkind
(Expression
(Exp
)) /= N_Qualified_Expression
1645 -- Apply constraint to designated subtype indication.
1647 Apply_Constraint_Check
(Expression
(Exp
),
1648 Designated_Type
(Designated_Type
(PtrT
)),
1649 No_Sliding
=> True);
1651 if Nkind
(Expression
(Exp
)) = N_Raise_Constraint_Error
then
1653 -- Propagate constraint_error to enclosing allocator
1655 Rewrite
(Exp
, New_Copy
(Expression
(Exp
)));
1658 -- First check against the type of the qualified expression
1660 -- NOTE: The commented call should be correct, but for
1661 -- some reason causes the compiler to bomb (sigsegv) on
1662 -- ACVC test c34007g, so for now we just perform the old
1663 -- (incorrect) test against the designated subtype with
1664 -- no sliding in the else part of the if statement below.
1667 -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
1669 -- A check is also needed in cases where the designated
1670 -- subtype is constrained and differs from the subtype
1671 -- given in the qualified expression. Note that the check
1672 -- on the qualified expression does not allow sliding,
1673 -- but this check does (a relaxation from Ada 83).
1675 if Is_Constrained
(Designated_Type
(PtrT
))
1676 and then not Subtypes_Statically_Match
1677 (T
, Designated_Type
(PtrT
))
1679 Apply_Constraint_Check
1680 (Exp
, Designated_Type
(PtrT
), No_Sliding
=> False);
1682 -- The nonsliding check should really be performed
1683 -- (unconditionally) against the subtype of the
1684 -- qualified expression, but that causes a problem
1685 -- with c34007g (see above), so for now we retain this.
1688 Apply_Constraint_Check
1689 (Exp
, Designated_Type
(PtrT
), No_Sliding
=> True);
1694 -- Here if not qualified expression case.
1695 -- In this case, an initialization routine may be required
1699 T
: constant Entity_Id
:= Entity
(Expression
(N
));
1707 Temp_Decl
: Node_Id
;
1708 Temp_Type
: Entity_Id
;
1712 if No_Initialization
(N
) then
1715 -- Case of no initialization procedure present
1717 elsif not Has_Non_Null_Base_Init_Proc
(T
) then
1719 -- Case of simple initialization required
1721 if Needs_Simple_Initialization
(T
) then
1722 Rewrite
(Expression
(N
),
1723 Make_Qualified_Expression
(Loc
,
1724 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1725 Expression
=> Get_Simple_Init_Val
(T
, Loc
)));
1727 Analyze_And_Resolve
(Expression
(Expression
(N
)), T
);
1728 Analyze_And_Resolve
(Expression
(N
), T
);
1729 Set_Paren_Count
(Expression
(Expression
(N
)), 1);
1730 Expand_N_Allocator
(N
);
1732 -- No initialization required
1738 -- Case of initialization procedure present, must be called
1741 Init
:= Base_Init_Proc
(T
);
1744 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1746 -- Construct argument list for the initialization routine call
1747 -- The CPP constructor needs the address directly
1749 if Is_CPP_Class
(T
) then
1750 Arg1
:= New_Reference_To
(Temp
, Loc
);
1755 Make_Explicit_Dereference
(Loc
,
1756 Prefix
=> New_Reference_To
(Temp
, Loc
));
1757 Set_Assignment_OK
(Arg1
);
1760 -- The initialization procedure expects a specific type.
1761 -- if the context is access to class wide, indicate that
1762 -- the object being allocated has the right specific type.
1764 if Is_Class_Wide_Type
(Designated_Type
(PtrT
)) then
1765 Arg1
:= Unchecked_Convert_To
(T
, Arg1
);
1769 -- If designated type is a concurrent type or if it is a
1770 -- private type whose definition is a concurrent type,
1771 -- the first argument in the Init routine has to be
1772 -- unchecked conversion to the corresponding record type.
1773 -- If the designated type is a derived type, we also
1774 -- convert the argument to its root type.
1776 if Is_Concurrent_Type
(T
) then
1778 Unchecked_Convert_To
(Corresponding_Record_Type
(T
), Arg1
);
1780 elsif Is_Private_Type
(T
)
1781 and then Present
(Full_View
(T
))
1782 and then Is_Concurrent_Type
(Full_View
(T
))
1785 Unchecked_Convert_To
1786 (Corresponding_Record_Type
(Full_View
(T
)), Arg1
);
1788 elsif Etype
(First_Formal
(Init
)) /= Base_Type
(T
) then
1791 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Init
));
1794 Arg1
:= OK_Convert_To
(Etype
(Ftyp
), Arg1
);
1795 Set_Etype
(Arg1
, Ftyp
);
1799 Args
:= New_List
(Arg1
);
1801 -- For the task case, pass the Master_Id of the access type
1802 -- as the value of the _Master parameter, and _Chain as the
1803 -- value of the _Chain parameter (_Chain will be defined as
1804 -- part of the generated code for the allocator).
1806 if Has_Task
(T
) then
1808 if No
(Master_Id
(Base_Type
(PtrT
))) then
1810 -- The designated type was an incomplete type, and
1811 -- the access type did not get expanded. Salvage
1814 Expand_N_Full_Type_Declaration
1815 (Parent
(Base_Type
(PtrT
)));
1818 -- If the context of the allocator is a declaration or
1819 -- an assignment, we can generate a meaningful image for
1820 -- it, even though subsequent assignments might remove
1821 -- the connection between task and entity. We build this
1822 -- image when the left-hand side is a simple variable,
1823 -- a simple indexed assignment or a simple selected
1826 if Nkind
(Parent
(N
)) = N_Assignment_Statement
then
1828 Nam
: constant Node_Id
:= Name
(Parent
(N
));
1831 if Is_Entity_Name
(Nam
) then
1833 Build_Task_Image_Decls
(
1836 (Entity
(Nam
), Sloc
(Nam
)), T
);
1838 elsif (Nkind
(Nam
) = N_Indexed_Component
1839 or else Nkind
(Nam
) = N_Selected_Component
)
1840 and then Is_Entity_Name
(Prefix
(Nam
))
1843 Build_Task_Image_Decls
1844 (Loc
, Nam
, Etype
(Prefix
(Nam
)));
1846 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
1850 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
1852 Build_Task_Image_Decls
(
1853 Loc
, Defining_Identifier
(Parent
(N
)), T
);
1856 Decls
:= Build_Task_Image_Decls
(Loc
, T
, T
);
1861 (Master_Id
(Base_Type
(Root_Type
(PtrT
))), Loc
));
1862 Append_To
(Args
, Make_Identifier
(Loc
, Name_uChain
));
1864 Decl
:= Last
(Decls
);
1866 New_Occurrence_Of
(Defining_Identifier
(Decl
), Loc
));
1868 -- Has_Task is false, Decls not used
1874 -- Add discriminants if discriminated type
1876 if Has_Discriminants
(T
) then
1877 Discr
:= First_Elmt
(Discriminant_Constraint
(T
));
1879 while Present
(Discr
) loop
1880 Append
(New_Copy
(Elists
.Node
(Discr
)), Args
);
1884 elsif Is_Private_Type
(T
)
1885 and then Present
(Full_View
(T
))
1886 and then Has_Discriminants
(Full_View
(T
))
1889 First_Elmt
(Discriminant_Constraint
(Full_View
(T
)));
1891 while Present
(Discr
) loop
1892 Append
(New_Copy
(Elists
.Node
(Discr
)), Args
);
1897 -- We set the allocator as analyzed so that when we analyze the
1898 -- expression actions node, we do not get an unwanted recursive
1899 -- expansion of the allocator expression.
1901 Set_Analyzed
(N
, True);
1902 Node
:= Relocate_Node
(N
);
1904 -- Here is the transformation:
1906 -- output: Temp : constant ptr_T := new T;
1907 -- Init (Temp.all, ...);
1908 -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
1909 -- <CTRL> Initialize (Finalizable (Temp.all));
1911 -- Here ptr_T is the pointer type for the allocator, and T
1912 -- is the subtype of the allocator.
1915 Make_Object_Declaration
(Loc
,
1916 Defining_Identifier
=> Temp
,
1917 Constant_Present
=> True,
1918 Object_Definition
=> New_Reference_To
(Temp_Type
, Loc
),
1919 Expression
=> Node
);
1921 Set_Assignment_OK
(Temp_Decl
);
1923 if Is_CPP_Class
(T
) then
1924 Set_Aliased_Present
(Temp_Decl
);
1927 Insert_Action
(N
, Temp_Decl
, Suppress
=> All_Checks
);
1929 -- Case of designated type is task or contains task
1930 -- Create block to activate created tasks, and insert
1931 -- declaration for Task_Image variable ahead of call.
1933 if Has_Task
(T
) then
1935 L
: List_Id
:= New_List
;
1939 Build_Task_Allocate_Block
(L
, Node
, Args
);
1942 Insert_List_Before
(First
(Declarations
(Blk
)), Decls
);
1943 Insert_Actions
(N
, L
);
1948 Make_Procedure_Call_Statement
(Loc
,
1949 Name
=> New_Reference_To
(Init
, Loc
),
1950 Parameter_Associations
=> Args
));
1953 if Controlled_Type
(T
) then
1955 -- If the context is an access parameter, we need to create
1956 -- a non-anonymous access type in order to have a usable
1957 -- final list, because there is otherwise no pool to which
1958 -- the allocated object can belong. We create both the type
1959 -- and the finalization chain here, because freezing an
1960 -- internal type does not create such a chain.
1962 if Ekind
(PtrT
) = E_Anonymous_Access_Type
then
1965 Make_Defining_Identifier
(Loc
,
1966 New_Internal_Name
('I'));
1969 Make_Full_Type_Declaration
(Loc
,
1970 Defining_Identifier
=> Acc
,
1972 Make_Access_To_Object_Definition
(Loc
,
1973 Subtype_Indication
=>
1974 New_Occurrence_Of
(T
, Loc
))));
1976 Build_Final_List
(N
, Acc
);
1977 Flist
:= Find_Final_List
(Acc
);
1981 Flist
:= Find_Final_List
(PtrT
);
1986 Ref
=> New_Copy_Tree
(Arg1
),
1989 With_Attach
=> Make_Integer_Literal
(Loc
, 2)));
1992 if Is_CPP_Class
(T
) then
1994 Make_Attribute_Reference
(Loc
,
1995 Prefix
=> New_Reference_To
(Temp
, Loc
),
1996 Attribute_Name
=> Name_Unchecked_Access
));
1998 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
2001 Analyze_And_Resolve
(N
, PtrT
);
2005 end Expand_N_Allocator
;
2007 -----------------------
2008 -- Expand_N_And_Then --
2009 -----------------------
2011 -- Expand into conditional expression if Actions present, and also
2012 -- deal with optimizing case of arguments being True or False.
2014 procedure Expand_N_And_Then
(N
: Node_Id
) is
2015 Loc
: constant Source_Ptr
:= Sloc
(N
);
2016 Typ
: constant Entity_Id
:= Etype
(N
);
2017 Left
: constant Node_Id
:= Left_Opnd
(N
);
2018 Right
: constant Node_Id
:= Right_Opnd
(N
);
2022 -- Deal with non-standard booleans
2024 if Is_Boolean_Type
(Typ
) then
2025 Adjust_Condition
(Left
);
2026 Adjust_Condition
(Right
);
2027 Set_Etype
(N
, Standard_Boolean
);
2030 -- Check for cases of left argument is True or False
2032 if Nkind
(Left
) = N_Identifier
then
2034 -- If left argument is True, change (True and then Right) to Right.
2035 -- Any actions associated with Right will be executed unconditionally
2036 -- and can thus be inserted into the tree unconditionally.
2038 if Entity
(Left
) = Standard_True
then
2039 if Present
(Actions
(N
)) then
2040 Insert_Actions
(N
, Actions
(N
));
2044 Adjust_Result_Type
(N
, Typ
);
2047 -- If left argument is False, change (False and then Right) to
2048 -- False. In this case we can forget the actions associated with
2049 -- Right, since they will never be executed.
2051 elsif Entity
(Left
) = Standard_False
then
2052 Kill_Dead_Code
(Right
);
2053 Kill_Dead_Code
(Actions
(N
));
2054 Rewrite
(N
, New_Occurrence_Of
(Standard_False
, Loc
));
2055 Adjust_Result_Type
(N
, Typ
);
2060 -- If Actions are present, we expand
2062 -- left and then right
2066 -- if left then right else false end
2068 -- with the actions becoming the Then_Actions of the conditional
2069 -- expression. This conditional expression is then further expanded
2070 -- (and will eventually disappear)
2072 if Present
(Actions
(N
)) then
2073 Actlist
:= Actions
(N
);
2075 Make_Conditional_Expression
(Loc
,
2076 Expressions
=> New_List
(
2079 New_Occurrence_Of
(Standard_False
, Loc
))));
2081 Set_Then_Actions
(N
, Actlist
);
2082 Analyze_And_Resolve
(N
, Standard_Boolean
);
2083 Adjust_Result_Type
(N
, Typ
);
2087 -- No actions present, check for cases of right argument True/False
2089 if Nkind
(Right
) = N_Identifier
then
2091 -- Change (Left and then True) to Left. Note that we know there
2092 -- are no actions associated with the True operand, since we
2093 -- just checked for this case above.
2095 if Entity
(Right
) = Standard_True
then
2098 -- Change (Left and then False) to False, making sure to preserve
2099 -- any side effects associated with the Left operand.
2101 elsif Entity
(Right
) = Standard_False
then
2102 Remove_Side_Effects
(Left
);
2104 (N
, New_Occurrence_Of
(Standard_False
, Loc
));
2108 Adjust_Result_Type
(N
, Typ
);
2109 end Expand_N_And_Then
;
2111 -------------------------------------
2112 -- Expand_N_Conditional_Expression --
2113 -------------------------------------
2115 -- Expand into expression actions if then/else actions present
2117 procedure Expand_N_Conditional_Expression
(N
: Node_Id
) is
2118 Loc
: constant Source_Ptr
:= Sloc
(N
);
2119 Cond
: constant Node_Id
:= First
(Expressions
(N
));
2120 Thenx
: constant Node_Id
:= Next
(Cond
);
2121 Elsex
: constant Node_Id
:= Next
(Thenx
);
2122 Typ
: constant Entity_Id
:= Etype
(N
);
2127 -- If either then or else actions are present, then given:
2129 -- if cond then then-expr else else-expr end
2131 -- we insert the following sequence of actions (using Insert_Actions):
2136 -- Cnn := then-expr;
2142 -- and replace the conditional expression by a reference to Cnn.
2144 if Present
(Then_Actions
(N
)) or else Present
(Else_Actions
(N
)) then
2145 Cnn
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
2148 Make_Implicit_If_Statement
(N
,
2149 Condition
=> Relocate_Node
(Cond
),
2151 Then_Statements
=> New_List
(
2152 Make_Assignment_Statement
(Sloc
(Thenx
),
2153 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Thenx
)),
2154 Expression
=> Relocate_Node
(Thenx
))),
2156 Else_Statements
=> New_List
(
2157 Make_Assignment_Statement
(Sloc
(Elsex
),
2158 Name
=> New_Occurrence_Of
(Cnn
, Sloc
(Elsex
)),
2159 Expression
=> Relocate_Node
(Elsex
))));
2161 if Present
(Then_Actions
(N
)) then
2163 (First
(Then_Statements
(New_If
)), Then_Actions
(N
));
2166 if Present
(Else_Actions
(N
)) then
2168 (First
(Else_Statements
(New_If
)), Else_Actions
(N
));
2171 Rewrite
(N
, New_Occurrence_Of
(Cnn
, Loc
));
2174 Make_Object_Declaration
(Loc
,
2175 Defining_Identifier
=> Cnn
,
2176 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)));
2178 Insert_Action
(N
, New_If
);
2179 Analyze_And_Resolve
(N
, Typ
);
2181 end Expand_N_Conditional_Expression
;
2183 -----------------------------------
2184 -- Expand_N_Explicit_Dereference --
2185 -----------------------------------
2187 procedure Expand_N_Explicit_Dereference
(N
: Node_Id
) is
2189 -- The only processing required is an insertion of an explicit
2190 -- dereference call for the checked storage pool case.
2192 Insert_Dereference_Action
(Prefix
(N
));
2193 end Expand_N_Explicit_Dereference
;
2199 procedure Expand_N_In
(N
: Node_Id
) is
2200 Loc
: constant Source_Ptr
:= Sloc
(N
);
2201 Rtyp
: constant Entity_Id
:= Etype
(N
);
2204 -- No expansion is required if we have an explicit range
2206 if Nkind
(Right_Opnd
(N
)) = N_Range
then
2209 -- Here right operand is a subtype mark
2213 Typ
: Entity_Id
:= Etype
(Right_Opnd
(N
));
2214 Obj
: Node_Id
:= Left_Opnd
(N
);
2215 Cond
: Node_Id
:= Empty
;
2216 Is_Acc
: Boolean := Is_Access_Type
(Typ
);
2219 Remove_Side_Effects
(Obj
);
2221 -- For tagged type, do tagged membership operation
2223 if Is_Tagged_Type
(Typ
) then
2224 -- No expansion will be performed when Java_VM, as the
2225 -- JVM back end will handle the membership tests directly
2226 -- (tags are not explicitly represented in Java objects,
2227 -- so the normal tagged membership expansion is not what
2231 Rewrite
(N
, Tagged_Membership
(N
));
2232 Analyze_And_Resolve
(N
, Rtyp
);
2237 -- If type is scalar type, rewrite as x in t'first .. t'last
2238 -- This reason we do this is that the bounds may have the wrong
2239 -- type if they come from the original type definition.
2241 elsif Is_Scalar_Type
(Typ
) then
2242 Rewrite
(Right_Opnd
(N
),
2245 Make_Attribute_Reference
(Loc
,
2246 Attribute_Name
=> Name_First
,
2247 Prefix
=> New_Reference_To
(Typ
, Loc
)),
2250 Make_Attribute_Reference
(Loc
,
2251 Attribute_Name
=> Name_Last
,
2252 Prefix
=> New_Reference_To
(Typ
, Loc
))));
2253 Analyze_And_Resolve
(N
, Rtyp
);
2258 Typ
:= Designated_Type
(Typ
);
2261 if not Is_Constrained
(Typ
) then
2263 New_Reference_To
(Standard_True
, Loc
));
2264 Analyze_And_Resolve
(N
, Rtyp
);
2266 -- For the constrained array case, we have to check the
2267 -- subscripts for an exact match if the lengths are
2268 -- non-zero (the lengths must match in any case).
2270 elsif Is_Array_Type
(Typ
) then
2273 function Construct_Attribute_Reference
2278 -- Build attribute reference E'Nam(Dim)
2280 function Construct_Attribute_Reference
2288 Make_Attribute_Reference
(Loc
,
2290 Attribute_Name
=> Nam
,
2291 Expressions
=> New_List
(
2292 Make_Integer_Literal
(Loc
, Dim
)));
2293 end Construct_Attribute_Reference
;
2296 for J
in 1 .. Number_Dimensions
(Typ
) loop
2297 Evolve_And_Then
(Cond
,
2300 Construct_Attribute_Reference
2301 (Duplicate_Subexpr
(Obj
), Name_First
, J
),
2303 Construct_Attribute_Reference
2304 (New_Occurrence_Of
(Typ
, Loc
), Name_First
, J
)));
2306 Evolve_And_Then
(Cond
,
2309 Construct_Attribute_Reference
2310 (Duplicate_Subexpr
(Obj
), Name_Last
, J
),
2312 Construct_Attribute_Reference
2313 (New_Occurrence_Of
(Typ
, Loc
), Name_Last
, J
)));
2317 Cond
:= Make_Or_Else
(Loc
,
2321 Right_Opnd
=> Make_Null
(Loc
)),
2322 Right_Opnd
=> Cond
);
2326 Analyze_And_Resolve
(N
, Rtyp
);
2329 -- These are the cases where constraint checks may be
2330 -- required, e.g. records with possible discriminants
2333 -- Expand the test into a series of discriminant comparisons.
2334 -- The expression that is built is the negation of the one
2335 -- that is used for checking discriminant constraints.
2337 Obj
:= Relocate_Node
(Left_Opnd
(N
));
2339 if Has_Discriminants
(Typ
) then
2340 Cond
:= Make_Op_Not
(Loc
,
2341 Right_Opnd
=> Build_Discriminant_Checks
(Obj
, Typ
));
2344 Cond
:= Make_Or_Else
(Loc
,
2348 Right_Opnd
=> Make_Null
(Loc
)),
2349 Right_Opnd
=> Cond
);
2353 Cond
:= New_Occurrence_Of
(Standard_True
, Loc
);
2357 Analyze_And_Resolve
(N
, Rtyp
);
2363 --------------------------------
2364 -- Expand_N_Indexed_Component --
2365 --------------------------------
2367 procedure Expand_N_Indexed_Component
(N
: Node_Id
) is
2368 Loc
: constant Source_Ptr
:= Sloc
(N
);
2369 Typ
: constant Entity_Id
:= Etype
(N
);
2370 P
: constant Node_Id
:= Prefix
(N
);
2371 T
: constant Entity_Id
:= Etype
(P
);
2374 -- A special optimization, if we have an indexed component that
2375 -- is selecting from a slice, then we can eliminate the slice,
2376 -- since, for example, x (i .. j)(k) is identical to x(k). The
2377 -- only difference is the range check required by the slice. The
2378 -- range check for the slice itself has already been generated.
2379 -- The range check for the subscripting operation is ensured
2380 -- by converting the subject to the subtype of the slice.
2382 -- This optimization not only generates better code, avoiding
2383 -- slice messing especially in the packed case, but more importantly
2384 -- bypasses some problems in handling this peculiar case, for
2385 -- example, the issue of dealing specially with object renamings.
2387 if Nkind
(P
) = N_Slice
then
2389 Make_Indexed_Component
(Loc
,
2390 Prefix
=> Prefix
(P
),
2391 Expressions
=> New_List
(
2393 (Etype
(First_Index
(Etype
(P
))),
2394 First
(Expressions
(N
))))));
2395 Analyze_And_Resolve
(N
, Typ
);
2399 -- If the prefix is an access type, then we unconditionally rewrite
2400 -- if as an explicit deference. This simplifies processing for several
2401 -- cases, including packed array cases and certain cases in which
2402 -- checks must be generated. We used to try to do this only when it
2403 -- was necessary, but it cleans up the code to do it all the time.
2405 if Is_Access_Type
(T
) then
2407 Make_Explicit_Dereference
(Sloc
(N
),
2408 Prefix
=> Relocate_Node
(P
)));
2409 Analyze_And_Resolve
(P
, Designated_Type
(T
));
2412 if Validity_Checks_On
and then Validity_Check_Subscripts
then
2413 Apply_Subscript_Validity_Checks
(N
);
2416 -- All done for the non-packed case
2418 if not Is_Packed
(Etype
(Prefix
(N
))) then
2422 -- For packed arrays that are not bit-packed (i.e. the case of an array
2423 -- with one or more index types with a non-coniguous enumeration type),
2424 -- we can always use the normal packed element get circuit.
2426 if not Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
2427 Expand_Packed_Element_Reference
(N
);
2431 -- For a reference to a component of a bit packed array, we have to
2432 -- convert it to a reference to the corresponding Packed_Array_Type.
2433 -- We only want to do this for simple references, and not for:
2435 -- Left side of assignment (or prefix of left side of assignment)
2436 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
2438 -- Renaming objects in renaming associations
2439 -- This case is handled when a use of the renamed variable occurs
2441 -- Actual parameters for a procedure call
2442 -- This case is handled in Exp_Ch6.Expand_Actuals
2444 -- The second expression in a 'Read attribute reference
2446 -- The prefix of an address or size attribute reference
2448 -- The following circuit detects these exceptions
2451 Child
: Node_Id
:= N
;
2452 Parnt
: Node_Id
:= Parent
(N
);
2456 if Nkind
(Parnt
) = N_Unchecked_Expression
then
2459 elsif Nkind
(Parnt
) = N_Object_Renaming_Declaration
2460 or else Nkind
(Parnt
) = N_Procedure_Call_Statement
2461 or else (Nkind
(Parnt
) = N_Parameter_Association
2463 Nkind
(Parent
(Parnt
)) = N_Procedure_Call_Statement
)
2467 elsif Nkind
(Parnt
) = N_Attribute_Reference
2468 and then (Attribute_Name
(Parnt
) = Name_Address
2470 Attribute_Name
(Parnt
) = Name_Size
)
2471 and then Prefix
(Parnt
) = Child
2475 elsif Nkind
(Parnt
) = N_Assignment_Statement
2476 and then Name
(Parnt
) = Child
2480 elsif Nkind
(Parnt
) = N_Attribute_Reference
2481 and then Attribute_Name
(Parnt
) = Name_Read
2482 and then Next
(First
(Expressions
(Parnt
))) = Child
2486 elsif (Nkind
(Parnt
) = N_Indexed_Component
2487 or else Nkind
(Parnt
) = N_Selected_Component
)
2488 and then Prefix
(Parnt
) = Child
2493 Expand_Packed_Element_Reference
(N
);
2497 -- Keep looking up tree for unchecked expression, or if we are
2498 -- the prefix of a possible assignment left side.
2501 Parnt
:= Parent
(Child
);
2505 end Expand_N_Indexed_Component
;
2507 ---------------------
2508 -- Expand_N_Not_In --
2509 ---------------------
2511 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
2512 -- can be done. This avoids needing to duplicate this expansion code.
2514 procedure Expand_N_Not_In
(N
: Node_Id
) is
2515 Loc
: constant Source_Ptr
:= Sloc
(N
);
2516 Typ
: constant Entity_Id
:= Etype
(N
);
2523 Left_Opnd
=> Left_Opnd
(N
),
2524 Right_Opnd
=> Right_Opnd
(N
))));
2525 Analyze_And_Resolve
(N
, Typ
);
2526 end Expand_N_Not_In
;
2532 -- The only replacement required is for the case of a null of type
2533 -- that is an access to protected subprogram. We represent such
2534 -- access values as a record, and so we must replace the occurrence
2535 -- of null by the equivalent record (with a null address and a null
2536 -- pointer in it), so that the backend creates the proper value.
2538 procedure Expand_N_Null
(N
: Node_Id
) is
2539 Loc
: constant Source_Ptr
:= Sloc
(N
);
2540 Typ
: constant Entity_Id
:= Etype
(N
);
2544 if Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
2546 Make_Aggregate
(Loc
,
2547 Expressions
=> New_List
(
2548 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
),
2552 Analyze_And_Resolve
(N
, Equivalent_Type
(Typ
));
2554 -- For subsequent semantic analysis, the node must retain its
2555 -- type. Gigi in any case replaces this type by the corresponding
2556 -- record type before processing the node.
2562 ---------------------
2563 -- Expand_N_Op_Abs --
2564 ---------------------
2566 procedure Expand_N_Op_Abs
(N
: Node_Id
) is
2567 Loc
: constant Source_Ptr
:= Sloc
(N
);
2568 Expr
: constant Node_Id
:= Right_Opnd
(N
);
2571 Unary_Op_Validity_Checks
(N
);
2573 -- Deal with software overflow checking
2575 if not Backend_Overflow_Checks_On_Target
2576 and then Is_Signed_Integer_Type
(Etype
(N
))
2577 and then Do_Overflow_Check
(N
)
2579 -- Software overflow checking expands abs (expr) into
2581 -- (if expr >= 0 then expr else -expr)
2583 -- with the usual Duplicate_Subexpr use coding for expr
2586 Make_Conditional_Expression
(Loc
,
2587 Expressions
=> New_List
(
2589 Left_Opnd
=> Duplicate_Subexpr
(Expr
),
2590 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
2592 Duplicate_Subexpr
(Expr
),
2595 Right_Opnd
=> Duplicate_Subexpr
(Expr
)))));
2597 Analyze_And_Resolve
(N
);
2599 -- Vax floating-point types case
2601 elsif Vax_Float
(Etype
(N
)) then
2602 Expand_Vax_Arith
(N
);
2604 end Expand_N_Op_Abs
;
2606 ---------------------
2607 -- Expand_N_Op_Add --
2608 ---------------------
2610 procedure Expand_N_Op_Add
(N
: Node_Id
) is
2611 Typ
: constant Entity_Id
:= Etype
(N
);
2614 Binary_Op_Validity_Checks
(N
);
2616 -- N + 0 = 0 + N = N for integer types
2618 if Is_Integer_Type
(Typ
) then
2619 if Compile_Time_Known_Value
(Right_Opnd
(N
))
2620 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
2622 Rewrite
(N
, Left_Opnd
(N
));
2625 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
2626 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
2628 Rewrite
(N
, Right_Opnd
(N
));
2633 -- Arithemtic overflow checks for signed integer/fixed point types
2635 if Is_Signed_Integer_Type
(Typ
)
2636 or else Is_Fixed_Point_Type
(Typ
)
2638 Apply_Arithmetic_Overflow_Check
(N
);
2641 -- Vax floating-point types case
2643 elsif Vax_Float
(Typ
) then
2644 Expand_Vax_Arith
(N
);
2646 end Expand_N_Op_Add
;
2648 ---------------------
2649 -- Expand_N_Op_And --
2650 ---------------------
2652 procedure Expand_N_Op_And
(N
: Node_Id
) is
2653 Typ
: constant Entity_Id
:= Etype
(N
);
2656 Binary_Op_Validity_Checks
(N
);
2658 if Is_Array_Type
(Etype
(N
)) then
2659 Expand_Boolean_Operator
(N
);
2661 elsif Is_Boolean_Type
(Etype
(N
)) then
2662 Adjust_Condition
(Left_Opnd
(N
));
2663 Adjust_Condition
(Right_Opnd
(N
));
2664 Set_Etype
(N
, Standard_Boolean
);
2665 Adjust_Result_Type
(N
, Typ
);
2667 end Expand_N_Op_And
;
2669 ------------------------
2670 -- Expand_N_Op_Concat --
2671 ------------------------
2673 procedure Expand_N_Op_Concat
(N
: Node_Id
) is
2676 -- List of operands to be concatenated
2679 -- Single operand for concatenation
2682 -- Node which is to be replaced by the result of concatenating
2683 -- the nodes in the list Opnds.
2686 -- Array type of concatenation result type
2689 -- Component type of concatenation represented by Cnode
2692 Binary_Op_Validity_Checks
(N
);
2694 -- If we are the left operand of a concatenation higher up the
2695 -- tree, then do nothing for now, since we want to deal with a
2696 -- series of concatenations as a unit.
2698 if Nkind
(Parent
(N
)) = N_Op_Concat
2699 and then N
= Left_Opnd
(Parent
(N
))
2704 -- We get here with a concatenation whose left operand may be a
2705 -- concatenation itself with a consistent type. We need to process
2706 -- these concatenation operands from left to right, which means
2707 -- from the deepest node in the tree to the highest node.
2710 while Nkind
(Left_Opnd
(Cnode
)) = N_Op_Concat
loop
2711 Cnode
:= Left_Opnd
(Cnode
);
2714 -- Now Opnd is the deepest Opnd, and its parents are the concatenation
2715 -- nodes above, so now we process bottom up, doing the operations. We
2716 -- gather a string that is as long as possible up to five operands
2718 -- The outer loop runs more than once if there are more than five
2719 -- concatenations of type Standard.String, the most we handle for
2720 -- this case, or if more than one concatenation type is involved.
2723 Opnds
:= New_List
(Left_Opnd
(Cnode
), Right_Opnd
(Cnode
));
2724 Set_Parent
(Opnds
, N
);
2726 -- The inner loop gathers concatenation operands
2728 Inner
: while Cnode
/= N
2729 and then (Base_Type
(Etype
(Cnode
)) /= Standard_String
2731 List_Length
(Opnds
) < 5)
2732 and then Base_Type
(Etype
(Cnode
)) =
2733 Base_Type
(Etype
(Parent
(Cnode
)))
2735 Cnode
:= Parent
(Cnode
);
2736 Append
(Right_Opnd
(Cnode
), Opnds
);
2739 -- Here we process the collected operands. First we convert
2740 -- singleton operands to singleton aggregates. This is skipped
2741 -- however for the case of two operands of type String, since
2742 -- we have special routines for these cases.
2744 Atyp
:= Base_Type
(Etype
(Cnode
));
2745 Ctyp
:= Base_Type
(Component_Type
(Etype
(Cnode
)));
2747 if List_Length
(Opnds
) > 2 or else Atyp
/= Standard_String
then
2748 Opnd
:= First
(Opnds
);
2750 if Base_Type
(Etype
(Opnd
)) = Ctyp
then
2752 Make_Aggregate
(Sloc
(Cnode
),
2753 Expressions
=> New_List
(Relocate_Node
(Opnd
))));
2754 Analyze_And_Resolve
(Opnd
, Atyp
);
2758 exit when No
(Opnd
);
2762 -- Now call appropriate continuation routine
2764 if Atyp
= Standard_String
then
2765 Expand_Concatenate_String
(Cnode
, Opnds
);
2767 Expand_Concatenate_Other
(Cnode
, Opnds
);
2770 exit Outer
when Cnode
= N
;
2771 Cnode
:= Parent
(Cnode
);
2773 end Expand_N_Op_Concat
;
2775 ------------------------
2776 -- Expand_N_Op_Divide --
2777 ------------------------
2779 procedure Expand_N_Op_Divide
(N
: Node_Id
) is
2780 Loc
: constant Source_Ptr
:= Sloc
(N
);
2781 Ltyp
: constant Entity_Id
:= Etype
(Left_Opnd
(N
));
2782 Rtyp
: constant Entity_Id
:= Etype
(Right_Opnd
(N
));
2783 Typ
: Entity_Id
:= Etype
(N
);
2786 Binary_Op_Validity_Checks
(N
);
2788 -- Vax_Float is a special case
2790 if Vax_Float
(Typ
) then
2791 Expand_Vax_Arith
(N
);
2795 -- N / 1 = N for integer types
2797 if Is_Integer_Type
(Typ
)
2798 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
2799 and then Expr_Value
(Right_Opnd
(N
)) = Uint_1
2801 Rewrite
(N
, Left_Opnd
(N
));
2805 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
2806 -- Is_Power_Of_2_For_Shift is set means that we know that our left
2807 -- operand is an unsigned integer, as required for this to work.
2809 if Nkind
(Right_Opnd
(N
)) = N_Op_Expon
2810 and then Is_Power_Of_2_For_Shift
(Right_Opnd
(N
))
2813 Make_Op_Shift_Right
(Loc
,
2814 Left_Opnd
=> Left_Opnd
(N
),
2816 Convert_To
(Standard_Natural
, Right_Opnd
(Right_Opnd
(N
)))));
2817 Analyze_And_Resolve
(N
, Typ
);
2821 -- Do required fixup of universal fixed operation
2823 if Typ
= Universal_Fixed
then
2824 Fixup_Universal_Fixed_Operation
(N
);
2828 -- Divisions with fixed-point results
2830 if Is_Fixed_Point_Type
(Typ
) then
2832 -- No special processing if Treat_Fixed_As_Integer is set,
2833 -- since from a semantic point of view such operations are
2834 -- simply integer operations and will be treated that way.
2836 if not Treat_Fixed_As_Integer
(N
) then
2837 if Is_Integer_Type
(Rtyp
) then
2838 Expand_Divide_Fixed_By_Integer_Giving_Fixed
(N
);
2840 Expand_Divide_Fixed_By_Fixed_Giving_Fixed
(N
);
2844 -- Other cases of division of fixed-point operands. Again we
2845 -- exclude the case where Treat_Fixed_As_Integer is set.
2847 elsif (Is_Fixed_Point_Type
(Ltyp
) or else
2848 Is_Fixed_Point_Type
(Rtyp
))
2849 and then not Treat_Fixed_As_Integer
(N
)
2851 if Is_Integer_Type
(Typ
) then
2852 Expand_Divide_Fixed_By_Fixed_Giving_Integer
(N
);
2854 pragma Assert
(Is_Floating_Point_Type
(Typ
));
2855 Expand_Divide_Fixed_By_Fixed_Giving_Float
(N
);
2858 -- Mixed-mode operations can appear in a non-static universal
2859 -- context, in which case the integer argument must be converted
2862 elsif Typ
= Universal_Real
2863 and then Is_Integer_Type
(Rtyp
)
2865 Rewrite
(Right_Opnd
(N
),
2866 Convert_To
(Universal_Real
, Relocate_Node
(Right_Opnd
(N
))));
2868 Analyze_And_Resolve
(Right_Opnd
(N
), Universal_Real
);
2870 elsif Typ
= Universal_Real
2871 and then Is_Integer_Type
(Ltyp
)
2873 Rewrite
(Left_Opnd
(N
),
2874 Convert_To
(Universal_Real
, Relocate_Node
(Left_Opnd
(N
))));
2876 Analyze_And_Resolve
(Left_Opnd
(N
), Universal_Real
);
2878 -- Non-fixed point cases, do zero divide and overflow checks
2880 elsif Is_Integer_Type
(Typ
) then
2881 Apply_Divide_Check
(N
);
2883 end Expand_N_Op_Divide
;
2885 --------------------
2886 -- Expand_N_Op_Eq --
2887 --------------------
2889 procedure Expand_N_Op_Eq
(N
: Node_Id
) is
2890 Loc
: constant Source_Ptr
:= Sloc
(N
);
2891 Typ
: constant Entity_Id
:= Etype
(N
);
2892 Lhs
: constant Node_Id
:= Left_Opnd
(N
);
2893 Rhs
: constant Node_Id
:= Right_Opnd
(N
);
2894 A_Typ
: Entity_Id
:= Etype
(Lhs
);
2895 Typl
: Entity_Id
:= A_Typ
;
2896 Op_Name
: Entity_Id
;
2898 Bodies
: List_Id
:= New_List
;
2900 procedure Build_Equality_Call
(Eq
: Entity_Id
);
2901 -- If a constructed equality exists for the type or for its parent,
2902 -- build and analyze call, adding conversions if the operation is
2905 -------------------------
2906 -- Build_Equality_Call --
2907 -------------------------
2909 procedure Build_Equality_Call
(Eq
: Entity_Id
) is
2910 Op_Type
: constant Entity_Id
:= Etype
(First_Formal
(Eq
));
2911 L_Exp
: Node_Id
:= Relocate_Node
(Lhs
);
2912 R_Exp
: Node_Id
:= Relocate_Node
(Rhs
);
2915 if Base_Type
(Op_Type
) /= Base_Type
(A_Typ
)
2916 and then not Is_Class_Wide_Type
(A_Typ
)
2918 L_Exp
:= OK_Convert_To
(Op_Type
, L_Exp
);
2919 R_Exp
:= OK_Convert_To
(Op_Type
, R_Exp
);
2923 Make_Function_Call
(Loc
,
2924 Name
=> New_Reference_To
(Eq
, Loc
),
2925 Parameter_Associations
=> New_List
(L_Exp
, R_Exp
)));
2927 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
2928 end Build_Equality_Call
;
2930 -- Start of processing for Expand_N_Op_Eq
2933 Binary_Op_Validity_Checks
(N
);
2935 if Ekind
(Typl
) = E_Private_Type
then
2936 Typl
:= Underlying_Type
(Typl
);
2938 elsif Ekind
(Typl
) = E_Private_Subtype
then
2939 Typl
:= Underlying_Type
(Base_Type
(Typl
));
2942 -- It may happen in error situations that the underlying type is not
2943 -- set. The error will be detected later, here we just defend the
2950 Typl
:= Base_Type
(Typl
);
2954 if Vax_Float
(Typl
) then
2955 Expand_Vax_Comparison
(N
);
2958 -- Boolean types (requiring handling of non-standard case)
2960 elsif Is_Boolean_Type
(Typl
) then
2961 Adjust_Condition
(Left_Opnd
(N
));
2962 Adjust_Condition
(Right_Opnd
(N
));
2963 Set_Etype
(N
, Standard_Boolean
);
2964 Adjust_Result_Type
(N
, Typ
);
2968 elsif Is_Array_Type
(Typl
) then
2972 if Is_Bit_Packed_Array
(Typl
) then
2973 Expand_Packed_Eq
(N
);
2975 -- For non-floating-point elementary types, the primitive equality
2976 -- always applies, and block-bit comparison is fine. Floating-point
2977 -- is an exception because of negative zeroes.
2979 -- However, we never use block bit comparison in No_Run_Time mode,
2980 -- since this may result in a call to a run time routine
2982 elsif Is_Elementary_Type
(Component_Type
(Typl
))
2983 and then not Is_Floating_Point_Type
(Component_Type
(Typl
))
2984 and then not No_Run_Time
2988 -- For composite and floating-point cases, expand equality loop
2989 -- to make sure of using proper comparisons for tagged types,
2990 -- and correctly handling the floating-point case.
2994 Expand_Array_Equality
(N
, Typl
, A_Typ
,
2995 Relocate_Node
(Lhs
), Relocate_Node
(Rhs
), Bodies
));
2997 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
2998 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
3003 elsif Is_Record_Type
(Typl
) then
3005 -- For tagged types, use the primitive "="
3007 if Is_Tagged_Type
(Typl
) then
3009 -- If this is derived from an untagged private type completed
3010 -- with a tagged type, it does not have a full view, so we
3011 -- use the primitive operations of the private type.
3012 -- This check should no longer be necessary when these
3013 -- types receive their full views ???
3015 if Is_Private_Type
(A_Typ
)
3016 and then not Is_Tagged_Type
(A_Typ
)
3017 and then Is_Derived_Type
(A_Typ
)
3018 and then No
(Full_View
(A_Typ
))
3020 Prim
:= First_Elmt
(Collect_Primitive_Operations
(A_Typ
));
3022 while Chars
(Node
(Prim
)) /= Name_Op_Eq
loop
3024 pragma Assert
(Present
(Prim
));
3027 Op_Name
:= Node
(Prim
);
3029 Op_Name
:= Find_Prim_Op
(Typl
, Name_Op_Eq
);
3032 Build_Equality_Call
(Op_Name
);
3034 -- If a type support function is present (for complex cases), use it
3036 elsif Present
(TSS
(Root_Type
(Typl
), Name_uEquality
)) then
3037 Build_Equality_Call
(TSS
(Root_Type
(Typl
), Name_uEquality
));
3039 -- Otherwise expand the component by component equality. Note that
3040 -- we never use block-bit coparisons for records, because of the
3041 -- problems with gaps. The backend will often be able to recombine
3042 -- the separate comparisons that we generate here.
3045 Remove_Side_Effects
(Lhs
);
3046 Remove_Side_Effects
(Rhs
);
3048 Expand_Record_Equality
(N
, Typl
, Lhs
, Rhs
, Bodies
));
3050 Insert_Actions
(N
, Bodies
, Suppress
=> All_Checks
);
3051 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
3055 -- If we still have an equality comparison (i.e. it was not rewritten
3056 -- in some way), then we can test if result is needed at compile time).
3058 if Nkind
(N
) = N_Op_Eq
then
3059 Rewrite_Comparison
(N
);
3063 -----------------------
3064 -- Expand_N_Op_Expon --
3065 -----------------------
3067 procedure Expand_N_Op_Expon
(N
: Node_Id
) is
3068 Loc
: constant Source_Ptr
:= Sloc
(N
);
3069 Typ
: constant Entity_Id
:= Etype
(N
);
3070 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
3071 Base
: constant Node_Id
:= Relocate_Node
(Left_Opnd
(N
));
3072 Bastyp
: constant Node_Id
:= Etype
(Base
);
3073 Exp
: constant Node_Id
:= Relocate_Node
(Right_Opnd
(N
));
3074 Exptyp
: constant Entity_Id
:= Etype
(Exp
);
3075 Ovflo
: constant Boolean := Do_Overflow_Check
(N
);
3083 Binary_Op_Validity_Checks
(N
);
3085 -- If either operand is of a private type, then we have the use of
3086 -- an intrinsic operator, and we get rid of the privateness, by using
3087 -- root types of underlying types for the actual operation. Otherwise
3088 -- the private types will cause trouble if we expand multiplications
3089 -- or shifts etc. We also do this transformation if the result type
3090 -- is different from the base type.
3092 if Is_Private_Type
(Etype
(Base
))
3094 Is_Private_Type
(Typ
)
3096 Is_Private_Type
(Exptyp
)
3098 Rtyp
/= Root_Type
(Bastyp
)
3101 Bt
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Bastyp
));
3102 Et
: constant Entity_Id
:= Root_Type
(Underlying_Type
(Exptyp
));
3106 Unchecked_Convert_To
(Typ
,
3108 Left_Opnd
=> Unchecked_Convert_To
(Bt
, Base
),
3109 Right_Opnd
=> Unchecked_Convert_To
(Et
, Exp
))));
3110 Analyze_And_Resolve
(N
, Typ
);
3115 -- At this point the exponentiation must be dynamic since the static
3116 -- case has already been folded after Resolve by Eval_Op_Expon.
3118 -- Test for case of literal right argument
3120 if Compile_Time_Known_Value
(Exp
) then
3121 Expv
:= Expr_Value
(Exp
);
3123 -- We only fold small non-negative exponents. You might think we
3124 -- could fold small negative exponents for the real case, but we
3125 -- can't because we are required to raise Constraint_Error for
3126 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
3127 -- See ACVC test C4A012B.
3129 if Expv
>= 0 and then Expv
<= 4 then
3131 -- X ** 0 = 1 (or 1.0)
3134 if Ekind
(Typ
) in Integer_Kind
then
3135 Xnode
:= Make_Integer_Literal
(Loc
, Intval
=> 1);
3137 Xnode
:= Make_Real_Literal
(Loc
, Ureal_1
);
3149 Make_Op_Multiply
(Loc
,
3150 Left_Opnd
=> Duplicate_Subexpr
(Base
),
3151 Right_Opnd
=> Duplicate_Subexpr
(Base
));
3153 -- X ** 3 = X * X * X
3157 Make_Op_Multiply
(Loc
,
3159 Make_Op_Multiply
(Loc
,
3160 Left_Opnd
=> Duplicate_Subexpr
(Base
),
3161 Right_Opnd
=> Duplicate_Subexpr
(Base
)),
3162 Right_Opnd
=> Duplicate_Subexpr
(Base
));
3165 -- En : constant base'type := base * base;
3171 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
3173 Insert_Actions
(N
, New_List
(
3174 Make_Object_Declaration
(Loc
,
3175 Defining_Identifier
=> Temp
,
3176 Constant_Present
=> True,
3177 Object_Definition
=> New_Reference_To
(Typ
, Loc
),
3179 Make_Op_Multiply
(Loc
,
3180 Left_Opnd
=> Duplicate_Subexpr
(Base
),
3181 Right_Opnd
=> Duplicate_Subexpr
(Base
)))));
3184 Make_Op_Multiply
(Loc
,
3185 Left_Opnd
=> New_Reference_To
(Temp
, Loc
),
3186 Right_Opnd
=> New_Reference_To
(Temp
, Loc
));
3190 Analyze_And_Resolve
(N
, Typ
);
3195 -- Case of (2 ** expression) appearing as an argument of an integer
3196 -- multiplication, or as the right argument of a division of a non-
3197 -- negative integer. In such cases we lave the node untouched, setting
3198 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
3199 -- of the higher level node converts it into a shift.
3201 if Nkind
(Base
) = N_Integer_Literal
3202 and then Intval
(Base
) = 2
3203 and then Is_Integer_Type
(Root_Type
(Exptyp
))
3204 and then Esize
(Root_Type
(Exptyp
)) <= Esize
(Standard_Integer
)
3205 and then Is_Unsigned_Type
(Exptyp
)
3207 and then Nkind
(Parent
(N
)) in N_Binary_Op
3210 P
: constant Node_Id
:= Parent
(N
);
3211 L
: constant Node_Id
:= Left_Opnd
(P
);
3212 R
: constant Node_Id
:= Right_Opnd
(P
);
3215 if (Nkind
(P
) = N_Op_Multiply
3217 ((Is_Integer_Type
(Etype
(L
)) and then R
= N
)
3219 (Is_Integer_Type
(Etype
(R
)) and then L
= N
))
3220 and then not Do_Overflow_Check
(P
))
3223 (Nkind
(P
) = N_Op_Divide
3224 and then Is_Integer_Type
(Etype
(L
))
3225 and then Is_Unsigned_Type
(Etype
(L
))
3227 and then not Do_Overflow_Check
(P
))
3229 Set_Is_Power_Of_2_For_Shift
(N
);
3235 -- Fall through if exponentiation must be done using a runtime routine
3238 Disallow_In_No_Run_Time_Mode
(N
);
3242 -- First deal with modular case
3244 if Is_Modular_Integer_Type
(Rtyp
) then
3246 -- Non-binary case, we call the special exponentiation routine for
3247 -- the non-binary case, converting the argument to Long_Long_Integer
3248 -- and passing the modulus value. Then the result is converted back
3249 -- to the base type.
3251 if Non_Binary_Modulus
(Rtyp
) then
3255 Make_Function_Call
(Loc
,
3256 Name
=> New_Reference_To
(RTE
(RE_Exp_Modular
), Loc
),
3257 Parameter_Associations
=> New_List
(
3258 Convert_To
(Standard_Integer
, Base
),
3259 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
)),
3262 -- Binary case, in this case, we call one of two routines, either
3263 -- the unsigned integer case, or the unsigned long long integer
3264 -- case, with a final "and" operation to do the required mod.
3267 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
3268 Ent
:= RTE
(RE_Exp_Unsigned
);
3270 Ent
:= RTE
(RE_Exp_Long_Long_Unsigned
);
3277 Make_Function_Call
(Loc
,
3278 Name
=> New_Reference_To
(Ent
, Loc
),
3279 Parameter_Associations
=> New_List
(
3280 Convert_To
(Etype
(First_Formal
(Ent
)), Base
),
3283 Make_Integer_Literal
(Loc
, Modulus
(Rtyp
) - 1))));
3287 -- Common exit point for modular type case
3289 Analyze_And_Resolve
(N
, Typ
);
3292 -- Signed integer cases
3294 elsif Rtyp
= Base_Type
(Standard_Integer
) then
3296 Rent
:= RE_Exp_Integer
;
3298 Rent
:= RE_Exn_Integer
;
3301 elsif Rtyp
= Base_Type
(Standard_Short_Integer
) then
3303 Rent
:= RE_Exp_Short_Integer
;
3305 Rent
:= RE_Exn_Short_Integer
;
3308 elsif Rtyp
= Base_Type
(Standard_Short_Short_Integer
) then
3310 Rent
:= RE_Exp_Short_Short_Integer
;
3312 Rent
:= RE_Exn_Short_Short_Integer
;
3315 elsif Rtyp
= Base_Type
(Standard_Long_Integer
) then
3317 Rent
:= RE_Exp_Long_Integer
;
3319 Rent
:= RE_Exn_Long_Integer
;
3322 elsif (Rtyp
= Base_Type
(Standard_Long_Long_Integer
)
3323 or else Rtyp
= Universal_Integer
)
3326 Rent
:= RE_Exp_Long_Long_Integer
;
3328 Rent
:= RE_Exn_Long_Long_Integer
;
3331 -- Floating-point cases
3333 elsif Rtyp
= Standard_Float
then
3335 Rent
:= RE_Exp_Float
;
3337 Rent
:= RE_Exn_Float
;
3340 elsif Rtyp
= Standard_Short_Float
then
3342 Rent
:= RE_Exp_Short_Float
;
3344 Rent
:= RE_Exn_Short_Float
;
3347 elsif Rtyp
= Standard_Long_Float
then
3349 Rent
:= RE_Exp_Long_Float
;
3351 Rent
:= RE_Exn_Long_Float
;
3356 (Rtyp
= Standard_Long_Long_Float
or else Rtyp
= Universal_Real
);
3359 Rent
:= RE_Exp_Long_Long_Float
;
3361 Rent
:= RE_Exn_Long_Long_Float
;
3365 -- Common processing for integer cases and floating-point cases.
3366 -- If we are in the base type, we can call runtime routine directly
3369 and then Rtyp
/= Universal_Integer
3370 and then Rtyp
/= Universal_Real
3373 Make_Function_Call
(Loc
,
3374 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
3375 Parameter_Associations
=> New_List
(Base
, Exp
)));
3377 -- Otherwise we have to introduce conversions (conversions are also
3378 -- required in the universal cases, since the runtime routine was
3379 -- typed using the largest integer or real case.
3384 Make_Function_Call
(Loc
,
3385 Name
=> New_Reference_To
(RTE
(Rent
), Loc
),
3386 Parameter_Associations
=> New_List
(
3387 Convert_To
(Rtyp
, Base
),
3391 Analyze_And_Resolve
(N
, Typ
);
3394 end Expand_N_Op_Expon
;
3396 --------------------
3397 -- Expand_N_Op_Ge --
3398 --------------------
3400 procedure Expand_N_Op_Ge
(N
: Node_Id
) is
3401 Typ
: constant Entity_Id
:= Etype
(N
);
3402 Op1
: constant Node_Id
:= Left_Opnd
(N
);
3403 Op2
: constant Node_Id
:= Right_Opnd
(N
);
3404 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
3407 Binary_Op_Validity_Checks
(N
);
3409 if Vax_Float
(Typ1
) then
3410 Expand_Vax_Comparison
(N
);
3413 elsif Is_Array_Type
(Typ1
) then
3414 Expand_Array_Comparison
(N
);
3418 if Is_Boolean_Type
(Typ1
) then
3419 Adjust_Condition
(Op1
);
3420 Adjust_Condition
(Op2
);
3421 Set_Etype
(N
, Standard_Boolean
);
3422 Adjust_Result_Type
(N
, Typ
);
3425 Rewrite_Comparison
(N
);
3428 --------------------
3429 -- Expand_N_Op_Gt --
3430 --------------------
3432 procedure Expand_N_Op_Gt
(N
: Node_Id
) is
3433 Typ
: constant Entity_Id
:= Etype
(N
);
3434 Op1
: constant Node_Id
:= Left_Opnd
(N
);
3435 Op2
: constant Node_Id
:= Right_Opnd
(N
);
3436 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
3439 Binary_Op_Validity_Checks
(N
);
3441 if Vax_Float
(Typ1
) then
3442 Expand_Vax_Comparison
(N
);
3445 elsif Is_Array_Type
(Typ1
) then
3446 Expand_Array_Comparison
(N
);
3450 if Is_Boolean_Type
(Typ1
) then
3451 Adjust_Condition
(Op1
);
3452 Adjust_Condition
(Op2
);
3453 Set_Etype
(N
, Standard_Boolean
);
3454 Adjust_Result_Type
(N
, Typ
);
3457 Rewrite_Comparison
(N
);
3460 --------------------
3461 -- Expand_N_Op_Le --
3462 --------------------
3464 procedure Expand_N_Op_Le
(N
: Node_Id
) is
3465 Typ
: constant Entity_Id
:= Etype
(N
);
3466 Op1
: constant Node_Id
:= Left_Opnd
(N
);
3467 Op2
: constant Node_Id
:= Right_Opnd
(N
);
3468 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
3471 Binary_Op_Validity_Checks
(N
);
3473 if Vax_Float
(Typ1
) then
3474 Expand_Vax_Comparison
(N
);
3477 elsif Is_Array_Type
(Typ1
) then
3478 Expand_Array_Comparison
(N
);
3482 if Is_Boolean_Type
(Typ1
) then
3483 Adjust_Condition
(Op1
);
3484 Adjust_Condition
(Op2
);
3485 Set_Etype
(N
, Standard_Boolean
);
3486 Adjust_Result_Type
(N
, Typ
);
3489 Rewrite_Comparison
(N
);
3492 --------------------
3493 -- Expand_N_Op_Lt --
3494 --------------------
3496 procedure Expand_N_Op_Lt
(N
: Node_Id
) is
3497 Typ
: constant Entity_Id
:= Etype
(N
);
3498 Op1
: constant Node_Id
:= Left_Opnd
(N
);
3499 Op2
: constant Node_Id
:= Right_Opnd
(N
);
3500 Typ1
: constant Entity_Id
:= Base_Type
(Etype
(Op1
));
3503 Binary_Op_Validity_Checks
(N
);
3505 if Vax_Float
(Typ1
) then
3506 Expand_Vax_Comparison
(N
);
3509 elsif Is_Array_Type
(Typ1
) then
3510 Expand_Array_Comparison
(N
);
3514 if Is_Boolean_Type
(Typ1
) then
3515 Adjust_Condition
(Op1
);
3516 Adjust_Condition
(Op2
);
3517 Set_Etype
(N
, Standard_Boolean
);
3518 Adjust_Result_Type
(N
, Typ
);
3521 Rewrite_Comparison
(N
);
3524 -----------------------
3525 -- Expand_N_Op_Minus --
3526 -----------------------
3528 procedure Expand_N_Op_Minus
(N
: Node_Id
) is
3529 Loc
: constant Source_Ptr
:= Sloc
(N
);
3530 Typ
: constant Entity_Id
:= Etype
(N
);
3533 Unary_Op_Validity_Checks
(N
);
3535 if not Backend_Overflow_Checks_On_Target
3536 and then Is_Signed_Integer_Type
(Etype
(N
))
3537 and then Do_Overflow_Check
(N
)
3539 -- Software overflow checking expands -expr into (0 - expr)
3542 Make_Op_Subtract
(Loc
,
3543 Left_Opnd
=> Make_Integer_Literal
(Loc
, 0),
3544 Right_Opnd
=> Right_Opnd
(N
)));
3546 Analyze_And_Resolve
(N
, Typ
);
3548 -- Vax floating-point types case
3550 elsif Vax_Float
(Etype
(N
)) then
3551 Expand_Vax_Arith
(N
);
3553 end Expand_N_Op_Minus
;
3555 ---------------------
3556 -- Expand_N_Op_Mod --
3557 ---------------------
3559 procedure Expand_N_Op_Mod
(N
: Node_Id
) is
3560 Loc
: constant Source_Ptr
:= Sloc
(N
);
3561 T
: constant Entity_Id
:= Etype
(N
);
3562 Left
: constant Node_Id
:= Left_Opnd
(N
);
3563 Right
: constant Node_Id
:= Right_Opnd
(N
);
3564 DOC
: constant Boolean := Do_Overflow_Check
(N
);
3565 DDC
: constant Boolean := Do_Division_Check
(N
);
3576 Binary_Op_Validity_Checks
(N
);
3578 Determine_Range
(Right
, ROK
, Rlo
, Rhi
);
3579 Determine_Range
(Left
, LOK
, Llo
, Lhi
);
3581 -- Convert mod to rem if operands are known non-negative. We do this
3582 -- since it is quite likely that this will improve the quality of code,
3583 -- (the operation now corresponds to the hardware remainder), and it
3584 -- does not seem likely that it could be harmful.
3586 if LOK
and then Llo
>= 0
3588 ROK
and then Rlo
>= 0
3591 Make_Op_Rem
(Sloc
(N
),
3592 Left_Opnd
=> Left_Opnd
(N
),
3593 Right_Opnd
=> Right_Opnd
(N
)));
3595 -- Instead of reanalyzing the node we do the analysis manually.
3596 -- This avoids anomalies when the replacement is done in an
3597 -- instance and is epsilon more efficient.
3599 Set_Entity
(N
, Standard_Entity
(S_Op_Rem
));
3601 Set_Do_Overflow_Check
(N
, DOC
);
3602 Set_Do_Division_Check
(N
, DDC
);
3603 Expand_N_Op_Rem
(N
);
3606 -- Otherwise, normal mod processing
3609 if Is_Integer_Type
(Etype
(N
)) then
3610 Apply_Divide_Check
(N
);
3613 -- Deal with annoying case of largest negative number remainder
3614 -- minus one. Gigi does not handle this case correctly, because
3615 -- it generates a divide instruction which may trap in this case.
3617 -- In fact the check is quite easy, if the right operand is -1,
3618 -- then the mod value is always 0, and we can just ignore the
3619 -- left operand completely in this case.
3621 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Etype
(Left
))));
3623 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
3625 ((not LOK
) or else (Llo
= LLB
))
3628 Make_Conditional_Expression
(Loc
,
3629 Expressions
=> New_List
(
3631 Left_Opnd
=> Duplicate_Subexpr
(Right
),
3633 Make_Integer_Literal
(Loc
, -1)),
3634 Make_Integer_Literal
(Loc
, Uint_0
),
3635 Relocate_Node
(N
))));
3637 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
3638 Analyze_And_Resolve
(N
, T
);
3641 end Expand_N_Op_Mod
;
3643 --------------------------
3644 -- Expand_N_Op_Multiply --
3645 --------------------------
3647 procedure Expand_N_Op_Multiply
(N
: Node_Id
) is
3648 Loc
: constant Source_Ptr
:= Sloc
(N
);
3649 Lop
: constant Node_Id
:= Left_Opnd
(N
);
3650 Rop
: constant Node_Id
:= Right_Opnd
(N
);
3651 Ltyp
: constant Entity_Id
:= Etype
(Lop
);
3652 Rtyp
: constant Entity_Id
:= Etype
(Rop
);
3653 Typ
: Entity_Id
:= Etype
(N
);
3656 Binary_Op_Validity_Checks
(N
);
3658 -- Special optimizations for integer types
3660 if Is_Integer_Type
(Typ
) then
3662 -- N * 0 = 0 * N = 0 for integer types
3664 if (Compile_Time_Known_Value
(Right_Opnd
(N
))
3665 and then Expr_Value
(Right_Opnd
(N
)) = Uint_0
)
3667 (Compile_Time_Known_Value
(Left_Opnd
(N
))
3668 and then Expr_Value
(Left_Opnd
(N
)) = Uint_0
)
3670 Rewrite
(N
, Make_Integer_Literal
(Loc
, Uint_0
));
3671 Analyze_And_Resolve
(N
, Typ
);
3675 -- N * 1 = 1 * N = N for integer types
3677 if Compile_Time_Known_Value
(Right_Opnd
(N
))
3678 and then Expr_Value
(Right_Opnd
(N
)) = Uint_1
3680 Rewrite
(N
, Left_Opnd
(N
));
3683 elsif Compile_Time_Known_Value
(Left_Opnd
(N
))
3684 and then Expr_Value
(Left_Opnd
(N
)) = Uint_1
3686 Rewrite
(N
, Right_Opnd
(N
));
3691 -- Deal with VAX float case
3693 if Vax_Float
(Typ
) then
3694 Expand_Vax_Arith
(N
);
3698 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
3699 -- Is_Power_Of_2_For_Shift is set means that we know that our left
3700 -- operand is an integer, as required for this to work.
3702 if Nkind
(Rop
) = N_Op_Expon
3703 and then Is_Power_Of_2_For_Shift
(Rop
)
3705 if Nkind
(Lop
) = N_Op_Expon
3706 and then Is_Power_Of_2_For_Shift
(Lop
)
3709 -- convert 2 ** A * 2 ** B into 2 ** (A + B)
3713 Left_Opnd
=> Make_Integer_Literal
(Loc
, 2),
3716 Left_Opnd
=> Right_Opnd
(Lop
),
3717 Right_Opnd
=> Right_Opnd
(Rop
))));
3718 Analyze_And_Resolve
(N
, Typ
);
3723 Make_Op_Shift_Left
(Loc
,
3726 Convert_To
(Standard_Natural
, Right_Opnd
(Rop
))));
3727 Analyze_And_Resolve
(N
, Typ
);
3731 -- Same processing for the operands the other way round
3733 elsif Nkind
(Lop
) = N_Op_Expon
3734 and then Is_Power_Of_2_For_Shift
(Lop
)
3737 Make_Op_Shift_Left
(Loc
,
3740 Convert_To
(Standard_Natural
, Right_Opnd
(Lop
))));
3741 Analyze_And_Resolve
(N
, Typ
);
3745 -- Do required fixup of universal fixed operation
3747 if Typ
= Universal_Fixed
then
3748 Fixup_Universal_Fixed_Operation
(N
);
3752 -- Multiplications with fixed-point results
3754 if Is_Fixed_Point_Type
(Typ
) then
3756 -- No special processing if Treat_Fixed_As_Integer is set,
3757 -- since from a semantic point of view such operations are
3758 -- simply integer operations and will be treated that way.
3760 if not Treat_Fixed_As_Integer
(N
) then
3762 -- Case of fixed * integer => fixed
3764 if Is_Integer_Type
(Rtyp
) then
3765 Expand_Multiply_Fixed_By_Integer_Giving_Fixed
(N
);
3767 -- Case of integer * fixed => fixed
3769 elsif Is_Integer_Type
(Ltyp
) then
3770 Expand_Multiply_Integer_By_Fixed_Giving_Fixed
(N
);
3772 -- Case of fixed * fixed => fixed
3775 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed
(N
);
3779 -- Other cases of multiplication of fixed-point operands. Again
3780 -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
3782 elsif (Is_Fixed_Point_Type
(Ltyp
) or else Is_Fixed_Point_Type
(Rtyp
))
3783 and then not Treat_Fixed_As_Integer
(N
)
3785 if Is_Integer_Type
(Typ
) then
3786 Expand_Multiply_Fixed_By_Fixed_Giving_Integer
(N
);
3788 pragma Assert
(Is_Floating_Point_Type
(Typ
));
3789 Expand_Multiply_Fixed_By_Fixed_Giving_Float
(N
);
3792 -- Mixed-mode operations can appear in a non-static universal
3793 -- context, in which case the integer argument must be converted
3796 elsif Typ
= Universal_Real
3797 and then Is_Integer_Type
(Rtyp
)
3799 Rewrite
(Rop
, Convert_To
(Universal_Real
, Relocate_Node
(Rop
)));
3801 Analyze_And_Resolve
(Rop
, Universal_Real
);
3803 elsif Typ
= Universal_Real
3804 and then Is_Integer_Type
(Ltyp
)
3806 Rewrite
(Lop
, Convert_To
(Universal_Real
, Relocate_Node
(Lop
)));
3808 Analyze_And_Resolve
(Lop
, Universal_Real
);
3810 -- Non-fixed point cases, check software overflow checking required
3812 elsif Is_Signed_Integer_Type
(Etype
(N
)) then
3813 Apply_Arithmetic_Overflow_Check
(N
);
3815 end Expand_N_Op_Multiply
;
3817 --------------------
3818 -- Expand_N_Op_Ne --
3819 --------------------
3821 -- Rewrite node as the negation of an equality operation, and reanalyze.
3822 -- The equality to be used is defined in the same scope and has the same
3823 -- signature. It must be set explicitly because in an instance it may not
3824 -- have the same visibility as in the generic unit.
3826 procedure Expand_N_Op_Ne
(N
: Node_Id
) is
3827 Loc
: constant Source_Ptr
:= Sloc
(N
);
3829 Ne
: constant Entity_Id
:= Entity
(N
);
3832 Binary_Op_Validity_Checks
(N
);
3838 Left_Opnd
=> Left_Opnd
(N
),
3839 Right_Opnd
=> Right_Opnd
(N
)));
3840 Set_Paren_Count
(Right_Opnd
(Neg
), 1);
3842 if Scope
(Ne
) /= Standard_Standard
then
3843 Set_Entity
(Right_Opnd
(Neg
), Corresponding_Equality
(Ne
));
3847 Analyze_And_Resolve
(N
, Standard_Boolean
);
3850 ---------------------
3851 -- Expand_N_Op_Not --
3852 ---------------------
3854 -- If the argument is other than a Boolean array type, there is no
3855 -- special expansion required.
3857 -- For the packed case, we call the special routine in Exp_Pakd, except
3858 -- that if the component size is greater than one, we use the standard
3859 -- routine generating a gruesome loop (it is so peculiar to have packed
3860 -- arrays with non-standard Boolean representations anyway, so it does
3861 -- not matter that we do not handle this case efficiently).
3863 -- For the unpacked case (and for the special packed case where we have
3864 -- non standard Booleans, as discussed above), we generate and insert
3865 -- into the tree the following function definition:
3867 -- function Nnnn (A : arr) is
3870 -- for J in a'range loop
3871 -- B (J) := not A (J);
3876 -- Here arr is the actual subtype of the parameter (and hence always
3877 -- constrained). Then we replace the not with a call to this function.
3879 procedure Expand_N_Op_Not
(N
: Node_Id
) is
3880 Loc
: constant Source_Ptr
:= Sloc
(N
);
3881 Typ
: constant Entity_Id
:= Etype
(N
);
3890 Func_Name
: Entity_Id
;
3891 Loop_Statement
: Node_Id
;
3894 Unary_Op_Validity_Checks
(N
);
3896 -- For boolean operand, deal with non-standard booleans
3898 if Is_Boolean_Type
(Typ
) then
3899 Adjust_Condition
(Right_Opnd
(N
));
3900 Set_Etype
(N
, Standard_Boolean
);
3901 Adjust_Result_Type
(N
, Typ
);
3905 -- Only array types need any other processing
3907 if not Is_Array_Type
(Typ
) then
3911 -- Case of array operand. If bit packed, handle it in Exp_Pakd
3913 if Is_Bit_Packed_Array
(Typ
) and then Component_Size
(Typ
) = 1 then
3914 Expand_Packed_Not
(N
);
3918 -- Case of array operand which is not bit-packed
3920 Opnd
:= Relocate_Node
(Right_Opnd
(N
));
3921 Convert_To_Actual_Subtype
(Opnd
);
3922 Arr
:= Etype
(Opnd
);
3923 Ensure_Defined
(Arr
, N
);
3925 A
:= Make_Defining_Identifier
(Loc
, Name_uA
);
3926 B
:= Make_Defining_Identifier
(Loc
, Name_uB
);
3927 J
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
3930 Make_Indexed_Component
(Loc
,
3931 Prefix
=> New_Reference_To
(A
, Loc
),
3932 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
3935 Make_Indexed_Component
(Loc
,
3936 Prefix
=> New_Reference_To
(B
, Loc
),
3937 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
3940 Make_Implicit_Loop_Statement
(N
,
3941 Identifier
=> Empty
,
3944 Make_Iteration_Scheme
(Loc
,
3945 Loop_Parameter_Specification
=>
3946 Make_Loop_Parameter_Specification
(Loc
,
3947 Defining_Identifier
=> J
,
3948 Discrete_Subtype_Definition
=>
3949 Make_Attribute_Reference
(Loc
,
3950 Prefix
=> Make_Identifier
(Loc
, Chars
(A
)),
3951 Attribute_Name
=> Name_Range
))),
3953 Statements
=> New_List
(
3954 Make_Assignment_Statement
(Loc
,
3956 Expression
=> Make_Op_Not
(Loc
, A_J
))));
3958 Func_Name
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('N'));
3959 Set_Is_Inlined
(Func_Name
);
3962 Make_Subprogram_Body
(Loc
,
3964 Make_Function_Specification
(Loc
,
3965 Defining_Unit_Name
=> Func_Name
,
3966 Parameter_Specifications
=> New_List
(
3967 Make_Parameter_Specification
(Loc
,
3968 Defining_Identifier
=> A
,
3969 Parameter_Type
=> New_Reference_To
(Typ
, Loc
))),
3970 Subtype_Mark
=> New_Reference_To
(Typ
, Loc
)),
3972 Declarations
=> New_List
(
3973 Make_Object_Declaration
(Loc
,
3974 Defining_Identifier
=> B
,
3975 Object_Definition
=> New_Reference_To
(Arr
, Loc
))),
3977 Handled_Statement_Sequence
=>
3978 Make_Handled_Sequence_Of_Statements
(Loc
,
3979 Statements
=> New_List
(
3981 Make_Return_Statement
(Loc
,
3983 Make_Identifier
(Loc
, Chars
(B
)))))));
3986 Make_Function_Call
(Loc
,
3987 Name
=> New_Reference_To
(Func_Name
, Loc
),
3988 Parameter_Associations
=> New_List
(Opnd
)));
3990 Analyze_And_Resolve
(N
, Typ
);
3991 end Expand_N_Op_Not
;
3993 --------------------
3994 -- Expand_N_Op_Or --
3995 --------------------
3997 procedure Expand_N_Op_Or
(N
: Node_Id
) is
3998 Typ
: constant Entity_Id
:= Etype
(N
);
4001 Binary_Op_Validity_Checks
(N
);
4003 if Is_Array_Type
(Etype
(N
)) then
4004 Expand_Boolean_Operator
(N
);
4006 elsif Is_Boolean_Type
(Etype
(N
)) then
4007 Adjust_Condition
(Left_Opnd
(N
));
4008 Adjust_Condition
(Right_Opnd
(N
));
4009 Set_Etype
(N
, Standard_Boolean
);
4010 Adjust_Result_Type
(N
, Typ
);
4014 ----------------------
4015 -- Expand_N_Op_Plus --
4016 ----------------------
4018 procedure Expand_N_Op_Plus
(N
: Node_Id
) is
4020 Unary_Op_Validity_Checks
(N
);
4021 end Expand_N_Op_Plus
;
4023 ---------------------
4024 -- Expand_N_Op_Rem --
4025 ---------------------
4027 procedure Expand_N_Op_Rem
(N
: Node_Id
) is
4028 Loc
: constant Source_Ptr
:= Sloc
(N
);
4030 Left
: constant Node_Id
:= Left_Opnd
(N
);
4031 Right
: constant Node_Id
:= Right_Opnd
(N
);
4043 Binary_Op_Validity_Checks
(N
);
4045 if Is_Integer_Type
(Etype
(N
)) then
4046 Apply_Divide_Check
(N
);
4049 -- Deal with annoying case of largest negative number remainder
4050 -- minus one. Gigi does not handle this case correctly, because
4051 -- it generates a divide instruction which may trap in this case.
4053 -- In fact the check is quite easy, if the right operand is -1,
4054 -- then the remainder is always 0, and we can just ignore the
4055 -- left operand completely in this case.
4057 Determine_Range
(Right
, ROK
, Rlo
, Rhi
);
4058 Determine_Range
(Left
, LOK
, Llo
, Lhi
);
4059 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Etype
(Left
))));
4062 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
4064 ((not LOK
) or else (Llo
= LLB
))
4067 Make_Conditional_Expression
(Loc
,
4068 Expressions
=> New_List
(
4070 Left_Opnd
=> Duplicate_Subexpr
(Right
),
4072 Make_Integer_Literal
(Loc
, -1)),
4074 Make_Integer_Literal
(Loc
, Uint_0
),
4076 Relocate_Node
(N
))));
4078 Set_Analyzed
(Next
(Next
(First
(Expressions
(N
)))));
4079 Analyze_And_Resolve
(N
, Typ
);
4081 end Expand_N_Op_Rem
;
4083 -----------------------------
4084 -- Expand_N_Op_Rotate_Left --
4085 -----------------------------
4087 procedure Expand_N_Op_Rotate_Left
(N
: Node_Id
) is
4089 Binary_Op_Validity_Checks
(N
);
4090 end Expand_N_Op_Rotate_Left
;
4092 ------------------------------
4093 -- Expand_N_Op_Rotate_Right --
4094 ------------------------------
4096 procedure Expand_N_Op_Rotate_Right
(N
: Node_Id
) is
4098 Binary_Op_Validity_Checks
(N
);
4099 end Expand_N_Op_Rotate_Right
;
4101 ----------------------------
4102 -- Expand_N_Op_Shift_Left --
4103 ----------------------------
4105 procedure Expand_N_Op_Shift_Left
(N
: Node_Id
) is
4107 Binary_Op_Validity_Checks
(N
);
4108 end Expand_N_Op_Shift_Left
;
4110 -----------------------------
4111 -- Expand_N_Op_Shift_Right --
4112 -----------------------------
4114 procedure Expand_N_Op_Shift_Right
(N
: Node_Id
) is
4116 Binary_Op_Validity_Checks
(N
);
4117 end Expand_N_Op_Shift_Right
;
4119 ----------------------------------------
4120 -- Expand_N_Op_Shift_Right_Arithmetic --
4121 ----------------------------------------
4123 procedure Expand_N_Op_Shift_Right_Arithmetic
(N
: Node_Id
) is
4125 Binary_Op_Validity_Checks
(N
);
4126 end Expand_N_Op_Shift_Right_Arithmetic
;
4128 --------------------------
4129 -- Expand_N_Op_Subtract --
4130 --------------------------
4132 procedure Expand_N_Op_Subtract
(N
: Node_Id
) is
4133 Typ
: constant Entity_Id
:= Etype
(N
);
4136 Binary_Op_Validity_Checks
(N
);
4138 -- N - 0 = N for integer types
4140 if Is_Integer_Type
(Typ
)
4141 and then Compile_Time_Known_Value
(Right_Opnd
(N
))
4142 and then Expr_Value
(Right_Opnd
(N
)) = 0
4144 Rewrite
(N
, Left_Opnd
(N
));
4148 -- Arithemtic overflow checks for signed integer/fixed point types
4150 if Is_Signed_Integer_Type
(Typ
)
4151 or else Is_Fixed_Point_Type
(Typ
)
4153 Apply_Arithmetic_Overflow_Check
(N
);
4155 -- Vax floating-point types case
4157 elsif Vax_Float
(Typ
) then
4158 Expand_Vax_Arith
(N
);
4160 end Expand_N_Op_Subtract
;
4162 ---------------------
4163 -- Expand_N_Op_Xor --
4164 ---------------------
4166 procedure Expand_N_Op_Xor
(N
: Node_Id
) is
4167 Typ
: constant Entity_Id
:= Etype
(N
);
4170 Binary_Op_Validity_Checks
(N
);
4172 if Is_Array_Type
(Etype
(N
)) then
4173 Expand_Boolean_Operator
(N
);
4175 elsif Is_Boolean_Type
(Etype
(N
)) then
4176 Adjust_Condition
(Left_Opnd
(N
));
4177 Adjust_Condition
(Right_Opnd
(N
));
4178 Set_Etype
(N
, Standard_Boolean
);
4179 Adjust_Result_Type
(N
, Typ
);
4181 end Expand_N_Op_Xor
;
4183 ----------------------
4184 -- Expand_N_Or_Else --
4185 ----------------------
4187 -- Expand into conditional expression if Actions present, and also
4188 -- deal with optimizing case of arguments being True or False.
4190 procedure Expand_N_Or_Else
(N
: Node_Id
) is
4191 Loc
: constant Source_Ptr
:= Sloc
(N
);
4192 Typ
: constant Entity_Id
:= Etype
(N
);
4193 Left
: constant Node_Id
:= Left_Opnd
(N
);
4194 Right
: constant Node_Id
:= Right_Opnd
(N
);
4198 -- Deal with non-standard booleans
4200 if Is_Boolean_Type
(Typ
) then
4201 Adjust_Condition
(Left
);
4202 Adjust_Condition
(Right
);
4203 Set_Etype
(N
, Standard_Boolean
);
4205 -- Check for cases of left argument is True or False
4207 elsif Nkind
(Left
) = N_Identifier
then
4209 -- If left argument is False, change (False or else Right) to Right.
4210 -- Any actions associated with Right will be executed unconditionally
4211 -- and can thus be inserted into the tree unconditionally.
4213 if Entity
(Left
) = Standard_False
then
4214 if Present
(Actions
(N
)) then
4215 Insert_Actions
(N
, Actions
(N
));
4219 Adjust_Result_Type
(N
, Typ
);
4222 -- If left argument is True, change (True and then Right) to
4223 -- True. In this case we can forget the actions associated with
4224 -- Right, since they will never be executed.
4226 elsif Entity
(Left
) = Standard_True
then
4227 Kill_Dead_Code
(Right
);
4228 Kill_Dead_Code
(Actions
(N
));
4229 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
4230 Adjust_Result_Type
(N
, Typ
);
4235 -- If Actions are present, we expand
4237 -- left or else right
4241 -- if left then True else right end
4243 -- with the actions becoming the Else_Actions of the conditional
4244 -- expression. This conditional expression is then further expanded
4245 -- (and will eventually disappear)
4247 if Present
(Actions
(N
)) then
4248 Actlist
:= Actions
(N
);
4250 Make_Conditional_Expression
(Loc
,
4251 Expressions
=> New_List
(
4253 New_Occurrence_Of
(Standard_True
, Loc
),
4256 Set_Else_Actions
(N
, Actlist
);
4257 Analyze_And_Resolve
(N
, Standard_Boolean
);
4258 Adjust_Result_Type
(N
, Typ
);
4262 -- No actions present, check for cases of right argument True/False
4264 if Nkind
(Right
) = N_Identifier
then
4266 -- Change (Left or else False) to Left. Note that we know there
4267 -- are no actions associated with the True operand, since we
4268 -- just checked for this case above.
4270 if Entity
(Right
) = Standard_False
then
4273 -- Change (Left or else True) to True, making sure to preserve
4274 -- any side effects associated with the Left operand.
4276 elsif Entity
(Right
) = Standard_True
then
4277 Remove_Side_Effects
(Left
);
4279 (N
, New_Occurrence_Of
(Standard_True
, Loc
));
4283 Adjust_Result_Type
(N
, Typ
);
4284 end Expand_N_Or_Else
;
4286 -----------------------------------
4287 -- Expand_N_Qualified_Expression --
4288 -----------------------------------
4290 procedure Expand_N_Qualified_Expression
(N
: Node_Id
) is
4291 Operand
: constant Node_Id
:= Expression
(N
);
4292 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
4295 Apply_Constraint_Check
(Operand
, Target_Type
, No_Sliding
=> True);
4296 end Expand_N_Qualified_Expression
;
4298 ---------------------------------
4299 -- Expand_N_Selected_Component --
4300 ---------------------------------
4302 -- If the selector is a discriminant of a concurrent object, rewrite the
4303 -- prefix to denote the corresponding record type.
4305 procedure Expand_N_Selected_Component
(N
: Node_Id
) is
4306 Loc
: constant Source_Ptr
:= Sloc
(N
);
4307 Par
: constant Node_Id
:= Parent
(N
);
4308 P
: constant Node_Id
:= Prefix
(N
);
4310 Ptyp
: Entity_Id
:= Underlying_Type
(Etype
(P
));
4313 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean;
4314 -- Gigi needs a temporary for prefixes that depend on a discriminant,
4315 -- unless the context of an assignment can provide size information.
4317 function In_Left_Hand_Side
(Comp
: Node_Id
) return Boolean is
4320 (Nkind
(Parent
(Comp
)) = N_Assignment_Statement
4321 and then Comp
= Name
(Parent
(Comp
)))
4323 (Present
(Parent
(Comp
))
4324 and then Nkind
(Parent
(Comp
)) in N_Subexpr
4325 and then In_Left_Hand_Side
(Parent
(Comp
)));
4326 end In_Left_Hand_Side
;
4329 if Do_Discriminant_Check
(N
) then
4331 -- Present the discrminant checking function to the backend,
4332 -- so that it can inline the call to the function.
4335 (Discriminant_Checking_Func
4336 (Original_Record_Component
(Entity
(Selector_Name
(N
)))));
4339 -- Insert explicit dereference call for the checked storage pool case
4341 if Is_Access_Type
(Ptyp
) then
4342 Insert_Dereference_Action
(P
);
4346 -- Gigi cannot handle unchecked conversions that are the prefix of
4347 -- a selected component with discriminants. This must be checked
4348 -- during expansion, because during analysis the type of the selector
4349 -- is not known at the point the prefix is analyzed. If the conversion
4350 -- is the target of an assignment, we cannot force the evaluation, of
4353 if Nkind
(Prefix
(N
)) = N_Unchecked_Type_Conversion
4354 and then Has_Discriminants
(Etype
(N
))
4355 and then not In_Left_Hand_Side
(N
)
4357 Force_Evaluation
(Prefix
(N
));
4360 -- Remaining processing applies only if selector is a discriminant
4362 if Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
then
4364 -- If the selector is a discriminant of a constrained record type,
4365 -- rewrite the expression with the actual value of the discriminant.
4366 -- Don't do this on the left hand of an assignment statement (this
4367 -- happens in generated code, and means we really want to set it!)
4368 -- We also only do this optimization for discrete types, and not
4369 -- for access types (access discriminants get us into trouble!)
4370 -- We also do not expand the prefix of an attribute or the
4371 -- operand of an object renaming declaration.
4373 if Is_Record_Type
(Ptyp
)
4374 and then Has_Discriminants
(Ptyp
)
4375 and then Is_Constrained
(Ptyp
)
4376 and then Is_Discrete_Type
(Etype
(N
))
4377 and then (Nkind
(Par
) /= N_Assignment_Statement
4378 or else Name
(Par
) /= N
)
4379 and then (Nkind
(Par
) /= N_Attribute_Reference
4380 or else Prefix
(Par
) /= N
)
4381 and then not Is_Renamed_Object
(N
)
4388 D
:= First_Discriminant
(Ptyp
);
4389 E
:= First_Elmt
(Discriminant_Constraint
(Ptyp
));
4391 while Present
(E
) loop
4392 if D
= Entity
(Selector_Name
(N
)) then
4394 -- In the context of a case statement, the expression
4395 -- may have the base type of the discriminant, and we
4396 -- need to preserve the constraint to avoid spurious
4397 -- errors on missing cases.
4399 if Nkind
(Parent
(N
)) = N_Case_Statement
4400 and then Etype
(Node
(E
)) /= Etype
(D
)
4403 Make_Qualified_Expression
(Loc
,
4404 Subtype_Mark
=> New_Occurrence_Of
(Etype
(D
), Loc
),
4405 Expression
=> New_Copy
(Node
(E
))));
4408 Rewrite
(N
, New_Copy
(Node
(E
)));
4411 Set_Is_Static_Expression
(N
, False);
4416 Next_Discriminant
(D
);
4419 -- Note: the above loop should always terminate, but if
4420 -- it does not, we just missed an optimization due to
4421 -- some glitch (perhaps a previous error), so ignore!
4425 -- The only remaining processing is in the case of a discriminant of
4426 -- a concurrent object, where we rewrite the prefix to denote the
4427 -- corresponding record type. If the type is derived and has renamed
4428 -- discriminants, use corresponding discriminant, which is the one
4429 -- that appears in the corresponding record.
4431 if not Is_Concurrent_Type
(Ptyp
) then
4435 Disc
:= Entity
(Selector_Name
(N
));
4437 if Is_Derived_Type
(Ptyp
)
4438 and then Present
(Corresponding_Discriminant
(Disc
))
4440 Disc
:= Corresponding_Discriminant
(Disc
);
4444 Make_Selected_Component
(Loc
,
4446 Unchecked_Convert_To
(Corresponding_Record_Type
(Ptyp
),
4448 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc
)));
4454 end Expand_N_Selected_Component
;
4456 --------------------
4457 -- Expand_N_Slice --
4458 --------------------
4460 procedure Expand_N_Slice
(N
: Node_Id
) is
4461 Loc
: constant Source_Ptr
:= Sloc
(N
);
4462 Typ
: constant Entity_Id
:= Etype
(N
);
4463 Pfx
: constant Node_Id
:= Prefix
(N
);
4464 Ptp
: Entity_Id
:= Etype
(Pfx
);
4469 -- Special handling for access types
4471 if Is_Access_Type
(Ptp
) then
4473 -- Check for explicit dereference required for checked pool
4475 Insert_Dereference_Action
(Pfx
);
4477 -- If we have an access to a packed array type, then put in an
4478 -- explicit dereference. We do this in case the slice must be
4479 -- expanded, and we want to make sure we get an access check.
4481 Ptp
:= Designated_Type
(Ptp
);
4483 if Is_Array_Type
(Ptp
) and then Is_Packed
(Ptp
) then
4485 Make_Explicit_Dereference
(Sloc
(N
),
4486 Prefix
=> Relocate_Node
(Pfx
)));
4488 Analyze_And_Resolve
(Pfx
, Ptp
);
4490 -- The prefix will now carry the Access_Check flag for the back
4491 -- end, remove it from slice itself.
4493 Set_Do_Access_Check
(N
, False);
4497 -- Range checks are potentially also needed for cases involving
4498 -- a slice indexed by a subtype indication, but Do_Range_Check
4499 -- can currently only be set for expressions ???
4501 if not Index_Checks_Suppressed
(Ptp
)
4502 and then (not Is_Entity_Name
(Pfx
)
4503 or else not Index_Checks_Suppressed
(Entity
(Pfx
)))
4504 and then Nkind
(Discrete_Range
(N
)) /= N_Subtype_Indication
4506 Enable_Range_Check
(Discrete_Range
(N
));
4509 -- The remaining case to be handled is packed slices. We can leave
4510 -- packed slices as they are in the following situations:
4512 -- 1. Right or left side of an assignment (we can handle this
4513 -- situation correctly in the assignment statement expansion).
4515 -- 2. Prefix of indexed component (the slide is optimized away
4516 -- in this case, see the start of Expand_N_Slice.
4518 -- 3. Object renaming declaration, since we want the name of
4519 -- the slice, not the value.
4521 -- 4. Argument to procedure call, since copy-in/copy-out handling
4522 -- may be required, and this is handled in the expansion of
4525 -- 5. Prefix of an address attribute (this is an error which
4526 -- is caught elsewhere, and the expansion would intefere
4527 -- with generating the error message).
4530 and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
4531 and then Nkind
(Parent
(N
)) /= N_Indexed_Component
4532 and then not Is_Renamed_Object
(N
)
4533 and then Nkind
(Parent
(N
)) /= N_Procedure_Call_Statement
4534 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
4536 Attribute_Name
(Parent
(N
)) /= Name_Address
)
4539 Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
4542 Make_Object_Declaration
(Loc
,
4543 Defining_Identifier
=> Ent
,
4544 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
4546 Set_No_Initialization
(Decl
);
4548 Insert_Actions
(N
, New_List
(
4550 Make_Assignment_Statement
(Loc
,
4551 Name
=> New_Occurrence_Of
(Ent
, Loc
),
4552 Expression
=> Relocate_Node
(N
))));
4554 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
4555 Analyze_And_Resolve
(N
, Typ
);
4559 ------------------------------
4560 -- Expand_N_Type_Conversion --
4561 ------------------------------
4563 procedure Expand_N_Type_Conversion
(N
: Node_Id
) is
4564 Loc
: constant Source_Ptr
:= Sloc
(N
);
4565 Operand
: constant Node_Id
:= Expression
(N
);
4566 Target_Type
: constant Entity_Id
:= Etype
(N
);
4567 Operand_Type
: Entity_Id
:= Etype
(Operand
);
4569 procedure Handle_Changed_Representation
;
4570 -- This is called in the case of record and array type conversions
4571 -- to see if there is a change of representation to be handled.
4572 -- Change of representation is actually handled at the assignment
4573 -- statement level, and what this procedure does is rewrite node N
4574 -- conversion as an assignment to temporary. If there is no change
4575 -- of representation, then the conversion node is unchanged.
4577 procedure Real_Range_Check
;
4578 -- Handles generation of range check for real target value
4580 -----------------------------------
4581 -- Handle_Changed_Representation --
4582 -----------------------------------
4584 procedure Handle_Changed_Representation
is
4593 -- Nothing to do if no change of representation
4595 if Same_Representation
(Operand_Type
, Target_Type
) then
4598 -- The real change of representation work is done by the assignment
4599 -- statement processing. So if this type conversion is appearing as
4600 -- the expression of an assignment statement, nothing needs to be
4601 -- done to the conversion.
4603 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
then
4606 -- Otherwise we need to generate a temporary variable, and do the
4607 -- change of representation assignment into that temporary variable.
4608 -- The conversion is then replaced by a reference to this variable.
4613 -- If type is unconstrained we have to add a constraint,
4614 -- copied from the actual value of the left hand side.
4616 if not Is_Constrained
(Target_Type
) then
4617 if Has_Discriminants
(Operand_Type
) then
4618 Disc
:= First_Discriminant
(Operand_Type
);
4620 while Present
(Disc
) loop
4622 Make_Selected_Component
(Loc
,
4623 Prefix
=> Duplicate_Subexpr
(Operand
),
4625 Make_Identifier
(Loc
, Chars
(Disc
))));
4626 Next_Discriminant
(Disc
);
4629 elsif Is_Array_Type
(Operand_Type
) then
4630 N_Ix
:= First_Index
(Target_Type
);
4633 for J
in 1 .. Number_Dimensions
(Operand_Type
) loop
4635 -- We convert the bounds explicitly. We use an unchecked
4636 -- conversion because bounds checks are done elsewhere.
4641 Unchecked_Convert_To
(Etype
(N_Ix
),
4642 Make_Attribute_Reference
(Loc
,
4645 (Operand
, Name_Req
=> True),
4646 Attribute_Name
=> Name_First
,
4647 Expressions
=> New_List
(
4648 Make_Integer_Literal
(Loc
, J
)))),
4651 Unchecked_Convert_To
(Etype
(N_Ix
),
4652 Make_Attribute_Reference
(Loc
,
4655 (Operand
, Name_Req
=> True),
4656 Attribute_Name
=> Name_Last
,
4657 Expressions
=> New_List
(
4658 Make_Integer_Literal
(Loc
, J
))))));
4665 Odef
:= New_Occurrence_Of
(Target_Type
, Loc
);
4667 if Present
(Cons
) then
4669 Make_Subtype_Indication
(Loc
,
4670 Subtype_Mark
=> Odef
,
4672 Make_Index_Or_Discriminant_Constraint
(Loc
,
4673 Constraints
=> Cons
));
4676 Temp
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('C'));
4678 Make_Object_Declaration
(Loc
,
4679 Defining_Identifier
=> Temp
,
4680 Object_Definition
=> Odef
);
4682 Set_No_Initialization
(Decl
, True);
4684 -- Insert required actions. It is essential to suppress checks
4685 -- since we have suppressed default initialization, which means
4686 -- that the variable we create may have no discriminants.
4691 Make_Assignment_Statement
(Loc
,
4692 Name
=> New_Occurrence_Of
(Temp
, Loc
),
4693 Expression
=> Relocate_Node
(N
))),
4694 Suppress
=> All_Checks
);
4696 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4699 end Handle_Changed_Representation
;
4701 ----------------------
4702 -- Real_Range_Check --
4703 ----------------------
4705 -- Case of conversions to floating-point or fixed-point. If range
4706 -- checks are enabled and the target type has a range constraint,
4713 -- Tnn : typ'Base := typ'Base (x);
4714 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
4717 procedure Real_Range_Check
is
4718 Btyp
: constant Entity_Id
:= Base_Type
(Target_Type
);
4719 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
4720 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
4725 -- Nothing to do if conversion was rewritten
4727 if Nkind
(N
) /= N_Type_Conversion
then
4731 -- Nothing to do if range checks suppressed, or target has the
4732 -- same range as the base type (or is the base type).
4734 if Range_Checks_Suppressed
(Target_Type
)
4735 or else (Lo
= Type_Low_Bound
(Btyp
)
4737 Hi
= Type_High_Bound
(Btyp
))
4742 -- Nothing to do if expression is an entity on which checks
4743 -- have been suppressed.
4745 if Is_Entity_Name
(Expression
(N
))
4746 and then Range_Checks_Suppressed
(Entity
(Expression
(N
)))
4751 -- Here we rewrite the conversion as described above
4753 Conv
:= Relocate_Node
(N
);
4755 (Subtype_Mark
(Conv
), New_Occurrence_Of
(Btyp
, Loc
));
4756 Set_Etype
(Conv
, Btyp
);
4758 -- Skip overflow check for integer to float conversions,
4759 -- since it is not needed, and in any case gigi generates
4760 -- incorrect code for such overflow checks ???
4762 if not Is_Integer_Type
(Etype
(Expression
(N
))) then
4763 Set_Do_Overflow_Check
(Conv
, True);
4767 Make_Defining_Identifier
(Loc
,
4768 Chars
=> New_Internal_Name
('T'));
4770 Insert_Actions
(N
, New_List
(
4771 Make_Object_Declaration
(Loc
,
4772 Defining_Identifier
=> Tnn
,
4773 Object_Definition
=> New_Occurrence_Of
(Btyp
, Loc
),
4774 Expression
=> Conv
),
4776 Make_Raise_Constraint_Error
(Loc
,
4781 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
4783 Make_Attribute_Reference
(Loc
,
4784 Attribute_Name
=> Name_First
,
4786 New_Occurrence_Of
(Target_Type
, Loc
))),
4790 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
4792 Make_Attribute_Reference
(Loc
,
4793 Attribute_Name
=> Name_Last
,
4795 New_Occurrence_Of
(Target_Type
, Loc
)))),
4796 Reason
=> CE_Range_Check_Failed
)));
4798 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
4799 Analyze_And_Resolve
(N
, Btyp
);
4800 end Real_Range_Check
;
4802 -- Start of processing for Expand_N_Type_Conversion
4805 -- Nothing at all to do if conversion is to the identical type
4806 -- so remove the conversion completely, it is useless.
4808 if Operand_Type
= Target_Type
then
4809 Rewrite
(N
, Relocate_Node
(Expression
(N
)));
4813 -- Deal with Vax floating-point cases
4815 if Vax_Float
(Operand_Type
) or else Vax_Float
(Target_Type
) then
4816 Expand_Vax_Conversion
(N
);
4820 -- Nothing to do if this is the second argument of read. This
4821 -- is a "backwards" conversion that will be handled by the
4822 -- specialized code in attribute processing.
4824 if Nkind
(Parent
(N
)) = N_Attribute_Reference
4825 and then Attribute_Name
(Parent
(N
)) = Name_Read
4826 and then Next
(First
(Expressions
(Parent
(N
)))) = N
4831 -- Here if we may need to expand conversion
4833 -- Special case of converting from non-standard boolean type
4835 if Is_Boolean_Type
(Operand_Type
)
4836 and then (Nonzero_Is_True
(Operand_Type
))
4838 Adjust_Condition
(Operand
);
4839 Set_Etype
(Operand
, Standard_Boolean
);
4840 Operand_Type
:= Standard_Boolean
;
4843 -- Case of converting to an access type
4845 if Is_Access_Type
(Target_Type
) then
4847 -- Apply an accessibility check if the operand is an
4848 -- access parameter. Note that other checks may still
4849 -- need to be applied below (such as tagged type checks).
4851 if Is_Entity_Name
(Operand
)
4852 and then Ekind
(Entity
(Operand
)) in Formal_Kind
4853 and then Ekind
(Etype
(Operand
)) = E_Anonymous_Access_Type
4855 Apply_Accessibility_Check
(Operand
, Target_Type
);
4857 -- If the level of the operand type is statically deeper
4858 -- then the level of the target type, then force Program_Error.
4859 -- Note that this can only occur for cases where the attribute
4860 -- is within the body of an instantiation (otherwise the
4861 -- conversion will already have been rejected as illegal).
4862 -- Note: warnings are issued by the analyzer for the instance
4865 elsif In_Instance_Body
4866 and then Type_Access_Level
(Operand_Type
) >
4867 Type_Access_Level
(Target_Type
)
4870 Make_Raise_Program_Error
(Sloc
(N
),
4871 Reason
=> PE_Accessibility_Check_Failed
));
4872 Set_Etype
(N
, Target_Type
);
4874 -- When the operand is a selected access discriminant
4875 -- the check needs to be made against the level of the
4876 -- object denoted by the prefix of the selected name.
4877 -- Force Program_Error for this case as well (this
4878 -- accessibility violation can only happen if within
4879 -- the body of an instantiation).
4881 elsif In_Instance_Body
4882 and then Ekind
(Operand_Type
) = E_Anonymous_Access_Type
4883 and then Nkind
(Operand
) = N_Selected_Component
4884 and then Object_Access_Level
(Operand
) >
4885 Type_Access_Level
(Target_Type
)
4888 Make_Raise_Program_Error
(Sloc
(N
),
4889 Reason
=> PE_Accessibility_Check_Failed
));
4890 Set_Etype
(N
, Target_Type
);
4894 -- Case of conversions of tagged types and access to tagged types
4896 -- When needed, that is to say when the expression is class-wide,
4897 -- Add runtime a tag check for (strict) downward conversion by using
4898 -- the membership test, generating:
4900 -- [constraint_error when Operand not in Target_Type'Class]
4902 -- or in the access type case
4904 -- [constraint_error
4905 -- when Operand /= null
4906 -- and then Operand.all not in
4907 -- Designated_Type (Target_Type)'Class]
4909 if (Is_Access_Type
(Target_Type
)
4910 and then Is_Tagged_Type
(Designated_Type
(Target_Type
)))
4911 or else Is_Tagged_Type
(Target_Type
)
4913 -- Do not do any expansion in the access type case if the
4914 -- parent is a renaming, since this is an error situation
4915 -- which will be caught by Sem_Ch8, and the expansion can
4916 -- intefere with this error check.
4918 if Is_Access_Type
(Target_Type
)
4919 and then Is_Renamed_Object
(N
)
4924 -- Oherwise, proceed with processing tagged conversion
4927 Actual_Operand_Type
: Entity_Id
;
4928 Actual_Target_Type
: Entity_Id
;
4933 if Is_Access_Type
(Target_Type
) then
4934 Actual_Operand_Type
:= Designated_Type
(Operand_Type
);
4935 Actual_Target_Type
:= Designated_Type
(Target_Type
);
4938 Actual_Operand_Type
:= Operand_Type
;
4939 Actual_Target_Type
:= Target_Type
;
4942 if Is_Class_Wide_Type
(Actual_Operand_Type
)
4943 and then Root_Type
(Actual_Operand_Type
) /= Actual_Target_Type
4944 and then Is_Ancestor
4945 (Root_Type
(Actual_Operand_Type
),
4947 and then not Tag_Checks_Suppressed
(Actual_Target_Type
)
4949 -- The conversion is valid for any descendant of the
4952 Actual_Target_Type
:= Class_Wide_Type
(Actual_Target_Type
);
4954 if Is_Access_Type
(Target_Type
) then
4959 Left_Opnd
=> Duplicate_Subexpr
(Operand
),
4960 Right_Opnd
=> Make_Null
(Loc
)),
4965 Make_Explicit_Dereference
(Loc
,
4966 Prefix
=> Duplicate_Subexpr
(Operand
)),
4968 New_Reference_To
(Actual_Target_Type
, Loc
)));
4973 Left_Opnd
=> Duplicate_Subexpr
(Operand
),
4975 New_Reference_To
(Actual_Target_Type
, Loc
));
4979 Make_Raise_Constraint_Error
(Loc
,
4981 Reason
=> CE_Tag_Check_Failed
));
4983 Change_Conversion_To_Unchecked
(N
);
4984 Analyze_And_Resolve
(N
, Target_Type
);
4988 -- Case of other access type conversions
4990 elsif Is_Access_Type
(Target_Type
) then
4991 Apply_Constraint_Check
(Operand
, Target_Type
);
4993 -- Case of conversions from a fixed-point type
4995 -- These conversions require special expansion and processing, found
4996 -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
4997 -- set, since from a semantic point of view, these are simple integer
4998 -- conversions, which do not need further processing.
5000 elsif Is_Fixed_Point_Type
(Operand_Type
)
5001 and then not Conversion_OK
(N
)
5003 -- We should never see universal fixed at this case, since the
5004 -- expansion of the constituent divide or multiply should have
5005 -- eliminated the explicit mention of universal fixed.
5007 pragma Assert
(Operand_Type
/= Universal_Fixed
);
5009 -- Check for special case of the conversion to universal real
5010 -- that occurs as a result of the use of a round attribute.
5011 -- In this case, the real type for the conversion is taken
5012 -- from the target type of the Round attribute and the
5013 -- result must be marked as rounded.
5015 if Target_Type
= Universal_Real
5016 and then Nkind
(Parent
(N
)) = N_Attribute_Reference
5017 and then Attribute_Name
(Parent
(N
)) = Name_Round
5019 Set_Rounded_Result
(N
);
5020 Set_Etype
(N
, Etype
(Parent
(N
)));
5023 -- Otherwise do correct fixed-conversion, but skip these if the
5024 -- Conversion_OK flag is set, because from a semantic point of
5025 -- view these are simple integer conversions needing no further
5026 -- processing (the backend will simply treat them as integers)
5028 if not Conversion_OK
(N
) then
5029 if Is_Fixed_Point_Type
(Etype
(N
)) then
5030 Expand_Convert_Fixed_To_Fixed
(N
);
5033 elsif Is_Integer_Type
(Etype
(N
)) then
5034 Expand_Convert_Fixed_To_Integer
(N
);
5037 pragma Assert
(Is_Floating_Point_Type
(Etype
(N
)));
5038 Expand_Convert_Fixed_To_Float
(N
);
5043 -- Case of conversions to a fixed-point type
5045 -- These conversions require special expansion and processing, found
5046 -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
5047 -- is set, since from a semantic point of view, these are simple
5048 -- integer conversions, which do not need further processing.
5050 elsif Is_Fixed_Point_Type
(Target_Type
)
5051 and then not Conversion_OK
(N
)
5053 if Is_Integer_Type
(Operand_Type
) then
5054 Expand_Convert_Integer_To_Fixed
(N
);
5057 pragma Assert
(Is_Floating_Point_Type
(Operand_Type
));
5058 Expand_Convert_Float_To_Fixed
(N
);
5062 -- Case of float-to-integer conversions
5064 -- We also handle float-to-fixed conversions with Conversion_OK set
5065 -- since semantically the fixed-point target is treated as though it
5066 -- were an integer in such cases.
5068 elsif Is_Floating_Point_Type
(Operand_Type
)
5070 (Is_Integer_Type
(Target_Type
)
5072 (Is_Fixed_Point_Type
(Target_Type
) and then Conversion_OK
(N
)))
5074 -- Special processing required if the conversion is the expression
5075 -- of a Truncation attribute reference. In this case we replace:
5077 -- ityp (ftyp'Truncation (x))
5083 -- with the Float_Truncate flag set. This is clearly more efficient.
5085 if Nkind
(Operand
) = N_Attribute_Reference
5086 and then Attribute_Name
(Operand
) = Name_Truncation
5089 Relocate_Node
(First
(Expressions
(Operand
))));
5090 Set_Float_Truncate
(N
, True);
5093 -- One more check here, gcc is still not able to do conversions of
5094 -- this type with proper overflow checking, and so gigi is doing an
5095 -- approximation of what is required by doing floating-point compares
5096 -- with the end-point. But that can lose precision in some cases, and
5097 -- give a wrong result. Converting the operand to Long_Long_Float is
5098 -- helpful, but still does not catch all cases with 64-bit integers
5099 -- on targets with only 64-bit floats ???
5101 if Do_Range_Check
(Expression
(N
)) then
5102 Rewrite
(Expression
(N
),
5103 Make_Type_Conversion
(Loc
,
5105 New_Occurrence_Of
(Standard_Long_Long_Float
, Loc
),
5107 Relocate_Node
(Expression
(N
))));
5109 Set_Etype
(Expression
(N
), Standard_Long_Long_Float
);
5110 Enable_Range_Check
(Expression
(N
));
5111 Set_Do_Range_Check
(Expression
(Expression
(N
)), False);
5114 -- Case of array conversions
5116 -- Expansion of array conversions, add required length/range checks
5117 -- but only do this if there is no change of representation. For
5118 -- handling of this case, see Handle_Changed_Representation.
5120 elsif Is_Array_Type
(Target_Type
) then
5122 if Is_Constrained
(Target_Type
) then
5123 Apply_Length_Check
(Operand
, Target_Type
);
5125 Apply_Range_Check
(Operand
, Target_Type
);
5128 Handle_Changed_Representation
;
5130 -- Case of conversions of discriminated types
5132 -- Add required discriminant checks if target is constrained. Again
5133 -- this change is skipped if we have a change of representation.
5135 elsif Has_Discriminants
(Target_Type
)
5136 and then Is_Constrained
(Target_Type
)
5138 Apply_Discriminant_Check
(Operand
, Target_Type
);
5139 Handle_Changed_Representation
;
5141 -- Case of all other record conversions. The only processing required
5142 -- is to check for a change of representation requiring the special
5143 -- assignment processing.
5145 elsif Is_Record_Type
(Target_Type
) then
5146 Handle_Changed_Representation
;
5148 -- Case of conversions of enumeration types
5150 elsif Is_Enumeration_Type
(Target_Type
) then
5152 -- Special processing is required if there is a change of
5153 -- representation (from enumeration representation clauses)
5155 if not Same_Representation
(Target_Type
, Operand_Type
) then
5157 -- Convert: x(y) to x'val (ytyp'val (y))
5160 Make_Attribute_Reference
(Loc
,
5161 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
5162 Attribute_Name
=> Name_Val
,
5163 Expressions
=> New_List
(
5164 Make_Attribute_Reference
(Loc
,
5165 Prefix
=> New_Occurrence_Of
(Operand_Type
, Loc
),
5166 Attribute_Name
=> Name_Pos
,
5167 Expressions
=> New_List
(Operand
)))));
5169 Analyze_And_Resolve
(N
, Target_Type
);
5172 -- Case of conversions to floating-point
5174 elsif Is_Floating_Point_Type
(Target_Type
) then
5177 -- The remaining cases require no front end processing
5183 -- At this stage, either the conversion node has been transformed
5184 -- into some other equivalent expression, or left as a conversion
5185 -- that can be handled by Gigi. The conversions that Gigi can handle
5186 -- are the following:
5188 -- Conversions with no change of representation or type
5190 -- Numeric conversions involving integer values, floating-point
5191 -- values, and fixed-point values. Fixed-point values are allowed
5192 -- only if Conversion_OK is set, i.e. if the fixed-point values
5193 -- are to be treated as integers.
5195 -- No other conversions should be passed to Gigi.
5197 end Expand_N_Type_Conversion
;
5199 -----------------------------------
5200 -- Expand_N_Unchecked_Expression --
5201 -----------------------------------
5203 -- Remove the unchecked expression node from the tree. It's job was simply
5204 -- to make sure that its constituent expression was handled with checks
5205 -- off, and now that that is done, we can remove it from the tree, and
5206 -- indeed must, since gigi does not expect to see these nodes.
5208 procedure Expand_N_Unchecked_Expression
(N
: Node_Id
) is
5209 Exp
: constant Node_Id
:= Expression
(N
);
5212 Set_Assignment_OK
(Exp
, Assignment_OK
(N
) or Assignment_OK
(Exp
));
5214 end Expand_N_Unchecked_Expression
;
5216 ----------------------------------------
5217 -- Expand_N_Unchecked_Type_Conversion --
5218 ----------------------------------------
5220 -- If this cannot be handled by Gigi and we haven't already made
5221 -- a temporary for it, do it now.
5223 procedure Expand_N_Unchecked_Type_Conversion
(N
: Node_Id
) is
5224 Target_Type
: constant Entity_Id
:= Etype
(N
);
5225 Operand
: constant Node_Id
:= Expression
(N
);
5226 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
5229 -- If we have a conversion of a compile time known value to a target
5230 -- type and the value is in range of the target type, then we can simply
5231 -- replace the construct by an integer literal of the correct type. We
5232 -- only apply this to integer types being converted. Possibly it may
5233 -- apply in other cases, but it is too much trouble to worry about.
5235 -- Note that we do not do this transformation if the Kill_Range_Check
5236 -- flag is set, since then the value may be outside the expected range.
5237 -- This happens in the Normalize_Scalars case.
5239 if Is_Integer_Type
(Target_Type
)
5240 and then Is_Integer_Type
(Operand_Type
)
5241 and then Compile_Time_Known_Value
(Operand
)
5242 and then not Kill_Range_Check
(N
)
5245 Val
: constant Uint
:= Expr_Value
(Operand
);
5248 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
5250 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
5252 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
5254 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
5256 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
5257 Analyze_And_Resolve
(N
, Target_Type
);
5263 -- Nothing to do if conversion is safe
5265 if Safe_Unchecked_Type_Conversion
(N
) then
5269 -- Otherwise force evaluation unless Assignment_OK flag is set (this
5270 -- flag indicates ??? -- more comments needed here)
5272 if Assignment_OK
(N
) then
5275 Force_Evaluation
(N
);
5277 end Expand_N_Unchecked_Type_Conversion
;
5279 ----------------------------
5280 -- Expand_Record_Equality --
5281 ----------------------------
5283 -- For non-variant records, Equality is expanded when needed into:
5285 -- and then Lhs.Discr1 = Rhs.Discr1
5287 -- and then Lhs.Discrn = Rhs.Discrn
5288 -- and then Lhs.Cmp1 = Rhs.Cmp1
5290 -- and then Lhs.Cmpn = Rhs.Cmpn
5292 -- The expression is folded by the back-end for adjacent fields. This
5293 -- function is called for tagged record in only one occasion: for imple-
5294 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
5295 -- otherwise the primitive "=" is used directly.
5297 function Expand_Record_Equality
5305 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
5307 function Suitable_Element
(C
: Entity_Id
) return Entity_Id
;
5308 -- Return the first field to compare beginning with C, skipping the
5309 -- inherited components
5311 function Suitable_Element
(C
: Entity_Id
) return Entity_Id
is
5316 elsif Ekind
(C
) /= E_Discriminant
5317 and then Ekind
(C
) /= E_Component
5319 return Suitable_Element
(Next_Entity
(C
));
5321 elsif Is_Tagged_Type
(Typ
)
5322 and then C
/= Original_Record_Component
(C
)
5324 return Suitable_Element
(Next_Entity
(C
));
5326 elsif Chars
(C
) = Name_uController
5327 or else Chars
(C
) = Name_uTag
5329 return Suitable_Element
(Next_Entity
(C
));
5334 end Suitable_Element
;
5339 First_Time
: Boolean := True;
5341 -- Start of processing for Expand_Record_Equality
5344 -- Special processing for the unchecked union case, which will occur
5345 -- only in the context of tagged types and dynamic dispatching, since
5346 -- other cases are handled statically. We return True, but insert a
5347 -- raise Program_Error statement.
5349 if Is_Unchecked_Union
(Typ
) then
5351 -- If this is a component of an enclosing record, return the Raise
5352 -- statement directly.
5354 if No
(Parent
(Lhs
)) then
5356 Make_Raise_Program_Error
(Loc
,
5357 Reason
=> PE_Unchecked_Union_Restriction
);
5358 Set_Etype
(Result
, Standard_Boolean
);
5363 Make_Raise_Program_Error
(Loc
,
5364 Reason
=> PE_Unchecked_Union_Restriction
));
5365 return New_Occurrence_Of
(Standard_True
, Loc
);
5369 -- Generates the following code: (assuming that Typ has one Discr and
5370 -- component C2 is also a record)
5373 -- and then Lhs.Discr1 = Rhs.Discr1
5374 -- and then Lhs.C1 = Rhs.C1
5375 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
5377 -- and then Lhs.Cmpn = Rhs.Cmpn
5379 Result
:= New_Reference_To
(Standard_True
, Loc
);
5380 C
:= Suitable_Element
(First_Entity
(Typ
));
5382 while Present
(C
) loop
5390 First_Time
:= False;
5395 New_Lhs
:= New_Copy_Tree
(Lhs
);
5396 New_Rhs
:= New_Copy_Tree
(Rhs
);
5401 Left_Opnd
=> Result
,
5403 Expand_Composite_Equality
(Nod
, Etype
(C
),
5405 Make_Selected_Component
(Loc
,
5407 Selector_Name
=> New_Reference_To
(C
, Loc
)),
5409 Make_Selected_Component
(Loc
,
5411 Selector_Name
=> New_Reference_To
(C
, Loc
)),
5415 C
:= Suitable_Element
(Next_Entity
(C
));
5419 end Expand_Record_Equality
;
5421 -------------------------------------
5422 -- Fixup_Universal_Fixed_Operation --
5423 -------------------------------------
5425 procedure Fixup_Universal_Fixed_Operation
(N
: Node_Id
) is
5426 Conv
: constant Node_Id
:= Parent
(N
);
5429 -- We must have a type conversion immediately above us
5431 pragma Assert
(Nkind
(Conv
) = N_Type_Conversion
);
5433 -- Normally the type conversion gives our target type. The exception
5434 -- occurs in the case of the Round attribute, where the conversion
5435 -- will be to universal real, and our real type comes from the Round
5436 -- attribute (as well as an indication that we must round the result)
5438 if Nkind
(Parent
(Conv
)) = N_Attribute_Reference
5439 and then Attribute_Name
(Parent
(Conv
)) = Name_Round
5441 Set_Etype
(N
, Etype
(Parent
(Conv
)));
5442 Set_Rounded_Result
(N
);
5444 -- Normal case where type comes from conversion above us
5447 Set_Etype
(N
, Etype
(Conv
));
5449 end Fixup_Universal_Fixed_Operation
;
5451 -------------------------------
5452 -- Insert_Dereference_Action --
5453 -------------------------------
5455 procedure Insert_Dereference_Action
(N
: Node_Id
) is
5456 Loc
: constant Source_Ptr
:= Sloc
(N
);
5457 Typ
: constant Entity_Id
:= Etype
(N
);
5458 Pool
: constant Entity_Id
:= Associated_Storage_Pool
(Typ
);
5460 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean;
5461 -- return true if type of P is derived from Checked_Pool;
5463 function Is_Checked_Storage_Pool
(P
: Entity_Id
) return Boolean is
5472 while T
/= Etype
(T
) loop
5473 if Is_RTE
(T
, RE_Checked_Pool
) then
5481 end Is_Checked_Storage_Pool
;
5483 -- Start of processing for Insert_Dereference_Action
5486 if not Comes_From_Source
(Parent
(N
)) then
5489 elsif not Is_Checked_Storage_Pool
(Pool
) then
5494 Make_Procedure_Call_Statement
(Loc
,
5495 Name
=> New_Reference_To
(
5496 Find_Prim_Op
(Etype
(Pool
), Name_Dereference
), Loc
),
5498 Parameter_Associations
=> New_List
(
5502 New_Reference_To
(Pool
, Loc
),
5506 Make_Attribute_Reference
(Loc
,
5508 Make_Explicit_Dereference
(Loc
, Duplicate_Subexpr
(N
)),
5509 Attribute_Name
=> Name_Address
),
5511 -- Size_In_Storage_Elements
5513 Make_Op_Divide
(Loc
,
5515 Make_Attribute_Reference
(Loc
,
5517 Make_Explicit_Dereference
(Loc
, Duplicate_Subexpr
(N
)),
5518 Attribute_Name
=> Name_Size
),
5520 Make_Integer_Literal
(Loc
, System_Storage_Unit
)),
5524 Make_Attribute_Reference
(Loc
,
5526 Make_Explicit_Dereference
(Loc
, Duplicate_Subexpr
(N
)),
5527 Attribute_Name
=> Name_Alignment
))));
5529 end Insert_Dereference_Action
;
5531 ------------------------------
5532 -- Make_Array_Comparison_Op --
5533 ------------------------------
5535 -- This is a hand-coded expansion of the following generic function:
5538 -- type elem is (<>);
5539 -- type index is (<>);
5540 -- type a is array (index range <>) of elem;
5542 -- function Gnnn (X : a; Y: a) return boolean is
5543 -- J : index := Y'first;
5546 -- if X'length = 0 then
5549 -- elsif Y'length = 0 then
5553 -- for I in X'range loop
5554 -- if X (I) = Y (J) then
5555 -- if J = Y'last then
5558 -- J := index'succ (J);
5562 -- return X (I) > Y (J);
5566 -- return X'length > Y'length;
5570 -- Note that since we are essentially doing this expansion by hand, we
5571 -- do not need to generate an actual or formal generic part, just the
5572 -- instantiated function itself.
5574 function Make_Array_Comparison_Op
5579 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
5581 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uX
);
5582 Y
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uY
);
5583 I
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uI
);
5584 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
5586 Index
: constant Entity_Id
:= Base_Type
(Etype
(First_Index
(Typ
)));
5588 Loop_Statement
: Node_Id
;
5589 Loop_Body
: Node_Id
;
5592 Final_Expr
: Node_Id
;
5593 Func_Body
: Node_Id
;
5594 Func_Name
: Entity_Id
;
5600 -- if J = Y'last then
5603 -- J := index'succ (J);
5607 Make_Implicit_If_Statement
(Nod
,
5610 Left_Opnd
=> New_Reference_To
(J
, Loc
),
5612 Make_Attribute_Reference
(Loc
,
5613 Prefix
=> New_Reference_To
(Y
, Loc
),
5614 Attribute_Name
=> Name_Last
)),
5616 Then_Statements
=> New_List
(
5617 Make_Exit_Statement
(Loc
)),
5621 Make_Assignment_Statement
(Loc
,
5622 Name
=> New_Reference_To
(J
, Loc
),
5624 Make_Attribute_Reference
(Loc
,
5625 Prefix
=> New_Reference_To
(Index
, Loc
),
5626 Attribute_Name
=> Name_Succ
,
5627 Expressions
=> New_List
(New_Reference_To
(J
, Loc
))))));
5629 -- if X (I) = Y (J) then
5632 -- return X (I) > Y (J);
5636 Make_Implicit_If_Statement
(Nod
,
5640 Make_Indexed_Component
(Loc
,
5641 Prefix
=> New_Reference_To
(X
, Loc
),
5642 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
5645 Make_Indexed_Component
(Loc
,
5646 Prefix
=> New_Reference_To
(Y
, Loc
),
5647 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)))),
5649 Then_Statements
=> New_List
(Inner_If
),
5651 Else_Statements
=> New_List
(
5652 Make_Return_Statement
(Loc
,
5656 Make_Indexed_Component
(Loc
,
5657 Prefix
=> New_Reference_To
(X
, Loc
),
5658 Expressions
=> New_List
(New_Reference_To
(I
, Loc
))),
5661 Make_Indexed_Component
(Loc
,
5662 Prefix
=> New_Reference_To
(Y
, Loc
),
5663 Expressions
=> New_List
(
5664 New_Reference_To
(J
, Loc
)))))));
5666 -- for I in X'range loop
5671 Make_Implicit_Loop_Statement
(Nod
,
5672 Identifier
=> Empty
,
5675 Make_Iteration_Scheme
(Loc
,
5676 Loop_Parameter_Specification
=>
5677 Make_Loop_Parameter_Specification
(Loc
,
5678 Defining_Identifier
=> I
,
5679 Discrete_Subtype_Definition
=>
5680 Make_Attribute_Reference
(Loc
,
5681 Prefix
=> New_Reference_To
(X
, Loc
),
5682 Attribute_Name
=> Name_Range
))),
5684 Statements
=> New_List
(Loop_Body
));
5686 -- if X'length = 0 then
5688 -- elsif Y'length = 0 then
5691 -- for ... loop ... end loop;
5692 -- return X'length > Y'length;
5696 Make_Attribute_Reference
(Loc
,
5697 Prefix
=> New_Reference_To
(X
, Loc
),
5698 Attribute_Name
=> Name_Length
);
5701 Make_Attribute_Reference
(Loc
,
5702 Prefix
=> New_Reference_To
(Y
, Loc
),
5703 Attribute_Name
=> Name_Length
);
5707 Left_Opnd
=> Length1
,
5708 Right_Opnd
=> Length2
);
5711 Make_Implicit_If_Statement
(Nod
,
5715 Make_Attribute_Reference
(Loc
,
5716 Prefix
=> New_Reference_To
(X
, Loc
),
5717 Attribute_Name
=> Name_Length
),
5719 Make_Integer_Literal
(Loc
, 0)),
5723 Make_Return_Statement
(Loc
,
5724 Expression
=> New_Reference_To
(Standard_False
, Loc
))),
5726 Elsif_Parts
=> New_List
(
5727 Make_Elsif_Part
(Loc
,
5731 Make_Attribute_Reference
(Loc
,
5732 Prefix
=> New_Reference_To
(Y
, Loc
),
5733 Attribute_Name
=> Name_Length
),
5735 Make_Integer_Literal
(Loc
, 0)),
5739 Make_Return_Statement
(Loc
,
5740 Expression
=> New_Reference_To
(Standard_True
, Loc
))))),
5742 Else_Statements
=> New_List
(
5744 Make_Return_Statement
(Loc
,
5745 Expression
=> Final_Expr
)));
5749 Formals
:= New_List
(
5750 Make_Parameter_Specification
(Loc
,
5751 Defining_Identifier
=> X
,
5752 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
5754 Make_Parameter_Specification
(Loc
,
5755 Defining_Identifier
=> Y
,
5756 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
5758 -- function Gnnn (...) return boolean is
5759 -- J : index := Y'first;
5764 Func_Name
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('G'));
5767 Make_Subprogram_Body
(Loc
,
5769 Make_Function_Specification
(Loc
,
5770 Defining_Unit_Name
=> Func_Name
,
5771 Parameter_Specifications
=> Formals
,
5772 Subtype_Mark
=> New_Reference_To
(Standard_Boolean
, Loc
)),
5774 Declarations
=> New_List
(
5775 Make_Object_Declaration
(Loc
,
5776 Defining_Identifier
=> J
,
5777 Object_Definition
=> New_Reference_To
(Index
, Loc
),
5779 Make_Attribute_Reference
(Loc
,
5780 Prefix
=> New_Reference_To
(Y
, Loc
),
5781 Attribute_Name
=> Name_First
))),
5783 Handled_Statement_Sequence
=>
5784 Make_Handled_Sequence_Of_Statements
(Loc
,
5785 Statements
=> New_List
(If_Stat
)));
5789 end Make_Array_Comparison_Op
;
5791 ---------------------------
5792 -- Make_Boolean_Array_Op --
5793 ---------------------------
5795 -- For logical operations on boolean arrays, expand in line the
5796 -- following, replacing 'and' with 'or' or 'xor' where needed:
5798 -- function Annn (A : typ; B: typ) return typ is
5801 -- for J in A'range loop
5802 -- C (J) := A (J) op B (J);
5807 -- Here typ is the boolean array type
5809 function Make_Boolean_Array_Op
5814 Loc
: constant Source_Ptr
:= Sloc
(N
);
5816 A
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uA
);
5817 B
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uB
);
5818 C
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uC
);
5819 J
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uJ
);
5827 Func_Name
: Entity_Id
;
5828 Func_Body
: Node_Id
;
5829 Loop_Statement
: Node_Id
;
5833 Make_Indexed_Component
(Loc
,
5834 Prefix
=> New_Reference_To
(A
, Loc
),
5835 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
5838 Make_Indexed_Component
(Loc
,
5839 Prefix
=> New_Reference_To
(B
, Loc
),
5840 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
5843 Make_Indexed_Component
(Loc
,
5844 Prefix
=> New_Reference_To
(C
, Loc
),
5845 Expressions
=> New_List
(New_Reference_To
(J
, Loc
)));
5847 if Nkind
(N
) = N_Op_And
then
5853 elsif Nkind
(N
) = N_Op_Or
then
5867 Make_Implicit_Loop_Statement
(N
,
5868 Identifier
=> Empty
,
5871 Make_Iteration_Scheme
(Loc
,
5872 Loop_Parameter_Specification
=>
5873 Make_Loop_Parameter_Specification
(Loc
,
5874 Defining_Identifier
=> J
,
5875 Discrete_Subtype_Definition
=>
5876 Make_Attribute_Reference
(Loc
,
5877 Prefix
=> New_Reference_To
(A
, Loc
),
5878 Attribute_Name
=> Name_Range
))),
5880 Statements
=> New_List
(
5881 Make_Assignment_Statement
(Loc
,
5883 Expression
=> Op
)));
5885 Formals
:= New_List
(
5886 Make_Parameter_Specification
(Loc
,
5887 Defining_Identifier
=> A
,
5888 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)),
5890 Make_Parameter_Specification
(Loc
,
5891 Defining_Identifier
=> B
,
5892 Parameter_Type
=> New_Reference_To
(Typ
, Loc
)));
5895 Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
5896 Set_Is_Inlined
(Func_Name
);
5899 Make_Subprogram_Body
(Loc
,
5901 Make_Function_Specification
(Loc
,
5902 Defining_Unit_Name
=> Func_Name
,
5903 Parameter_Specifications
=> Formals
,
5904 Subtype_Mark
=> New_Reference_To
(Typ
, Loc
)),
5906 Declarations
=> New_List
(
5907 Make_Object_Declaration
(Loc
,
5908 Defining_Identifier
=> C
,
5909 Object_Definition
=> New_Reference_To
(Typ
, Loc
))),
5911 Handled_Statement_Sequence
=>
5912 Make_Handled_Sequence_Of_Statements
(Loc
,
5913 Statements
=> New_List
(
5915 Make_Return_Statement
(Loc
,
5916 Expression
=> New_Reference_To
(C
, Loc
)))));
5919 end Make_Boolean_Array_Op
;
5921 ------------------------
5922 -- Rewrite_Comparison --
5923 ------------------------
5925 procedure Rewrite_Comparison
(N
: Node_Id
) is
5926 Typ
: constant Entity_Id
:= Etype
(N
);
5927 Op1
: constant Node_Id
:= Left_Opnd
(N
);
5928 Op2
: constant Node_Id
:= Right_Opnd
(N
);
5930 Res
: constant Compare_Result
:= Compile_Time_Compare
(Op1
, Op2
);
5931 -- Res indicates if compare outcome can be determined at compile time
5933 True_Result
: Boolean;
5934 False_Result
: Boolean;
5937 case N_Op_Compare
(Nkind
(N
)) is
5939 True_Result
:= Res
= EQ
;
5940 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
5943 True_Result
:= Res
in Compare_GE
;
5944 False_Result
:= Res
= LT
;
5947 True_Result
:= Res
= GT
;
5948 False_Result
:= Res
in Compare_LE
;
5951 True_Result
:= Res
= LT
;
5952 False_Result
:= Res
in Compare_GE
;
5955 True_Result
:= Res
in Compare_LE
;
5956 False_Result
:= Res
= GT
;
5959 True_Result
:= Res
= NE
;
5960 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= EQ
;
5965 Convert_To
(Typ
, New_Occurrence_Of
(Standard_True
, Sloc
(N
))));
5966 Analyze_And_Resolve
(N
, Typ
);
5967 Warn_On_Known_Condition
(N
);
5969 elsif False_Result
then
5971 Convert_To
(Typ
, New_Occurrence_Of
(Standard_False
, Sloc
(N
))));
5972 Analyze_And_Resolve
(N
, Typ
);
5973 Warn_On_Known_Condition
(N
);
5975 end Rewrite_Comparison
;
5977 -----------------------
5978 -- Tagged_Membership --
5979 -----------------------
5981 -- There are two different cases to consider depending on whether
5982 -- the right operand is a class-wide type or not. If not we just
5983 -- compare the actual tag of the left expr to the target type tag:
5985 -- Left_Expr.Tag = Right_Type'Tag;
5987 -- If it is a class-wide type we use the RT function CW_Membership which
5988 -- is usually implemented by looking in the ancestor tables contained in
5989 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
5991 function Tagged_Membership
(N
: Node_Id
) return Node_Id
is
5992 Left
: constant Node_Id
:= Left_Opnd
(N
);
5993 Right
: constant Node_Id
:= Right_Opnd
(N
);
5994 Loc
: constant Source_Ptr
:= Sloc
(N
);
5996 Left_Type
: Entity_Id
;
5997 Right_Type
: Entity_Id
;
6001 Left_Type
:= Etype
(Left
);
6002 Right_Type
:= Etype
(Right
);
6004 if Is_Class_Wide_Type
(Left_Type
) then
6005 Left_Type
:= Root_Type
(Left_Type
);
6009 Make_Selected_Component
(Loc
,
6010 Prefix
=> Relocate_Node
(Left
),
6011 Selector_Name
=> New_Reference_To
(Tag_Component
(Left_Type
), Loc
));
6013 if Is_Class_Wide_Type
(Right_Type
) then
6015 Make_DT_Access_Action
(Left_Type
,
6016 Action
=> CW_Membership
,
6020 Access_Disp_Table
(Root_Type
(Right_Type
)), Loc
)));
6024 Left_Opnd
=> Obj_Tag
,
6026 New_Reference_To
(Access_Disp_Table
(Right_Type
), Loc
));
6029 end Tagged_Membership
;
6031 ------------------------------
6032 -- Unary_Op_Validity_Checks --
6033 ------------------------------
6035 procedure Unary_Op_Validity_Checks
(N
: Node_Id
) is
6037 if Validity_Checks_On
and Validity_Check_Operands
then
6038 Ensure_Valid
(Right_Opnd
(N
));
6040 end Unary_Op_Validity_Checks
;