1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Aggr; use Exp_Aggr;
33 with Exp_Atag; use Exp_Atag;
34 with Exp_Ch2; use Exp_Ch2;
35 with Exp_Ch3; use Exp_Ch3;
36 with Exp_Ch6; use Exp_Ch6;
37 with Exp_Ch7; use Exp_Ch7;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Disp; use Exp_Disp;
40 with Exp_Fixd; use Exp_Fixd;
41 with Exp_Intr; use Exp_Intr;
42 with Exp_Pakd; use Exp_Pakd;
43 with Exp_Tss; use Exp_Tss;
44 with Exp_Util; use Exp_Util;
45 with Exp_VFpt; use Exp_VFpt;
46 with Freeze; use Freeze;
47 with Inline; use Inline;
49 with Namet; use Namet;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
53 with Par_SCO; use Par_SCO;
54 with Restrict; use Restrict;
55 with Rident; use Rident;
56 with Rtsfind; use Rtsfind;
58 with Sem_Aux; use Sem_Aux;
59 with Sem_Cat; use Sem_Cat;
60 with Sem_Ch3; use Sem_Ch3;
61 with Sem_Ch8; use Sem_Ch8;
62 with Sem_Ch13; use Sem_Ch13;
63 with Sem_Eval; use Sem_Eval;
64 with Sem_Res; use Sem_Res;
65 with Sem_Type; use Sem_Type;
66 with Sem_Util; use Sem_Util;
67 with Sem_Warn; use Sem_Warn;
68 with Sinfo; use Sinfo;
69 with Snames; use Snames;
70 with Stand; use Stand;
71 with SCIL_LL; use SCIL_LL;
72 with Targparm; use Targparm;
73 with Tbuild; use Tbuild;
74 with Ttypes; use Ttypes;
75 with Uintp; use Uintp;
76 with Urealp; use Urealp;
77 with Validsw; use Validsw;
79 package body Exp_Ch4 is
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 procedure Binary_Op_Validity_Checks (N : Node_Id);
86 pragma Inline (Binary_Op_Validity_Checks);
87 -- Performs validity checks for a binary operator
89 procedure Build_Boolean_Array_Proc_Call
93 -- If a boolean array assignment can be done in place, build call to
94 -- corresponding library procedure.
96 function Current_Anonymous_Master return Entity_Id;
97 -- Return the entity of the heterogeneous finalization master belonging to
98 -- the current unit (either function, package or procedure). This master
99 -- services all anonymous access-to-controlled types. If the current unit
100 -- does not have such master, create one.
102 procedure Displace_Allocator_Pointer (N : Node_Id);
103 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
104 -- Expand_Allocator_Expression. Allocating class-wide interface objects
105 -- this routine displaces the pointer to the allocated object to reference
106 -- the component referencing the corresponding secondary dispatch table.
108 procedure Expand_Allocator_Expression (N : Node_Id);
109 -- Subsidiary to Expand_N_Allocator, for the case when the expression
110 -- is a qualified expression or an aggregate.
112 procedure Expand_Array_Comparison (N : Node_Id);
113 -- This routine handles expansion of the comparison operators (N_Op_Lt,
114 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
115 -- code for these operators is similar, differing only in the details of
116 -- the actual comparison call that is made. Special processing (call a
119 function Expand_Array_Equality
124 Typ : Entity_Id) return Node_Id;
125 -- Expand an array equality into a call to a function implementing this
126 -- equality, and a call to it. Loc is the location for the generated nodes.
127 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
128 -- on which to attach bodies of local functions that are created in the
129 -- process. It is the responsibility of the caller to insert those bodies
130 -- at the right place. Nod provides the Sloc value for the generated code.
131 -- Normally the types used for the generated equality routine are taken
132 -- from Lhs and Rhs. However, in some situations of generated code, the
133 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
134 -- the type to be used for the formal parameters.
136 procedure Expand_Boolean_Operator (N : Node_Id);
137 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
138 -- case of array type arguments.
140 procedure Expand_Short_Circuit_Operator (N : Node_Id);
141 -- Common expansion processing for short-circuit boolean operators
143 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
144 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
145 -- where we allow comparison of "out of range" values.
147 function Expand_Composite_Equality
152 Bodies : List_Id) return Node_Id;
153 -- Local recursive function used to expand equality for nested composite
154 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
155 -- to attach bodies of local functions that are created in the process.
156 -- It is the responsibility of the caller to insert those bodies at the
157 -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
158 -- are the left and right sides for the comparison, and Typ is the type of
159 -- the objects to compare.
161 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
162 -- Routine to expand concatenation of a sequence of two or more operands
163 -- (in the list Operands) and replace node Cnode with the result of the
164 -- concatenation. The operands can be of any appropriate type, and can
165 -- include both arrays and singleton elements.
167 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
168 -- N is an N_In membership test mode, with the overflow check mode set to
169 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
170 -- integer type. This is a case where top level processing is required to
171 -- handle overflow checks in subtrees.
173 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
174 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
175 -- fixed. We do not have such a type at runtime, so the purpose of this
176 -- routine is to find the real type by looking up the tree. We also
177 -- determine if the operation must be rounded.
179 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
180 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
181 -- discriminants if it has a constrained nominal type, unless the object
182 -- is a component of an enclosing Unchecked_Union object that is subject
183 -- to a per-object constraint and the enclosing object lacks inferable
186 -- An expression of an Unchecked_Union type has inferable discriminants
187 -- if it is either a name of an object with inferable discriminants or a
188 -- qualified expression whose subtype mark denotes a constrained subtype.
190 procedure Insert_Dereference_Action (N : Node_Id);
191 -- N is an expression whose type is an access. When the type of the
192 -- associated storage pool is derived from Checked_Pool, generate a
193 -- call to the 'Dereference' primitive operation.
195 function Make_Array_Comparison_Op
197 Nod : Node_Id) return Node_Id;
198 -- Comparisons between arrays are expanded in line. This function produces
199 -- the body of the implementation of (a > b), where a and b are one-
200 -- dimensional arrays of some discrete type. The original node is then
201 -- expanded into the appropriate call to this function. Nod provides the
202 -- Sloc value for the generated code.
204 function Make_Boolean_Array_Op
206 N : Node_Id) return Node_Id;
207 -- Boolean operations on boolean arrays are expanded in line. This function
208 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
209 -- b). It is used only the normal case and not the packed case. The type
210 -- involved, Typ, is the Boolean array type, and the logical operations in
211 -- the body are simple boolean operations. Note that Typ is always a
212 -- constrained type (the caller has ensured this by using
213 -- Convert_To_Actual_Subtype if necessary).
215 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
216 -- For signed arithmetic operations when the current overflow mode is
217 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
218 -- as the first thing we do. We then return. We count on the recursive
219 -- apparatus for overflow checks to call us back with an equivalent
220 -- operation that is in CHECKED mode, avoiding a recursive entry into this
221 -- routine, and that is when we will proceed with the expansion of the
222 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
223 -- these optimizations without first making this check, since there may be
224 -- operands further down the tree that are relying on the recursive calls
225 -- triggered by the top level nodes to properly process overflow checking
226 -- and remaining expansion on these nodes. Note that this call back may be
227 -- skipped if the operation is done in Bignum mode but that's fine, since
228 -- the Bignum call takes care of everything.
230 procedure Optimize_Length_Comparison (N : Node_Id);
231 -- Given an expression, if it is of the form X'Length op N (or the other
232 -- way round), where N is known at compile time to be 0 or 1, and X is a
233 -- simple entity, and op is a comparison operator, optimizes it into a
234 -- comparison of First and Last.
236 procedure Process_Transient_Object
239 -- Subsidiary routine to the expansion of expression_with_actions and if
240 -- expressions. Generate all the necessary code to finalize a transient
241 -- controlled object when the enclosing context is elaborated or evaluated.
242 -- Decl denotes the declaration of the transient controlled object which is
243 -- usually the result of a controlled function call. Rel_Node denotes the
244 -- context, either an expression_with_actions or an if expression.
246 procedure Rewrite_Comparison (N : Node_Id);
247 -- If N is the node for a comparison whose outcome can be determined at
248 -- compile time, then the node N can be rewritten with True or False. If
249 -- the outcome cannot be determined at compile time, the call has no
250 -- effect. If N is a type conversion, then this processing is applied to
251 -- its expression. If N is neither comparison nor a type conversion, the
252 -- call has no effect.
254 procedure Tagged_Membership
256 SCIL_Node : out Node_Id;
257 Result : out Node_Id);
258 -- Construct the expression corresponding to the tagged membership test.
259 -- Deals with a second operand being (or not) a class-wide type.
261 function Safe_In_Place_Array_Op
264 Op2 : Node_Id) return Boolean;
265 -- In the context of an assignment, where the right-hand side is a boolean
266 -- operation on arrays, check whether operation can be performed in place.
268 procedure Unary_Op_Validity_Checks (N : Node_Id);
269 pragma Inline (Unary_Op_Validity_Checks);
270 -- Performs validity checks for a unary operator
272 -------------------------------
273 -- Binary_Op_Validity_Checks --
274 -------------------------------
276 procedure Binary_Op_Validity_Checks (N : Node_Id) is
278 if Validity_Checks_On and Validity_Check_Operands then
279 Ensure_Valid (Left_Opnd (N));
280 Ensure_Valid (Right_Opnd (N));
282 end Binary_Op_Validity_Checks;
284 ------------------------------------
285 -- Build_Boolean_Array_Proc_Call --
286 ------------------------------------
288 procedure Build_Boolean_Array_Proc_Call
293 Loc : constant Source_Ptr := Sloc (N);
294 Kind : constant Node_Kind := Nkind (Expression (N));
295 Target : constant Node_Id :=
296 Make_Attribute_Reference (Loc,
298 Attribute_Name => Name_Address);
300 Arg1 : Node_Id := Op1;
301 Arg2 : Node_Id := Op2;
303 Proc_Name : Entity_Id;
306 if Kind = N_Op_Not then
307 if Nkind (Op1) in N_Binary_Op then
309 -- Use negated version of the binary operators
311 if Nkind (Op1) = N_Op_And then
312 Proc_Name := RTE (RE_Vector_Nand);
314 elsif Nkind (Op1) = N_Op_Or then
315 Proc_Name := RTE (RE_Vector_Nor);
317 else pragma Assert (Nkind (Op1) = N_Op_Xor);
318 Proc_Name := RTE (RE_Vector_Xor);
322 Make_Procedure_Call_Statement (Loc,
323 Name => New_Occurrence_Of (Proc_Name, Loc),
325 Parameter_Associations => New_List (
327 Make_Attribute_Reference (Loc,
328 Prefix => Left_Opnd (Op1),
329 Attribute_Name => Name_Address),
331 Make_Attribute_Reference (Loc,
332 Prefix => Right_Opnd (Op1),
333 Attribute_Name => Name_Address),
335 Make_Attribute_Reference (Loc,
336 Prefix => Left_Opnd (Op1),
337 Attribute_Name => Name_Length)));
340 Proc_Name := RTE (RE_Vector_Not);
343 Make_Procedure_Call_Statement (Loc,
344 Name => New_Occurrence_Of (Proc_Name, Loc),
345 Parameter_Associations => New_List (
348 Make_Attribute_Reference (Loc,
350 Attribute_Name => Name_Address),
352 Make_Attribute_Reference (Loc,
354 Attribute_Name => Name_Length)));
358 -- We use the following equivalences:
360 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
361 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
362 -- (not X) xor (not Y) = X xor Y
363 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
365 if Nkind (Op1) = N_Op_Not then
366 Arg1 := Right_Opnd (Op1);
367 Arg2 := Right_Opnd (Op2);
369 if Kind = N_Op_And then
370 Proc_Name := RTE (RE_Vector_Nor);
371 elsif Kind = N_Op_Or then
372 Proc_Name := RTE (RE_Vector_Nand);
374 Proc_Name := RTE (RE_Vector_Xor);
378 if Kind = N_Op_And then
379 Proc_Name := RTE (RE_Vector_And);
380 elsif Kind = N_Op_Or then
381 Proc_Name := RTE (RE_Vector_Or);
382 elsif Nkind (Op2) = N_Op_Not then
383 Proc_Name := RTE (RE_Vector_Nxor);
384 Arg2 := Right_Opnd (Op2);
386 Proc_Name := RTE (RE_Vector_Xor);
391 Make_Procedure_Call_Statement (Loc,
392 Name => New_Occurrence_Of (Proc_Name, Loc),
393 Parameter_Associations => New_List (
395 Make_Attribute_Reference (Loc,
397 Attribute_Name => Name_Address),
398 Make_Attribute_Reference (Loc,
400 Attribute_Name => Name_Address),
401 Make_Attribute_Reference (Loc,
403 Attribute_Name => Name_Length)));
406 Rewrite (N, Call_Node);
410 when RE_Not_Available =>
412 end Build_Boolean_Array_Proc_Call;
414 ------------------------------
415 -- Current_Anonymous_Master --
416 ------------------------------
418 function Current_Anonymous_Master return Entity_Id is
426 Unit_Id := Cunit_Entity (Current_Sem_Unit);
428 -- Find the entity of the current unit
430 if Ekind (Unit_Id) = E_Subprogram_Body then
432 -- When processing subprogram bodies, the proper scope is always that
435 Subp_Body := Unit_Id;
436 while Present (Subp_Body)
437 and then Nkind (Subp_Body) /= N_Subprogram_Body
439 Subp_Body := Parent (Subp_Body);
442 Unit_Id := Corresponding_Spec (Subp_Body);
445 Loc := Sloc (Unit_Id);
446 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
448 -- Find the declarations list of the current unit
450 if Nkind (Unit_Decl) = N_Package_Declaration then
451 Unit_Decl := Specification (Unit_Decl);
452 Decls := Visible_Declarations (Unit_Decl);
455 Decls := New_List (Make_Null_Statement (Loc));
456 Set_Visible_Declarations (Unit_Decl, Decls);
458 elsif Is_Empty_List (Decls) then
459 Append_To (Decls, Make_Null_Statement (Loc));
463 Decls := Declarations (Unit_Decl);
466 Decls := New_List (Make_Null_Statement (Loc));
467 Set_Declarations (Unit_Decl, Decls);
469 elsif Is_Empty_List (Decls) then
470 Append_To (Decls, Make_Null_Statement (Loc));
474 -- The current unit has an existing anonymous master, traverse its
475 -- declarations and locate the entity.
477 if Has_Anonymous_Master (Unit_Id) then
480 Fin_Mas_Id : Entity_Id;
483 Decl := First (Decls);
484 while Present (Decl) loop
486 -- Look for the first variable in the declarations whole type
487 -- is Finalization_Master.
489 if Nkind (Decl) = N_Object_Declaration then
490 Fin_Mas_Id := Defining_Identifier (Decl);
492 if Ekind (Fin_Mas_Id) = E_Variable
493 and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
502 -- The master was not found even though the unit was labeled as
508 -- Create a new anonymous master
512 First_Decl : constant Node_Id := First (Decls);
514 Fin_Mas_Id : Entity_Id;
517 -- Since the master and its associated initialization is inserted
518 -- at top level, use the scope of the unit when analyzing.
520 Push_Scope (Unit_Id);
522 -- Create the finalization master
525 Make_Defining_Identifier (Loc,
526 Chars => New_External_Name (Chars (Unit_Id), "AM"));
529 -- <Fin_Mas_Id> : Finalization_Master;
532 Make_Object_Declaration (Loc,
533 Defining_Identifier => Fin_Mas_Id,
535 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
537 Insert_Before_And_Analyze (First_Decl, Action);
539 -- Mark the unit to prevent the generation of multiple masters
541 Set_Has_Anonymous_Master (Unit_Id);
543 -- Do not set the base pool and mode of operation on .NET/JVM
544 -- since those targets do not support pools and all VM masters
545 -- are heterogeneous by default.
547 if VM_Target = No_VM then
551 -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
554 Make_Procedure_Call_Statement (Loc,
556 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
558 Parameter_Associations => New_List (
559 New_Occurrence_Of (Fin_Mas_Id, Loc),
560 Make_Attribute_Reference (Loc,
562 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
563 Attribute_Name => Name_Unrestricted_Access)));
565 Insert_Before_And_Analyze (First_Decl, Action);
568 -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
571 Make_Procedure_Call_Statement (Loc,
573 New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc),
574 Parameter_Associations => New_List (
575 New_Occurrence_Of (Fin_Mas_Id, Loc)));
577 Insert_Before_And_Analyze (First_Decl, Action);
580 -- Restore the original state of the scope stack
587 end Current_Anonymous_Master;
589 --------------------------------
590 -- Displace_Allocator_Pointer --
591 --------------------------------
593 procedure Displace_Allocator_Pointer (N : Node_Id) is
594 Loc : constant Source_Ptr := Sloc (N);
595 Orig_Node : constant Node_Id := Original_Node (N);
601 -- Do nothing in case of VM targets: the virtual machine will handle
602 -- interfaces directly.
604 if not Tagged_Type_Expansion then
608 pragma Assert (Nkind (N) = N_Identifier
609 and then Nkind (Orig_Node) = N_Allocator);
611 PtrT := Etype (Orig_Node);
612 Dtyp := Available_View (Designated_Type (PtrT));
613 Etyp := Etype (Expression (Orig_Node));
615 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
617 -- If the type of the allocator expression is not an interface type
618 -- we can generate code to reference the record component containing
619 -- the pointer to the secondary dispatch table.
621 if not Is_Interface (Etyp) then
623 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
626 -- 1) Get access to the allocated object
629 Make_Explicit_Dereference (Loc, Relocate_Node (N)));
633 -- 2) Add the conversion to displace the pointer to reference
634 -- the secondary dispatch table.
636 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
637 Analyze_And_Resolve (N, Dtyp);
639 -- 3) The 'access to the secondary dispatch table will be used
640 -- as the value returned by the allocator.
643 Make_Attribute_Reference (Loc,
644 Prefix => Relocate_Node (N),
645 Attribute_Name => Name_Access));
646 Set_Etype (N, Saved_Typ);
650 -- If the type of the allocator expression is an interface type we
651 -- generate a run-time call to displace "this" to reference the
652 -- component containing the pointer to the secondary dispatch table
653 -- or else raise Constraint_Error if the actual object does not
654 -- implement the target interface. This case corresponds to the
655 -- following example:
657 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
659 -- return new Iface_2'Class'(Obj);
664 Unchecked_Convert_To (PtrT,
665 Make_Function_Call (Loc,
666 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
667 Parameter_Associations => New_List (
668 Unchecked_Convert_To (RTE (RE_Address),
674 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
676 Analyze_And_Resolve (N, PtrT);
679 end Displace_Allocator_Pointer;
681 ---------------------------------
682 -- Expand_Allocator_Expression --
683 ---------------------------------
685 procedure Expand_Allocator_Expression (N : Node_Id) is
686 Loc : constant Source_Ptr := Sloc (N);
687 Exp : constant Node_Id := Expression (Expression (N));
688 PtrT : constant Entity_Id := Etype (N);
689 DesigT : constant Entity_Id := Designated_Type (PtrT);
691 procedure Apply_Accessibility_Check
693 Built_In_Place : Boolean := False);
694 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
695 -- type, generate an accessibility check to verify that the level of the
696 -- type of the created object is not deeper than the level of the access
697 -- type. If the type of the qualified expression is class-wide, then
698 -- always generate the check (except in the case where it is known to be
699 -- unnecessary, see comment below). Otherwise, only generate the check
700 -- if the level of the qualified expression type is statically deeper
701 -- than the access type.
703 -- Although the static accessibility will generally have been performed
704 -- as a legality check, it won't have been done in cases where the
705 -- allocator appears in generic body, so a run-time check is needed in
706 -- general. One special case is when the access type is declared in the
707 -- same scope as the class-wide allocator, in which case the check can
708 -- never fail, so it need not be generated.
710 -- As an open issue, there seem to be cases where the static level
711 -- associated with the class-wide object's underlying type is not
712 -- sufficient to perform the proper accessibility check, such as for
713 -- allocators in nested subprograms or accept statements initialized by
714 -- class-wide formals when the actual originates outside at a deeper
715 -- static level. The nested subprogram case might require passing
716 -- accessibility levels along with class-wide parameters, and the task
717 -- case seems to be an actual gap in the language rules that needs to
718 -- be fixed by the ARG. ???
720 -------------------------------
721 -- Apply_Accessibility_Check --
722 -------------------------------
724 procedure Apply_Accessibility_Check
726 Built_In_Place : Boolean := False)
728 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
736 if Ada_Version >= Ada_2005
737 and then Is_Class_Wide_Type (DesigT)
738 and then (Tagged_Type_Expansion or else VM_Target /= No_VM)
739 and then not Scope_Suppress.Suppress (Accessibility_Check)
741 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
743 (Is_Class_Wide_Type (Etype (Exp))
744 and then Scope (PtrT) /= Current_Scope))
746 -- If the allocator was built in place, Ref is already a reference
747 -- to the access object initialized to the result of the allocator
748 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
749 -- Remove_Side_Effects for cases where the build-in-place call may
750 -- still be the prefix of the reference (to avoid generating
751 -- duplicate calls). Otherwise, it is the entity associated with
752 -- the object containing the address of the allocated object.
754 if Built_In_Place then
755 Remove_Side_Effects (Ref);
756 Obj_Ref := New_Copy_Tree (Ref);
758 Obj_Ref := New_Occurrence_Of (Ref, Loc);
761 -- Step 1: Create the object clean up code
765 -- Deallocate the object if the accessibility check fails. This
766 -- is done only on targets or profiles that support deallocation.
770 if RTE_Available (RE_Free) then
771 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
772 Set_Storage_Pool (Free_Stmt, Pool_Id);
774 Append_To (Stmts, Free_Stmt);
776 -- The target or profile cannot deallocate objects
782 -- Finalize the object if applicable. Generate:
784 -- [Deep_]Finalize (Obj_Ref.all);
786 if Needs_Finalization (DesigT) then
790 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
793 -- When the target or profile supports deallocation, wrap the
794 -- finalization call in a block to ensure proper deallocation
795 -- even if finalization fails. Generate:
805 if Present (Free_Stmt) then
807 Make_Block_Statement (Loc,
808 Handled_Statement_Sequence =>
809 Make_Handled_Sequence_Of_Statements (Loc,
810 Statements => New_List (Fin_Call),
812 Exception_Handlers => New_List (
813 Make_Exception_Handler (Loc,
814 Exception_Choices => New_List (
815 Make_Others_Choice (Loc)),
817 Statements => New_List (
818 New_Copy_Tree (Free_Stmt),
819 Make_Raise_Statement (Loc))))));
822 Prepend_To (Stmts, Fin_Call);
825 -- Signal the accessibility failure through a Program_Error
828 Make_Raise_Program_Error (Loc,
829 Condition => New_Occurrence_Of (Standard_True, Loc),
830 Reason => PE_Accessibility_Check_Failed));
832 -- Step 2: Create the accessibility comparison
834 -- Reference the tag: for a renaming of an access to an interface
835 -- object Obj_Ref already references the tag of the secondary
838 if Nkind (Obj_Ref) in N_Has_Entity
839 and then Present (Entity (Obj_Ref))
840 and then Present (Renamed_Object (Entity (Obj_Ref)))
841 and then Is_Interface (DesigT)
850 Make_Attribute_Reference (Loc,
852 Attribute_Name => Name_Tag);
855 -- For tagged types, determine the accessibility level by looking
856 -- at the type specific data of the dispatch table. Generate:
858 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
860 if Tagged_Type_Expansion then
861 Cond := Build_Get_Access_Level (Loc, Obj_Ref);
863 -- Use a runtime call to determine the accessibility level when
864 -- compiling on virtual machine targets. Generate:
866 -- Get_Access_Level (Ref'Tag)
870 Make_Function_Call (Loc,
872 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
873 Parameter_Associations => New_List (Obj_Ref));
880 Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
882 -- Due to the complexity and side effects of the check, utilize an
883 -- if statement instead of the regular Program_Error circuitry.
886 Make_Implicit_If_Statement (N,
888 Then_Statements => Stmts));
890 end Apply_Accessibility_Check;
894 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
895 Indic : constant Node_Id := Subtype_Mark (Expression (N));
896 T : constant Entity_Id := Entity (Indic);
898 Tag_Assign : Node_Id;
902 TagT : Entity_Id := Empty;
903 -- Type used as source for tag assignment
905 TagR : Node_Id := Empty;
906 -- Target reference for tag assignment
908 -- Start of processing for Expand_Allocator_Expression
911 -- Handle call to C++ constructor
913 if Is_CPP_Constructor_Call (Exp) then
914 Make_CPP_Constructor_Call_In_Allocator
916 Function_Call => Exp);
920 -- In the case of an Ada 2012 allocator whose initial value comes from a
921 -- function call, pass "the accessibility level determined by the point
922 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
923 -- Expand_Call but it couldn't be done there (because the Etype of the
924 -- allocator wasn't set then) so we generate the parameter here. See
925 -- the Boolean variable Defer in (a block within) Expand_Call.
927 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
932 if Nkind (Name (Exp)) = N_Explicit_Dereference then
933 Subp := Designated_Type (Etype (Prefix (Name (Exp))));
935 Subp := Entity (Name (Exp));
938 Subp := Ultimate_Alias (Subp);
940 if Present (Extra_Accessibility_Of_Result (Subp)) then
941 Add_Extra_Actual_To_Call
942 (Subprogram_Call => Exp,
943 Extra_Formal => Extra_Accessibility_Of_Result (Subp),
944 Extra_Actual => Dynamic_Accessibility_Level (PtrT));
949 -- Case of tagged type or type requiring finalization
951 if Is_Tagged_Type (T) or else Needs_Finalization (T) then
953 -- Ada 2005 (AI-318-02): If the initialization expression is a call
954 -- to a build-in-place function, then access to the allocated object
955 -- must be passed to the function. Currently we limit such functions
956 -- to those with constrained limited result subtypes, but eventually
957 -- we plan to expand the allowed forms of functions that are treated
958 -- as build-in-place.
960 if Ada_Version >= Ada_2005
961 and then Is_Build_In_Place_Function_Call (Exp)
963 Make_Build_In_Place_Call_In_Allocator (N, Exp);
964 Apply_Accessibility_Check (N, Built_In_Place => True);
968 -- Actions inserted before:
969 -- Temp : constant ptr_T := new T'(Expression);
970 -- Temp._tag = T'tag; -- when not class-wide
971 -- [Deep_]Adjust (Temp.all);
973 -- We analyze by hand the new internal allocator to avoid any
974 -- recursion and inappropriate call to Initialize.
976 -- We don't want to remove side effects when the expression must be
977 -- built in place. In the case of a build-in-place function call,
978 -- that could lead to a duplication of the call, which was already
979 -- substituted for the allocator.
981 if not Aggr_In_Place then
982 Remove_Side_Effects (Exp);
985 Temp := Make_Temporary (Loc, 'P', N);
987 -- For a class wide allocation generate the following code:
989 -- type Equiv_Record is record ... end record;
990 -- implicit subtype CW is <Class_Wide_Subytpe>;
991 -- temp : PtrT := new CW'(CW!(expr));
993 if Is_Class_Wide_Type (T) then
994 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
996 -- Ada 2005 (AI-251): If the expression is a class-wide interface
997 -- object we generate code to move up "this" to reference the
998 -- base of the object before allocating the new object.
1000 -- Note that Exp'Address is recursively expanded into a call
1001 -- to Base_Address (Exp.Tag)
1003 if Is_Class_Wide_Type (Etype (Exp))
1004 and then Is_Interface (Etype (Exp))
1005 and then Tagged_Type_Expansion
1009 Unchecked_Convert_To (Entity (Indic),
1010 Make_Explicit_Dereference (Loc,
1011 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
1012 Make_Attribute_Reference (Loc,
1014 Attribute_Name => Name_Address)))));
1018 Unchecked_Convert_To (Entity (Indic), Exp));
1021 Analyze_And_Resolve (Expression (N), Entity (Indic));
1024 -- Processing for allocators returning non-interface types
1026 if not Is_Interface (Directly_Designated_Type (PtrT)) then
1027 if Aggr_In_Place then
1029 Make_Object_Declaration (Loc,
1030 Defining_Identifier => Temp,
1031 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1033 Make_Allocator (Loc,
1035 New_Occurrence_Of (Etype (Exp), Loc)));
1037 -- Copy the Comes_From_Source flag for the allocator we just
1038 -- built, since logically this allocator is a replacement of
1039 -- the original allocator node. This is for proper handling of
1040 -- restriction No_Implicit_Heap_Allocations.
1042 Set_Comes_From_Source
1043 (Expression (Temp_Decl), Comes_From_Source (N));
1045 Set_No_Initialization (Expression (Temp_Decl));
1046 Insert_Action (N, Temp_Decl);
1048 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1049 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1051 -- Attach the object to the associated finalization master.
1052 -- This is done manually on .NET/JVM since those compilers do
1053 -- no support pools and can't benefit from internally generated
1054 -- Allocate / Deallocate procedures.
1056 if VM_Target /= No_VM
1057 and then Is_Controlled (DesigT)
1058 and then Present (Finalization_Master (PtrT))
1062 Obj_Ref => New_Occurrence_Of (Temp, Loc),
1067 Node := Relocate_Node (N);
1068 Set_Analyzed (Node);
1071 Make_Object_Declaration (Loc,
1072 Defining_Identifier => Temp,
1073 Constant_Present => True,
1074 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1075 Expression => Node);
1077 Insert_Action (N, Temp_Decl);
1078 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1080 -- Attach the object to the associated finalization master.
1081 -- This is done manually on .NET/JVM since those compilers do
1082 -- no support pools and can't benefit from internally generated
1083 -- Allocate / Deallocate procedures.
1085 if VM_Target /= No_VM
1086 and then Is_Controlled (DesigT)
1087 and then Present (Finalization_Master (PtrT))
1092 New_Occurrence_Of (Temp, Loc),
1097 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1098 -- interface type. In this case we use the type of the qualified
1099 -- expression to allocate the object.
1103 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
1108 Make_Full_Type_Declaration (Loc,
1109 Defining_Identifier => Def_Id,
1111 Make_Access_To_Object_Definition (Loc,
1112 All_Present => True,
1113 Null_Exclusion_Present => False,
1115 Is_Access_Constant (Etype (N)),
1116 Subtype_Indication =>
1117 New_Occurrence_Of (Etype (Exp), Loc)));
1119 Insert_Action (N, New_Decl);
1121 -- Inherit the allocation-related attributes from the original
1124 Set_Finalization_Master (Def_Id, Finalization_Master (PtrT));
1126 Set_Associated_Storage_Pool (Def_Id,
1127 Associated_Storage_Pool (PtrT));
1129 -- Declare the object using the previous type declaration
1131 if Aggr_In_Place then
1133 Make_Object_Declaration (Loc,
1134 Defining_Identifier => Temp,
1135 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1137 Make_Allocator (Loc,
1138 New_Occurrence_Of (Etype (Exp), Loc)));
1140 -- Copy the Comes_From_Source flag for the allocator we just
1141 -- built, since logically this allocator is a replacement of
1142 -- the original allocator node. This is for proper handling
1143 -- of restriction No_Implicit_Heap_Allocations.
1145 Set_Comes_From_Source
1146 (Expression (Temp_Decl), Comes_From_Source (N));
1148 Set_No_Initialization (Expression (Temp_Decl));
1149 Insert_Action (N, Temp_Decl);
1151 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1152 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1155 Node := Relocate_Node (N);
1156 Set_Analyzed (Node);
1159 Make_Object_Declaration (Loc,
1160 Defining_Identifier => Temp,
1161 Constant_Present => True,
1162 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1163 Expression => Node);
1165 Insert_Action (N, Temp_Decl);
1166 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1169 -- Generate an additional object containing the address of the
1170 -- returned object. The type of this second object declaration
1171 -- is the correct type required for the common processing that
1172 -- is still performed by this subprogram. The displacement of
1173 -- this pointer to reference the component associated with the
1174 -- interface type will be done at the end of common processing.
1177 Make_Object_Declaration (Loc,
1178 Defining_Identifier => Make_Temporary (Loc, 'P'),
1179 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1181 Unchecked_Convert_To (PtrT,
1182 New_Occurrence_Of (Temp, Loc)));
1184 Insert_Action (N, New_Decl);
1186 Temp_Decl := New_Decl;
1187 Temp := Defining_Identifier (New_Decl);
1191 Apply_Accessibility_Check (Temp);
1193 -- Generate the tag assignment
1195 -- Suppress the tag assignment when VM_Target because VM tags are
1196 -- represented implicitly in objects.
1198 if not Tagged_Type_Expansion then
1201 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1202 -- interface objects because in this case the tag does not change.
1204 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1205 pragma Assert (Is_Class_Wide_Type
1206 (Directly_Designated_Type (Etype (N))));
1209 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1211 TagR := New_Occurrence_Of (Temp, Loc);
1213 elsif Is_Private_Type (T)
1214 and then Is_Tagged_Type (Underlying_Type (T))
1216 TagT := Underlying_Type (T);
1218 Unchecked_Convert_To (Underlying_Type (T),
1219 Make_Explicit_Dereference (Loc,
1220 Prefix => New_Occurrence_Of (Temp, Loc)));
1223 if Present (TagT) then
1225 Full_T : constant Entity_Id := Underlying_Type (TagT);
1229 Make_Assignment_Statement (Loc,
1231 Make_Selected_Component (Loc,
1235 (First_Tag_Component (Full_T), Loc)),
1238 Unchecked_Convert_To (RTE (RE_Tag),
1241 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1244 -- The previous assignment has to be done in any case
1246 Set_Assignment_OK (Name (Tag_Assign));
1247 Insert_Action (N, Tag_Assign);
1250 if Needs_Finalization (DesigT) and then Needs_Finalization (T) then
1252 -- Generate an Adjust call if the object will be moved. In Ada
1253 -- 2005, the object may be inherently limited, in which case
1254 -- there is no Adjust procedure, and the object is built in
1255 -- place. In Ada 95, the object can be limited but not
1256 -- inherently limited if this allocator came from a return
1257 -- statement (we're allocating the result on the secondary
1258 -- stack). In that case, the object will be moved, so we _do_
1261 if not Aggr_In_Place
1262 and then not Is_Limited_View (T)
1266 -- An unchecked conversion is needed in the classwide case
1267 -- because the designated type can be an ancestor of the
1268 -- subtype mark of the allocator.
1272 Unchecked_Convert_To (T,
1273 Make_Explicit_Dereference (Loc,
1274 Prefix => New_Occurrence_Of (Temp, Loc))),
1279 -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1281 -- Do not generate this call in the following cases:
1283 -- * .NET/JVM - these targets do not support address arithmetic
1284 -- and unchecked conversion, key elements of Finalize_Address.
1286 -- * CodePeer mode - TSS primitive Finalize_Address is not
1287 -- created in this mode.
1289 if VM_Target = No_VM
1290 and then not CodePeer_Mode
1291 and then Present (Finalization_Master (PtrT))
1292 and then Present (Temp_Decl)
1293 and then Nkind (Expression (Temp_Decl)) = N_Allocator
1296 Make_Set_Finalize_Address_Call
1303 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1304 Analyze_And_Resolve (N, PtrT);
1306 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1307 -- component containing the secondary dispatch table of the interface
1310 if Is_Interface (Directly_Designated_Type (PtrT)) then
1311 Displace_Allocator_Pointer (N);
1314 elsif Aggr_In_Place then
1315 Temp := Make_Temporary (Loc, 'P', N);
1317 Make_Object_Declaration (Loc,
1318 Defining_Identifier => Temp,
1319 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1321 Make_Allocator (Loc,
1322 Expression => New_Occurrence_Of (Etype (Exp), Loc)));
1324 -- Copy the Comes_From_Source flag for the allocator we just built,
1325 -- since logically this allocator is a replacement of the original
1326 -- allocator node. This is for proper handling of restriction
1327 -- No_Implicit_Heap_Allocations.
1329 Set_Comes_From_Source
1330 (Expression (Temp_Decl), Comes_From_Source (N));
1332 Set_No_Initialization (Expression (Temp_Decl));
1333 Insert_Action (N, Temp_Decl);
1335 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1336 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1338 -- Attach the object to the associated finalization master. Thisis
1339 -- done manually on .NET/JVM since those compilers do no support
1340 -- pools and cannot benefit from internally generated Allocate and
1341 -- Deallocate procedures.
1343 if VM_Target /= No_VM
1344 and then Is_Controlled (DesigT)
1345 and then Present (Finalization_Master (PtrT))
1349 (Obj_Ref => New_Occurrence_Of (Temp, Loc),
1353 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1354 Analyze_And_Resolve (N, PtrT);
1356 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
1357 Install_Null_Excluding_Check (Exp);
1359 elsif Is_Access_Type (DesigT)
1360 and then Nkind (Exp) = N_Allocator
1361 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1363 -- Apply constraint to designated subtype indication
1365 Apply_Constraint_Check (Expression (Exp),
1366 Designated_Type (DesigT),
1367 No_Sliding => True);
1369 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1371 -- Propagate constraint_error to enclosing allocator
1373 Rewrite (Exp, New_Copy (Expression (Exp)));
1377 Build_Allocate_Deallocate_Proc (N, True);
1380 -- type A is access T1;
1381 -- X : A := new T2'(...);
1382 -- T1 and T2 can be different subtypes, and we might need to check
1383 -- both constraints. First check against the type of the qualified
1386 Apply_Constraint_Check (Exp, T, No_Sliding => True);
1388 if Do_Range_Check (Exp) then
1389 Set_Do_Range_Check (Exp, False);
1390 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1393 -- A check is also needed in cases where the designated subtype is
1394 -- constrained and differs from the subtype given in the qualified
1395 -- expression. Note that the check on the qualified expression does
1396 -- not allow sliding, but this check does (a relaxation from Ada 83).
1398 if Is_Constrained (DesigT)
1399 and then not Subtypes_Statically_Match (T, DesigT)
1401 Apply_Constraint_Check
1402 (Exp, DesigT, No_Sliding => False);
1404 if Do_Range_Check (Exp) then
1405 Set_Do_Range_Check (Exp, False);
1406 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1410 -- For an access to unconstrained packed array, GIGI needs to see an
1411 -- expression with a constrained subtype in order to compute the
1412 -- proper size for the allocator.
1414 if Is_Array_Type (T)
1415 and then not Is_Constrained (T)
1416 and then Is_Packed (T)
1419 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
1420 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1423 Make_Subtype_Declaration (Loc,
1424 Defining_Identifier => ConstrT,
1425 Subtype_Indication =>
1426 Make_Subtype_From_Expr (Internal_Exp, T)));
1427 Freeze_Itype (ConstrT, Exp);
1428 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1432 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1433 -- to a build-in-place function, then access to the allocated object
1434 -- must be passed to the function. Currently we limit such functions
1435 -- to those with constrained limited result subtypes, but eventually
1436 -- we plan to expand the allowed forms of functions that are treated
1437 -- as build-in-place.
1439 if Ada_Version >= Ada_2005
1440 and then Is_Build_In_Place_Function_Call (Exp)
1442 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1447 when RE_Not_Available =>
1449 end Expand_Allocator_Expression;
1451 -----------------------------
1452 -- Expand_Array_Comparison --
1453 -----------------------------
1455 -- Expansion is only required in the case of array types. For the unpacked
1456 -- case, an appropriate runtime routine is called. For packed cases, and
1457 -- also in some other cases where a runtime routine cannot be called, the
1458 -- form of the expansion is:
1460 -- [body for greater_nn; boolean_expression]
1462 -- The body is built by Make_Array_Comparison_Op, and the form of the
1463 -- Boolean expression depends on the operator involved.
1465 procedure Expand_Array_Comparison (N : Node_Id) is
1466 Loc : constant Source_Ptr := Sloc (N);
1467 Op1 : Node_Id := Left_Opnd (N);
1468 Op2 : Node_Id := Right_Opnd (N);
1469 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1470 Ctyp : constant Entity_Id := Component_Type (Typ1);
1473 Func_Body : Node_Id;
1474 Func_Name : Entity_Id;
1478 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1479 -- True for byte addressable target
1481 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1482 -- Returns True if the length of the given operand is known to be less
1483 -- than 4. Returns False if this length is known to be four or greater
1484 -- or is not known at compile time.
1486 ------------------------
1487 -- Length_Less_Than_4 --
1488 ------------------------
1490 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1491 Otyp : constant Entity_Id := Etype (Opnd);
1494 if Ekind (Otyp) = E_String_Literal_Subtype then
1495 return String_Literal_Length (Otyp) < 4;
1499 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1500 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1501 Hi : constant Node_Id := Type_High_Bound (Ityp);
1506 if Compile_Time_Known_Value (Lo) then
1507 Lov := Expr_Value (Lo);
1512 if Compile_Time_Known_Value (Hi) then
1513 Hiv := Expr_Value (Hi);
1518 return Hiv < Lov + 3;
1521 end Length_Less_Than_4;
1523 -- Start of processing for Expand_Array_Comparison
1526 -- Deal first with unpacked case, where we can call a runtime routine
1527 -- except that we avoid this for targets for which are not addressable
1528 -- by bytes, and for the JVM/CIL, since they do not support direct
1529 -- addressing of array components.
1531 if not Is_Bit_Packed_Array (Typ1)
1532 and then Byte_Addressable
1533 and then VM_Target = No_VM
1535 -- The call we generate is:
1537 -- Compare_Array_xn[_Unaligned]
1538 -- (left'address, right'address, left'length, right'length) <op> 0
1540 -- x = U for unsigned, S for signed
1541 -- n = 8,16,32,64 for component size
1542 -- Add _Unaligned if length < 4 and component size is 8.
1543 -- <op> is the standard comparison operator
1545 if Component_Size (Typ1) = 8 then
1546 if Length_Less_Than_4 (Op1)
1548 Length_Less_Than_4 (Op2)
1550 if Is_Unsigned_Type (Ctyp) then
1551 Comp := RE_Compare_Array_U8_Unaligned;
1553 Comp := RE_Compare_Array_S8_Unaligned;
1557 if Is_Unsigned_Type (Ctyp) then
1558 Comp := RE_Compare_Array_U8;
1560 Comp := RE_Compare_Array_S8;
1564 elsif Component_Size (Typ1) = 16 then
1565 if Is_Unsigned_Type (Ctyp) then
1566 Comp := RE_Compare_Array_U16;
1568 Comp := RE_Compare_Array_S16;
1571 elsif Component_Size (Typ1) = 32 then
1572 if Is_Unsigned_Type (Ctyp) then
1573 Comp := RE_Compare_Array_U32;
1575 Comp := RE_Compare_Array_S32;
1578 else pragma Assert (Component_Size (Typ1) = 64);
1579 if Is_Unsigned_Type (Ctyp) then
1580 Comp := RE_Compare_Array_U64;
1582 Comp := RE_Compare_Array_S64;
1586 Remove_Side_Effects (Op1, Name_Req => True);
1587 Remove_Side_Effects (Op2, Name_Req => True);
1590 Make_Function_Call (Sloc (Op1),
1591 Name => New_Occurrence_Of (RTE (Comp), Loc),
1593 Parameter_Associations => New_List (
1594 Make_Attribute_Reference (Loc,
1595 Prefix => Relocate_Node (Op1),
1596 Attribute_Name => Name_Address),
1598 Make_Attribute_Reference (Loc,
1599 Prefix => Relocate_Node (Op2),
1600 Attribute_Name => Name_Address),
1602 Make_Attribute_Reference (Loc,
1603 Prefix => Relocate_Node (Op1),
1604 Attribute_Name => Name_Length),
1606 Make_Attribute_Reference (Loc,
1607 Prefix => Relocate_Node (Op2),
1608 Attribute_Name => Name_Length))));
1611 Make_Integer_Literal (Sloc (Op2),
1614 Analyze_And_Resolve (Op1, Standard_Integer);
1615 Analyze_And_Resolve (Op2, Standard_Integer);
1619 -- Cases where we cannot make runtime call
1621 -- For (a <= b) we convert to not (a > b)
1623 if Chars (N) = Name_Op_Le then
1629 Right_Opnd => Op2)));
1630 Analyze_And_Resolve (N, Standard_Boolean);
1633 -- For < the Boolean expression is
1634 -- greater__nn (op2, op1)
1636 elsif Chars (N) = Name_Op_Lt then
1637 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1641 Op1 := Right_Opnd (N);
1642 Op2 := Left_Opnd (N);
1644 -- For (a >= b) we convert to not (a < b)
1646 elsif Chars (N) = Name_Op_Ge then
1652 Right_Opnd => Op2)));
1653 Analyze_And_Resolve (N, Standard_Boolean);
1656 -- For > the Boolean expression is
1657 -- greater__nn (op1, op2)
1660 pragma Assert (Chars (N) = Name_Op_Gt);
1661 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1664 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1666 Make_Function_Call (Loc,
1667 Name => New_Occurrence_Of (Func_Name, Loc),
1668 Parameter_Associations => New_List (Op1, Op2));
1670 Insert_Action (N, Func_Body);
1672 Analyze_And_Resolve (N, Standard_Boolean);
1675 when RE_Not_Available =>
1677 end Expand_Array_Comparison;
1679 ---------------------------
1680 -- Expand_Array_Equality --
1681 ---------------------------
1683 -- Expand an equality function for multi-dimensional arrays. Here is an
1684 -- example of such a function for Nb_Dimension = 2
1686 -- function Enn (A : atyp; B : btyp) return boolean is
1688 -- if (A'length (1) = 0 or else A'length (2) = 0)
1690 -- (B'length (1) = 0 or else B'length (2) = 0)
1692 -- return True; -- RM 4.5.2(22)
1695 -- if A'length (1) /= B'length (1)
1697 -- A'length (2) /= B'length (2)
1699 -- return False; -- RM 4.5.2(23)
1703 -- A1 : Index_T1 := A'first (1);
1704 -- B1 : Index_T1 := B'first (1);
1708 -- A2 : Index_T2 := A'first (2);
1709 -- B2 : Index_T2 := B'first (2);
1712 -- if A (A1, A2) /= B (B1, B2) then
1716 -- exit when A2 = A'last (2);
1717 -- A2 := Index_T2'succ (A2);
1718 -- B2 := Index_T2'succ (B2);
1722 -- exit when A1 = A'last (1);
1723 -- A1 := Index_T1'succ (A1);
1724 -- B1 := Index_T1'succ (B1);
1731 -- Note on the formal types used (atyp and btyp). If either of the arrays
1732 -- is of a private type, we use the underlying type, and do an unchecked
1733 -- conversion of the actual. If either of the arrays has a bound depending
1734 -- on a discriminant, then we use the base type since otherwise we have an
1735 -- escaped discriminant in the function.
1737 -- If both arrays are constrained and have the same bounds, we can generate
1738 -- a loop with an explicit iteration scheme using a 'Range attribute over
1741 function Expand_Array_Equality
1746 Typ : Entity_Id) return Node_Id
1748 Loc : constant Source_Ptr := Sloc (Nod);
1749 Decls : constant List_Id := New_List;
1750 Index_List1 : constant List_Id := New_List;
1751 Index_List2 : constant List_Id := New_List;
1755 Func_Name : Entity_Id;
1756 Func_Body : Node_Id;
1758 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1759 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1763 -- The parameter types to be used for the formals
1768 Num : Int) return Node_Id;
1769 -- This builds the attribute reference Arr'Nam (Expr)
1771 function Component_Equality (Typ : Entity_Id) return Node_Id;
1772 -- Create one statement to compare corresponding components, designated
1773 -- by a full set of indexes.
1775 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1776 -- Given one of the arguments, computes the appropriate type to be used
1777 -- for that argument in the corresponding function formal
1779 function Handle_One_Dimension
1781 Index : Node_Id) return Node_Id;
1782 -- This procedure returns the following code
1785 -- Bn : Index_T := B'First (N);
1789 -- exit when An = A'Last (N);
1790 -- An := Index_T'Succ (An)
1791 -- Bn := Index_T'Succ (Bn)
1795 -- If both indexes are constrained and identical, the procedure
1796 -- returns a simpler loop:
1798 -- for An in A'Range (N) loop
1802 -- N is the dimension for which we are generating a loop. Index is the
1803 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1804 -- xxx statement is either the loop or declare for the next dimension
1805 -- or if this is the last dimension the comparison of corresponding
1806 -- components of the arrays.
1808 -- The actual way the code works is to return the comparison of
1809 -- corresponding components for the N+1 call. That's neater.
1811 function Test_Empty_Arrays return Node_Id;
1812 -- This function constructs the test for both arrays being empty
1813 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1815 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1817 function Test_Lengths_Correspond return Node_Id;
1818 -- This function constructs the test for arrays having different lengths
1819 -- in at least one index position, in which case the resulting code is:
1821 -- A'length (1) /= B'length (1)
1823 -- A'length (2) /= B'length (2)
1834 Num : Int) return Node_Id
1838 Make_Attribute_Reference (Loc,
1839 Attribute_Name => Nam,
1840 Prefix => New_Occurrence_Of (Arr, Loc),
1841 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1844 ------------------------
1845 -- Component_Equality --
1846 ------------------------
1848 function Component_Equality (Typ : Entity_Id) return Node_Id is
1853 -- if a(i1...) /= b(j1...) then return false; end if;
1856 Make_Indexed_Component (Loc,
1857 Prefix => Make_Identifier (Loc, Chars (A)),
1858 Expressions => Index_List1);
1861 Make_Indexed_Component (Loc,
1862 Prefix => Make_Identifier (Loc, Chars (B)),
1863 Expressions => Index_List2);
1865 Test := Expand_Composite_Equality
1866 (Nod, Component_Type (Typ), L, R, Decls);
1868 -- If some (sub)component is an unchecked_union, the whole operation
1869 -- will raise program error.
1871 if Nkind (Test) = N_Raise_Program_Error then
1873 -- This node is going to be inserted at a location where a
1874 -- statement is expected: clear its Etype so analysis will set
1875 -- it to the expected Standard_Void_Type.
1877 Set_Etype (Test, Empty);
1882 Make_Implicit_If_Statement (Nod,
1883 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1884 Then_Statements => New_List (
1885 Make_Simple_Return_Statement (Loc,
1886 Expression => New_Occurrence_Of (Standard_False, Loc))));
1888 end Component_Equality;
1894 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1905 T := Underlying_Type (T);
1907 X := First_Index (T);
1908 while Present (X) loop
1909 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1911 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1924 --------------------------
1925 -- Handle_One_Dimension --
1926 ---------------------------
1928 function Handle_One_Dimension
1930 Index : Node_Id) return Node_Id
1932 Need_Separate_Indexes : constant Boolean :=
1933 Ltyp /= Rtyp or else not Is_Constrained (Ltyp);
1934 -- If the index types are identical, and we are working with
1935 -- constrained types, then we can use the same index for both
1938 An : constant Entity_Id := Make_Temporary (Loc, 'A');
1941 Index_T : Entity_Id;
1946 if N > Number_Dimensions (Ltyp) then
1947 return Component_Equality (Ltyp);
1950 -- Case where we generate a loop
1952 Index_T := Base_Type (Etype (Index));
1954 if Need_Separate_Indexes then
1955 Bn := Make_Temporary (Loc, 'B');
1960 Append (New_Occurrence_Of (An, Loc), Index_List1);
1961 Append (New_Occurrence_Of (Bn, Loc), Index_List2);
1963 Stm_List := New_List (
1964 Handle_One_Dimension (N + 1, Next_Index (Index)));
1966 if Need_Separate_Indexes then
1968 -- Generate guard for loop, followed by increments of indexes
1970 Append_To (Stm_List,
1971 Make_Exit_Statement (Loc,
1974 Left_Opnd => New_Occurrence_Of (An, Loc),
1975 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1977 Append_To (Stm_List,
1978 Make_Assignment_Statement (Loc,
1979 Name => New_Occurrence_Of (An, Loc),
1981 Make_Attribute_Reference (Loc,
1982 Prefix => New_Occurrence_Of (Index_T, Loc),
1983 Attribute_Name => Name_Succ,
1984 Expressions => New_List (
1985 New_Occurrence_Of (An, Loc)))));
1987 Append_To (Stm_List,
1988 Make_Assignment_Statement (Loc,
1989 Name => New_Occurrence_Of (Bn, Loc),
1991 Make_Attribute_Reference (Loc,
1992 Prefix => New_Occurrence_Of (Index_T, Loc),
1993 Attribute_Name => Name_Succ,
1994 Expressions => New_List (
1995 New_Occurrence_Of (Bn, Loc)))));
1998 -- If separate indexes, we need a declare block for An and Bn, and a
1999 -- loop without an iteration scheme.
2001 if Need_Separate_Indexes then
2003 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
2006 Make_Block_Statement (Loc,
2007 Declarations => New_List (
2008 Make_Object_Declaration (Loc,
2009 Defining_Identifier => An,
2010 Object_Definition => New_Occurrence_Of (Index_T, Loc),
2011 Expression => Arr_Attr (A, Name_First, N)),
2013 Make_Object_Declaration (Loc,
2014 Defining_Identifier => Bn,
2015 Object_Definition => New_Occurrence_Of (Index_T, Loc),
2016 Expression => Arr_Attr (B, Name_First, N))),
2018 Handled_Statement_Sequence =>
2019 Make_Handled_Sequence_Of_Statements (Loc,
2020 Statements => New_List (Loop_Stm)));
2022 -- If no separate indexes, return loop statement with explicit
2023 -- iteration scheme on its own
2027 Make_Implicit_Loop_Statement (Nod,
2028 Statements => Stm_List,
2030 Make_Iteration_Scheme (Loc,
2031 Loop_Parameter_Specification =>
2032 Make_Loop_Parameter_Specification (Loc,
2033 Defining_Identifier => An,
2034 Discrete_Subtype_Definition =>
2035 Arr_Attr (A, Name_Range, N))));
2038 end Handle_One_Dimension;
2040 -----------------------
2041 -- Test_Empty_Arrays --
2042 -----------------------
2044 function Test_Empty_Arrays return Node_Id is
2054 for J in 1 .. Number_Dimensions (Ltyp) loop
2057 Left_Opnd => Arr_Attr (A, Name_Length, J),
2058 Right_Opnd => Make_Integer_Literal (Loc, 0));
2062 Left_Opnd => Arr_Attr (B, Name_Length, J),
2063 Right_Opnd => Make_Integer_Literal (Loc, 0));
2072 Left_Opnd => Relocate_Node (Alist),
2073 Right_Opnd => Atest);
2077 Left_Opnd => Relocate_Node (Blist),
2078 Right_Opnd => Btest);
2085 Right_Opnd => Blist);
2086 end Test_Empty_Arrays;
2088 -----------------------------
2089 -- Test_Lengths_Correspond --
2090 -----------------------------
2092 function Test_Lengths_Correspond return Node_Id is
2098 for J in 1 .. Number_Dimensions (Ltyp) loop
2101 Left_Opnd => Arr_Attr (A, Name_Length, J),
2102 Right_Opnd => Arr_Attr (B, Name_Length, J));
2109 Left_Opnd => Relocate_Node (Result),
2110 Right_Opnd => Rtest);
2115 end Test_Lengths_Correspond;
2117 -- Start of processing for Expand_Array_Equality
2120 Ltyp := Get_Arg_Type (Lhs);
2121 Rtyp := Get_Arg_Type (Rhs);
2123 -- For now, if the argument types are not the same, go to the base type,
2124 -- since the code assumes that the formals have the same type. This is
2125 -- fixable in future ???
2127 if Ltyp /= Rtyp then
2128 Ltyp := Base_Type (Ltyp);
2129 Rtyp := Base_Type (Rtyp);
2130 pragma Assert (Ltyp = Rtyp);
2133 -- Build list of formals for function
2135 Formals := New_List (
2136 Make_Parameter_Specification (Loc,
2137 Defining_Identifier => A,
2138 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)),
2140 Make_Parameter_Specification (Loc,
2141 Defining_Identifier => B,
2142 Parameter_Type => New_Occurrence_Of (Rtyp, Loc)));
2144 Func_Name := Make_Temporary (Loc, 'E');
2146 -- Build statement sequence for function
2149 Make_Subprogram_Body (Loc,
2151 Make_Function_Specification (Loc,
2152 Defining_Unit_Name => Func_Name,
2153 Parameter_Specifications => Formals,
2154 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
2156 Declarations => Decls,
2158 Handled_Statement_Sequence =>
2159 Make_Handled_Sequence_Of_Statements (Loc,
2160 Statements => New_List (
2162 Make_Implicit_If_Statement (Nod,
2163 Condition => Test_Empty_Arrays,
2164 Then_Statements => New_List (
2165 Make_Simple_Return_Statement (Loc,
2167 New_Occurrence_Of (Standard_True, Loc)))),
2169 Make_Implicit_If_Statement (Nod,
2170 Condition => Test_Lengths_Correspond,
2171 Then_Statements => New_List (
2172 Make_Simple_Return_Statement (Loc,
2174 New_Occurrence_Of (Standard_False, Loc)))),
2176 Handle_One_Dimension (1, First_Index (Ltyp)),
2178 Make_Simple_Return_Statement (Loc,
2179 Expression => New_Occurrence_Of (Standard_True, Loc)))));
2181 Set_Has_Completion (Func_Name, True);
2182 Set_Is_Inlined (Func_Name);
2184 -- If the array type is distinct from the type of the arguments, it
2185 -- is the full view of a private type. Apply an unchecked conversion
2186 -- to insure that analysis of the call succeeds.
2196 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
2198 L := OK_Convert_To (Ltyp, Lhs);
2202 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
2204 R := OK_Convert_To (Rtyp, Rhs);
2207 Actuals := New_List (L, R);
2210 Append_To (Bodies, Func_Body);
2213 Make_Function_Call (Loc,
2214 Name => New_Occurrence_Of (Func_Name, Loc),
2215 Parameter_Associations => Actuals);
2216 end Expand_Array_Equality;
2218 -----------------------------
2219 -- Expand_Boolean_Operator --
2220 -----------------------------
2222 -- Note that we first get the actual subtypes of the operands, since we
2223 -- always want to deal with types that have bounds.
2225 procedure Expand_Boolean_Operator (N : Node_Id) is
2226 Typ : constant Entity_Id := Etype (N);
2229 -- Special case of bit packed array where both operands are known to be
2230 -- properly aligned. In this case we use an efficient run time routine
2231 -- to carry out the operation (see System.Bit_Ops).
2233 if Is_Bit_Packed_Array (Typ)
2234 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2235 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2237 Expand_Packed_Boolean_Operator (N);
2241 -- For the normal non-packed case, the general expansion is to build
2242 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2243 -- and then inserting it into the tree. The original operator node is
2244 -- then rewritten as a call to this function. We also use this in the
2245 -- packed case if either operand is a possibly unaligned object.
2248 Loc : constant Source_Ptr := Sloc (N);
2249 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2250 R : constant Node_Id := Relocate_Node (Right_Opnd (N));
2251 Func_Body : Node_Id;
2252 Func_Name : Entity_Id;
2255 Convert_To_Actual_Subtype (L);
2256 Convert_To_Actual_Subtype (R);
2257 Ensure_Defined (Etype (L), N);
2258 Ensure_Defined (Etype (R), N);
2259 Apply_Length_Check (R, Etype (L));
2261 if Nkind (N) = N_Op_Xor then
2262 Silly_Boolean_Array_Xor_Test (N, Etype (L));
2265 if Nkind (Parent (N)) = N_Assignment_Statement
2266 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2268 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2270 elsif Nkind (Parent (N)) = N_Op_Not
2271 and then Nkind (N) = N_Op_And
2273 Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2278 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2279 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2280 Insert_Action (N, Func_Body);
2282 -- Now rewrite the expression with a call
2285 Make_Function_Call (Loc,
2286 Name => New_Occurrence_Of (Func_Name, Loc),
2287 Parameter_Associations =>
2290 Make_Type_Conversion
2291 (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
2293 Analyze_And_Resolve (N, Typ);
2296 end Expand_Boolean_Operator;
2298 ------------------------------------------------
2299 -- Expand_Compare_Minimize_Eliminate_Overflow --
2300 ------------------------------------------------
2302 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2303 Loc : constant Source_Ptr := Sloc (N);
2305 Result_Type : constant Entity_Id := Etype (N);
2306 -- Capture result type (could be a derived boolean type)
2311 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2312 -- Entity for Long_Long_Integer'Base
2314 Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
2315 -- Current overflow checking mode
2318 procedure Set_False;
2319 -- These procedures rewrite N with an occurrence of Standard_True or
2320 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2326 procedure Set_False is
2328 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2329 Warn_On_Known_Condition (N);
2336 procedure Set_True is
2338 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2339 Warn_On_Known_Condition (N);
2342 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2345 -- Nothing to do unless we have a comparison operator with operands
2346 -- that are signed integer types, and we are operating in either
2347 -- MINIMIZED or ELIMINATED overflow checking mode.
2349 if Nkind (N) not in N_Op_Compare
2350 or else Check not in Minimized_Or_Eliminated
2351 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
2356 -- OK, this is the case we are interested in. First step is to process
2357 -- our operands using the Minimize_Eliminate circuitry which applies
2358 -- this processing to the two operand subtrees.
2360 Minimize_Eliminate_Overflows
2361 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
2362 Minimize_Eliminate_Overflows
2363 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
2365 -- See if the range information decides the result of the comparison.
2366 -- We can only do this if we in fact have full range information (which
2367 -- won't be the case if either operand is bignum at this stage).
2369 if Llo /= No_Uint and then Rlo /= No_Uint then
2370 case N_Op_Compare (Nkind (N)) is
2372 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2374 elsif Llo > Rhi or else Lhi < Rlo then
2381 elsif Lhi < Rlo then
2388 elsif Lhi <= Rlo then
2395 elsif Lhi <= Rlo then
2402 elsif Lhi < Rlo then
2407 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2409 elsif Llo > Rhi or else Lhi < Rlo then
2414 -- All done if we did the rewrite
2416 if Nkind (N) not in N_Op_Compare then
2421 -- Otherwise, time to do the comparison
2424 Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2425 Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2428 -- If the two operands have the same signed integer type we are
2429 -- all set, nothing more to do. This is the case where either
2430 -- both operands were unchanged, or we rewrote both of them to
2431 -- be Long_Long_Integer.
2433 -- Note: Entity for the comparison may be wrong, but it's not worth
2434 -- the effort to change it, since the back end does not use it.
2436 if Is_Signed_Integer_Type (Ltype)
2437 and then Base_Type (Ltype) = Base_Type (Rtype)
2441 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2443 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2445 Left : Node_Id := Left_Opnd (N);
2446 Right : Node_Id := Right_Opnd (N);
2447 -- Bignum references for left and right operands
2450 if not Is_RTE (Ltype, RE_Bignum) then
2451 Left := Convert_To_Bignum (Left);
2452 elsif not Is_RTE (Rtype, RE_Bignum) then
2453 Right := Convert_To_Bignum (Right);
2456 -- We rewrite our node with:
2459 -- Bnn : Result_Type;
2461 -- M : Mark_Id := SS_Mark;
2463 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2471 Blk : constant Node_Id := Make_Bignum_Block (Loc);
2472 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2476 case N_Op_Compare (Nkind (N)) is
2477 when N_Op_Eq => Ent := RE_Big_EQ;
2478 when N_Op_Ge => Ent := RE_Big_GE;
2479 when N_Op_Gt => Ent := RE_Big_GT;
2480 when N_Op_Le => Ent := RE_Big_LE;
2481 when N_Op_Lt => Ent := RE_Big_LT;
2482 when N_Op_Ne => Ent := RE_Big_NE;
2485 -- Insert assignment to Bnn into the bignum block
2488 (First (Statements (Handled_Statement_Sequence (Blk))),
2489 Make_Assignment_Statement (Loc,
2490 Name => New_Occurrence_Of (Bnn, Loc),
2492 Make_Function_Call (Loc,
2494 New_Occurrence_Of (RTE (Ent), Loc),
2495 Parameter_Associations => New_List (Left, Right))));
2497 -- Now do the rewrite with expression actions
2500 Make_Expression_With_Actions (Loc,
2501 Actions => New_List (
2502 Make_Object_Declaration (Loc,
2503 Defining_Identifier => Bnn,
2504 Object_Definition =>
2505 New_Occurrence_Of (Result_Type, Loc)),
2507 Expression => New_Occurrence_Of (Bnn, Loc)));
2508 Analyze_And_Resolve (N, Result_Type);
2512 -- No bignums involved, but types are different, so we must have
2513 -- rewritten one of the operands as a Long_Long_Integer but not
2516 -- If left operand is Long_Long_Integer, convert right operand
2517 -- and we are done (with a comparison of two Long_Long_Integers).
2519 elsif Ltype = LLIB then
2520 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2521 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2524 -- If right operand is Long_Long_Integer, convert left operand
2525 -- and we are done (with a comparison of two Long_Long_Integers).
2527 -- This is the only remaining possibility
2529 else pragma Assert (Rtype = LLIB);
2530 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2531 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2535 end Expand_Compare_Minimize_Eliminate_Overflow;
2537 -------------------------------
2538 -- Expand_Composite_Equality --
2539 -------------------------------
2541 -- This function is only called for comparing internal fields of composite
2542 -- types when these fields are themselves composites. This is a special
2543 -- case because it is not possible to respect normal Ada visibility rules.
2545 function Expand_Composite_Equality
2550 Bodies : List_Id) return Node_Id
2552 Loc : constant Source_Ptr := Sloc (Nod);
2553 Full_Type : Entity_Id;
2557 function Find_Primitive_Eq return Node_Id;
2558 -- AI05-0123: Locate primitive equality for type if it exists, and
2559 -- build the corresponding call. If operation is abstract, replace
2560 -- call with an explicit raise. Return Empty if there is no primitive.
2562 -----------------------
2563 -- Find_Primitive_Eq --
2564 -----------------------
2566 function Find_Primitive_Eq return Node_Id is
2571 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
2572 while Present (Prim_E) loop
2573 Prim := Node (Prim_E);
2575 -- Locate primitive equality with the right signature
2577 if Chars (Prim) = Name_Op_Eq
2578 and then Etype (First_Formal (Prim)) =
2579 Etype (Next_Formal (First_Formal (Prim)))
2580 and then Etype (Prim) = Standard_Boolean
2582 if Is_Abstract_Subprogram (Prim) then
2584 Make_Raise_Program_Error (Loc,
2585 Reason => PE_Explicit_Raise);
2589 Make_Function_Call (Loc,
2590 Name => New_Occurrence_Of (Prim, Loc),
2591 Parameter_Associations => New_List (Lhs, Rhs));
2598 -- If not found, predefined operation will be used
2601 end Find_Primitive_Eq;
2603 -- Start of processing for Expand_Composite_Equality
2606 if Is_Private_Type (Typ) then
2607 Full_Type := Underlying_Type (Typ);
2612 -- If the private type has no completion the context may be the
2613 -- expansion of a composite equality for a composite type with some
2614 -- still incomplete components. The expression will not be analyzed
2615 -- until the enclosing type is completed, at which point this will be
2616 -- properly expanded, unless there is a bona fide completion error.
2618 if No (Full_Type) then
2619 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2622 Full_Type := Base_Type (Full_Type);
2624 -- When the base type itself is private, use the full view to expand
2625 -- the composite equality.
2627 if Is_Private_Type (Full_Type) then
2628 Full_Type := Underlying_Type (Full_Type);
2631 -- Case of array types
2633 if Is_Array_Type (Full_Type) then
2635 -- If the operand is an elementary type other than a floating-point
2636 -- type, then we can simply use the built-in block bitwise equality,
2637 -- since the predefined equality operators always apply and bitwise
2638 -- equality is fine for all these cases.
2640 if Is_Elementary_Type (Component_Type (Full_Type))
2641 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2643 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2645 -- For composite component types, and floating-point types, use the
2646 -- expansion. This deals with tagged component types (where we use
2647 -- the applicable equality routine) and floating-point, (where we
2648 -- need to worry about negative zeroes), and also the case of any
2649 -- composite type recursively containing such fields.
2652 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
2655 -- Case of tagged record types
2657 elsif Is_Tagged_Type (Full_Type) then
2659 -- Call the primitive operation "=" of this type
2661 if Is_Class_Wide_Type (Full_Type) then
2662 Full_Type := Root_Type (Full_Type);
2665 -- If this is derived from an untagged private type completed with a
2666 -- tagged type, it does not have a full view, so we use the primitive
2667 -- operations of the private type. This check should no longer be
2668 -- necessary when these types receive their full views ???
2670 if Is_Private_Type (Typ)
2671 and then not Is_Tagged_Type (Typ)
2672 and then not Is_Controlled (Typ)
2673 and then Is_Derived_Type (Typ)
2674 and then No (Full_View (Typ))
2676 Prim := First_Elmt (Collect_Primitive_Operations (Typ));
2678 Prim := First_Elmt (Primitive_Operations (Full_Type));
2682 Eq_Op := Node (Prim);
2683 exit when Chars (Eq_Op) = Name_Op_Eq
2684 and then Etype (First_Formal (Eq_Op)) =
2685 Etype (Next_Formal (First_Formal (Eq_Op)))
2686 and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
2688 pragma Assert (Present (Prim));
2691 Eq_Op := Node (Prim);
2694 Make_Function_Call (Loc,
2695 Name => New_Occurrence_Of (Eq_Op, Loc),
2696 Parameter_Associations =>
2698 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2699 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2701 -- Case of untagged record types
2703 elsif Is_Record_Type (Full_Type) then
2704 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2706 if Present (Eq_Op) then
2707 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2709 -- Inherited equality from parent type. Convert the actuals to
2710 -- match signature of operation.
2713 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2717 Make_Function_Call (Loc,
2718 Name => New_Occurrence_Of (Eq_Op, Loc),
2719 Parameter_Associations => New_List (
2720 OK_Convert_To (T, Lhs),
2721 OK_Convert_To (T, Rhs)));
2725 -- Comparison between Unchecked_Union components
2727 if Is_Unchecked_Union (Full_Type) then
2729 Lhs_Type : Node_Id := Full_Type;
2730 Rhs_Type : Node_Id := Full_Type;
2731 Lhs_Discr_Val : Node_Id;
2732 Rhs_Discr_Val : Node_Id;
2737 if Nkind (Lhs) = N_Selected_Component then
2738 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2743 if Nkind (Rhs) = N_Selected_Component then
2744 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2747 -- Lhs of the composite equality
2749 if Is_Constrained (Lhs_Type) then
2751 -- Since the enclosing record type can never be an
2752 -- Unchecked_Union (this code is executed for records
2753 -- that do not have variants), we may reference its
2756 if Nkind (Lhs) = N_Selected_Component
2757 and then Has_Per_Object_Constraint
2758 (Entity (Selector_Name (Lhs)))
2761 Make_Selected_Component (Loc,
2762 Prefix => Prefix (Lhs),
2765 (Get_Discriminant_Value
2766 (First_Discriminant (Lhs_Type),
2768 Stored_Constraint (Lhs_Type))));
2773 (Get_Discriminant_Value
2774 (First_Discriminant (Lhs_Type),
2776 Stored_Constraint (Lhs_Type)));
2780 -- It is not possible to infer the discriminant since
2781 -- the subtype is not constrained.
2784 Make_Raise_Program_Error (Loc,
2785 Reason => PE_Unchecked_Union_Restriction);
2788 -- Rhs of the composite equality
2790 if Is_Constrained (Rhs_Type) then
2791 if Nkind (Rhs) = N_Selected_Component
2792 and then Has_Per_Object_Constraint
2793 (Entity (Selector_Name (Rhs)))
2796 Make_Selected_Component (Loc,
2797 Prefix => Prefix (Rhs),
2800 (Get_Discriminant_Value
2801 (First_Discriminant (Rhs_Type),
2803 Stored_Constraint (Rhs_Type))));
2808 (Get_Discriminant_Value
2809 (First_Discriminant (Rhs_Type),
2811 Stored_Constraint (Rhs_Type)));
2816 Make_Raise_Program_Error (Loc,
2817 Reason => PE_Unchecked_Union_Restriction);
2820 -- Call the TSS equality function with the inferred
2821 -- discriminant values.
2824 Make_Function_Call (Loc,
2825 Name => New_Occurrence_Of (Eq_Op, Loc),
2826 Parameter_Associations => New_List (
2835 Make_Function_Call (Loc,
2836 Name => New_Occurrence_Of (Eq_Op, Loc),
2837 Parameter_Associations => New_List (Lhs, Rhs));
2841 -- Equality composes in Ada 2012 for untagged record types. It also
2842 -- composes for bounded strings, because they are part of the
2843 -- predefined environment. We could make it compose for bounded
2844 -- strings by making them tagged, or by making sure all subcomponents
2845 -- are set to the same value, even when not used. Instead, we have
2846 -- this special case in the compiler, because it's more efficient.
2848 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
2850 -- If no TSS has been created for the type, check whether there is
2851 -- a primitive equality declared for it.
2854 Op : constant Node_Id := Find_Primitive_Eq;
2857 -- Use user-defined primitive if it exists, otherwise use
2858 -- predefined equality.
2860 if Present (Op) then
2863 return Make_Op_Eq (Loc, Lhs, Rhs);
2868 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2871 -- Non-composite types (always use predefined equality)
2874 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2876 end Expand_Composite_Equality;
2878 ------------------------
2879 -- Expand_Concatenate --
2880 ------------------------
2882 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2883 Loc : constant Source_Ptr := Sloc (Cnode);
2885 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2886 -- Result type of concatenation
2888 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2889 -- Component type. Elements of this component type can appear as one
2890 -- of the operands of concatenation as well as arrays.
2892 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2895 Ityp : constant Entity_Id := Base_Type (Istyp);
2896 -- Index type. This is the base type of the index subtype, and is used
2897 -- for all computed bounds (which may be out of range of Istyp in the
2898 -- case of null ranges).
2901 -- This is the type we use to do arithmetic to compute the bounds and
2902 -- lengths of operands. The choice of this type is a little subtle and
2903 -- is discussed in a separate section at the start of the body code.
2905 Concatenation_Error : exception;
2906 -- Raised if concatenation is sure to raise a CE
2908 Result_May_Be_Null : Boolean := True;
2909 -- Reset to False if at least one operand is encountered which is known
2910 -- at compile time to be non-null. Used for handling the special case
2911 -- of setting the high bound to the last operand high bound for a null
2912 -- result, thus ensuring a proper high bound in the super-flat case.
2914 N : constant Nat := List_Length (Opnds);
2915 -- Number of concatenation operands including possibly null operands
2918 -- Number of operands excluding any known to be null, except that the
2919 -- last operand is always retained, in case it provides the bounds for
2923 -- Current operand being processed in the loop through operands. After
2924 -- this loop is complete, always contains the last operand (which is not
2925 -- the same as Operands (NN), since null operands are skipped).
2927 -- Arrays describing the operands, only the first NN entries of each
2928 -- array are set (NN < N when we exclude known null operands).
2930 Is_Fixed_Length : array (1 .. N) of Boolean;
2931 -- True if length of corresponding operand known at compile time
2933 Operands : array (1 .. N) of Node_Id;
2934 -- Set to the corresponding entry in the Opnds list (but note that null
2935 -- operands are excluded, so not all entries in the list are stored).
2937 Fixed_Length : array (1 .. N) of Uint;
2938 -- Set to length of operand. Entries in this array are set only if the
2939 -- corresponding entry in Is_Fixed_Length is True.
2941 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2942 -- Set to lower bound of operand. Either an integer literal in the case
2943 -- where the bound is known at compile time, else actual lower bound.
2944 -- The operand low bound is of type Ityp.
2946 Var_Length : array (1 .. N) of Entity_Id;
2947 -- Set to an entity of type Natural that contains the length of an
2948 -- operand whose length is not known at compile time. Entries in this
2949 -- array are set only if the corresponding entry in Is_Fixed_Length
2950 -- is False. The entity is of type Artyp.
2952 Aggr_Length : array (0 .. N) of Node_Id;
2953 -- The J'th entry in an expression node that represents the total length
2954 -- of operands 1 through J. It is either an integer literal node, or a
2955 -- reference to a constant entity with the right value, so it is fine
2956 -- to just do a Copy_Node to get an appropriate copy. The extra zero'th
2957 -- entry always is set to zero. The length is of type Artyp.
2959 Low_Bound : Node_Id;
2960 -- A tree node representing the low bound of the result (of type Ityp).
2961 -- This is either an integer literal node, or an identifier reference to
2962 -- a constant entity initialized to the appropriate value.
2964 Last_Opnd_Low_Bound : Node_Id;
2965 -- A tree node representing the low bound of the last operand. This
2966 -- need only be set if the result could be null. It is used for the
2967 -- special case of setting the right low bound for a null result.
2968 -- This is of type Ityp.
2970 Last_Opnd_High_Bound : Node_Id;
2971 -- A tree node representing the high bound of the last operand. This
2972 -- need only be set if the result could be null. It is used for the
2973 -- special case of setting the right high bound for a null result.
2974 -- This is of type Ityp.
2976 High_Bound : Node_Id;
2977 -- A tree node representing the high bound of the result (of type Ityp)
2980 -- Result of the concatenation (of type Ityp)
2982 Actions : constant List_Id := New_List;
2983 -- Collect actions to be inserted
2985 Known_Non_Null_Operand_Seen : Boolean;
2986 -- Set True during generation of the assignments of operands into
2987 -- result once an operand known to be non-null has been seen.
2989 function Make_Artyp_Literal (Val : Nat) return Node_Id;
2990 -- This function makes an N_Integer_Literal node that is returned in
2991 -- analyzed form with the type set to Artyp. Importantly this literal
2992 -- is not flagged as static, so that if we do computations with it that
2993 -- result in statically detected out of range conditions, we will not
2994 -- generate error messages but instead warning messages.
2996 function To_Artyp (X : Node_Id) return Node_Id;
2997 -- Given a node of type Ityp, returns the corresponding value of type
2998 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2999 -- For enum types, the Pos of the value is returned.
3001 function To_Ityp (X : Node_Id) return Node_Id;
3002 -- The inverse function (uses Val in the case of enumeration types)
3004 ------------------------
3005 -- Make_Artyp_Literal --
3006 ------------------------
3008 function Make_Artyp_Literal (Val : Nat) return Node_Id is
3009 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
3011 Set_Etype (Result, Artyp);
3012 Set_Analyzed (Result, True);
3013 Set_Is_Static_Expression (Result, False);
3015 end Make_Artyp_Literal;
3021 function To_Artyp (X : Node_Id) return Node_Id is
3023 if Ityp = Base_Type (Artyp) then
3026 elsif Is_Enumeration_Type (Ityp) then
3028 Make_Attribute_Reference (Loc,
3029 Prefix => New_Occurrence_Of (Ityp, Loc),
3030 Attribute_Name => Name_Pos,
3031 Expressions => New_List (X));
3034 return Convert_To (Artyp, X);
3042 function To_Ityp (X : Node_Id) return Node_Id is
3044 if Is_Enumeration_Type (Ityp) then
3046 Make_Attribute_Reference (Loc,
3047 Prefix => New_Occurrence_Of (Ityp, Loc),
3048 Attribute_Name => Name_Val,
3049 Expressions => New_List (X));
3051 -- Case where we will do a type conversion
3054 if Ityp = Base_Type (Artyp) then
3057 return Convert_To (Ityp, X);
3062 -- Local Declarations
3064 Lib_Level_Target : constant Boolean :=
3065 Nkind (Parent (Cnode)) = N_Object_Declaration
3067 Is_Library_Level_Entity (Defining_Identifier (Parent (Cnode)));
3069 -- If the concatenation declares a library level entity, we call the
3070 -- built-in concatenation routines to prevent code bloat, regardless
3071 -- of optimization level. This is space-efficient, and prevent linking
3072 -- problems when units are compiled with different optimizations.
3074 Opnd_Typ : Entity_Id;
3081 -- Start of processing for Expand_Concatenate
3084 -- Choose an appropriate computational type
3086 -- We will be doing calculations of lengths and bounds in this routine
3087 -- and computing one from the other in some cases, e.g. getting the high
3088 -- bound by adding the length-1 to the low bound.
3090 -- We can't just use the index type, or even its base type for this
3091 -- purpose for two reasons. First it might be an enumeration type which
3092 -- is not suitable for computations of any kind, and second it may
3093 -- simply not have enough range. For example if the index type is
3094 -- -128..+127 then lengths can be up to 256, which is out of range of
3097 -- For enumeration types, we can simply use Standard_Integer, this is
3098 -- sufficient since the actual number of enumeration literals cannot
3099 -- possibly exceed the range of integer (remember we will be doing the
3100 -- arithmetic with POS values, not representation values).
3102 if Is_Enumeration_Type (Ityp) then
3103 Artyp := Standard_Integer;
3105 -- If index type is Positive, we use the standard unsigned type, to give
3106 -- more room on the top of the range, obviating the need for an overflow
3107 -- check when creating the upper bound. This is needed to avoid junk
3108 -- overflow checks in the common case of String types.
3110 -- ??? Disabled for now
3112 -- elsif Istyp = Standard_Positive then
3113 -- Artyp := Standard_Unsigned;
3115 -- For modular types, we use a 32-bit modular type for types whose size
3116 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3117 -- identity type, and for larger unsigned types we use 64-bits.
3119 elsif Is_Modular_Integer_Type (Ityp) then
3120 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
3121 Artyp := Standard_Unsigned;
3122 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
3125 Artyp := RTE (RE_Long_Long_Unsigned);
3128 -- Similar treatment for signed types
3131 if RM_Size (Ityp) < RM_Size (Standard_Integer) then
3132 Artyp := Standard_Integer;
3133 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
3136 Artyp := Standard_Long_Long_Integer;
3140 -- Supply dummy entry at start of length array
3142 Aggr_Length (0) := Make_Artyp_Literal (0);
3144 -- Go through operands setting up the above arrays
3148 Opnd := Remove_Head (Opnds);
3149 Opnd_Typ := Etype (Opnd);
3151 -- The parent got messed up when we put the operands in a list,
3152 -- so now put back the proper parent for the saved operand, that
3153 -- is to say the concatenation node, to make sure that each operand
3154 -- is seen as a subexpression, e.g. if actions must be inserted.
3156 Set_Parent (Opnd, Cnode);
3158 -- Set will be True when we have setup one entry in the array
3162 -- Singleton element (or character literal) case
3164 if Base_Type (Opnd_Typ) = Ctyp then
3166 Operands (NN) := Opnd;
3167 Is_Fixed_Length (NN) := True;
3168 Fixed_Length (NN) := Uint_1;
3169 Result_May_Be_Null := False;
3171 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3172 -- since we know that the result cannot be null).
3174 Opnd_Low_Bound (NN) :=
3175 Make_Attribute_Reference (Loc,
3176 Prefix => New_Occurrence_Of (Istyp, Loc),
3177 Attribute_Name => Name_First);
3181 -- String literal case (can only occur for strings of course)
3183 elsif Nkind (Opnd) = N_String_Literal then
3184 Len := String_Literal_Length (Opnd_Typ);
3187 Result_May_Be_Null := False;
3190 -- Capture last operand low and high bound if result could be null
3192 if J = N and then Result_May_Be_Null then
3193 Last_Opnd_Low_Bound :=
3194 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3196 Last_Opnd_High_Bound :=
3197 Make_Op_Subtract (Loc,
3199 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
3200 Right_Opnd => Make_Integer_Literal (Loc, 1));
3203 -- Skip null string literal
3205 if J < N and then Len = 0 then
3210 Operands (NN) := Opnd;
3211 Is_Fixed_Length (NN) := True;
3213 -- Set length and bounds
3215 Fixed_Length (NN) := Len;
3217 Opnd_Low_Bound (NN) :=
3218 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3225 -- Check constrained case with known bounds
3227 if Is_Constrained (Opnd_Typ) then
3229 Index : constant Node_Id := First_Index (Opnd_Typ);
3230 Indx_Typ : constant Entity_Id := Etype (Index);
3231 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
3232 Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
3235 -- Fixed length constrained array type with known at compile
3236 -- time bounds is last case of fixed length operand.
3238 if Compile_Time_Known_Value (Lo)
3240 Compile_Time_Known_Value (Hi)
3243 Loval : constant Uint := Expr_Value (Lo);
3244 Hival : constant Uint := Expr_Value (Hi);
3245 Len : constant Uint :=
3246 UI_Max (Hival - Loval + 1, Uint_0);
3250 Result_May_Be_Null := False;
3253 -- Capture last operand bounds if result could be null
3255 if J = N and then Result_May_Be_Null then
3256 Last_Opnd_Low_Bound :=
3258 Make_Integer_Literal (Loc, Expr_Value (Lo)));
3260 Last_Opnd_High_Bound :=
3262 Make_Integer_Literal (Loc, Expr_Value (Hi)));
3265 -- Exclude null length case unless last operand
3267 if J < N and then Len = 0 then
3272 Operands (NN) := Opnd;
3273 Is_Fixed_Length (NN) := True;
3274 Fixed_Length (NN) := Len;
3276 Opnd_Low_Bound (NN) :=
3278 (Make_Integer_Literal (Loc, Expr_Value (Lo)));
3285 -- All cases where the length is not known at compile time, or the
3286 -- special case of an operand which is known to be null but has a
3287 -- lower bound other than 1 or is other than a string type.
3292 -- Capture operand bounds
3294 Opnd_Low_Bound (NN) :=
3295 Make_Attribute_Reference (Loc,
3297 Duplicate_Subexpr (Opnd, Name_Req => True),
3298 Attribute_Name => Name_First);
3300 -- Capture last operand bounds if result could be null
3302 if J = N and Result_May_Be_Null then
3303 Last_Opnd_Low_Bound :=
3305 Make_Attribute_Reference (Loc,
3307 Duplicate_Subexpr (Opnd, Name_Req => True),
3308 Attribute_Name => Name_First));
3310 Last_Opnd_High_Bound :=
3312 Make_Attribute_Reference (Loc,
3314 Duplicate_Subexpr (Opnd, Name_Req => True),
3315 Attribute_Name => Name_Last));
3318 -- Capture length of operand in entity
3320 Operands (NN) := Opnd;
3321 Is_Fixed_Length (NN) := False;
3323 Var_Length (NN) := Make_Temporary (Loc, 'L');
3326 Make_Object_Declaration (Loc,
3327 Defining_Identifier => Var_Length (NN),
3328 Constant_Present => True,
3329 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3331 Make_Attribute_Reference (Loc,
3333 Duplicate_Subexpr (Opnd, Name_Req => True),
3334 Attribute_Name => Name_Length)));
3338 -- Set next entry in aggregate length array
3340 -- For first entry, make either integer literal for fixed length
3341 -- or a reference to the saved length for variable length.
3344 if Is_Fixed_Length (1) then
3345 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
3347 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
3350 -- If entry is fixed length and only fixed lengths so far, make
3351 -- appropriate new integer literal adding new length.
3353 elsif Is_Fixed_Length (NN)
3354 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3357 Make_Integer_Literal (Loc,
3358 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3360 -- All other cases, construct an addition node for the length and
3361 -- create an entity initialized to this length.
3364 Ent := Make_Temporary (Loc, 'L');
3366 if Is_Fixed_Length (NN) then
3367 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3369 Clen := New_Occurrence_Of (Var_Length (NN), Loc);
3373 Make_Object_Declaration (Loc,
3374 Defining_Identifier => Ent,
3375 Constant_Present => True,
3376 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3379 Left_Opnd => New_Copy (Aggr_Length (NN - 1)),
3380 Right_Opnd => Clen)));
3382 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
3389 -- If we have only skipped null operands, return the last operand
3396 -- If we have only one non-null operand, return it and we are done.
3397 -- There is one case in which this cannot be done, and that is when
3398 -- the sole operand is of the element type, in which case it must be
3399 -- converted to an array, and the easiest way of doing that is to go
3400 -- through the normal general circuit.
3402 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
3403 Result := Operands (1);
3407 -- Cases where we have a real concatenation
3409 -- Next step is to find the low bound for the result array that we
3410 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3412 -- If the ultimate ancestor of the index subtype is a constrained array
3413 -- definition, then the lower bound is that of the index subtype as
3414 -- specified by (RM 4.5.3(6)).
3416 -- The right test here is to go to the root type, and then the ultimate
3417 -- ancestor is the first subtype of this root type.
3419 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
3421 Make_Attribute_Reference (Loc,
3423 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
3424 Attribute_Name => Name_First);
3426 -- If the first operand in the list has known length we know that
3427 -- the lower bound of the result is the lower bound of this operand.
3429 elsif Is_Fixed_Length (1) then
3430 Low_Bound := Opnd_Low_Bound (1);
3432 -- OK, we don't know the lower bound, we have to build a horrible
3433 -- if expression node of the form
3435 -- if Cond1'Length /= 0 then
3438 -- if Opnd2'Length /= 0 then
3443 -- The nesting ends either when we hit an operand whose length is known
3444 -- at compile time, or on reaching the last operand, whose low bound we
3445 -- take unconditionally whether or not it is null. It's easiest to do
3446 -- this with a recursive procedure:
3450 function Get_Known_Bound (J : Nat) return Node_Id;
3451 -- Returns the lower bound determined by operands J .. NN
3453 ---------------------
3454 -- Get_Known_Bound --
3455 ---------------------
3457 function Get_Known_Bound (J : Nat) return Node_Id is
3459 if Is_Fixed_Length (J) or else J = NN then
3460 return New_Copy (Opnd_Low_Bound (J));
3464 Make_If_Expression (Loc,
3465 Expressions => New_List (
3469 New_Occurrence_Of (Var_Length (J), Loc),
3471 Make_Integer_Literal (Loc, 0)),
3473 New_Copy (Opnd_Low_Bound (J)),
3474 Get_Known_Bound (J + 1)));
3476 end Get_Known_Bound;
3479 Ent := Make_Temporary (Loc, 'L');
3482 Make_Object_Declaration (Loc,
3483 Defining_Identifier => Ent,
3484 Constant_Present => True,
3485 Object_Definition => New_Occurrence_Of (Ityp, Loc),
3486 Expression => Get_Known_Bound (1)));
3488 Low_Bound := New_Occurrence_Of (Ent, Loc);
3492 -- Now we can safely compute the upper bound, normally
3493 -- Low_Bound + Length - 1.
3498 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3500 Make_Op_Subtract (Loc,
3501 Left_Opnd => New_Copy (Aggr_Length (NN)),
3502 Right_Opnd => Make_Artyp_Literal (1))));
3504 -- Note that calculation of the high bound may cause overflow in some
3505 -- very weird cases, so in the general case we need an overflow check on
3506 -- the high bound. We can avoid this for the common case of string types
3507 -- and other types whose index is Positive, since we chose a wider range
3508 -- for the arithmetic type.
3510 if Istyp /= Standard_Positive then
3511 Activate_Overflow_Check (High_Bound);
3514 -- Handle the exceptional case where the result is null, in which case
3515 -- case the bounds come from the last operand (so that we get the proper
3516 -- bounds if the last operand is super-flat).
3518 if Result_May_Be_Null then
3520 Make_If_Expression (Loc,
3521 Expressions => New_List (
3523 Left_Opnd => New_Copy (Aggr_Length (NN)),
3524 Right_Opnd => Make_Artyp_Literal (0)),
3525 Last_Opnd_Low_Bound,
3529 Make_If_Expression (Loc,
3530 Expressions => New_List (
3532 Left_Opnd => New_Copy (Aggr_Length (NN)),
3533 Right_Opnd => Make_Artyp_Literal (0)),
3534 Last_Opnd_High_Bound,
3538 -- Here is where we insert the saved up actions
3540 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3542 -- Now we construct an array object with appropriate bounds. We mark
3543 -- the target as internal to prevent useless initialization when
3544 -- Initialize_Scalars is enabled. Also since this is the actual result
3545 -- entity, we make sure we have debug information for the result.
3547 Ent := Make_Temporary (Loc, 'S');
3548 Set_Is_Internal (Ent);
3549 Set_Needs_Debug_Info (Ent);
3551 -- If the bound is statically known to be out of range, we do not want
3552 -- to abort, we want a warning and a runtime constraint error. Note that
3553 -- we have arranged that the result will not be treated as a static
3554 -- constant, so we won't get an illegality during this insertion.
3556 Insert_Action (Cnode,
3557 Make_Object_Declaration (Loc,
3558 Defining_Identifier => Ent,
3559 Object_Definition =>
3560 Make_Subtype_Indication (Loc,
3561 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3563 Make_Index_Or_Discriminant_Constraint (Loc,
3564 Constraints => New_List (
3566 Low_Bound => Low_Bound,
3567 High_Bound => High_Bound))))),
3568 Suppress => All_Checks);
3570 -- If the result of the concatenation appears as the initializing
3571 -- expression of an object declaration, we can just rename the
3572 -- result, rather than copying it.
3574 Set_OK_To_Rename (Ent);
3576 -- Catch the static out of range case now
3578 if Raises_Constraint_Error (High_Bound) then
3579 raise Concatenation_Error;
3582 -- Now we will generate the assignments to do the actual concatenation
3584 -- There is one case in which we will not do this, namely when all the
3585 -- following conditions are met:
3587 -- The result type is Standard.String
3589 -- There are nine or fewer retained (non-null) operands
3591 -- The optimization level is -O0
3593 -- The corresponding System.Concat_n.Str_Concat_n routine is
3594 -- available in the run time.
3596 -- The debug flag gnatd.c is not set
3598 -- If all these conditions are met then we generate a call to the
3599 -- relevant concatenation routine. The purpose of this is to avoid
3600 -- undesirable code bloat at -O0.
3602 if Atyp = Standard_String
3603 and then NN in 2 .. 9
3604 and then (Lib_Level_Target
3606 ((Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3607 and then not Debug_Flag_Dot_C))
3610 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3621 if RTE_Available (RR (NN)) then
3623 Opnds : constant List_Id :=
3624 New_List (New_Occurrence_Of (Ent, Loc));
3627 for J in 1 .. NN loop
3628 if Is_List_Member (Operands (J)) then
3629 Remove (Operands (J));
3632 if Base_Type (Etype (Operands (J))) = Ctyp then
3634 Make_Aggregate (Loc,
3635 Component_Associations => New_List (
3636 Make_Component_Association (Loc,
3637 Choices => New_List (
3638 Make_Integer_Literal (Loc, 1)),
3639 Expression => Operands (J)))));
3642 Append_To (Opnds, Operands (J));
3646 Insert_Action (Cnode,
3647 Make_Procedure_Call_Statement (Loc,
3648 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
3649 Parameter_Associations => Opnds));
3651 Result := New_Occurrence_Of (Ent, Loc);
3658 -- Not special case so generate the assignments
3660 Known_Non_Null_Operand_Seen := False;
3662 for J in 1 .. NN loop
3664 Lo : constant Node_Id :=
3666 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3667 Right_Opnd => Aggr_Length (J - 1));
3669 Hi : constant Node_Id :=
3671 Left_Opnd => To_Artyp (New_Copy (Low_Bound)),
3673 Make_Op_Subtract (Loc,
3674 Left_Opnd => Aggr_Length (J),
3675 Right_Opnd => Make_Artyp_Literal (1)));
3678 -- Singleton case, simple assignment
3680 if Base_Type (Etype (Operands (J))) = Ctyp then
3681 Known_Non_Null_Operand_Seen := True;
3682 Insert_Action (Cnode,
3683 Make_Assignment_Statement (Loc,
3685 Make_Indexed_Component (Loc,
3686 Prefix => New_Occurrence_Of (Ent, Loc),
3687 Expressions => New_List (To_Ityp (Lo))),
3688 Expression => Operands (J)),
3689 Suppress => All_Checks);
3691 -- Array case, slice assignment, skipped when argument is fixed
3692 -- length and known to be null.
3694 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3697 Make_Assignment_Statement (Loc,
3701 New_Occurrence_Of (Ent, Loc),
3704 Low_Bound => To_Ityp (Lo),
3705 High_Bound => To_Ityp (Hi))),
3706 Expression => Operands (J));
3708 if Is_Fixed_Length (J) then
3709 Known_Non_Null_Operand_Seen := True;
3711 elsif not Known_Non_Null_Operand_Seen then
3713 -- Here if operand length is not statically known and no
3714 -- operand known to be non-null has been processed yet.
3715 -- If operand length is 0, we do not need to perform the
3716 -- assignment, and we must avoid the evaluation of the
3717 -- high bound of the slice, since it may underflow if the
3718 -- low bound is Ityp'First.
3721 Make_Implicit_If_Statement (Cnode,
3725 New_Occurrence_Of (Var_Length (J), Loc),
3726 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3727 Then_Statements => New_List (Assign));
3730 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3736 -- Finally we build the result, which is a reference to the array object
3738 Result := New_Occurrence_Of (Ent, Loc);
3741 Rewrite (Cnode, Result);
3742 Analyze_And_Resolve (Cnode, Atyp);
3745 when Concatenation_Error =>
3747 -- Kill warning generated for the declaration of the static out of
3748 -- range high bound, and instead generate a Constraint_Error with
3749 -- an appropriate specific message.
3751 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3752 Apply_Compile_Time_Constraint_Error
3754 Msg => "concatenation result upper bound out of range??",
3755 Reason => CE_Range_Check_Failed);
3756 end Expand_Concatenate;
3758 ---------------------------------------------------
3759 -- Expand_Membership_Minimize_Eliminate_Overflow --
3760 ---------------------------------------------------
3762 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3763 pragma Assert (Nkind (N) = N_In);
3764 -- Despite the name, this routine applies only to N_In, not to
3765 -- N_Not_In. The latter is always rewritten as not (X in Y).
3767 Result_Type : constant Entity_Id := Etype (N);
3768 -- Capture result type, may be a derived boolean type
3770 Loc : constant Source_Ptr := Sloc (N);
3771 Lop : constant Node_Id := Left_Opnd (N);
3772 Rop : constant Node_Id := Right_Opnd (N);
3774 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3775 -- is thus tempting to capture these values, but due to the rewrites
3776 -- that occur as a result of overflow checking, these values change
3777 -- as we go along, and it is safe just to always use Etype explicitly.
3779 Restype : constant Entity_Id := Etype (N);
3783 -- Bounds in Minimize calls, not used currently
3785 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3786 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3789 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3791 -- If right operand is a subtype name, and the subtype name has no
3792 -- predicate, then we can just replace the right operand with an
3793 -- explicit range T'First .. T'Last, and use the explicit range code.
3795 if Nkind (Rop) /= N_Range
3796 and then No (Predicate_Function (Etype (Rop)))
3799 Rtyp : constant Entity_Id := Etype (Rop);
3804 Make_Attribute_Reference (Loc,
3805 Attribute_Name => Name_First,
3806 Prefix => New_Occurrence_Of (Rtyp, Loc)),
3808 Make_Attribute_Reference (Loc,
3809 Attribute_Name => Name_Last,
3810 Prefix => New_Occurrence_Of (Rtyp, Loc))));
3811 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3815 -- Here for the explicit range case. Note that the bounds of the range
3816 -- have not been processed for minimized or eliminated checks.
3818 if Nkind (Rop) = N_Range then
3819 Minimize_Eliminate_Overflows
3820 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3821 Minimize_Eliminate_Overflows
3822 (High_Bound (Rop), Lo, Hi, Top_Level => False);
3824 -- We have A in B .. C, treated as A >= B and then A <= C
3828 if Is_RTE (Etype (Lop), RE_Bignum)
3829 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3830 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3833 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3834 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3835 L : constant Entity_Id :=
3836 Make_Defining_Identifier (Loc, Name_uL);
3837 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3838 Lbound : constant Node_Id :=
3839 Convert_To_Bignum (Low_Bound (Rop));
3840 Hbound : constant Node_Id :=
3841 Convert_To_Bignum (High_Bound (Rop));
3843 -- Now we rewrite the membership test node to look like
3846 -- Bnn : Result_Type;
3848 -- M : Mark_Id := SS_Mark;
3849 -- L : Bignum := Lopnd;
3851 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3859 -- Insert declaration of L into declarations of bignum block
3862 (Last (Declarations (Blk)),
3863 Make_Object_Declaration (Loc,
3864 Defining_Identifier => L,
3865 Object_Definition =>
3866 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3867 Expression => Lopnd));
3869 -- Insert assignment to Bnn into expressions of bignum block
3872 (First (Statements (Handled_Statement_Sequence (Blk))),
3873 Make_Assignment_Statement (Loc,
3874 Name => New_Occurrence_Of (Bnn, Loc),
3878 Make_Function_Call (Loc,
3880 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3881 Parameter_Associations => New_List (
3882 New_Occurrence_Of (L, Loc),
3885 Make_Function_Call (Loc,
3887 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3888 Parameter_Associations => New_List (
3889 New_Occurrence_Of (L, Loc),
3892 -- Now rewrite the node
3895 Make_Expression_With_Actions (Loc,
3896 Actions => New_List (
3897 Make_Object_Declaration (Loc,
3898 Defining_Identifier => Bnn,
3899 Object_Definition =>
3900 New_Occurrence_Of (Result_Type, Loc)),
3902 Expression => New_Occurrence_Of (Bnn, Loc)));
3903 Analyze_And_Resolve (N, Result_Type);
3907 -- Here if no bignums around
3910 -- Case where types are all the same
3912 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3914 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3918 -- If types are not all the same, it means that we have rewritten
3919 -- at least one of them to be of type Long_Long_Integer, and we
3920 -- will convert the other operands to Long_Long_Integer.
3923 Convert_To_And_Rewrite (LLIB, Lop);
3924 Set_Analyzed (Lop, False);
3925 Analyze_And_Resolve (Lop, LLIB);
3927 -- For the right operand, avoid unnecessary recursion into
3928 -- this routine, we know that overflow is not possible.
3930 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3931 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3932 Set_Analyzed (Rop, False);
3933 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3936 -- Now the three operands are of the same signed integer type,
3937 -- so we can use the normal expansion routine for membership,
3938 -- setting the flag to prevent recursion into this procedure.
3940 Set_No_Minimize_Eliminate (N);
3944 -- Right operand is a subtype name and the subtype has a predicate. We
3945 -- have to make sure the predicate is checked, and for that we need to
3946 -- use the standard N_In circuitry with appropriate types.
3949 pragma Assert (Present (Predicate_Function (Etype (Rop))));
3951 -- If types are "right", just call Expand_N_In preventing recursion
3953 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3954 Set_No_Minimize_Eliminate (N);
3959 elsif Is_RTE (Etype (Lop), RE_Bignum) then
3961 -- For X in T, we want to rewrite our node as
3964 -- Bnn : Result_Type;
3967 -- M : Mark_Id := SS_Mark;
3968 -- Lnn : Long_Long_Integer'Base
3974 -- if not Bignum_In_LLI_Range (Nnn) then
3977 -- Lnn := From_Bignum (Nnn);
3979 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3980 -- and then T'Base (Lnn) in T;
3989 -- A bit gruesome, but there doesn't seem to be a simpler way
3992 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3993 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3994 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
3995 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
3996 T : constant Entity_Id := Etype (Rop);
3997 TB : constant Entity_Id := Base_Type (T);
4001 -- Mark the last membership operation to prevent recursion
4005 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
4006 Right_Opnd => New_Occurrence_Of (T, Loc));
4007 Set_No_Minimize_Eliminate (Nin);
4009 -- Now decorate the block
4012 (Last (Declarations (Blk)),
4013 Make_Object_Declaration (Loc,
4014 Defining_Identifier => Lnn,
4015 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
4018 (Last (Declarations (Blk)),
4019 Make_Object_Declaration (Loc,
4020 Defining_Identifier => Nnn,
4021 Object_Definition =>
4022 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
4025 (First (Statements (Handled_Statement_Sequence (Blk))),
4027 Make_Assignment_Statement (Loc,
4028 Name => New_Occurrence_Of (Nnn, Loc),
4029 Expression => Relocate_Node (Lop)),
4031 Make_Implicit_If_Statement (N,
4035 Make_Function_Call (Loc,
4038 (RTE (RE_Bignum_In_LLI_Range), Loc),
4039 Parameter_Associations => New_List (
4040 New_Occurrence_Of (Nnn, Loc)))),
4042 Then_Statements => New_List (
4043 Make_Assignment_Statement (Loc,
4044 Name => New_Occurrence_Of (Bnn, Loc),
4046 New_Occurrence_Of (Standard_False, Loc))),
4048 Else_Statements => New_List (
4049 Make_Assignment_Statement (Loc,
4050 Name => New_Occurrence_Of (Lnn, Loc),
4052 Make_Function_Call (Loc,
4054 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
4055 Parameter_Associations => New_List (
4056 New_Occurrence_Of (Nnn, Loc)))),
4058 Make_Assignment_Statement (Loc,
4059 Name => New_Occurrence_Of (Bnn, Loc),
4064 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4069 Make_Attribute_Reference (Loc,
4070 Attribute_Name => Name_First,
4072 New_Occurrence_Of (TB, Loc))),
4076 Make_Attribute_Reference (Loc,
4077 Attribute_Name => Name_Last,
4079 New_Occurrence_Of (TB, Loc))))),
4081 Right_Opnd => Nin))))));
4083 -- Now we can do the rewrite
4086 Make_Expression_With_Actions (Loc,
4087 Actions => New_List (
4088 Make_Object_Declaration (Loc,
4089 Defining_Identifier => Bnn,
4090 Object_Definition =>
4091 New_Occurrence_Of (Result_Type, Loc)),
4093 Expression => New_Occurrence_Of (Bnn, Loc)));
4094 Analyze_And_Resolve (N, Result_Type);
4098 -- Not bignum case, but types don't match (this means we rewrote the
4099 -- left operand to be Long_Long_Integer).
4102 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
4104 -- We rewrite the membership test as (where T is the type with
4105 -- the predicate, i.e. the type of the right operand)
4107 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4108 -- and then T'Base (Lop) in T
4111 T : constant Entity_Id := Etype (Rop);
4112 TB : constant Entity_Id := Base_Type (T);
4116 -- The last membership test is marked to prevent recursion
4120 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
4121 Right_Opnd => New_Occurrence_Of (T, Loc));
4122 Set_No_Minimize_Eliminate (Nin);
4124 -- Now do the rewrite
4135 Make_Attribute_Reference (Loc,
4136 Attribute_Name => Name_First,
4137 Prefix => New_Occurrence_Of (TB, Loc))),
4140 Make_Attribute_Reference (Loc,
4141 Attribute_Name => Name_Last,
4142 Prefix => New_Occurrence_Of (TB, Loc))))),
4143 Right_Opnd => Nin));
4144 Set_Analyzed (N, False);
4145 Analyze_And_Resolve (N, Restype);
4149 end Expand_Membership_Minimize_Eliminate_Overflow;
4151 ------------------------
4152 -- Expand_N_Allocator --
4153 ------------------------
4155 procedure Expand_N_Allocator (N : Node_Id) is
4156 Etyp : constant Entity_Id := Etype (Expression (N));
4157 Loc : constant Source_Ptr := Sloc (N);
4158 PtrT : constant Entity_Id := Etype (N);
4160 procedure Rewrite_Coextension (N : Node_Id);
4161 -- Static coextensions have the same lifetime as the entity they
4162 -- constrain. Such occurrences can be rewritten as aliased objects
4163 -- and their unrestricted access used instead of the coextension.
4165 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
4166 -- Given a constrained array type E, returns a node representing the
4167 -- code to compute the size in storage elements for the given type.
4168 -- This is done without using the attribute (which malfunctions for
4171 -------------------------
4172 -- Rewrite_Coextension --
4173 -------------------------
4175 procedure Rewrite_Coextension (N : Node_Id) is
4176 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
4177 Temp_Decl : Node_Id;
4181 -- Cnn : aliased Etyp;
4184 Make_Object_Declaration (Loc,
4185 Defining_Identifier => Temp_Id,
4186 Aliased_Present => True,
4187 Object_Definition => New_Occurrence_Of (Etyp, Loc));
4189 if Nkind (Expression (N)) = N_Qualified_Expression then
4190 Set_Expression (Temp_Decl, Expression (Expression (N)));
4193 Insert_Action (N, Temp_Decl);
4195 Make_Attribute_Reference (Loc,
4196 Prefix => New_Occurrence_Of (Temp_Id, Loc),
4197 Attribute_Name => Name_Unrestricted_Access));
4199 Analyze_And_Resolve (N, PtrT);
4200 end Rewrite_Coextension;
4202 ------------------------------
4203 -- Size_In_Storage_Elements --
4204 ------------------------------
4206 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
4208 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4209 -- However, the reason for the existence of this function is
4210 -- to construct a test for sizes too large, which means near the
4211 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4212 -- is that we get overflows when sizes are greater than 2**31.
4214 -- So what we end up doing for array types is to use the expression:
4216 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4218 -- which avoids this problem. All this is a bit bogus, but it does
4219 -- mean we catch common cases of trying to allocate arrays that
4220 -- are too large, and which in the absence of a check results in
4221 -- undetected chaos ???
4223 -- Note in particular that this is a pessimistic estimate in the
4224 -- case of packed array types, where an array element might occupy
4225 -- just a fraction of a storage element???
4232 for J in 1 .. Number_Dimensions (E) loop
4234 Make_Attribute_Reference (Loc,
4235 Prefix => New_Occurrence_Of (E, Loc),
4236 Attribute_Name => Name_Length,
4237 Expressions => New_List (Make_Integer_Literal (Loc, J)));
4244 Make_Op_Multiply (Loc,
4251 Make_Op_Multiply (Loc,
4254 Make_Attribute_Reference (Loc,
4255 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4256 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4258 end Size_In_Storage_Elements;
4262 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
4266 Rel_Typ : Entity_Id;
4269 -- Start of processing for Expand_N_Allocator
4272 -- RM E.2.3(22). We enforce that the expected type of an allocator
4273 -- shall not be a remote access-to-class-wide-limited-private type
4275 -- Why is this being done at expansion time, seems clearly wrong ???
4277 Validate_Remote_Access_To_Class_Wide_Type (N);
4279 -- Processing for anonymous access-to-controlled types. These access
4280 -- types receive a special finalization master which appears in the
4281 -- declarations of the enclosing semantic unit. This expansion is done
4282 -- now to ensure that any additional types generated by this routine or
4283 -- Expand_Allocator_Expression inherit the proper type attributes.
4285 if (Ekind (PtrT) = E_Anonymous_Access_Type
4286 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4287 and then Needs_Finalization (Dtyp)
4289 -- Detect the allocation of an anonymous controlled object where the
4290 -- type of the context is named. For example:
4292 -- procedure Proc (Ptr : Named_Access_Typ);
4293 -- Proc (new Designated_Typ);
4295 -- Regardless of the anonymous-to-named access type conversion, the
4296 -- lifetime of the object must be associated with the named access
4297 -- type. Use the finalization-related attributes of this type.
4299 if Nkind_In (Parent (N), N_Type_Conversion,
4300 N_Unchecked_Type_Conversion)
4301 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
4303 E_General_Access_Type)
4305 Rel_Typ := Etype (Parent (N));
4310 -- Anonymous access-to-controlled types allocate on the global pool.
4311 -- Do not set this attribute on .NET/JVM since those targets do not
4314 if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then
4315 if Present (Rel_Typ) then
4316 Set_Associated_Storage_Pool (PtrT,
4317 Associated_Storage_Pool (Rel_Typ));
4319 Set_Associated_Storage_Pool (PtrT,
4320 Get_Global_Pool_For_Access_Type (PtrT));
4324 -- The finalization master must be inserted and analyzed as part of
4325 -- the current semantic unit. Note that the master is updated when
4326 -- analysis changes current units.
4328 if Present (Rel_Typ) then
4329 Set_Finalization_Master (PtrT, Finalization_Master (Rel_Typ));
4331 Set_Finalization_Master (PtrT, Current_Anonymous_Master);
4335 -- Set the storage pool and find the appropriate version of Allocate to
4336 -- call. Do not overwrite the storage pool if it is already set, which
4337 -- can happen for build-in-place function returns (see
4338 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4340 if No (Storage_Pool (N)) then
4341 Pool := Associated_Storage_Pool (Root_Type (PtrT));
4343 if Present (Pool) then
4344 Set_Storage_Pool (N, Pool);
4346 if Is_RTE (Pool, RE_SS_Pool) then
4347 if VM_Target = No_VM then
4348 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4351 -- In the case of an allocator for a simple storage pool, locate
4352 -- and save a reference to the pool type's Allocate routine.
4354 elsif Present (Get_Rep_Pragma
4355 (Etype (Pool), Name_Simple_Storage_Pool_Type))
4358 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4359 Alloc_Op : Entity_Id;
4361 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4362 while Present (Alloc_Op) loop
4363 if Scope (Alloc_Op) = Scope (Pool_Type)
4364 and then Present (First_Formal (Alloc_Op))
4365 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4367 Set_Procedure_To_Call (N, Alloc_Op);
4370 Alloc_Op := Homonym (Alloc_Op);
4375 elsif Is_Class_Wide_Type (Etype (Pool)) then
4376 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4379 Set_Procedure_To_Call (N,
4380 Find_Prim_Op (Etype (Pool), Name_Allocate));
4385 -- Under certain circumstances we can replace an allocator by an access
4386 -- to statically allocated storage. The conditions, as noted in AARM
4387 -- 3.10 (10c) are as follows:
4389 -- Size and initial value is known at compile time
4390 -- Access type is access-to-constant
4392 -- The allocator is not part of a constraint on a record component,
4393 -- because in that case the inserted actions are delayed until the
4394 -- record declaration is fully analyzed, which is too late for the
4395 -- analysis of the rewritten allocator.
4397 if Is_Access_Constant (PtrT)
4398 and then Nkind (Expression (N)) = N_Qualified_Expression
4399 and then Compile_Time_Known_Value (Expression (Expression (N)))
4400 and then Size_Known_At_Compile_Time
4401 (Etype (Expression (Expression (N))))
4402 and then not Is_Record_Type (Current_Scope)
4404 -- Here we can do the optimization. For the allocator
4408 -- We insert an object declaration
4410 -- Tnn : aliased x := y;
4412 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4413 -- marked as requiring static allocation.
4415 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4416 Desig := Subtype_Mark (Expression (N));
4418 -- If context is constrained, use constrained subtype directly,
4419 -- so that the constant is not labelled as having a nominally
4420 -- unconstrained subtype.
4422 if Entity (Desig) = Base_Type (Dtyp) then
4423 Desig := New_Occurrence_Of (Dtyp, Loc);
4427 Make_Object_Declaration (Loc,
4428 Defining_Identifier => Temp,
4429 Aliased_Present => True,
4430 Constant_Present => Is_Access_Constant (PtrT),
4431 Object_Definition => Desig,
4432 Expression => Expression (Expression (N))));
4435 Make_Attribute_Reference (Loc,
4436 Prefix => New_Occurrence_Of (Temp, Loc),
4437 Attribute_Name => Name_Unrestricted_Access));
4439 Analyze_And_Resolve (N, PtrT);
4441 -- We set the variable as statically allocated, since we don't want
4442 -- it going on the stack of the current procedure.
4444 Set_Is_Statically_Allocated (Temp);
4448 -- Same if the allocator is an access discriminant for a local object:
4449 -- instead of an allocator we create a local value and constrain the
4450 -- enclosing object with the corresponding access attribute.
4452 if Is_Static_Coextension (N) then
4453 Rewrite_Coextension (N);
4457 -- Check for size too large, we do this because the back end misses
4458 -- proper checks here and can generate rubbish allocation calls when
4459 -- we are near the limit. We only do this for the 32-bit address case
4460 -- since that is from a practical point of view where we see a problem.
4462 if System_Address_Size = 32
4463 and then not Storage_Checks_Suppressed (PtrT)
4464 and then not Storage_Checks_Suppressed (Dtyp)
4465 and then not Storage_Checks_Suppressed (Etyp)
4467 -- The check we want to generate should look like
4469 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4470 -- raise Storage_Error;
4473 -- where 3.5 gigabytes is a constant large enough to accommodate any
4474 -- reasonable request for. But we can't do it this way because at
4475 -- least at the moment we don't compute this attribute right, and
4476 -- can silently give wrong results when the result gets large. Since
4477 -- this is all about large results, that's bad, so instead we only
4478 -- apply the check for constrained arrays, and manually compute the
4479 -- value of the attribute ???
4481 if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
4483 Make_Raise_Storage_Error (Loc,
4486 Left_Opnd => Size_In_Storage_Elements (Etyp),
4488 Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
4489 Reason => SE_Object_Too_Large));
4493 -- Handle case of qualified expression (other than optimization above)
4494 -- First apply constraint checks, because the bounds or discriminants
4495 -- in the aggregate might not match the subtype mark in the allocator.
4497 if Nkind (Expression (N)) = N_Qualified_Expression then
4498 Apply_Constraint_Check
4499 (Expression (Expression (N)), Etype (Expression (N)));
4501 Expand_Allocator_Expression (N);
4505 -- If the allocator is for a type which requires initialization, and
4506 -- there is no initial value (i.e. operand is a subtype indication
4507 -- rather than a qualified expression), then we must generate a call to
4508 -- the initialization routine using an expressions action node:
4510 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4512 -- Here ptr_T is the pointer type for the allocator, and T is the
4513 -- subtype of the allocator. A special case arises if the designated
4514 -- type of the access type is a task or contains tasks. In this case
4515 -- the call to Init (Temp.all ...) is replaced by code that ensures
4516 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4517 -- for details). In addition, if the type T is a task T, then the
4518 -- first argument to Init must be converted to the task record type.
4521 T : constant Entity_Id := Entity (Expression (N));
4527 Init_Arg1 : Node_Id;
4528 Temp_Decl : Node_Id;
4529 Temp_Type : Entity_Id;
4532 if No_Initialization (N) then
4534 -- Even though this might be a simple allocation, create a custom
4535 -- Allocate if the context requires it. Since .NET/JVM compilers
4536 -- do not support pools, this step is skipped.
4538 if VM_Target = No_VM
4539 and then Present (Finalization_Master (PtrT))
4541 Build_Allocate_Deallocate_Proc
4543 Is_Allocate => True);
4546 -- Case of no initialization procedure present
4548 elsif not Has_Non_Null_Base_Init_Proc (T) then
4550 -- Case of simple initialization required
4552 if Needs_Simple_Initialization (T) then
4553 Check_Restriction (No_Default_Initialization, N);
4554 Rewrite (Expression (N),
4555 Make_Qualified_Expression (Loc,
4556 Subtype_Mark => New_Occurrence_Of (T, Loc),
4557 Expression => Get_Simple_Init_Val (T, N)));
4559 Analyze_And_Resolve (Expression (Expression (N)), T);
4560 Analyze_And_Resolve (Expression (N), T);
4561 Set_Paren_Count (Expression (Expression (N)), 1);
4562 Expand_N_Allocator (N);
4564 -- No initialization required
4570 -- Case of initialization procedure present, must be called
4573 Check_Restriction (No_Default_Initialization, N);
4575 if not Restriction_Active (No_Default_Initialization) then
4576 Init := Base_Init_Proc (T);
4578 Temp := Make_Temporary (Loc, 'P');
4580 -- Construct argument list for the initialization routine call
4583 Make_Explicit_Dereference (Loc,
4585 New_Occurrence_Of (Temp, Loc));
4587 Set_Assignment_OK (Init_Arg1);
4590 -- The initialization procedure expects a specific type. if the
4591 -- context is access to class wide, indicate that the object
4592 -- being allocated has the right specific type.
4594 if Is_Class_Wide_Type (Dtyp) then
4595 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
4598 -- If designated type is a concurrent type or if it is private
4599 -- type whose definition is a concurrent type, the first
4600 -- argument in the Init routine has to be unchecked conversion
4601 -- to the corresponding record type. If the designated type is
4602 -- a derived type, also convert the argument to its root type.
4604 if Is_Concurrent_Type (T) then
4606 Unchecked_Convert_To (
4607 Corresponding_Record_Type (T), Init_Arg1);
4609 elsif Is_Private_Type (T)
4610 and then Present (Full_View (T))
4611 and then Is_Concurrent_Type (Full_View (T))
4614 Unchecked_Convert_To
4615 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
4617 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
4619 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
4622 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
4623 Set_Etype (Init_Arg1, Ftyp);
4627 Args := New_List (Init_Arg1);
4629 -- For the task case, pass the Master_Id of the access type as
4630 -- the value of the _Master parameter, and _Chain as the value
4631 -- of the _Chain parameter (_Chain will be defined as part of
4632 -- the generated code for the allocator).
4634 -- In Ada 2005, the context may be a function that returns an
4635 -- anonymous access type. In that case the Master_Id has been
4636 -- created when expanding the function declaration.
4638 if Has_Task (T) then
4639 if No (Master_Id (Base_Type (PtrT))) then
4641 -- The designated type was an incomplete type, and the
4642 -- access type did not get expanded. Salvage it now.
4644 if not Restriction_Active (No_Task_Hierarchy) then
4645 if Present (Parent (Base_Type (PtrT))) then
4646 Expand_N_Full_Type_Declaration
4647 (Parent (Base_Type (PtrT)));
4649 -- The only other possibility is an itype. For this
4650 -- case, the master must exist in the context. This is
4651 -- the case when the allocator initializes an access
4652 -- component in an init-proc.
4655 pragma Assert (Is_Itype (PtrT));
4656 Build_Master_Renaming (PtrT, N);
4661 -- If the context of the allocator is a declaration or an
4662 -- assignment, we can generate a meaningful image for it,
4663 -- even though subsequent assignments might remove the
4664 -- connection between task and entity. We build this image
4665 -- when the left-hand side is a simple variable, a simple
4666 -- indexed assignment or a simple selected component.
4668 if Nkind (Parent (N)) = N_Assignment_Statement then
4670 Nam : constant Node_Id := Name (Parent (N));
4673 if Is_Entity_Name (Nam) then
4675 Build_Task_Image_Decls
4678 (Entity (Nam), Sloc (Nam)), T);
4680 elsif Nkind_In (Nam, N_Indexed_Component,
4681 N_Selected_Component)
4682 and then Is_Entity_Name (Prefix (Nam))
4685 Build_Task_Image_Decls
4686 (Loc, Nam, Etype (Prefix (Nam)));
4688 Decls := Build_Task_Image_Decls (Loc, T, T);
4692 elsif Nkind (Parent (N)) = N_Object_Declaration then
4694 Build_Task_Image_Decls
4695 (Loc, Defining_Identifier (Parent (N)), T);
4698 Decls := Build_Task_Image_Decls (Loc, T, T);
4701 if Restriction_Active (No_Task_Hierarchy) then
4703 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
4707 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
4710 Append_To (Args, Make_Identifier (Loc, Name_uChain));
4712 Decl := Last (Decls);
4714 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
4716 -- Has_Task is false, Decls not used
4722 -- Add discriminants if discriminated type
4725 Dis : Boolean := False;
4729 if Has_Discriminants (T) then
4733 elsif Is_Private_Type (T)
4734 and then Present (Full_View (T))
4735 and then Has_Discriminants (Full_View (T))
4738 Typ := Full_View (T);
4743 -- If the allocated object will be constrained by the
4744 -- default values for discriminants, then build a subtype
4745 -- with those defaults, and change the allocated subtype
4746 -- to that. Note that this happens in fewer cases in Ada
4749 if not Is_Constrained (Typ)
4750 and then Present (Discriminant_Default_Value
4751 (First_Discriminant (Typ)))
4752 and then (Ada_Version < Ada_2005
4754 Object_Type_Has_Constrained_Partial_View
4755 (Typ, Current_Scope))
4757 Typ := Build_Default_Subtype (Typ, N);
4758 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
4761 Discr := First_Elmt (Discriminant_Constraint (Typ));
4762 while Present (Discr) loop
4763 Nod := Node (Discr);
4764 Append (New_Copy_Tree (Node (Discr)), Args);
4766 -- AI-416: when the discriminant constraint is an
4767 -- anonymous access type make sure an accessibility
4768 -- check is inserted if necessary (3.10.2(22.q/2))
4770 if Ada_Version >= Ada_2005
4772 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
4774 Apply_Accessibility_Check
4775 (Nod, Typ, Insert_Node => Nod);
4783 -- We set the allocator as analyzed so that when we analyze
4784 -- the if expression node, we do not get an unwanted recursive
4785 -- expansion of the allocator expression.
4787 Set_Analyzed (N, True);
4788 Nod := Relocate_Node (N);
4790 -- Here is the transformation:
4791 -- input: new Ctrl_Typ
4792 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4793 -- Ctrl_TypIP (Temp.all, ...);
4794 -- [Deep_]Initialize (Temp.all);
4796 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4797 -- is the subtype of the allocator.
4800 Make_Object_Declaration (Loc,
4801 Defining_Identifier => Temp,
4802 Constant_Present => True,
4803 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
4806 Set_Assignment_OK (Temp_Decl);
4807 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
4809 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
4811 -- If the designated type is a task type or contains tasks,
4812 -- create block to activate created tasks, and insert
4813 -- declaration for Task_Image variable ahead of call.
4815 if Has_Task (T) then
4817 L : constant List_Id := New_List;
4820 Build_Task_Allocate_Block (L, Nod, Args);
4822 Insert_List_Before (First (Declarations (Blk)), Decls);
4823 Insert_Actions (N, L);
4828 Make_Procedure_Call_Statement (Loc,
4829 Name => New_Occurrence_Of (Init, Loc),
4830 Parameter_Associations => Args));
4833 if Needs_Finalization (T) then
4836 -- [Deep_]Initialize (Init_Arg1);
4840 (Obj_Ref => New_Copy_Tree (Init_Arg1),
4843 if Present (Finalization_Master (PtrT)) then
4845 -- Special processing for .NET/JVM, the allocated object
4846 -- is attached to the finalization master. Generate:
4848 -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4850 -- Types derived from [Limited_]Controlled are the only
4851 -- ones considered since they have fields Prev and Next.
4853 if VM_Target /= No_VM then
4854 if Is_Controlled (T) then
4857 (Obj_Ref => New_Copy_Tree (Init_Arg1),
4861 -- Default case, generate:
4863 -- Set_Finalize_Address
4864 -- (<PtrT>FM, <T>FD'Unrestricted_Access);
4866 -- Do not generate this call in CodePeer mode, as TSS
4867 -- primitive Finalize_Address is not created in this
4870 elsif not CodePeer_Mode then
4872 Make_Set_Finalize_Address_Call
4880 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4881 Analyze_And_Resolve (N, PtrT);
4886 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
4887 -- object that has been rewritten as a reference, we displace "this"
4888 -- to reference properly its secondary dispatch table.
4890 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
4891 Displace_Allocator_Pointer (N);
4895 when RE_Not_Available =>
4897 end Expand_N_Allocator;
4899 -----------------------
4900 -- Expand_N_And_Then --
4901 -----------------------
4903 procedure Expand_N_And_Then (N : Node_Id)
4904 renames Expand_Short_Circuit_Operator;
4906 ------------------------------
4907 -- Expand_N_Case_Expression --
4908 ------------------------------
4910 procedure Expand_N_Case_Expression (N : Node_Id) is
4911 Loc : constant Source_Ptr := Sloc (N);
4912 Typ : constant Entity_Id := Etype (N);
4923 -- Check for MINIMIZED/ELIMINATED overflow mode
4925 if Minimized_Eliminated_Overflow_Check (N) then
4926 Apply_Arithmetic_Overflow_Check (N);
4932 -- case X is when A => AX, when B => BX ...
4947 -- However, this expansion is wrong for limited types, and also
4948 -- wrong for unconstrained types (since the bounds may not be the
4949 -- same in all branches). Furthermore it involves an extra copy
4950 -- for large objects. So we take care of this by using the following
4951 -- modified expansion for non-elementary types:
4954 -- type Pnn is access all typ;
4958 -- T := AX'Unrestricted_Access;
4960 -- T := BX'Unrestricted_Access;
4966 Make_Case_Statement (Loc,
4967 Expression => Expression (N),
4968 Alternatives => New_List);
4970 Actions := New_List;
4974 if Is_Elementary_Type (Typ) then
4978 Pnn := Make_Temporary (Loc, 'P');
4980 Make_Full_Type_Declaration (Loc,
4981 Defining_Identifier => Pnn,
4983 Make_Access_To_Object_Definition (Loc,
4984 All_Present => True,
4985 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
4989 Tnn := Make_Temporary (Loc, 'T');
4991 -- Create declaration for target of expression, and indicate that it
4992 -- does not require initialization.
4995 Make_Object_Declaration (Loc,
4996 Defining_Identifier => Tnn,
4997 Object_Definition => New_Occurrence_Of (Ttyp, Loc));
4998 Set_No_Initialization (Decl);
4999 Append_To (Actions, Decl);
5001 -- Now process the alternatives
5003 Alt := First (Alternatives (N));
5004 while Present (Alt) loop
5006 Aexp : Node_Id := Expression (Alt);
5007 Aloc : constant Source_Ptr := Sloc (Aexp);
5011 -- As described above, take Unrestricted_Access for case of non-
5012 -- scalar types, to avoid big copies, and special cases.
5014 if not Is_Elementary_Type (Typ) then
5016 Make_Attribute_Reference (Aloc,
5017 Prefix => Relocate_Node (Aexp),
5018 Attribute_Name => Name_Unrestricted_Access);
5022 Make_Assignment_Statement (Aloc,
5023 Name => New_Occurrence_Of (Tnn, Loc),
5024 Expression => Aexp));
5026 -- Propagate declarations inserted in the node by Insert_Actions
5027 -- (for example, temporaries generated to remove side effects).
5028 -- These actions must remain attached to the alternative, given
5029 -- that they are generated by the corresponding expression.
5031 if Present (Sinfo.Actions (Alt)) then
5032 Prepend_List (Sinfo.Actions (Alt), Stats);
5036 (Alternatives (Cstmt),
5037 Make_Case_Statement_Alternative (Sloc (Alt),
5038 Discrete_Choices => Discrete_Choices (Alt),
5039 Statements => Stats));
5045 Append_To (Actions, Cstmt);
5047 -- Construct and return final expression with actions
5049 if Is_Elementary_Type (Typ) then
5050 Fexp := New_Occurrence_Of (Tnn, Loc);
5053 Make_Explicit_Dereference (Loc,
5054 Prefix => New_Occurrence_Of (Tnn, Loc));
5058 Make_Expression_With_Actions (Loc,
5060 Actions => Actions));
5062 Analyze_And_Resolve (N, Typ);
5063 end Expand_N_Case_Expression;
5065 -----------------------------------
5066 -- Expand_N_Explicit_Dereference --
5067 -----------------------------------
5069 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
5071 -- Insert explicit dereference call for the checked storage pool case
5073 Insert_Dereference_Action (Prefix (N));
5075 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5076 -- we set the atomic sync flag.
5078 if Is_Atomic (Etype (N))
5079 and then not Atomic_Synchronization_Disabled (Etype (N))
5081 Activate_Atomic_Synchronization (N);
5083 end Expand_N_Explicit_Dereference;
5085 --------------------------------------
5086 -- Expand_N_Expression_With_Actions --
5087 --------------------------------------
5089 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
5091 function Process_Action (Act : Node_Id) return Traverse_Result;
5092 -- Inspect and process a single action of an expression_with_actions for
5093 -- transient controlled objects. If such objects are found, the routine
5094 -- generates code to clean them up when the context of the expression is
5095 -- evaluated or elaborated.
5097 --------------------
5098 -- Process_Action --
5099 --------------------
5101 function Process_Action (Act : Node_Id) return Traverse_Result is
5103 if Nkind (Act) = N_Object_Declaration
5104 and then Is_Finalizable_Transient (Act, N)
5106 Process_Transient_Object (Act, N);
5109 -- Avoid processing temporary function results multiple times when
5110 -- dealing with nested expression_with_actions.
5112 elsif Nkind (Act) = N_Expression_With_Actions then
5115 -- Do not process temporary function results in loops. This is done
5116 -- by Expand_N_Loop_Statement and Build_Finalizer.
5118 elsif Nkind (Act) = N_Loop_Statement then
5125 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5131 -- Start of processing for Expand_N_Expression_With_Actions
5134 -- Process the actions as described above
5136 Act := First (Actions (N));
5137 while Present (Act) loop
5138 Process_Single_Action (Act);
5142 -- Deal with case where there are no actions. In this case we simply
5143 -- rewrite the node with its expression since we don't need the actions
5144 -- and the specification of this node does not allow a null action list.
5146 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5147 -- the expanded tree and relying on being able to retrieve the original
5148 -- tree in cases like this. This raises a whole lot of issues of whether
5149 -- we have problems elsewhere, which will be addressed in the future???
5151 if Is_Empty_List (Actions (N)) then
5152 Rewrite (N, Relocate_Node (Expression (N)));
5154 end Expand_N_Expression_With_Actions;
5156 ----------------------------
5157 -- Expand_N_If_Expression --
5158 ----------------------------
5160 -- Deal with limited types and condition actions
5162 procedure Expand_N_If_Expression (N : Node_Id) is
5163 procedure Process_Actions (Actions : List_Id);
5164 -- Inspect and process a single action list of an if expression for
5165 -- transient controlled objects. If such objects are found, the routine
5166 -- generates code to clean them up when the context of the expression is
5167 -- evaluated or elaborated.
5169 ---------------------
5170 -- Process_Actions --
5171 ---------------------
5173 procedure Process_Actions (Actions : List_Id) is
5177 Act := First (Actions);
5178 while Present (Act) loop
5179 if Nkind (Act) = N_Object_Declaration
5180 and then Is_Finalizable_Transient (Act, N)
5182 Process_Transient_Object (Act, N);
5187 end Process_Actions;
5191 Loc : constant Source_Ptr := Sloc (N);
5192 Cond : constant Node_Id := First (Expressions (N));
5193 Thenx : constant Node_Id := Next (Cond);
5194 Elsex : constant Node_Id := Next (Thenx);
5195 Typ : constant Entity_Id := Etype (N);
5203 Ptr_Typ : Entity_Id;
5205 -- Start of processing for Expand_N_If_Expression
5208 -- Check for MINIMIZED/ELIMINATED overflow mode
5210 if Minimized_Eliminated_Overflow_Check (N) then
5211 Apply_Arithmetic_Overflow_Check (N);
5215 -- Fold at compile time if condition known. We have already folded
5216 -- static if expressions, but it is possible to fold any case in which
5217 -- the condition is known at compile time, even though the result is
5220 -- Note that we don't do the fold of such cases in Sem_Elab because
5221 -- it can cause infinite loops with the expander adding a conditional
5222 -- expression, and Sem_Elab circuitry removing it repeatedly.
5224 if Compile_Time_Known_Value (Cond) then
5225 if Is_True (Expr_Value (Cond)) then
5227 Actions := Then_Actions (N);
5230 Actions := Else_Actions (N);
5235 if Present (Actions) then
5237 Make_Expression_With_Actions (Loc,
5238 Expression => Relocate_Node (Expr),
5239 Actions => Actions));
5240 Analyze_And_Resolve (N, Typ);
5242 Rewrite (N, Relocate_Node (Expr));
5245 -- Note that the result is never static (legitimate cases of static
5246 -- if expressions were folded in Sem_Eval).
5248 Set_Is_Static_Expression (N, False);
5252 -- If the type is limited or unconstrained, we expand as follows to
5253 -- avoid any possibility of improper copies.
5255 -- Note: it may be possible to avoid this special processing if the
5256 -- back end uses its own mechanisms for handling by-reference types ???
5258 -- type Ptr is access all Typ;
5262 -- Cnn := then-expr'Unrestricted_Access;
5265 -- Cnn := else-expr'Unrestricted_Access;
5268 -- and replace the if expression by a reference to Cnn.all.
5270 -- This special case can be skipped if the back end handles limited
5271 -- types properly and ensures that no incorrect copies are made.
5273 if Is_By_Reference_Type (Typ)
5274 and then not Back_End_Handles_Limited_Types
5276 -- When the "then" or "else" expressions involve controlled function
5277 -- calls, generated temporaries are chained on the corresponding list
5278 -- of actions. These temporaries need to be finalized after the if
5279 -- expression is evaluated.
5281 Process_Actions (Then_Actions (N));
5282 Process_Actions (Else_Actions (N));
5285 -- type Ann is access all Typ;
5287 Ptr_Typ := Make_Temporary (Loc, 'A');
5290 Make_Full_Type_Declaration (Loc,
5291 Defining_Identifier => Ptr_Typ,
5293 Make_Access_To_Object_Definition (Loc,
5294 All_Present => True,
5295 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5300 Cnn := Make_Temporary (Loc, 'C', N);
5303 Make_Object_Declaration (Loc,
5304 Defining_Identifier => Cnn,
5305 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
5309 -- Cnn := <Thenx>'Unrestricted_Access;
5311 -- Cnn := <Elsex>'Unrestricted_Access;
5315 Make_Implicit_If_Statement (N,
5316 Condition => Relocate_Node (Cond),
5317 Then_Statements => New_List (
5318 Make_Assignment_Statement (Sloc (Thenx),
5319 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5321 Make_Attribute_Reference (Loc,
5322 Prefix => Relocate_Node (Thenx),
5323 Attribute_Name => Name_Unrestricted_Access))),
5325 Else_Statements => New_List (
5326 Make_Assignment_Statement (Sloc (Elsex),
5327 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5329 Make_Attribute_Reference (Loc,
5330 Prefix => Relocate_Node (Elsex),
5331 Attribute_Name => Name_Unrestricted_Access))));
5334 Make_Explicit_Dereference (Loc,
5335 Prefix => New_Occurrence_Of (Cnn, Loc));
5337 -- For other types, we only need to expand if there are other actions
5338 -- associated with either branch.
5340 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
5342 -- We now wrap the actions into the appropriate expression
5344 if Present (Then_Actions (N)) then
5346 Make_Expression_With_Actions (Sloc (Thenx),
5347 Actions => Then_Actions (N),
5348 Expression => Relocate_Node (Thenx)));
5350 Set_Then_Actions (N, No_List);
5351 Analyze_And_Resolve (Thenx, Typ);
5354 if Present (Else_Actions (N)) then
5356 Make_Expression_With_Actions (Sloc (Elsex),
5357 Actions => Else_Actions (N),
5358 Expression => Relocate_Node (Elsex)));
5360 Set_Else_Actions (N, No_List);
5361 Analyze_And_Resolve (Elsex, Typ);
5366 -- If no actions then no expansion needed, gigi will handle it using the
5367 -- same approach as a C conditional expression.
5373 -- Fall through here for either the limited expansion, or the case of
5374 -- inserting actions for non-limited types. In both these cases, we must
5375 -- move the SLOC of the parent If statement to the newly created one and
5376 -- change it to the SLOC of the expression which, after expansion, will
5377 -- correspond to what is being evaluated.
5379 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
5380 Set_Sloc (New_If, Sloc (Parent (N)));
5381 Set_Sloc (Parent (N), Loc);
5384 -- Make sure Then_Actions and Else_Actions are appropriately moved
5385 -- to the new if statement.
5387 if Present (Then_Actions (N)) then
5389 (First (Then_Statements (New_If)), Then_Actions (N));
5392 if Present (Else_Actions (N)) then
5394 (First (Else_Statements (New_If)), Else_Actions (N));
5397 Insert_Action (N, Decl);
5398 Insert_Action (N, New_If);
5400 Analyze_And_Resolve (N, Typ);
5401 end Expand_N_If_Expression;
5407 procedure Expand_N_In (N : Node_Id) is
5408 Loc : constant Source_Ptr := Sloc (N);
5409 Restyp : constant Entity_Id := Etype (N);
5410 Lop : constant Node_Id := Left_Opnd (N);
5411 Rop : constant Node_Id := Right_Opnd (N);
5412 Static : constant Boolean := Is_OK_Static_Expression (N);
5417 procedure Substitute_Valid_Check;
5418 -- Replaces node N by Lop'Valid. This is done when we have an explicit
5419 -- test for the left operand being in range of its subtype.
5421 ----------------------------
5422 -- Substitute_Valid_Check --
5423 ----------------------------
5425 procedure Substitute_Valid_Check is
5428 Make_Attribute_Reference (Loc,
5429 Prefix => Relocate_Node (Lop),
5430 Attribute_Name => Name_Valid));
5432 Analyze_And_Resolve (N, Restyp);
5434 -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5435 -- in which case, this usage makes sense, and in any case, we have
5436 -- actually eliminated the danger of optimization above.
5438 if Overflow_Check_Mode not in Minimized_Or_Eliminated then
5440 ("??explicit membership test may be optimized away", N);
5441 Error_Msg_N -- CODEFIX
5442 ("\??use ''Valid attribute instead", N);
5446 end Substitute_Valid_Check;
5448 -- Start of processing for Expand_N_In
5451 -- If set membership case, expand with separate procedure
5453 if Present (Alternatives (N)) then
5454 Expand_Set_Membership (N);
5458 -- Not set membership, proceed with expansion
5460 Ltyp := Etype (Left_Opnd (N));
5461 Rtyp := Etype (Right_Opnd (N));
5463 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5464 -- type, then expand with a separate procedure. Note the use of the
5465 -- flag No_Minimize_Eliminate to prevent infinite recursion.
5467 if Overflow_Check_Mode in Minimized_Or_Eliminated
5468 and then Is_Signed_Integer_Type (Ltyp)
5469 and then not No_Minimize_Eliminate (N)
5471 Expand_Membership_Minimize_Eliminate_Overflow (N);
5475 -- Check case of explicit test for an expression in range of its
5476 -- subtype. This is suspicious usage and we replace it with a 'Valid
5477 -- test and give a warning for scalar types.
5479 if Is_Scalar_Type (Ltyp)
5481 -- Only relevant for source comparisons
5483 and then Comes_From_Source (N)
5485 -- In floating-point this is a standard way to check for finite values
5486 -- and using 'Valid would typically be a pessimization.
5488 and then not Is_Floating_Point_Type (Ltyp)
5490 -- Don't give the message unless right operand is a type entity and
5491 -- the type of the left operand matches this type. Note that this
5492 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5493 -- checks have changed the type of the left operand.
5495 and then Nkind (Rop) in N_Has_Entity
5496 and then Ltyp = Entity (Rop)
5498 -- Skip in VM mode, where we have no sense of invalid values. The
5499 -- warning still seems relevant, but not important enough to worry.
5501 and then VM_Target = No_VM
5503 -- Skip this for predicated types, where such expressions are a
5504 -- reasonable way of testing if something meets the predicate.
5506 and then not Present (Predicate_Function (Ltyp))
5508 Substitute_Valid_Check;
5512 -- Do validity check on operands
5514 if Validity_Checks_On and Validity_Check_Operands then
5515 Ensure_Valid (Left_Opnd (N));
5516 Validity_Check_Range (Right_Opnd (N));
5519 -- Case of explicit range
5521 if Nkind (Rop) = N_Range then
5523 Lo : constant Node_Id := Low_Bound (Rop);
5524 Hi : constant Node_Id := High_Bound (Rop);
5526 Lo_Orig : constant Node_Id := Original_Node (Lo);
5527 Hi_Orig : constant Node_Id := Original_Node (Hi);
5529 Lcheck : Compare_Result;
5530 Ucheck : Compare_Result;
5532 Warn1 : constant Boolean :=
5533 Constant_Condition_Warnings
5534 and then Comes_From_Source (N)
5535 and then not In_Instance;
5536 -- This must be true for any of the optimization warnings, we
5537 -- clearly want to give them only for source with the flag on. We
5538 -- also skip these warnings in an instance since it may be the
5539 -- case that different instantiations have different ranges.
5541 Warn2 : constant Boolean :=
5543 and then Nkind (Original_Node (Rop)) = N_Range
5544 and then Is_Integer_Type (Etype (Lo));
5545 -- For the case where only one bound warning is elided, we also
5546 -- insist on an explicit range and an integer type. The reason is
5547 -- that the use of enumeration ranges including an end point is
5548 -- common, as is the use of a subtype name, one of whose bounds is
5549 -- the same as the type of the expression.
5552 -- If test is explicit x'First .. x'Last, replace by valid check
5554 -- Could use some individual comments for this complex test ???
5556 if Is_Scalar_Type (Ltyp)
5558 -- And left operand is X'First where X matches left operand
5559 -- type (this eliminates cases of type mismatch, including
5560 -- the cases where ELIMINATED/MINIMIZED mode has changed the
5561 -- type of the left operand.
5563 and then Nkind (Lo_Orig) = N_Attribute_Reference
5564 and then Attribute_Name (Lo_Orig) = Name_First
5565 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
5566 and then Entity (Prefix (Lo_Orig)) = Ltyp
5568 -- Same tests for right operand
5570 and then Nkind (Hi_Orig) = N_Attribute_Reference
5571 and then Attribute_Name (Hi_Orig) = Name_Last
5572 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
5573 and then Entity (Prefix (Hi_Orig)) = Ltyp
5575 -- Relevant only for source cases
5577 and then Comes_From_Source (N)
5579 -- Omit for VM cases, where we don't have invalid values
5581 and then VM_Target = No_VM
5583 Substitute_Valid_Check;
5587 -- If bounds of type are known at compile time, and the end points
5588 -- are known at compile time and identical, this is another case
5589 -- for substituting a valid test. We only do this for discrete
5590 -- types, since it won't arise in practice for float types.
5592 if Comes_From_Source (N)
5593 and then Is_Discrete_Type (Ltyp)
5594 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
5595 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
5596 and then Compile_Time_Known_Value (Lo)
5597 and then Compile_Time_Known_Value (Hi)
5598 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
5599 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
5601 -- Kill warnings in instances, since they may be cases where we
5602 -- have a test in the generic that makes sense with some types
5603 -- and not with other types.
5605 and then not In_Instance
5607 Substitute_Valid_Check;
5611 -- If we have an explicit range, do a bit of optimization based on
5612 -- range analysis (we may be able to kill one or both checks).
5614 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
5615 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
5617 -- If either check is known to fail, replace result by False since
5618 -- the other check does not matter. Preserve the static flag for
5619 -- legality checks, because we are constant-folding beyond RM 4.9.
5621 if Lcheck = LT or else Ucheck = GT then
5623 Error_Msg_N ("?c?range test optimized away", N);
5624 Error_Msg_N ("\?c?value is known to be out of range", N);
5627 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5628 Analyze_And_Resolve (N, Restyp);
5629 Set_Is_Static_Expression (N, Static);
5632 -- If both checks are known to succeed, replace result by True,
5633 -- since we know we are in range.
5635 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
5637 Error_Msg_N ("?c?range test optimized away", N);
5638 Error_Msg_N ("\?c?value is known to be in range", N);
5641 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5642 Analyze_And_Resolve (N, Restyp);
5643 Set_Is_Static_Expression (N, Static);
5646 -- If lower bound check succeeds and upper bound check is not
5647 -- known to succeed or fail, then replace the range check with
5648 -- a comparison against the upper bound.
5650 elsif Lcheck in Compare_GE then
5651 if Warn2 and then not In_Instance then
5652 Error_Msg_N ("??lower bound test optimized away", Lo);
5653 Error_Msg_N ("\??value is known to be in range", Lo);
5659 Right_Opnd => High_Bound (Rop)));
5660 Analyze_And_Resolve (N, Restyp);
5663 -- If upper bound check succeeds and lower bound check is not
5664 -- known to succeed or fail, then replace the range check with
5665 -- a comparison against the lower bound.
5667 elsif Ucheck in Compare_LE then
5668 if Warn2 and then not In_Instance then
5669 Error_Msg_N ("??upper bound test optimized away", Hi);
5670 Error_Msg_N ("\??value is known to be in range", Hi);
5676 Right_Opnd => Low_Bound (Rop)));
5677 Analyze_And_Resolve (N, Restyp);
5681 -- We couldn't optimize away the range check, but there is one
5682 -- more issue. If we are checking constant conditionals, then we
5683 -- see if we can determine the outcome assuming everything is
5684 -- valid, and if so give an appropriate warning.
5686 if Warn1 and then not Assume_No_Invalid_Values then
5687 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
5688 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
5690 -- Result is out of range for valid value
5692 if Lcheck = LT or else Ucheck = GT then
5694 ("?c?value can only be in range if it is invalid", N);
5696 -- Result is in range for valid value
5698 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
5700 ("?c?value can only be out of range if it is invalid", N);
5702 -- Lower bound check succeeds if value is valid
5704 elsif Warn2 and then Lcheck in Compare_GE then
5706 ("?c?lower bound check only fails if it is invalid", Lo);
5708 -- Upper bound check succeeds if value is valid
5710 elsif Warn2 and then Ucheck in Compare_LE then
5712 ("?c?upper bound check only fails for invalid values", Hi);
5717 -- For all other cases of an explicit range, nothing to be done
5721 -- Here right operand is a subtype mark
5725 Typ : Entity_Id := Etype (Rop);
5726 Is_Acc : constant Boolean := Is_Access_Type (Typ);
5727 Cond : Node_Id := Empty;
5729 Obj : Node_Id := Lop;
5730 SCIL_Node : Node_Id;
5733 Remove_Side_Effects (Obj);
5735 -- For tagged type, do tagged membership operation
5737 if Is_Tagged_Type (Typ) then
5739 -- No expansion will be performed when VM_Target, as the VM
5740 -- back-ends will handle the membership tests directly (tags
5741 -- are not explicitly represented in Java objects, so the
5742 -- normal tagged membership expansion is not what we want).
5744 if Tagged_Type_Expansion then
5745 Tagged_Membership (N, SCIL_Node, New_N);
5747 Analyze_And_Resolve (N, Restyp);
5749 -- Update decoration of relocated node referenced by the
5752 if Generate_SCIL and then Present (SCIL_Node) then
5753 Set_SCIL_Node (N, SCIL_Node);
5759 -- If type is scalar type, rewrite as x in t'First .. t'Last.
5760 -- This reason we do this is that the bounds may have the wrong
5761 -- type if they come from the original type definition. Also this
5762 -- way we get all the processing above for an explicit range.
5764 -- Don't do this for predicated types, since in this case we
5765 -- want to check the predicate.
5767 elsif Is_Scalar_Type (Typ) then
5768 if No (Predicate_Function (Typ)) then
5772 Make_Attribute_Reference (Loc,
5773 Attribute_Name => Name_First,
5774 Prefix => New_Occurrence_Of (Typ, Loc)),
5777 Make_Attribute_Reference (Loc,
5778 Attribute_Name => Name_Last,
5779 Prefix => New_Occurrence_Of (Typ, Loc))));
5780 Analyze_And_Resolve (N, Restyp);
5785 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
5786 -- a membership test if the subtype mark denotes a constrained
5787 -- Unchecked_Union subtype and the expression lacks inferable
5790 elsif Is_Unchecked_Union (Base_Type (Typ))
5791 and then Is_Constrained (Typ)
5792 and then not Has_Inferable_Discriminants (Lop)
5795 Make_Raise_Program_Error (Loc,
5796 Reason => PE_Unchecked_Union_Restriction));
5798 -- Prevent Gigi from generating incorrect code by rewriting the
5799 -- test as False. What is this undocumented thing about ???
5801 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5805 -- Here we have a non-scalar type
5808 Typ := Designated_Type (Typ);
5811 if not Is_Constrained (Typ) then
5812 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5813 Analyze_And_Resolve (N, Restyp);
5815 -- For the constrained array case, we have to check the subscripts
5816 -- for an exact match if the lengths are non-zero (the lengths
5817 -- must match in any case).
5819 elsif Is_Array_Type (Typ) then
5820 Check_Subscripts : declare
5821 function Build_Attribute_Reference
5824 Dim : Nat) return Node_Id;
5825 -- Build attribute reference E'Nam (Dim)
5827 -------------------------------
5828 -- Build_Attribute_Reference --
5829 -------------------------------
5831 function Build_Attribute_Reference
5834 Dim : Nat) return Node_Id
5838 Make_Attribute_Reference (Loc,
5840 Attribute_Name => Nam,
5841 Expressions => New_List (
5842 Make_Integer_Literal (Loc, Dim)));
5843 end Build_Attribute_Reference;
5845 -- Start of processing for Check_Subscripts
5848 for J in 1 .. Number_Dimensions (Typ) loop
5849 Evolve_And_Then (Cond,
5852 Build_Attribute_Reference
5853 (Duplicate_Subexpr_No_Checks (Obj),
5856 Build_Attribute_Reference
5857 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
5859 Evolve_And_Then (Cond,
5862 Build_Attribute_Reference
5863 (Duplicate_Subexpr_No_Checks (Obj),
5866 Build_Attribute_Reference
5867 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
5876 Right_Opnd => Make_Null (Loc)),
5877 Right_Opnd => Cond);
5881 Analyze_And_Resolve (N, Restyp);
5882 end Check_Subscripts;
5884 -- These are the cases where constraint checks may be required,
5885 -- e.g. records with possible discriminants
5888 -- Expand the test into a series of discriminant comparisons.
5889 -- The expression that is built is the negation of the one that
5890 -- is used for checking discriminant constraints.
5892 Obj := Relocate_Node (Left_Opnd (N));
5894 if Has_Discriminants (Typ) then
5895 Cond := Make_Op_Not (Loc,
5896 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
5899 Cond := Make_Or_Else (Loc,
5903 Right_Opnd => Make_Null (Loc)),
5904 Right_Opnd => Cond);
5908 Cond := New_Occurrence_Of (Standard_True, Loc);
5912 Analyze_And_Resolve (N, Restyp);
5915 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
5916 -- expression of an anonymous access type. This can involve an
5917 -- accessibility test and a tagged type membership test in the
5918 -- case of tagged designated types.
5920 if Ada_Version >= Ada_2012
5922 and then Ekind (Ltyp) = E_Anonymous_Access_Type
5925 Expr_Entity : Entity_Id := Empty;
5927 Param_Level : Node_Id;
5928 Type_Level : Node_Id;
5931 if Is_Entity_Name (Lop) then
5932 Expr_Entity := Param_Entity (Lop);
5934 if not Present (Expr_Entity) then
5935 Expr_Entity := Entity (Lop);
5939 -- If a conversion of the anonymous access value to the
5940 -- tested type would be illegal, then the result is False.
5942 if not Valid_Conversion
5943 (Lop, Rtyp, Lop, Report_Errs => False)
5945 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5946 Analyze_And_Resolve (N, Restyp);
5948 -- Apply an accessibility check if the access object has an
5949 -- associated access level and when the level of the type is
5950 -- less deep than the level of the access parameter. This
5951 -- only occur for access parameters and stand-alone objects
5952 -- of an anonymous access type.
5955 if Present (Expr_Entity)
5958 (Effective_Extra_Accessibility (Expr_Entity))
5959 and then UI_Gt (Object_Access_Level (Lop),
5960 Type_Access_Level (Rtyp))
5964 (Effective_Extra_Accessibility (Expr_Entity), Loc);
5967 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
5969 -- Return True only if the accessibility level of the
5970 -- expression entity is not deeper than the level of
5971 -- the tested access type.
5975 Left_Opnd => Relocate_Node (N),
5976 Right_Opnd => Make_Op_Le (Loc,
5977 Left_Opnd => Param_Level,
5978 Right_Opnd => Type_Level)));
5980 Analyze_And_Resolve (N);
5983 -- If the designated type is tagged, do tagged membership
5986 -- *** NOTE: we have to check not null before doing the
5987 -- tagged membership test (but maybe that can be done
5988 -- inside Tagged_Membership?).
5990 if Is_Tagged_Type (Typ) then
5993 Left_Opnd => Relocate_Node (N),
5997 Right_Opnd => Make_Null (Loc))));
5999 -- No expansion will be performed when VM_Target, as
6000 -- the VM back-ends will handle the membership tests
6001 -- directly (tags are not explicitly represented in
6002 -- Java objects, so the normal tagged membership
6003 -- expansion is not what we want).
6005 if Tagged_Type_Expansion then
6007 -- Note that we have to pass Original_Node, because
6008 -- the membership test might already have been
6009 -- rewritten by earlier parts of membership test.
6012 (Original_Node (N), SCIL_Node, New_N);
6014 -- Update decoration of relocated node referenced
6015 -- by the SCIL node.
6017 if Generate_SCIL and then Present (SCIL_Node) then
6018 Set_SCIL_Node (New_N, SCIL_Node);
6023 Left_Opnd => Relocate_Node (N),
6024 Right_Opnd => New_N));
6026 Analyze_And_Resolve (N, Restyp);
6035 -- At this point, we have done the processing required for the basic
6036 -- membership test, but not yet dealt with the predicate.
6040 -- If a predicate is present, then we do the predicate test, but we
6041 -- most certainly want to omit this if we are within the predicate
6042 -- function itself, since otherwise we have an infinite recursion.
6043 -- The check should also not be emitted when testing against a range
6044 -- (the check is only done when the right operand is a subtype; see
6045 -- RM12-4.5.2 (28.1/3-30/3)).
6048 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
6052 and then Current_Scope /= PFunc
6053 and then Nkind (Rop) /= N_Range
6057 Left_Opnd => Relocate_Node (N),
6058 Right_Opnd => Make_Predicate_Call (Rtyp, Lop, Mem => True)));
6060 -- Analyze new expression, mark left operand as analyzed to
6061 -- avoid infinite recursion adding predicate calls. Similarly,
6062 -- suppress further range checks on the call.
6064 Set_Analyzed (Left_Opnd (N));
6065 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6067 -- All done, skip attempt at compile time determination of result
6074 --------------------------------
6075 -- Expand_N_Indexed_Component --
6076 --------------------------------
6078 procedure Expand_N_Indexed_Component (N : Node_Id) is
6079 Loc : constant Source_Ptr := Sloc (N);
6080 Typ : constant Entity_Id := Etype (N);
6081 P : constant Node_Id := Prefix (N);
6082 T : constant Entity_Id := Etype (P);
6086 -- A special optimization, if we have an indexed component that is
6087 -- selecting from a slice, then we can eliminate the slice, since, for
6088 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6089 -- the range check required by the slice. The range check for the slice
6090 -- itself has already been generated. The range check for the
6091 -- subscripting operation is ensured by converting the subject to
6092 -- the subtype of the slice.
6094 -- This optimization not only generates better code, avoiding slice
6095 -- messing especially in the packed case, but more importantly bypasses
6096 -- some problems in handling this peculiar case, for example, the issue
6097 -- of dealing specially with object renamings.
6099 if Nkind (P) = N_Slice then
6101 Make_Indexed_Component (Loc,
6102 Prefix => Prefix (P),
6103 Expressions => New_List (
6105 (Etype (First_Index (Etype (P))),
6106 First (Expressions (N))))));
6107 Analyze_And_Resolve (N, Typ);
6111 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6112 -- function, then additional actuals must be passed.
6114 if Ada_Version >= Ada_2005
6115 and then Is_Build_In_Place_Function_Call (P)
6117 Make_Build_In_Place_Call_In_Anonymous_Context (P);
6120 -- If the prefix is an access type, then we unconditionally rewrite if
6121 -- as an explicit dereference. This simplifies processing for several
6122 -- cases, including packed array cases and certain cases in which checks
6123 -- must be generated. We used to try to do this only when it was
6124 -- necessary, but it cleans up the code to do it all the time.
6126 if Is_Access_Type (T) then
6127 Insert_Explicit_Dereference (P);
6128 Analyze_And_Resolve (P, Designated_Type (T));
6129 Atp := Designated_Type (T);
6134 -- Generate index and validity checks
6136 Generate_Index_Checks (N);
6138 if Validity_Checks_On and then Validity_Check_Subscripts then
6139 Apply_Subscript_Validity_Checks (N);
6142 -- If selecting from an array with atomic components, and atomic sync
6143 -- is not suppressed for this array type, set atomic sync flag.
6145 if (Has_Atomic_Components (Atp)
6146 and then not Atomic_Synchronization_Disabled (Atp))
6147 or else (Is_Atomic (Typ)
6148 and then not Atomic_Synchronization_Disabled (Typ))
6150 Activate_Atomic_Synchronization (N);
6153 -- All done for the non-packed case
6155 if not Is_Packed (Etype (Prefix (N))) then
6159 -- For packed arrays that are not bit-packed (i.e. the case of an array
6160 -- with one or more index types with a non-contiguous enumeration type),
6161 -- we can always use the normal packed element get circuit.
6163 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
6164 Expand_Packed_Element_Reference (N);
6168 -- For a reference to a component of a bit packed array, we have to
6169 -- convert it to a reference to the corresponding Packed_Array_Type.
6170 -- We only want to do this for simple references, and not for:
6172 -- Left side of assignment, or prefix of left side of assignment, or
6173 -- prefix of the prefix, to handle packed arrays of packed arrays,
6174 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6176 -- Renaming objects in renaming associations
6177 -- This case is handled when a use of the renamed variable occurs
6179 -- Actual parameters for a procedure call
6180 -- This case is handled in Exp_Ch6.Expand_Actuals
6182 -- The second expression in a 'Read attribute reference
6184 -- The prefix of an address or bit or size attribute reference
6186 -- The following circuit detects these exceptions
6189 Child : Node_Id := N;
6190 Parnt : Node_Id := Parent (N);
6194 if Nkind (Parnt) = N_Unchecked_Expression then
6197 elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
6198 N_Procedure_Call_Statement)
6199 or else (Nkind (Parnt) = N_Parameter_Association
6201 Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
6205 elsif Nkind (Parnt) = N_Attribute_Reference
6206 and then Nam_In (Attribute_Name (Parnt), Name_Address,
6209 and then Prefix (Parnt) = Child
6213 elsif Nkind (Parnt) = N_Assignment_Statement
6214 and then Name (Parnt) = Child
6218 -- If the expression is an index of an indexed component, it must
6219 -- be expanded regardless of context.
6221 elsif Nkind (Parnt) = N_Indexed_Component
6222 and then Child /= Prefix (Parnt)
6224 Expand_Packed_Element_Reference (N);
6227 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
6228 and then Name (Parent (Parnt)) = Parnt
6232 elsif Nkind (Parnt) = N_Attribute_Reference
6233 and then Attribute_Name (Parnt) = Name_Read
6234 and then Next (First (Expressions (Parnt))) = Child
6238 elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
6239 and then Prefix (Parnt) = Child
6244 Expand_Packed_Element_Reference (N);
6248 -- Keep looking up tree for unchecked expression, or if we are the
6249 -- prefix of a possible assignment left side.
6252 Parnt := Parent (Child);
6255 end Expand_N_Indexed_Component;
6257 ---------------------
6258 -- Expand_N_Not_In --
6259 ---------------------
6261 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
6262 -- can be done. This avoids needing to duplicate this expansion code.
6264 procedure Expand_N_Not_In (N : Node_Id) is
6265 Loc : constant Source_Ptr := Sloc (N);
6266 Typ : constant Entity_Id := Etype (N);
6267 Cfs : constant Boolean := Comes_From_Source (N);
6274 Left_Opnd => Left_Opnd (N),
6275 Right_Opnd => Right_Opnd (N))));
6277 -- If this is a set membership, preserve list of alternatives
6279 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
6281 -- We want this to appear as coming from source if original does (see
6282 -- transformations in Expand_N_In).
6284 Set_Comes_From_Source (N, Cfs);
6285 Set_Comes_From_Source (Right_Opnd (N), Cfs);
6287 -- Now analyze transformed node
6289 Analyze_And_Resolve (N, Typ);
6290 end Expand_N_Not_In;
6296 -- The only replacement required is for the case of a null of a type that
6297 -- is an access to protected subprogram, or a subtype thereof. We represent
6298 -- such access values as a record, and so we must replace the occurrence of
6299 -- null by the equivalent record (with a null address and a null pointer in
6300 -- it), so that the backend creates the proper value.
6302 procedure Expand_N_Null (N : Node_Id) is
6303 Loc : constant Source_Ptr := Sloc (N);
6304 Typ : constant Entity_Id := Base_Type (Etype (N));
6308 if Is_Access_Protected_Subprogram_Type (Typ) then
6310 Make_Aggregate (Loc,
6311 Expressions => New_List (
6312 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
6316 Analyze_And_Resolve (N, Equivalent_Type (Typ));
6318 -- For subsequent semantic analysis, the node must retain its type.
6319 -- Gigi in any case replaces this type by the corresponding record
6320 -- type before processing the node.
6326 when RE_Not_Available =>
6330 ---------------------
6331 -- Expand_N_Op_Abs --
6332 ---------------------
6334 procedure Expand_N_Op_Abs (N : Node_Id) is
6335 Loc : constant Source_Ptr := Sloc (N);
6336 Expr : constant Node_Id := Right_Opnd (N);
6339 Unary_Op_Validity_Checks (N);
6341 -- Check for MINIMIZED/ELIMINATED overflow mode
6343 if Minimized_Eliminated_Overflow_Check (N) then
6344 Apply_Arithmetic_Overflow_Check (N);
6348 -- Deal with software overflow checking
6350 if not Backend_Overflow_Checks_On_Target
6351 and then Is_Signed_Integer_Type (Etype (N))
6352 and then Do_Overflow_Check (N)
6354 -- The only case to worry about is when the argument is equal to the
6355 -- largest negative number, so what we do is to insert the check:
6357 -- [constraint_error when Expr = typ'Base'First]
6359 -- with the usual Duplicate_Subexpr use coding for expr
6362 Make_Raise_Constraint_Error (Loc,
6365 Left_Opnd => Duplicate_Subexpr (Expr),
6367 Make_Attribute_Reference (Loc,
6369 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
6370 Attribute_Name => Name_First)),
6371 Reason => CE_Overflow_Check_Failed));
6374 -- Vax floating-point types case
6376 if Vax_Float (Etype (N)) then
6377 Expand_Vax_Arith (N);
6379 end Expand_N_Op_Abs;
6381 ---------------------
6382 -- Expand_N_Op_Add --
6383 ---------------------
6385 procedure Expand_N_Op_Add (N : Node_Id) is
6386 Typ : constant Entity_Id := Etype (N);
6389 Binary_Op_Validity_Checks (N);
6391 -- Check for MINIMIZED/ELIMINATED overflow mode
6393 if Minimized_Eliminated_Overflow_Check (N) then
6394 Apply_Arithmetic_Overflow_Check (N);
6398 -- N + 0 = 0 + N = N for integer types
6400 if Is_Integer_Type (Typ) then
6401 if Compile_Time_Known_Value (Right_Opnd (N))
6402 and then Expr_Value (Right_Opnd (N)) = Uint_0
6404 Rewrite (N, Left_Opnd (N));
6407 elsif Compile_Time_Known_Value (Left_Opnd (N))
6408 and then Expr_Value (Left_Opnd (N)) = Uint_0
6410 Rewrite (N, Right_Opnd (N));
6415 -- Arithmetic overflow checks for signed integer/fixed point types
6417 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
6418 Apply_Arithmetic_Overflow_Check (N);
6421 -- Vax floating-point types case
6423 elsif Vax_Float (Typ) then
6424 Expand_Vax_Arith (N);
6426 end Expand_N_Op_Add;
6428 ---------------------
6429 -- Expand_N_Op_And --
6430 ---------------------
6432 procedure Expand_N_Op_And (N : Node_Id) is
6433 Typ : constant Entity_Id := Etype (N);
6436 Binary_Op_Validity_Checks (N);
6438 if Is_Array_Type (Etype (N)) then
6439 Expand_Boolean_Operator (N);
6441 elsif Is_Boolean_Type (Etype (N)) then
6442 Adjust_Condition (Left_Opnd (N));
6443 Adjust_Condition (Right_Opnd (N));
6444 Set_Etype (N, Standard_Boolean);
6445 Adjust_Result_Type (N, Typ);
6447 elsif Is_Intrinsic_Subprogram (Entity (N)) then
6448 Expand_Intrinsic_Call (N, Entity (N));
6451 end Expand_N_Op_And;
6453 ------------------------
6454 -- Expand_N_Op_Concat --
6455 ------------------------
6457 procedure Expand_N_Op_Concat (N : Node_Id) is
6459 -- List of operands to be concatenated
6462 -- Node which is to be replaced by the result of concatenating the nodes
6463 -- in the list Opnds.
6466 -- Ensure validity of both operands
6468 Binary_Op_Validity_Checks (N);
6470 -- If we are the left operand of a concatenation higher up the tree,
6471 -- then do nothing for now, since we want to deal with a series of
6472 -- concatenations as a unit.
6474 if Nkind (Parent (N)) = N_Op_Concat
6475 and then N = Left_Opnd (Parent (N))
6480 -- We get here with a concatenation whose left operand may be a
6481 -- concatenation itself with a consistent type. We need to process
6482 -- these concatenation operands from left to right, which means
6483 -- from the deepest node in the tree to the highest node.
6486 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
6487 Cnode := Left_Opnd (Cnode);
6490 -- Now Cnode is the deepest concatenation, and its parents are the
6491 -- concatenation nodes above, so now we process bottom up, doing the
6494 -- The outer loop runs more than once if more than one concatenation
6495 -- type is involved.
6498 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
6499 Set_Parent (Opnds, N);
6501 -- The inner loop gathers concatenation operands
6503 Inner : while Cnode /= N
6504 and then Base_Type (Etype (Cnode)) =
6505 Base_Type (Etype (Parent (Cnode)))
6507 Cnode := Parent (Cnode);
6508 Append (Right_Opnd (Cnode), Opnds);
6511 Expand_Concatenate (Cnode, Opnds);
6513 exit Outer when Cnode = N;
6514 Cnode := Parent (Cnode);
6516 end Expand_N_Op_Concat;
6518 ------------------------
6519 -- Expand_N_Op_Divide --
6520 ------------------------
6522 procedure Expand_N_Op_Divide (N : Node_Id) is
6523 Loc : constant Source_Ptr := Sloc (N);
6524 Lopnd : constant Node_Id := Left_Opnd (N);
6525 Ropnd : constant Node_Id := Right_Opnd (N);
6526 Ltyp : constant Entity_Id := Etype (Lopnd);
6527 Rtyp : constant Entity_Id := Etype (Ropnd);
6528 Typ : Entity_Id := Etype (N);
6529 Rknow : constant Boolean := Is_Integer_Type (Typ)
6531 Compile_Time_Known_Value (Ropnd);
6535 Binary_Op_Validity_Checks (N);
6537 -- Check for MINIMIZED/ELIMINATED overflow mode
6539 if Minimized_Eliminated_Overflow_Check (N) then
6540 Apply_Arithmetic_Overflow_Check (N);
6544 -- Otherwise proceed with expansion of division
6547 Rval := Expr_Value (Ropnd);
6550 -- N / 1 = N for integer types
6552 if Rknow and then Rval = Uint_1 then
6557 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6558 -- Is_Power_Of_2_For_Shift is set means that we know that our left
6559 -- operand is an unsigned integer, as required for this to work.
6561 if Nkind (Ropnd) = N_Op_Expon
6562 and then Is_Power_Of_2_For_Shift (Ropnd)
6564 -- We cannot do this transformation in configurable run time mode if we
6565 -- have 64-bit integers and long shifts are not available.
6567 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
6570 Make_Op_Shift_Right (Loc,
6573 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
6574 Analyze_And_Resolve (N, Typ);
6578 -- Do required fixup of universal fixed operation
6580 if Typ = Universal_Fixed then
6581 Fixup_Universal_Fixed_Operation (N);
6585 -- Divisions with fixed-point results
6587 if Is_Fixed_Point_Type (Typ) then
6589 -- No special processing if Treat_Fixed_As_Integer is set, since
6590 -- from a semantic point of view such operations are simply integer
6591 -- operations and will be treated that way.
6593 if not Treat_Fixed_As_Integer (N) then
6594 if Is_Integer_Type (Rtyp) then
6595 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
6597 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
6601 -- Other cases of division of fixed-point operands. Again we exclude the
6602 -- case where Treat_Fixed_As_Integer is set.
6604 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
6605 and then not Treat_Fixed_As_Integer (N)
6607 if Is_Integer_Type (Typ) then
6608 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
6610 pragma Assert (Is_Floating_Point_Type (Typ));
6611 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
6614 -- Mixed-mode operations can appear in a non-static universal context,
6615 -- in which case the integer argument must be converted explicitly.
6617 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
6619 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
6621 Analyze_And_Resolve (Ropnd, Universal_Real);
6623 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
6625 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
6627 Analyze_And_Resolve (Lopnd, Universal_Real);
6629 -- Non-fixed point cases, do integer zero divide and overflow checks
6631 elsif Is_Integer_Type (Typ) then
6632 Apply_Divide_Checks (N);
6634 -- Deal with Vax_Float
6636 elsif Vax_Float (Typ) then
6637 Expand_Vax_Arith (N);
6640 end Expand_N_Op_Divide;
6642 --------------------
6643 -- Expand_N_Op_Eq --
6644 --------------------
6646 procedure Expand_N_Op_Eq (N : Node_Id) is
6647 Loc : constant Source_Ptr := Sloc (N);
6648 Typ : constant Entity_Id := Etype (N);
6649 Lhs : constant Node_Id := Left_Opnd (N);
6650 Rhs : constant Node_Id := Right_Opnd (N);
6651 Bodies : constant List_Id := New_List;
6652 A_Typ : constant Entity_Id := Etype (Lhs);
6654 Typl : Entity_Id := A_Typ;
6655 Op_Name : Entity_Id;
6658 procedure Build_Equality_Call (Eq : Entity_Id);
6659 -- If a constructed equality exists for the type or for its parent,
6660 -- build and analyze call, adding conversions if the operation is
6663 function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
6664 -- Determines whether a type has a subcomponent of an unconstrained
6665 -- Unchecked_Union subtype. Typ is a record type.
6667 -------------------------
6668 -- Build_Equality_Call --
6669 -------------------------
6671 procedure Build_Equality_Call (Eq : Entity_Id) is
6672 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
6673 L_Exp : Node_Id := Relocate_Node (Lhs);
6674 R_Exp : Node_Id := Relocate_Node (Rhs);
6677 -- Adjust operands if necessary to comparison type
6679 if Base_Type (Op_Type) /= Base_Type (A_Typ)
6680 and then not Is_Class_Wide_Type (A_Typ)
6682 L_Exp := OK_Convert_To (Op_Type, L_Exp);
6683 R_Exp := OK_Convert_To (Op_Type, R_Exp);
6686 -- If we have an Unchecked_Union, we need to add the inferred
6687 -- discriminant values as actuals in the function call. At this
6688 -- point, the expansion has determined that both operands have
6689 -- inferable discriminants.
6691 if Is_Unchecked_Union (Op_Type) then
6693 Lhs_Type : constant Node_Id := Etype (L_Exp);
6694 Rhs_Type : constant Node_Id := Etype (R_Exp);
6696 Lhs_Discr_Vals : Elist_Id;
6697 -- List of inferred discriminant values for left operand.
6699 Rhs_Discr_Vals : Elist_Id;
6700 -- List of inferred discriminant values for right operand.
6705 Lhs_Discr_Vals := New_Elmt_List;
6706 Rhs_Discr_Vals := New_Elmt_List;
6708 -- Per-object constrained selected components require special
6709 -- attention. If the enclosing scope of the component is an
6710 -- Unchecked_Union, we cannot reference its discriminants
6711 -- directly. This is why we use the extra parameters of the
6712 -- equality function of the enclosing Unchecked_Union.
6714 -- type UU_Type (Discr : Integer := 0) is
6717 -- pragma Unchecked_Union (UU_Type);
6719 -- 1. Unchecked_Union enclosing record:
6721 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
6723 -- Comp : UU_Type (Discr);
6725 -- end Enclosing_UU_Type;
6726 -- pragma Unchecked_Union (Enclosing_UU_Type);
6728 -- Obj1 : Enclosing_UU_Type;
6729 -- Obj2 : Enclosing_UU_Type (1);
6731 -- [. . .] Obj1 = Obj2 [. . .]
6735 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
6737 -- A and B are the formal parameters of the equality function
6738 -- of Enclosing_UU_Type. The function always has two extra
6739 -- formals to capture the inferred discriminant values for
6740 -- each discriminant of the type.
6742 -- 2. Non-Unchecked_Union enclosing record:
6745 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
6748 -- Comp : UU_Type (Discr);
6750 -- end Enclosing_Non_UU_Type;
6752 -- Obj1 : Enclosing_Non_UU_Type;
6753 -- Obj2 : Enclosing_Non_UU_Type (1);
6755 -- ... Obj1 = Obj2 ...
6759 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
6760 -- obj1.discr, obj2.discr)) then
6762 -- In this case we can directly reference the discriminants of
6763 -- the enclosing record.
6765 -- Process left operand of equality
6767 if Nkind (Lhs) = N_Selected_Component
6769 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
6771 -- If enclosing record is an Unchecked_Union, use formals
6772 -- corresponding to each discriminant. The name of the
6773 -- formal is that of the discriminant, with added suffix,
6774 -- see Exp_Ch3.Build_Record_Equality for details.
6776 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
6780 (Scope (Entity (Selector_Name (Lhs))));
6781 while Present (Discr) loop
6783 Make_Identifier (Loc,
6784 Chars => New_External_Name (Chars (Discr), 'A')),
6785 To => Lhs_Discr_Vals);
6786 Next_Discriminant (Discr);
6789 -- If enclosing record is of a non-Unchecked_Union type, it
6790 -- is possible to reference its discriminants directly.
6793 Discr := First_Discriminant (Lhs_Type);
6794 while Present (Discr) loop
6796 Make_Selected_Component (Loc,
6797 Prefix => Prefix (Lhs),
6800 (Get_Discriminant_Value (Discr,
6802 Stored_Constraint (Lhs_Type)))),
6803 To => Lhs_Discr_Vals);
6804 Next_Discriminant (Discr);
6808 -- Otherwise operand is on object with a constrained type.
6809 -- Infer the discriminant values from the constraint.
6813 Discr := First_Discriminant (Lhs_Type);
6814 while Present (Discr) loop
6817 (Get_Discriminant_Value (Discr,
6819 Stored_Constraint (Lhs_Type))),
6820 To => Lhs_Discr_Vals);
6821 Next_Discriminant (Discr);
6825 -- Similar processing for right operand of equality
6827 if Nkind (Rhs) = N_Selected_Component
6829 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
6831 if Is_Unchecked_Union
6832 (Scope (Entity (Selector_Name (Rhs))))
6836 (Scope (Entity (Selector_Name (Rhs))));
6837 while Present (Discr) loop
6839 Make_Identifier (Loc,
6840 Chars => New_External_Name (Chars (Discr), 'B')),
6841 To => Rhs_Discr_Vals);
6842 Next_Discriminant (Discr);
6846 Discr := First_Discriminant (Rhs_Type);
6847 while Present (Discr) loop
6849 Make_Selected_Component (Loc,
6850 Prefix => Prefix (Rhs),
6852 New_Copy (Get_Discriminant_Value
6855 Stored_Constraint (Rhs_Type)))),
6856 To => Rhs_Discr_Vals);
6857 Next_Discriminant (Discr);
6862 Discr := First_Discriminant (Rhs_Type);
6863 while Present (Discr) loop
6865 New_Copy (Get_Discriminant_Value
6868 Stored_Constraint (Rhs_Type))),
6869 To => Rhs_Discr_Vals);
6870 Next_Discriminant (Discr);
6874 -- Now merge the list of discriminant values so that values
6875 -- of corresponding discriminants are adjacent.
6883 Params := New_List (L_Exp, R_Exp);
6884 L_Elmt := First_Elmt (Lhs_Discr_Vals);
6885 R_Elmt := First_Elmt (Rhs_Discr_Vals);
6886 while Present (L_Elmt) loop
6887 Append_To (Params, Node (L_Elmt));
6888 Append_To (Params, Node (R_Elmt));
6894 Make_Function_Call (Loc,
6895 Name => New_Occurrence_Of (Eq, Loc),
6896 Parameter_Associations => Params));
6900 -- Normal case, not an unchecked union
6904 Make_Function_Call (Loc,
6905 Name => New_Occurrence_Of (Eq, Loc),
6906 Parameter_Associations => New_List (L_Exp, R_Exp)));
6909 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6910 end Build_Equality_Call;
6912 ------------------------------------
6913 -- Has_Unconstrained_UU_Component --
6914 ------------------------------------
6916 function Has_Unconstrained_UU_Component
6917 (Typ : Node_Id) return Boolean
6919 Tdef : constant Node_Id :=
6920 Type_Definition (Declaration_Node (Base_Type (Typ)));
6924 function Component_Is_Unconstrained_UU
6925 (Comp : Node_Id) return Boolean;
6926 -- Determines whether the subtype of the component is an
6927 -- unconstrained Unchecked_Union.
6929 function Variant_Is_Unconstrained_UU
6930 (Variant : Node_Id) return Boolean;
6931 -- Determines whether a component of the variant has an unconstrained
6932 -- Unchecked_Union subtype.
6934 -----------------------------------
6935 -- Component_Is_Unconstrained_UU --
6936 -----------------------------------
6938 function Component_Is_Unconstrained_UU
6939 (Comp : Node_Id) return Boolean
6942 if Nkind (Comp) /= N_Component_Declaration then
6947 Sindic : constant Node_Id :=
6948 Subtype_Indication (Component_Definition (Comp));
6951 -- Unconstrained nominal type. In the case of a constraint
6952 -- present, the node kind would have been N_Subtype_Indication.
6954 if Nkind (Sindic) = N_Identifier then
6955 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
6960 end Component_Is_Unconstrained_UU;
6962 ---------------------------------
6963 -- Variant_Is_Unconstrained_UU --
6964 ---------------------------------
6966 function Variant_Is_Unconstrained_UU
6967 (Variant : Node_Id) return Boolean
6969 Clist : constant Node_Id := Component_List (Variant);
6972 if Is_Empty_List (Component_Items (Clist)) then
6976 -- We only need to test one component
6979 Comp : Node_Id := First (Component_Items (Clist));
6982 while Present (Comp) loop
6983 if Component_Is_Unconstrained_UU (Comp) then
6991 -- None of the components withing the variant were of
6992 -- unconstrained Unchecked_Union type.
6995 end Variant_Is_Unconstrained_UU;
6997 -- Start of processing for Has_Unconstrained_UU_Component
7000 if Null_Present (Tdef) then
7004 Clist := Component_List (Tdef);
7005 Vpart := Variant_Part (Clist);
7007 -- Inspect available components
7009 if Present (Component_Items (Clist)) then
7011 Comp : Node_Id := First (Component_Items (Clist));
7014 while Present (Comp) loop
7016 -- One component is sufficient
7018 if Component_Is_Unconstrained_UU (Comp) then
7027 -- Inspect available components withing variants
7029 if Present (Vpart) then
7031 Variant : Node_Id := First (Variants (Vpart));
7034 while Present (Variant) loop
7036 -- One component within a variant is sufficient
7038 if Variant_Is_Unconstrained_UU (Variant) then
7047 -- Neither the available components, nor the components inside the
7048 -- variant parts were of an unconstrained Unchecked_Union subtype.
7051 end Has_Unconstrained_UU_Component;
7053 -- Start of processing for Expand_N_Op_Eq
7056 Binary_Op_Validity_Checks (N);
7058 -- Deal with private types
7060 if Ekind (Typl) = E_Private_Type then
7061 Typl := Underlying_Type (Typl);
7062 elsif Ekind (Typl) = E_Private_Subtype then
7063 Typl := Underlying_Type (Base_Type (Typl));
7068 -- It may happen in error situations that the underlying type is not
7069 -- set. The error will be detected later, here we just defend the
7076 Typl := Base_Type (Typl);
7078 -- Equality between variant records results in a call to a routine
7079 -- that has conditional tests of the discriminant value(s), and hence
7080 -- violates the No_Implicit_Conditionals restriction.
7082 if Has_Variant_Part (Typl) then
7087 Check_Restriction (Msg, No_Implicit_Conditionals, N);
7091 ("\comparison of variant records tests discriminants", N);
7097 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7098 -- means we no longer have a comparison operation, we are all done.
7100 Expand_Compare_Minimize_Eliminate_Overflow (N);
7102 if Nkind (N) /= N_Op_Eq then
7106 -- Boolean types (requiring handling of non-standard case)
7108 if Is_Boolean_Type (Typl) then
7109 Adjust_Condition (Left_Opnd (N));
7110 Adjust_Condition (Right_Opnd (N));
7111 Set_Etype (N, Standard_Boolean);
7112 Adjust_Result_Type (N, Typ);
7116 elsif Is_Array_Type (Typl) then
7118 -- If we are doing full validity checking, and it is possible for the
7119 -- array elements to be invalid then expand out array comparisons to
7120 -- make sure that we check the array elements.
7122 if Validity_Check_Operands
7123 and then not Is_Known_Valid (Component_Type (Typl))
7126 Save_Force_Validity_Checks : constant Boolean :=
7127 Force_Validity_Checks;
7129 Force_Validity_Checks := True;
7131 Expand_Array_Equality
7133 Relocate_Node (Lhs),
7134 Relocate_Node (Rhs),
7137 Insert_Actions (N, Bodies);
7138 Analyze_And_Resolve (N, Standard_Boolean);
7139 Force_Validity_Checks := Save_Force_Validity_Checks;
7142 -- Packed case where both operands are known aligned
7144 elsif Is_Bit_Packed_Array (Typl)
7145 and then not Is_Possibly_Unaligned_Object (Lhs)
7146 and then not Is_Possibly_Unaligned_Object (Rhs)
7148 Expand_Packed_Eq (N);
7150 -- Where the component type is elementary we can use a block bit
7151 -- comparison (if supported on the target) exception in the case
7152 -- of floating-point (negative zero issues require element by
7153 -- element comparison), and atomic types (where we must be sure
7154 -- to load elements independently) and possibly unaligned arrays.
7156 elsif Is_Elementary_Type (Component_Type (Typl))
7157 and then not Is_Floating_Point_Type (Component_Type (Typl))
7158 and then not Is_Atomic (Component_Type (Typl))
7159 and then not Is_Possibly_Unaligned_Object (Lhs)
7160 and then not Is_Possibly_Unaligned_Object (Rhs)
7161 and then Support_Composite_Compare_On_Target
7165 -- For composite and floating-point cases, expand equality loop to
7166 -- make sure of using proper comparisons for tagged types, and
7167 -- correctly handling the floating-point case.
7171 Expand_Array_Equality
7173 Relocate_Node (Lhs),
7174 Relocate_Node (Rhs),
7177 Insert_Actions (N, Bodies, Suppress => All_Checks);
7178 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7183 elsif Is_Record_Type (Typl) then
7185 -- For tagged types, use the primitive "="
7187 if Is_Tagged_Type (Typl) then
7189 -- No need to do anything else compiling under restriction
7190 -- No_Dispatching_Calls. During the semantic analysis we
7191 -- already notified such violation.
7193 if Restriction_Active (No_Dispatching_Calls) then
7197 -- If this is derived from an untagged private type completed with
7198 -- a tagged type, it does not have a full view, so we use the
7199 -- primitive operations of the private type. This check should no
7200 -- longer be necessary when these types get their full views???
7202 if Is_Private_Type (A_Typ)
7203 and then not Is_Tagged_Type (A_Typ)
7204 and then Is_Derived_Type (A_Typ)
7205 and then No (Full_View (A_Typ))
7207 -- Search for equality operation, checking that the operands
7208 -- have the same type. Note that we must find a matching entry,
7209 -- or something is very wrong.
7211 Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
7213 while Present (Prim) loop
7214 exit when Chars (Node (Prim)) = Name_Op_Eq
7215 and then Etype (First_Formal (Node (Prim))) =
7216 Etype (Next_Formal (First_Formal (Node (Prim))))
7218 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7223 pragma Assert (Present (Prim));
7224 Op_Name := Node (Prim);
7226 -- Find the type's predefined equality or an overriding
7227 -- user- defined equality. The reason for not simply calling
7228 -- Find_Prim_Op here is that there may be a user-defined
7229 -- overloaded equality op that precedes the equality that we want,
7230 -- so we have to explicitly search (e.g., there could be an
7231 -- equality with two different parameter types).
7234 if Is_Class_Wide_Type (Typl) then
7235 Typl := Root_Type (Typl);
7238 Prim := First_Elmt (Primitive_Operations (Typl));
7239 while Present (Prim) loop
7240 exit when Chars (Node (Prim)) = Name_Op_Eq
7241 and then Etype (First_Formal (Node (Prim))) =
7242 Etype (Next_Formal (First_Formal (Node (Prim))))
7244 Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7249 pragma Assert (Present (Prim));
7250 Op_Name := Node (Prim);
7253 Build_Equality_Call (Op_Name);
7255 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
7256 -- predefined equality operator for a type which has a subcomponent
7257 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
7259 elsif Has_Unconstrained_UU_Component (Typl) then
7261 Make_Raise_Program_Error (Loc,
7262 Reason => PE_Unchecked_Union_Restriction));
7264 -- Prevent Gigi from generating incorrect code by rewriting the
7265 -- equality as a standard False. (is this documented somewhere???)
7268 New_Occurrence_Of (Standard_False, Loc));
7270 elsif Is_Unchecked_Union (Typl) then
7272 -- If we can infer the discriminants of the operands, we make a
7273 -- call to the TSS equality function.
7275 if Has_Inferable_Discriminants (Lhs)
7277 Has_Inferable_Discriminants (Rhs)
7280 (TSS (Root_Type (Typl), TSS_Composite_Equality));
7283 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
7284 -- the predefined equality operator for an Unchecked_Union type
7285 -- if either of the operands lack inferable discriminants.
7288 Make_Raise_Program_Error (Loc,
7289 Reason => PE_Unchecked_Union_Restriction));
7291 -- Prevent Gigi from generating incorrect code by rewriting
7292 -- the equality as a standard False (documented where???).
7295 New_Occurrence_Of (Standard_False, Loc));
7299 -- If a type support function is present (for complex cases), use it
7301 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
7303 (TSS (Root_Type (Typl), TSS_Composite_Equality));
7305 -- When comparing two Bounded_Strings, use the primitive equality of
7306 -- the root Super_String type.
7308 elsif Is_Bounded_String (Typl) then
7310 First_Elmt (Collect_Primitive_Operations (Root_Type (Typl)));
7312 while Present (Prim) loop
7313 exit when Chars (Node (Prim)) = Name_Op_Eq
7314 and then Etype (First_Formal (Node (Prim))) =
7315 Etype (Next_Formal (First_Formal (Node (Prim))))
7316 and then Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7321 -- A Super_String type should always have a primitive equality
7323 pragma Assert (Present (Prim));
7324 Build_Equality_Call (Node (Prim));
7326 -- Otherwise expand the component by component equality. Note that
7327 -- we never use block-bit comparisons for records, because of the
7328 -- problems with gaps. The backend will often be able to recombine
7329 -- the separate comparisons that we generate here.
7332 Remove_Side_Effects (Lhs);
7333 Remove_Side_Effects (Rhs);
7335 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
7337 Insert_Actions (N, Bodies, Suppress => All_Checks);
7338 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7342 -- Test if result is known at compile time
7344 Rewrite_Comparison (N);
7346 -- If we still have comparison for Vax_Float, process it
7348 if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then
7349 Expand_Vax_Comparison (N);
7353 Optimize_Length_Comparison (N);
7356 -----------------------
7357 -- Expand_N_Op_Expon --
7358 -----------------------
7360 procedure Expand_N_Op_Expon (N : Node_Id) is
7361 Loc : constant Source_Ptr := Sloc (N);
7362 Typ : constant Entity_Id := Etype (N);
7363 Rtyp : constant Entity_Id := Root_Type (Typ);
7364 Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
7365 Bastyp : constant Node_Id := Etype (Base);
7366 Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
7367 Exptyp : constant Entity_Id := Etype (Exp);
7368 Ovflo : constant Boolean := Do_Overflow_Check (N);
7377 Binary_Op_Validity_Checks (N);
7379 -- CodePeer wants to see the unexpanded N_Op_Expon node
7381 if CodePeer_Mode then
7385 -- If either operand is of a private type, then we have the use of an
7386 -- intrinsic operator, and we get rid of the privateness, by using root
7387 -- types of underlying types for the actual operation. Otherwise the
7388 -- private types will cause trouble if we expand multiplications or
7389 -- shifts etc. We also do this transformation if the result type is
7390 -- different from the base type.
7392 if Is_Private_Type (Etype (Base))
7393 or else Is_Private_Type (Typ)
7394 or else Is_Private_Type (Exptyp)
7395 or else Rtyp /= Root_Type (Bastyp)
7398 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
7399 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
7402 Unchecked_Convert_To (Typ,
7404 Left_Opnd => Unchecked_Convert_To (Bt, Base),
7405 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
7406 Analyze_And_Resolve (N, Typ);
7411 -- Check for MINIMIZED/ELIMINATED overflow mode
7413 if Minimized_Eliminated_Overflow_Check (N) then
7414 Apply_Arithmetic_Overflow_Check (N);
7418 -- Test for case of known right argument where we can replace the
7419 -- exponentiation by an equivalent expression using multiplication.
7421 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
7422 -- configurable run-time mode, we may not have the exponentiation
7423 -- routine available, and we don't want the legality of the program
7424 -- to depend on how clever the compiler is in knowing values.
7426 if CRT_Safe_Compile_Time_Known_Value (Exp) then
7427 Expv := Expr_Value (Exp);
7429 -- We only fold small non-negative exponents. You might think we
7430 -- could fold small negative exponents for the real case, but we
7431 -- can't because we are required to raise Constraint_Error for
7432 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
7433 -- See ACVC test C4A012B.
7435 if Expv >= 0 and then Expv <= 4 then
7437 -- X ** 0 = 1 (or 1.0)
7441 -- Call Remove_Side_Effects to ensure that any side effects
7442 -- in the ignored left operand (in particular function calls
7443 -- to user defined functions) are properly executed.
7445 Remove_Side_Effects (Base);
7447 if Ekind (Typ) in Integer_Kind then
7448 Xnode := Make_Integer_Literal (Loc, Intval => 1);
7450 Xnode := Make_Real_Literal (Loc, Ureal_1);
7462 Make_Op_Multiply (Loc,
7463 Left_Opnd => Duplicate_Subexpr (Base),
7464 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
7466 -- X ** 3 = X * X * X
7470 Make_Op_Multiply (Loc,
7472 Make_Op_Multiply (Loc,
7473 Left_Opnd => Duplicate_Subexpr (Base),
7474 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
7475 Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
7480 -- En : constant base'type := base * base;
7485 pragma Assert (Expv = 4);
7486 Temp := Make_Temporary (Loc, 'E', Base);
7489 Make_Expression_With_Actions (Loc,
7490 Actions => New_List (
7491 Make_Object_Declaration (Loc,
7492 Defining_Identifier => Temp,
7493 Constant_Present => True,
7494 Object_Definition => New_Occurrence_Of (Typ, Loc),
7496 Make_Op_Multiply (Loc,
7498 Duplicate_Subexpr (Base),
7500 Duplicate_Subexpr_No_Checks (Base)))),
7503 Make_Op_Multiply (Loc,
7504 Left_Opnd => New_Occurrence_Of (Temp, Loc),
7505 Right_Opnd => New_Occurrence_Of (Temp, Loc)));
7509 Analyze_And_Resolve (N, Typ);
7514 -- Case of (2 ** expression) appearing as an argument of an integer
7515 -- multiplication, or as the right argument of a division of a non-
7516 -- negative integer. In such cases we leave the node untouched, setting
7517 -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
7518 -- of the higher level node converts it into a shift.
7520 -- Another case is 2 ** N in any other context. We simply convert
7521 -- this to 1 * 2 ** N, and then the above transformation applies.
7523 -- Note: this transformation is not applicable for a modular type with
7524 -- a non-binary modulus in the multiplication case, since we get a wrong
7525 -- result if the shift causes an overflow before the modular reduction.
7527 -- Note: we used to check that Exptyp was an unsigned type. But that is
7528 -- an unnecessary check, since if Exp is negative, we have a run-time
7529 -- error that is either caught (so we get the right result) or we have
7530 -- suppressed the check, in which case the code is erroneous anyway.
7532 if Nkind (Base) = N_Integer_Literal
7533 and then CRT_Safe_Compile_Time_Known_Value (Base)
7534 and then Expr_Value (Base) = Uint_2
7535 and then Is_Integer_Type (Root_Type (Exptyp))
7536 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
7539 -- First the multiply and divide cases
7541 if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then
7543 P : constant Node_Id := Parent (N);
7544 L : constant Node_Id := Left_Opnd (P);
7545 R : constant Node_Id := Right_Opnd (P);
7548 if (Nkind (P) = N_Op_Multiply
7549 and then not Non_Binary_Modulus (Typ)
7551 ((Is_Integer_Type (Etype (L)) and then R = N)
7553 (Is_Integer_Type (Etype (R)) and then L = N))
7554 and then not Do_Overflow_Check (P))
7556 (Nkind (P) = N_Op_Divide
7557 and then Is_Integer_Type (Etype (L))
7558 and then Is_Unsigned_Type (Etype (L))
7560 and then not Do_Overflow_Check (P))
7562 Set_Is_Power_Of_2_For_Shift (N);
7567 -- Now the other cases
7569 elsif not Non_Binary_Modulus (Typ) then
7571 Make_Op_Multiply (Loc,
7572 Left_Opnd => Make_Integer_Literal (Loc, 1),
7573 Right_Opnd => Relocate_Node (N)));
7574 Analyze_And_Resolve (N, Typ);
7579 -- Fall through if exponentiation must be done using a runtime routine
7581 -- First deal with modular case
7583 if Is_Modular_Integer_Type (Rtyp) then
7585 -- Non-binary case, we call the special exponentiation routine for
7586 -- the non-binary case, converting the argument to Long_Long_Integer
7587 -- and passing the modulus value. Then the result is converted back
7588 -- to the base type.
7590 if Non_Binary_Modulus (Rtyp) then
7593 Make_Function_Call (Loc,
7594 Name => New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
7595 Parameter_Associations => New_List (
7596 Convert_To (Standard_Integer, Base),
7597 Make_Integer_Literal (Loc, Modulus (Rtyp)),
7600 -- Binary case, in this case, we call one of two routines, either the
7601 -- unsigned integer case, or the unsigned long long integer case,
7602 -- with a final "and" operation to do the required mod.
7605 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
7606 Ent := RTE (RE_Exp_Unsigned);
7608 Ent := RTE (RE_Exp_Long_Long_Unsigned);
7615 Make_Function_Call (Loc,
7616 Name => New_Occurrence_Of (Ent, Loc),
7617 Parameter_Associations => New_List (
7618 Convert_To (Etype (First_Formal (Ent)), Base),
7621 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
7625 -- Common exit point for modular type case
7627 Analyze_And_Resolve (N, Typ);
7630 -- Signed integer cases, done using either Integer or Long_Long_Integer.
7631 -- It is not worth having routines for Short_[Short_]Integer, since for
7632 -- most machines it would not help, and it would generate more code that
7633 -- might need certification when a certified run time is required.
7635 -- In the integer cases, we have two routines, one for when overflow
7636 -- checks are required, and one when they are not required, since there
7637 -- is a real gain in omitting checks on many machines.
7639 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
7640 or else (Rtyp = Base_Type (Standard_Long_Integer)
7642 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
7643 or else Rtyp = Universal_Integer
7645 Etyp := Standard_Long_Long_Integer;
7647 -- Overflow checking is the only choice on the AAMP target, where
7648 -- arithmetic instructions check overflow automatically, so only
7649 -- one version of the exponentiation unit is needed.
7651 if Ovflo or AAMP_On_Target then
7652 Rent := RE_Exp_Long_Long_Integer;
7654 Rent := RE_Exn_Long_Long_Integer;
7657 elsif Is_Signed_Integer_Type (Rtyp) then
7658 Etyp := Standard_Integer;
7660 -- Overflow checking is the only choice on the AAMP target, where
7661 -- arithmetic instructions check overflow automatically, so only
7662 -- one version of the exponentiation unit is needed.
7664 if Ovflo or AAMP_On_Target then
7665 Rent := RE_Exp_Integer;
7667 Rent := RE_Exn_Integer;
7670 -- Floating-point cases, always done using Long_Long_Float. We do not
7671 -- need separate routines for the overflow case here, since in the case
7672 -- of floating-point, we generate infinities anyway as a rule (either
7673 -- that or we automatically trap overflow), and if there is an infinity
7674 -- generated and a range check is required, the check will fail anyway.
7677 pragma Assert (Is_Floating_Point_Type (Rtyp));
7678 Etyp := Standard_Long_Long_Float;
7679 Rent := RE_Exn_Long_Long_Float;
7682 -- Common processing for integer cases and floating-point cases.
7683 -- If we are in the right type, we can call runtime routine directly
7686 and then Rtyp /= Universal_Integer
7687 and then Rtyp /= Universal_Real
7690 Make_Function_Call (Loc,
7691 Name => New_Occurrence_Of (RTE (Rent), Loc),
7692 Parameter_Associations => New_List (Base, Exp)));
7694 -- Otherwise we have to introduce conversions (conversions are also
7695 -- required in the universal cases, since the runtime routine is
7696 -- typed using one of the standard types).
7701 Make_Function_Call (Loc,
7702 Name => New_Occurrence_Of (RTE (Rent), Loc),
7703 Parameter_Associations => New_List (
7704 Convert_To (Etyp, Base),
7708 Analyze_And_Resolve (N, Typ);
7712 when RE_Not_Available =>
7714 end Expand_N_Op_Expon;
7716 --------------------
7717 -- Expand_N_Op_Ge --
7718 --------------------
7720 procedure Expand_N_Op_Ge (N : Node_Id) is
7721 Typ : constant Entity_Id := Etype (N);
7722 Op1 : constant Node_Id := Left_Opnd (N);
7723 Op2 : constant Node_Id := Right_Opnd (N);
7724 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7727 Binary_Op_Validity_Checks (N);
7729 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7730 -- means we no longer have a comparison operation, we are all done.
7732 Expand_Compare_Minimize_Eliminate_Overflow (N);
7734 if Nkind (N) /= N_Op_Ge then
7740 if Is_Array_Type (Typ1) then
7741 Expand_Array_Comparison (N);
7745 -- Deal with boolean operands
7747 if Is_Boolean_Type (Typ1) then
7748 Adjust_Condition (Op1);
7749 Adjust_Condition (Op2);
7750 Set_Etype (N, Standard_Boolean);
7751 Adjust_Result_Type (N, Typ);
7754 Rewrite_Comparison (N);
7756 -- If we still have comparison, and Vax_Float type, process it
7758 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
7759 Expand_Vax_Comparison (N);
7763 Optimize_Length_Comparison (N);
7766 --------------------
7767 -- Expand_N_Op_Gt --
7768 --------------------
7770 procedure Expand_N_Op_Gt (N : Node_Id) is
7771 Typ : constant Entity_Id := Etype (N);
7772 Op1 : constant Node_Id := Left_Opnd (N);
7773 Op2 : constant Node_Id := Right_Opnd (N);
7774 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7777 Binary_Op_Validity_Checks (N);
7779 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7780 -- means we no longer have a comparison operation, we are all done.
7782 Expand_Compare_Minimize_Eliminate_Overflow (N);
7784 if Nkind (N) /= N_Op_Gt then
7788 -- Deal with array type operands
7790 if Is_Array_Type (Typ1) then
7791 Expand_Array_Comparison (N);
7795 -- Deal with boolean type operands
7797 if Is_Boolean_Type (Typ1) then
7798 Adjust_Condition (Op1);
7799 Adjust_Condition (Op2);
7800 Set_Etype (N, Standard_Boolean);
7801 Adjust_Result_Type (N, Typ);
7804 Rewrite_Comparison (N);
7806 -- If we still have comparison, and Vax_Float type, process it
7808 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
7809 Expand_Vax_Comparison (N);
7813 Optimize_Length_Comparison (N);
7816 --------------------
7817 -- Expand_N_Op_Le --
7818 --------------------
7820 procedure Expand_N_Op_Le (N : Node_Id) is
7821 Typ : constant Entity_Id := Etype (N);
7822 Op1 : constant Node_Id := Left_Opnd (N);
7823 Op2 : constant Node_Id := Right_Opnd (N);
7824 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7827 Binary_Op_Validity_Checks (N);
7829 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7830 -- means we no longer have a comparison operation, we are all done.
7832 Expand_Compare_Minimize_Eliminate_Overflow (N);
7834 if Nkind (N) /= N_Op_Le then
7838 -- Deal with array type operands
7840 if Is_Array_Type (Typ1) then
7841 Expand_Array_Comparison (N);
7845 -- Deal with Boolean type operands
7847 if Is_Boolean_Type (Typ1) then
7848 Adjust_Condition (Op1);
7849 Adjust_Condition (Op2);
7850 Set_Etype (N, Standard_Boolean);
7851 Adjust_Result_Type (N, Typ);
7854 Rewrite_Comparison (N);
7856 -- If we still have comparison, and Vax_Float type, process it
7858 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
7859 Expand_Vax_Comparison (N);
7863 Optimize_Length_Comparison (N);
7866 --------------------
7867 -- Expand_N_Op_Lt --
7868 --------------------
7870 procedure Expand_N_Op_Lt (N : Node_Id) is
7871 Typ : constant Entity_Id := Etype (N);
7872 Op1 : constant Node_Id := Left_Opnd (N);
7873 Op2 : constant Node_Id := Right_Opnd (N);
7874 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7877 Binary_Op_Validity_Checks (N);
7879 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7880 -- means we no longer have a comparison operation, we are all done.
7882 Expand_Compare_Minimize_Eliminate_Overflow (N);
7884 if Nkind (N) /= N_Op_Lt then
7888 -- Deal with array type operands
7890 if Is_Array_Type (Typ1) then
7891 Expand_Array_Comparison (N);
7895 -- Deal with Boolean type operands
7897 if Is_Boolean_Type (Typ1) then
7898 Adjust_Condition (Op1);
7899 Adjust_Condition (Op2);
7900 Set_Etype (N, Standard_Boolean);
7901 Adjust_Result_Type (N, Typ);
7904 Rewrite_Comparison (N);
7906 -- If we still have comparison, and Vax_Float type, process it
7908 if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
7909 Expand_Vax_Comparison (N);
7913 Optimize_Length_Comparison (N);
7916 -----------------------
7917 -- Expand_N_Op_Minus --
7918 -----------------------
7920 procedure Expand_N_Op_Minus (N : Node_Id) is
7921 Loc : constant Source_Ptr := Sloc (N);
7922 Typ : constant Entity_Id := Etype (N);
7925 Unary_Op_Validity_Checks (N);
7927 -- Check for MINIMIZED/ELIMINATED overflow mode
7929 if Minimized_Eliminated_Overflow_Check (N) then
7930 Apply_Arithmetic_Overflow_Check (N);
7934 if not Backend_Overflow_Checks_On_Target
7935 and then Is_Signed_Integer_Type (Etype (N))
7936 and then Do_Overflow_Check (N)
7938 -- Software overflow checking expands -expr into (0 - expr)
7941 Make_Op_Subtract (Loc,
7942 Left_Opnd => Make_Integer_Literal (Loc, 0),
7943 Right_Opnd => Right_Opnd (N)));
7945 Analyze_And_Resolve (N, Typ);
7947 -- Vax floating-point types case
7949 elsif Vax_Float (Etype (N)) then
7950 Expand_Vax_Arith (N);
7952 end Expand_N_Op_Minus;
7954 ---------------------
7955 -- Expand_N_Op_Mod --
7956 ---------------------
7958 procedure Expand_N_Op_Mod (N : Node_Id) is
7959 Loc : constant Source_Ptr := Sloc (N);
7960 Typ : constant Entity_Id := Etype (N);
7961 DDC : constant Boolean := Do_Division_Check (N);
7974 pragma Warnings (Off, Lhi);
7977 Binary_Op_Validity_Checks (N);
7979 -- Check for MINIMIZED/ELIMINATED overflow mode
7981 if Minimized_Eliminated_Overflow_Check (N) then
7982 Apply_Arithmetic_Overflow_Check (N);
7986 if Is_Integer_Type (Etype (N)) then
7987 Apply_Divide_Checks (N);
7989 -- All done if we don't have a MOD any more, which can happen as a
7990 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
7992 if Nkind (N) /= N_Op_Mod then
7997 -- Proceed with expansion of mod operator
7999 Left := Left_Opnd (N);
8000 Right := Right_Opnd (N);
8002 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
8003 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
8005 -- Convert mod to rem if operands are both known to be non-negative, or
8006 -- both known to be non-positive (these are the cases in which rem and
8007 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
8008 -- likely that this will improve the quality of code, (the operation now
8009 -- corresponds to the hardware remainder), and it does not seem likely
8010 -- that it could be harmful. It also avoids some cases of the elaborate
8011 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
8014 and then ((Llo >= 0 and then Rlo >= 0)
8016 (Lhi <= 0 and then Rhi <= 0))
8019 Make_Op_Rem (Sloc (N),
8020 Left_Opnd => Left_Opnd (N),
8021 Right_Opnd => Right_Opnd (N)));
8023 -- Instead of reanalyzing the node we do the analysis manually. This
8024 -- avoids anomalies when the replacement is done in an instance and
8025 -- is epsilon more efficient.
8027 Set_Entity (N, Standard_Entity (S_Op_Rem));
8029 Set_Do_Division_Check (N, DDC);
8030 Expand_N_Op_Rem (N);
8034 -- Otherwise, normal mod processing
8037 -- Apply optimization x mod 1 = 0. We don't really need that with
8038 -- gcc, but it is useful with other back ends (e.g. AAMP), and is
8039 -- certainly harmless.
8041 if Is_Integer_Type (Etype (N))
8042 and then Compile_Time_Known_Value (Right)
8043 and then Expr_Value (Right) = Uint_1
8045 -- Call Remove_Side_Effects to ensure that any side effects in
8046 -- the ignored left operand (in particular function calls to
8047 -- user defined functions) are properly executed.
8049 Remove_Side_Effects (Left);
8051 Rewrite (N, Make_Integer_Literal (Loc, 0));
8052 Analyze_And_Resolve (N, Typ);
8056 -- If we still have a mod operator and we are in Modify_Tree_For_C
8057 -- mode, and we have a signed integer type, then here is where we do
8058 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
8059 -- for the special handling of the annoying case of largest negative
8060 -- number mod minus one.
8062 if Nkind (N) = N_Op_Mod
8063 and then Is_Signed_Integer_Type (Typ)
8064 and then Modify_Tree_For_C
8066 -- In the general case, we expand A mod B as
8068 -- Tnn : constant typ := A rem B;
8070 -- (if (A >= 0) = (B >= 0) then Tnn
8071 -- elsif Tnn = 0 then 0
8074 -- The comparison can be written simply as A >= 0 if we know that
8075 -- B >= 0 which is a very common case.
8077 -- An important optimization is when B is known at compile time
8078 -- to be 2**K for some constant. In this case we can simply AND
8079 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
8080 -- and that works for both the positive and negative cases.
8083 P2 : constant Nat := Power_Of_Two (Right);
8088 Unchecked_Convert_To (Typ,
8091 Unchecked_Convert_To
8092 (Corresponding_Unsigned_Type (Typ), Left),
8094 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
8095 Analyze_And_Resolve (N, Typ);
8100 -- Here for the full rewrite
8103 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
8109 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
8110 Right_Opnd => Make_Integer_Literal (Loc, 0));
8112 if not LOK or else Rlo < 0 then
8118 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
8119 Right_Opnd => Make_Integer_Literal (Loc, 0)));
8123 Make_Object_Declaration (Loc,
8124 Defining_Identifier => Tnn,
8125 Constant_Present => True,
8126 Object_Definition => New_Occurrence_Of (Typ, Loc),
8130 Right_Opnd => Right)));
8133 Make_If_Expression (Loc,
8134 Expressions => New_List (
8136 New_Occurrence_Of (Tnn, Loc),
8137 Make_If_Expression (Loc,
8139 Expressions => New_List (
8141 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8142 Right_Opnd => Make_Integer_Literal (Loc, 0)),
8143 Make_Integer_Literal (Loc, 0),
8145 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
8147 Duplicate_Subexpr_No_Checks (Right)))))));
8149 Analyze_And_Resolve (N, Typ);
8154 -- Deal with annoying case of largest negative number mod minus one.
8155 -- Gigi may not handle this case correctly, because on some targets,
8156 -- the mod value is computed using a divide instruction which gives
8157 -- an overflow trap for this case.
8159 -- It would be a bit more efficient to figure out which targets
8160 -- this is really needed for, but in practice it is reasonable
8161 -- to do the following special check in all cases, since it means
8162 -- we get a clearer message, and also the overhead is minimal given
8163 -- that division is expensive in any case.
8165 -- In fact the check is quite easy, if the right operand is -1, then
8166 -- the mod value is always 0, and we can just ignore the left operand
8167 -- completely in this case.
8169 -- This only applies if we still have a mod operator. Skip if we
8170 -- have already rewritten this (e.g. in the case of eliminated
8171 -- overflow checks which have driven us into bignum mode).
8173 if Nkind (N) = N_Op_Mod then
8175 -- The operand type may be private (e.g. in the expansion of an
8176 -- intrinsic operation) so we must use the underlying type to get
8177 -- the bounds, and convert the literals explicitly.
8181 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
8183 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
8184 and then ((not LOK) or else (Llo = LLB))
8187 Make_If_Expression (Loc,
8188 Expressions => New_List (
8190 Left_Opnd => Duplicate_Subexpr (Right),
8192 Unchecked_Convert_To (Typ,
8193 Make_Integer_Literal (Loc, -1))),
8194 Unchecked_Convert_To (Typ,
8195 Make_Integer_Literal (Loc, Uint_0)),
8196 Relocate_Node (N))));
8198 Set_Analyzed (Next (Next (First (Expressions (N)))));
8199 Analyze_And_Resolve (N, Typ);
8203 end Expand_N_Op_Mod;
8205 --------------------------
8206 -- Expand_N_Op_Multiply --
8207 --------------------------
8209 procedure Expand_N_Op_Multiply (N : Node_Id) is
8210 Loc : constant Source_Ptr := Sloc (N);
8211 Lop : constant Node_Id := Left_Opnd (N);
8212 Rop : constant Node_Id := Right_Opnd (N);
8214 Lp2 : constant Boolean :=
8215 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
8216 Rp2 : constant Boolean :=
8217 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
8219 Ltyp : constant Entity_Id := Etype (Lop);
8220 Rtyp : constant Entity_Id := Etype (Rop);
8221 Typ : Entity_Id := Etype (N);
8224 Binary_Op_Validity_Checks (N);
8226 -- Check for MINIMIZED/ELIMINATED overflow mode
8228 if Minimized_Eliminated_Overflow_Check (N) then
8229 Apply_Arithmetic_Overflow_Check (N);
8233 -- Special optimizations for integer types
8235 if Is_Integer_Type (Typ) then
8237 -- N * 0 = 0 for integer types
8239 if Compile_Time_Known_Value (Rop)
8240 and then Expr_Value (Rop) = Uint_0
8242 -- Call Remove_Side_Effects to ensure that any side effects in
8243 -- the ignored left operand (in particular function calls to
8244 -- user defined functions) are properly executed.
8246 Remove_Side_Effects (Lop);
8248 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8249 Analyze_And_Resolve (N, Typ);
8253 -- Similar handling for 0 * N = 0
8255 if Compile_Time_Known_Value (Lop)
8256 and then Expr_Value (Lop) = Uint_0
8258 Remove_Side_Effects (Rop);
8259 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8260 Analyze_And_Resolve (N, Typ);
8264 -- N * 1 = 1 * N = N for integer types
8266 -- This optimisation is not done if we are going to
8267 -- rewrite the product 1 * 2 ** N to a shift.
8269 if Compile_Time_Known_Value (Rop)
8270 and then Expr_Value (Rop) = Uint_1
8276 elsif Compile_Time_Known_Value (Lop)
8277 and then Expr_Value (Lop) = Uint_1
8285 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8286 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8287 -- operand is an integer, as required for this to work.
8292 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
8296 Left_Opnd => Make_Integer_Literal (Loc, 2),
8299 Left_Opnd => Right_Opnd (Lop),
8300 Right_Opnd => Right_Opnd (Rop))));
8301 Analyze_And_Resolve (N, Typ);
8305 -- If the result is modular, perform the reduction of the result
8308 if Is_Modular_Integer_Type (Typ)
8309 and then not Non_Binary_Modulus (Typ)
8314 Make_Op_Shift_Left (Loc,
8317 Convert_To (Standard_Natural, Right_Opnd (Rop))),
8319 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
8323 Make_Op_Shift_Left (Loc,
8326 Convert_To (Standard_Natural, Right_Opnd (Rop))));
8329 Analyze_And_Resolve (N, Typ);
8333 -- Same processing for the operands the other way round
8336 if Is_Modular_Integer_Type (Typ)
8337 and then not Non_Binary_Modulus (Typ)
8342 Make_Op_Shift_Left (Loc,
8345 Convert_To (Standard_Natural, Right_Opnd (Lop))),
8347 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
8351 Make_Op_Shift_Left (Loc,
8354 Convert_To (Standard_Natural, Right_Opnd (Lop))));
8357 Analyze_And_Resolve (N, Typ);
8361 -- Do required fixup of universal fixed operation
8363 if Typ = Universal_Fixed then
8364 Fixup_Universal_Fixed_Operation (N);
8368 -- Multiplications with fixed-point results
8370 if Is_Fixed_Point_Type (Typ) then
8372 -- No special processing if Treat_Fixed_As_Integer is set, since from
8373 -- a semantic point of view such operations are simply integer
8374 -- operations and will be treated that way.
8376 if not Treat_Fixed_As_Integer (N) then
8378 -- Case of fixed * integer => fixed
8380 if Is_Integer_Type (Rtyp) then
8381 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
8383 -- Case of integer * fixed => fixed
8385 elsif Is_Integer_Type (Ltyp) then
8386 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
8388 -- Case of fixed * fixed => fixed
8391 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
8395 -- Other cases of multiplication of fixed-point operands. Again we
8396 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
8398 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
8399 and then not Treat_Fixed_As_Integer (N)
8401 if Is_Integer_Type (Typ) then
8402 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
8404 pragma Assert (Is_Floating_Point_Type (Typ));
8405 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
8408 -- Mixed-mode operations can appear in a non-static universal context,
8409 -- in which case the integer argument must be converted explicitly.
8411 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
8412 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
8413 Analyze_And_Resolve (Rop, Universal_Real);
8415 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
8416 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
8417 Analyze_And_Resolve (Lop, Universal_Real);
8419 -- Non-fixed point cases, check software overflow checking required
8421 elsif Is_Signed_Integer_Type (Etype (N)) then
8422 Apply_Arithmetic_Overflow_Check (N);
8424 -- Deal with VAX float case
8426 elsif Vax_Float (Typ) then
8427 Expand_Vax_Arith (N);
8430 end Expand_N_Op_Multiply;
8432 --------------------
8433 -- Expand_N_Op_Ne --
8434 --------------------
8436 procedure Expand_N_Op_Ne (N : Node_Id) is
8437 Typ : constant Entity_Id := Etype (Left_Opnd (N));
8440 -- Case of elementary type with standard operator
8442 if Is_Elementary_Type (Typ)
8443 and then Sloc (Entity (N)) = Standard_Location
8445 Binary_Op_Validity_Checks (N);
8447 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8448 -- means we no longer have a /= operation, we are all done.
8450 Expand_Compare_Minimize_Eliminate_Overflow (N);
8452 if Nkind (N) /= N_Op_Ne then
8456 -- Boolean types (requiring handling of non-standard case)
8458 if Is_Boolean_Type (Typ) then
8459 Adjust_Condition (Left_Opnd (N));
8460 Adjust_Condition (Right_Opnd (N));
8461 Set_Etype (N, Standard_Boolean);
8462 Adjust_Result_Type (N, Typ);
8465 Rewrite_Comparison (N);
8467 -- If we still have comparison for Vax_Float, process it
8469 if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then
8470 Expand_Vax_Comparison (N);
8474 -- For all cases other than elementary types, we rewrite node as the
8475 -- negation of an equality operation, and reanalyze. The equality to be
8476 -- used is defined in the same scope and has the same signature. This
8477 -- signature must be set explicitly since in an instance it may not have
8478 -- the same visibility as in the generic unit. This avoids duplicating
8479 -- or factoring the complex code for record/array equality tests etc.
8483 Loc : constant Source_Ptr := Sloc (N);
8485 Ne : constant Entity_Id := Entity (N);
8488 Binary_Op_Validity_Checks (N);
8494 Left_Opnd => Left_Opnd (N),
8495 Right_Opnd => Right_Opnd (N)));
8496 Set_Paren_Count (Right_Opnd (Neg), 1);
8498 if Scope (Ne) /= Standard_Standard then
8499 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
8502 -- For navigation purposes, we want to treat the inequality as an
8503 -- implicit reference to the corresponding equality. Preserve the
8504 -- Comes_From_ source flag to generate proper Xref entries.
8506 Preserve_Comes_From_Source (Neg, N);
8507 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
8509 Analyze_And_Resolve (N, Standard_Boolean);
8513 Optimize_Length_Comparison (N);
8516 ---------------------
8517 -- Expand_N_Op_Not --
8518 ---------------------
8520 -- If the argument is other than a Boolean array type, there is no special
8521 -- expansion required, except for VMS operations on signed integers.
8523 -- For the packed case, we call the special routine in Exp_Pakd, except
8524 -- that if the component size is greater than one, we use the standard
8525 -- routine generating a gruesome loop (it is so peculiar to have packed
8526 -- arrays with non-standard Boolean representations anyway, so it does not
8527 -- matter that we do not handle this case efficiently).
8529 -- For the unpacked case (and for the special packed case where we have non
8530 -- standard Booleans, as discussed above), we generate and insert into the
8531 -- tree the following function definition:
8533 -- function Nnnn (A : arr) is
8536 -- for J in a'range loop
8537 -- B (J) := not A (J);
8542 -- Here arr is the actual subtype of the parameter (and hence always
8543 -- constrained). Then we replace the not with a call to this function.
8545 procedure Expand_N_Op_Not (N : Node_Id) is
8546 Loc : constant Source_Ptr := Sloc (N);
8547 Typ : constant Entity_Id := Etype (N);
8556 Func_Name : Entity_Id;
8557 Loop_Statement : Node_Id;
8560 Unary_Op_Validity_Checks (N);
8562 -- For boolean operand, deal with non-standard booleans
8564 if Is_Boolean_Type (Typ) then
8565 Adjust_Condition (Right_Opnd (N));
8566 Set_Etype (N, Standard_Boolean);
8567 Adjust_Result_Type (N, Typ);
8571 -- For the VMS "not" on signed integer types, use conversion to and from
8572 -- a predefined modular type.
8574 if Is_VMS_Operator (Entity (N)) then
8580 -- If this is a derived type, retrieve original VMS type so that
8581 -- the proper sized type is used for intermediate values.
8583 if Is_Derived_Type (Typ) then
8584 Rtyp := First_Subtype (Etype (Typ));
8589 -- The proper unsigned type must have a size compatible with the
8590 -- operand, to prevent misalignment.
8592 if RM_Size (Rtyp) <= 8 then
8593 Utyp := RTE (RE_Unsigned_8);
8595 elsif RM_Size (Rtyp) <= 16 then
8596 Utyp := RTE (RE_Unsigned_16);
8598 elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then
8599 Utyp := RTE (RE_Unsigned_32);
8602 Utyp := RTE (RE_Long_Long_Unsigned);
8606 Unchecked_Convert_To (Typ,
8608 Unchecked_Convert_To (Utyp, Right_Opnd (N)))));
8609 Analyze_And_Resolve (N, Typ);
8614 -- Only array types need any other processing
8616 if not Is_Array_Type (Typ) then
8620 -- Case of array operand. If bit packed with a component size of 1,
8621 -- handle it in Exp_Pakd if the operand is known to be aligned.
8623 if Is_Bit_Packed_Array (Typ)
8624 and then Component_Size (Typ) = 1
8625 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
8627 Expand_Packed_Not (N);
8631 -- Case of array operand which is not bit-packed. If the context is
8632 -- a safe assignment, call in-place operation, If context is a larger
8633 -- boolean expression in the context of a safe assignment, expansion is
8634 -- done by enclosing operation.
8636 Opnd := Relocate_Node (Right_Opnd (N));
8637 Convert_To_Actual_Subtype (Opnd);
8638 Arr := Etype (Opnd);
8639 Ensure_Defined (Arr, N);
8640 Silly_Boolean_Array_Not_Test (N, Arr);
8642 if Nkind (Parent (N)) = N_Assignment_Statement then
8643 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
8644 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8647 -- Special case the negation of a binary operation
8649 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
8650 and then Safe_In_Place_Array_Op
8651 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
8653 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8657 elsif Nkind (Parent (N)) in N_Binary_Op
8658 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
8661 Op1 : constant Node_Id := Left_Opnd (Parent (N));
8662 Op2 : constant Node_Id := Right_Opnd (Parent (N));
8663 Lhs : constant Node_Id := Name (Parent (Parent (N)));
8666 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
8668 -- (not A) op (not B) can be reduced to a single call
8670 if N = Op1 and then Nkind (Op2) = N_Op_Not then
8673 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
8676 -- A xor (not B) can also be special-cased
8678 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
8685 A := Make_Defining_Identifier (Loc, Name_uA);
8686 B := Make_Defining_Identifier (Loc, Name_uB);
8687 J := Make_Defining_Identifier (Loc, Name_uJ);
8690 Make_Indexed_Component (Loc,
8691 Prefix => New_Occurrence_Of (A, Loc),
8692 Expressions => New_List (New_Occurrence_Of (J, Loc)));
8695 Make_Indexed_Component (Loc,
8696 Prefix => New_Occurrence_Of (B, Loc),
8697 Expressions => New_List (New_Occurrence_Of (J, Loc)));
8700 Make_Implicit_Loop_Statement (N,
8701 Identifier => Empty,
8704 Make_Iteration_Scheme (Loc,
8705 Loop_Parameter_Specification =>
8706 Make_Loop_Parameter_Specification (Loc,
8707 Defining_Identifier => J,
8708 Discrete_Subtype_Definition =>
8709 Make_Attribute_Reference (Loc,
8710 Prefix => Make_Identifier (Loc, Chars (A)),
8711 Attribute_Name => Name_Range))),
8713 Statements => New_List (
8714 Make_Assignment_Statement (Loc,
8716 Expression => Make_Op_Not (Loc, A_J))));
8718 Func_Name := Make_Temporary (Loc, 'N');
8719 Set_Is_Inlined (Func_Name);
8722 Make_Subprogram_Body (Loc,
8724 Make_Function_Specification (Loc,
8725 Defining_Unit_Name => Func_Name,
8726 Parameter_Specifications => New_List (
8727 Make_Parameter_Specification (Loc,
8728 Defining_Identifier => A,
8729 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
8730 Result_Definition => New_Occurrence_Of (Typ, Loc)),
8732 Declarations => New_List (
8733 Make_Object_Declaration (Loc,
8734 Defining_Identifier => B,
8735 Object_Definition => New_Occurrence_Of (Arr, Loc))),
8737 Handled_Statement_Sequence =>
8738 Make_Handled_Sequence_Of_Statements (Loc,
8739 Statements => New_List (
8741 Make_Simple_Return_Statement (Loc,
8742 Expression => Make_Identifier (Loc, Chars (B)))))));
8745 Make_Function_Call (Loc,
8746 Name => New_Occurrence_Of (Func_Name, Loc),
8747 Parameter_Associations => New_List (Opnd)));
8749 Analyze_And_Resolve (N, Typ);
8750 end Expand_N_Op_Not;
8752 --------------------
8753 -- Expand_N_Op_Or --
8754 --------------------
8756 procedure Expand_N_Op_Or (N : Node_Id) is
8757 Typ : constant Entity_Id := Etype (N);
8760 Binary_Op_Validity_Checks (N);
8762 if Is_Array_Type (Etype (N)) then
8763 Expand_Boolean_Operator (N);
8765 elsif Is_Boolean_Type (Etype (N)) then
8766 Adjust_Condition (Left_Opnd (N));
8767 Adjust_Condition (Right_Opnd (N));
8768 Set_Etype (N, Standard_Boolean);
8769 Adjust_Result_Type (N, Typ);
8771 elsif Is_Intrinsic_Subprogram (Entity (N)) then
8772 Expand_Intrinsic_Call (N, Entity (N));
8777 ----------------------
8778 -- Expand_N_Op_Plus --
8779 ----------------------
8781 procedure Expand_N_Op_Plus (N : Node_Id) is
8783 Unary_Op_Validity_Checks (N);
8785 -- Check for MINIMIZED/ELIMINATED overflow mode
8787 if Minimized_Eliminated_Overflow_Check (N) then
8788 Apply_Arithmetic_Overflow_Check (N);
8791 end Expand_N_Op_Plus;
8793 ---------------------
8794 -- Expand_N_Op_Rem --
8795 ---------------------
8797 procedure Expand_N_Op_Rem (N : Node_Id) is
8798 Loc : constant Source_Ptr := Sloc (N);
8799 Typ : constant Entity_Id := Etype (N);
8810 -- Set if corresponding operand can be negative
8812 pragma Unreferenced (Hi);
8815 Binary_Op_Validity_Checks (N);
8817 -- Check for MINIMIZED/ELIMINATED overflow mode
8819 if Minimized_Eliminated_Overflow_Check (N) then
8820 Apply_Arithmetic_Overflow_Check (N);
8824 if Is_Integer_Type (Etype (N)) then
8825 Apply_Divide_Checks (N);
8827 -- All done if we don't have a REM any more, which can happen as a
8828 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
8830 if Nkind (N) /= N_Op_Rem then
8835 -- Proceed with expansion of REM
8837 Left := Left_Opnd (N);
8838 Right := Right_Opnd (N);
8840 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
8841 -- but it is useful with other back ends (e.g. AAMP), and is certainly
8844 if Is_Integer_Type (Etype (N))
8845 and then Compile_Time_Known_Value (Right)
8846 and then Expr_Value (Right) = Uint_1
8848 -- Call Remove_Side_Effects to ensure that any side effects in the
8849 -- ignored left operand (in particular function calls to user defined
8850 -- functions) are properly executed.
8852 Remove_Side_Effects (Left);
8854 Rewrite (N, Make_Integer_Literal (Loc, 0));
8855 Analyze_And_Resolve (N, Typ);
8859 -- Deal with annoying case of largest negative number remainder minus
8860 -- one. Gigi may not handle this case correctly, because on some
8861 -- targets, the mod value is computed using a divide instruction
8862 -- which gives an overflow trap for this case.
8864 -- It would be a bit more efficient to figure out which targets this
8865 -- is really needed for, but in practice it is reasonable to do the
8866 -- following special check in all cases, since it means we get a clearer
8867 -- message, and also the overhead is minimal given that division is
8868 -- expensive in any case.
8870 -- In fact the check is quite easy, if the right operand is -1, then
8871 -- the remainder is always 0, and we can just ignore the left operand
8872 -- completely in this case.
8874 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
8875 Lneg := (not OK) or else Lo < 0;
8877 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
8878 Rneg := (not OK) or else Lo < 0;
8880 -- We won't mess with trying to find out if the left operand can really
8881 -- be the largest negative number (that's a pain in the case of private
8882 -- types and this is really marginal). We will just assume that we need
8883 -- the test if the left operand can be negative at all.
8885 if Lneg and Rneg then
8887 Make_If_Expression (Loc,
8888 Expressions => New_List (
8890 Left_Opnd => Duplicate_Subexpr (Right),
8892 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
8894 Unchecked_Convert_To (Typ,
8895 Make_Integer_Literal (Loc, Uint_0)),
8897 Relocate_Node (N))));
8899 Set_Analyzed (Next (Next (First (Expressions (N)))));
8900 Analyze_And_Resolve (N, Typ);
8902 end Expand_N_Op_Rem;
8904 -----------------------------
8905 -- Expand_N_Op_Rotate_Left --
8906 -----------------------------
8908 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
8910 Binary_Op_Validity_Checks (N);
8912 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
8913 -- so we rewrite in terms of logical shifts
8915 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
8917 -- where Bits is the shift count mod Esize (the mod operation here
8918 -- deals with ludicrous large shift counts, which are apparently OK).
8920 -- What about non-binary modulus ???
8923 Loc : constant Source_Ptr := Sloc (N);
8924 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
8925 Typ : constant Entity_Id := Etype (N);
8928 if Modify_Tree_For_C then
8929 Rewrite (Right_Opnd (N),
8931 Left_Opnd => Relocate_Node (Right_Opnd (N)),
8932 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
8934 Analyze_And_Resolve (Right_Opnd (N), Rtp);
8939 Make_Op_Shift_Left (Loc,
8940 Left_Opnd => Left_Opnd (N),
8941 Right_Opnd => Right_Opnd (N)),
8944 Make_Op_Shift_Right (Loc,
8945 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
8947 Make_Op_Subtract (Loc,
8948 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
8950 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
8952 Analyze_And_Resolve (N, Typ);
8955 end Expand_N_Op_Rotate_Left;
8957 ------------------------------
8958 -- Expand_N_Op_Rotate_Right --
8959 ------------------------------
8961 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
8963 Binary_Op_Validity_Checks (N);
8965 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
8966 -- so we rewrite in terms of logical shifts
8968 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
8970 -- where Bits is the shift count mod Esize (the mod operation here
8971 -- deals with ludicrous large shift counts, which are apparently OK).
8973 -- What about non-binary modulus ???
8976 Loc : constant Source_Ptr := Sloc (N);
8977 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
8978 Typ : constant Entity_Id := Etype (N);
8981 Rewrite (Right_Opnd (N),
8983 Left_Opnd => Relocate_Node (Right_Opnd (N)),
8984 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
8986 Analyze_And_Resolve (Right_Opnd (N), Rtp);
8988 if Modify_Tree_For_C then
8992 Make_Op_Shift_Right (Loc,
8993 Left_Opnd => Left_Opnd (N),
8994 Right_Opnd => Right_Opnd (N)),
8997 Make_Op_Shift_Left (Loc,
8998 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
9000 Make_Op_Subtract (Loc,
9001 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
9003 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
9005 Analyze_And_Resolve (N, Typ);
9008 end Expand_N_Op_Rotate_Right;
9010 ----------------------------
9011 -- Expand_N_Op_Shift_Left --
9012 ----------------------------
9014 -- Note: nothing in this routine depends on left as opposed to right shifts
9015 -- so we share the routine for expanding shift right operations.
9017 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
9019 Binary_Op_Validity_Checks (N);
9021 -- If we are in Modify_Tree_For_C mode, then ensure that the right
9022 -- operand is not greater than the word size (since that would not
9023 -- be defined properly by the corresponding C shift operator).
9025 if Modify_Tree_For_C then
9027 Right : constant Node_Id := Right_Opnd (N);
9028 Loc : constant Source_Ptr := Sloc (Right);
9029 Typ : constant Entity_Id := Etype (N);
9030 Siz : constant Uint := Esize (Typ);
9037 if Compile_Time_Known_Value (Right) then
9038 if Expr_Value (Right) >= Siz then
9039 Rewrite (N, Make_Integer_Literal (Loc, 0));
9040 Analyze_And_Resolve (N, Typ);
9043 -- Not compile time known, find range
9046 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
9048 -- Nothing to do if known to be OK range, otherwise expand
9050 if not OK or else Hi >= Siz then
9052 -- Prevent recursion on copy of shift node
9054 Orig := Relocate_Node (N);
9055 Set_Analyzed (Orig);
9057 -- Now do the rewrite
9060 Make_If_Expression (Loc,
9061 Expressions => New_List (
9063 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
9064 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
9065 Make_Integer_Literal (Loc, 0),
9067 Analyze_And_Resolve (N, Typ);
9072 end Expand_N_Op_Shift_Left;
9074 -----------------------------
9075 -- Expand_N_Op_Shift_Right --
9076 -----------------------------
9078 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
9080 -- Share shift left circuit
9082 Expand_N_Op_Shift_Left (N);
9083 end Expand_N_Op_Shift_Right;
9085 ----------------------------------------
9086 -- Expand_N_Op_Shift_Right_Arithmetic --
9087 ----------------------------------------
9089 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
9091 Binary_Op_Validity_Checks (N);
9093 -- If we are in Modify_Tree_For_C mode, there is no shift right
9094 -- arithmetic in C, so we rewrite in terms of logical shifts.
9096 -- Shift_Right (Num, Bits) or
9098 -- then not (Shift_Right (Mask, bits))
9101 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
9103 -- Note: in almost all C compilers it would work to just shift a
9104 -- signed integer right, but it's undefined and we cannot rely on it.
9106 -- Note: the above works fine for shift counts greater than or equal
9107 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
9108 -- generates all 1'bits.
9110 -- What about non-binary modulus ???
9113 Loc : constant Source_Ptr := Sloc (N);
9114 Typ : constant Entity_Id := Etype (N);
9115 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
9116 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
9117 Left : constant Node_Id := Left_Opnd (N);
9118 Right : constant Node_Id := Right_Opnd (N);
9122 if Modify_Tree_For_C then
9124 -- Here if not (Shift_Right (Mask, bits)) can be computed at
9125 -- compile time as a single constant.
9127 if Compile_Time_Known_Value (Right) then
9129 Val : constant Uint := Expr_Value (Right);
9132 if Val >= Esize (Typ) then
9133 Maskx := Make_Integer_Literal (Loc, Mask);
9137 Make_Integer_Literal (Loc,
9138 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
9146 Make_Op_Shift_Right (Loc,
9147 Left_Opnd => Make_Integer_Literal (Loc, Mask),
9148 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
9151 -- Now do the rewrite
9156 Make_Op_Shift_Right (Loc,
9158 Right_Opnd => Right),
9160 Make_If_Expression (Loc,
9161 Expressions => New_List (
9163 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9164 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
9166 Make_Integer_Literal (Loc, 0)))));
9167 Analyze_And_Resolve (N, Typ);
9170 end Expand_N_Op_Shift_Right_Arithmetic;
9172 --------------------------
9173 -- Expand_N_Op_Subtract --
9174 --------------------------
9176 procedure Expand_N_Op_Subtract (N : Node_Id) is
9177 Typ : constant Entity_Id := Etype (N);
9180 Binary_Op_Validity_Checks (N);
9182 -- Check for MINIMIZED/ELIMINATED overflow mode
9184 if Minimized_Eliminated_Overflow_Check (N) then
9185 Apply_Arithmetic_Overflow_Check (N);
9189 -- N - 0 = N for integer types
9191 if Is_Integer_Type (Typ)
9192 and then Compile_Time_Known_Value (Right_Opnd (N))
9193 and then Expr_Value (Right_Opnd (N)) = 0
9195 Rewrite (N, Left_Opnd (N));
9199 -- Arithmetic overflow checks for signed integer/fixed point types
9201 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
9202 Apply_Arithmetic_Overflow_Check (N);
9204 -- VAX floating-point types case
9206 elsif Vax_Float (Typ) then
9207 Expand_Vax_Arith (N);
9209 end Expand_N_Op_Subtract;
9211 ---------------------
9212 -- Expand_N_Op_Xor --
9213 ---------------------
9215 procedure Expand_N_Op_Xor (N : Node_Id) is
9216 Typ : constant Entity_Id := Etype (N);
9219 Binary_Op_Validity_Checks (N);
9221 if Is_Array_Type (Etype (N)) then
9222 Expand_Boolean_Operator (N);
9224 elsif Is_Boolean_Type (Etype (N)) then
9225 Adjust_Condition (Left_Opnd (N));
9226 Adjust_Condition (Right_Opnd (N));
9227 Set_Etype (N, Standard_Boolean);
9228 Adjust_Result_Type (N, Typ);
9230 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9231 Expand_Intrinsic_Call (N, Entity (N));
9234 end Expand_N_Op_Xor;
9236 ----------------------
9237 -- Expand_N_Or_Else --
9238 ----------------------
9240 procedure Expand_N_Or_Else (N : Node_Id)
9241 renames Expand_Short_Circuit_Operator;
9243 -----------------------------------
9244 -- Expand_N_Qualified_Expression --
9245 -----------------------------------
9247 procedure Expand_N_Qualified_Expression (N : Node_Id) is
9248 Operand : constant Node_Id := Expression (N);
9249 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
9252 -- Do validity check if validity checking operands
9254 if Validity_Checks_On and Validity_Check_Operands then
9255 Ensure_Valid (Operand);
9258 -- Apply possible constraint check
9260 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
9262 if Do_Range_Check (Operand) then
9263 Set_Do_Range_Check (Operand, False);
9264 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
9266 end Expand_N_Qualified_Expression;
9268 ------------------------------------
9269 -- Expand_N_Quantified_Expression --
9270 ------------------------------------
9274 -- for all X in range => Cond
9279 -- for X in range loop
9286 -- Similarly, an existentially quantified expression:
9288 -- for some X in range => Cond
9293 -- for X in range loop
9300 -- In both cases, the iteration may be over a container in which case it is
9301 -- given by an iterator specification, not a loop parameter specification.
9303 procedure Expand_N_Quantified_Expression (N : Node_Id) is
9304 Actions : constant List_Id := New_List;
9305 For_All : constant Boolean := All_Present (N);
9306 Iter_Spec : constant Node_Id := Iterator_Specification (N);
9307 Loc : constant Source_Ptr := Sloc (N);
9308 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
9315 -- Create the declaration of the flag which tracks the status of the
9316 -- quantified expression. Generate:
9318 -- Flag : Boolean := (True | False);
9320 Flag := Make_Temporary (Loc, 'T', N);
9323 Make_Object_Declaration (Loc,
9324 Defining_Identifier => Flag,
9325 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
9327 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
9329 -- Construct the circuitry which tracks the status of the quantified
9330 -- expression. Generate:
9332 -- if [not] Cond then
9333 -- Flag := (False | True);
9337 Cond := Relocate_Node (Condition (N));
9340 Cond := Make_Op_Not (Loc, Cond);
9344 Make_Implicit_If_Statement (N,
9346 Then_Statements => New_List (
9347 Make_Assignment_Statement (Loc,
9348 Name => New_Occurrence_Of (Flag, Loc),
9350 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
9351 Make_Exit_Statement (Loc))));
9353 -- Build the loop equivalent of the quantified expression
9355 if Present (Iter_Spec) then
9357 Make_Iteration_Scheme (Loc,
9358 Iterator_Specification => Iter_Spec);
9361 Make_Iteration_Scheme (Loc,
9362 Loop_Parameter_Specification => Loop_Spec);
9366 Make_Loop_Statement (Loc,
9367 Iteration_Scheme => Scheme,
9368 Statements => Stmts,
9369 End_Label => Empty));
9371 -- Transform the quantified expression
9374 Make_Expression_With_Actions (Loc,
9375 Expression => New_Occurrence_Of (Flag, Loc),
9376 Actions => Actions));
9377 Analyze_And_Resolve (N, Standard_Boolean);
9378 end Expand_N_Quantified_Expression;
9380 ---------------------------------
9381 -- Expand_N_Selected_Component --
9382 ---------------------------------
9384 procedure Expand_N_Selected_Component (N : Node_Id) is
9385 Loc : constant Source_Ptr := Sloc (N);
9386 Par : constant Node_Id := Parent (N);
9387 P : constant Node_Id := Prefix (N);
9388 S : constant Node_Id := Selector_Name (N);
9389 Ptyp : Entity_Id := Underlying_Type (Etype (P));
9395 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
9396 -- Gigi needs a temporary for prefixes that depend on a discriminant,
9397 -- unless the context of an assignment can provide size information.
9398 -- Don't we have a general routine that does this???
9400 function Is_Subtype_Declaration return Boolean;
9401 -- The replacement of a discriminant reference by its value is required
9402 -- if this is part of the initialization of an temporary generated by a
9403 -- change of representation. This shows up as the construction of a
9404 -- discriminant constraint for a subtype declared at the same point as
9405 -- the entity in the prefix of the selected component. We recognize this
9406 -- case when the context of the reference is:
9407 -- subtype ST is T(Obj.D);
9408 -- where the entity for Obj comes from source, and ST has the same sloc.
9410 -----------------------
9411 -- In_Left_Hand_Side --
9412 -----------------------
9414 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
9416 return (Nkind (Parent (Comp)) = N_Assignment_Statement
9417 and then Comp = Name (Parent (Comp)))
9418 or else (Present (Parent (Comp))
9419 and then Nkind (Parent (Comp)) in N_Subexpr
9420 and then In_Left_Hand_Side (Parent (Comp)));
9421 end In_Left_Hand_Side;
9423 -----------------------------
9424 -- Is_Subtype_Declaration --
9425 -----------------------------
9427 function Is_Subtype_Declaration return Boolean is
9428 Par : constant Node_Id := Parent (N);
9431 Nkind (Par) = N_Index_Or_Discriminant_Constraint
9432 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
9433 and then Comes_From_Source (Entity (Prefix (N)))
9434 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
9435 end Is_Subtype_Declaration;
9437 -- Start of processing for Expand_N_Selected_Component
9440 -- Insert explicit dereference if required
9442 if Is_Access_Type (Ptyp) then
9444 -- First set prefix type to proper access type, in case it currently
9445 -- has a private (non-access) view of this type.
9447 Set_Etype (P, Ptyp);
9449 Insert_Explicit_Dereference (P);
9450 Analyze_And_Resolve (P, Designated_Type (Ptyp));
9452 if Ekind (Etype (P)) = E_Private_Subtype
9453 and then Is_For_Access_Subtype (Etype (P))
9455 Set_Etype (P, Base_Type (Etype (P)));
9461 -- Deal with discriminant check required
9463 if Do_Discriminant_Check (N) then
9464 if Present (Discriminant_Checking_Func
9465 (Original_Record_Component (Entity (S))))
9467 -- Present the discriminant checking function to the backend, so
9468 -- that it can inline the call to the function.
9471 (Discriminant_Checking_Func
9472 (Original_Record_Component (Entity (S))));
9474 -- Now reset the flag and generate the call
9476 Set_Do_Discriminant_Check (N, False);
9477 Generate_Discriminant_Check (N);
9479 -- In the case of Unchecked_Union, no discriminant checking is
9480 -- actually performed.
9483 Set_Do_Discriminant_Check (N, False);
9487 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9488 -- function, then additional actuals must be passed.
9490 if Ada_Version >= Ada_2005
9491 and then Is_Build_In_Place_Function_Call (P)
9493 Make_Build_In_Place_Call_In_Anonymous_Context (P);
9496 -- Gigi cannot handle unchecked conversions that are the prefix of a
9497 -- selected component with discriminants. This must be checked during
9498 -- expansion, because during analysis the type of the selector is not
9499 -- known at the point the prefix is analyzed. If the conversion is the
9500 -- target of an assignment, then we cannot force the evaluation.
9502 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
9503 and then Has_Discriminants (Etype (N))
9504 and then not In_Left_Hand_Side (N)
9506 Force_Evaluation (Prefix (N));
9509 -- Remaining processing applies only if selector is a discriminant
9511 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
9513 -- If the selector is a discriminant of a constrained record type,
9514 -- we may be able to rewrite the expression with the actual value
9515 -- of the discriminant, a useful optimization in some cases.
9517 if Is_Record_Type (Ptyp)
9518 and then Has_Discriminants (Ptyp)
9519 and then Is_Constrained (Ptyp)
9521 -- Do this optimization for discrete types only, and not for
9522 -- access types (access discriminants get us into trouble).
9524 if not Is_Discrete_Type (Etype (N)) then
9527 -- Don't do this on the left hand of an assignment statement.
9528 -- Normally one would think that references like this would not
9529 -- occur, but they do in generated code, and mean that we really
9530 -- do want to assign the discriminant.
9532 elsif Nkind (Par) = N_Assignment_Statement
9533 and then Name (Par) = N
9537 -- Don't do this optimization for the prefix of an attribute or
9538 -- the name of an object renaming declaration since these are
9539 -- contexts where we do not want the value anyway.
9541 elsif (Nkind (Par) = N_Attribute_Reference
9542 and then Prefix (Par) = N)
9543 or else Is_Renamed_Object (N)
9547 -- Don't do this optimization if we are within the code for a
9548 -- discriminant check, since the whole point of such a check may
9549 -- be to verify the condition on which the code below depends.
9551 elsif Is_In_Discriminant_Check (N) then
9554 -- Green light to see if we can do the optimization. There is
9555 -- still one condition that inhibits the optimization below but
9556 -- now is the time to check the particular discriminant.
9559 -- Loop through discriminants to find the matching discriminant
9560 -- constraint to see if we can copy it.
9562 Disc := First_Discriminant (Ptyp);
9563 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
9564 Discr_Loop : while Present (Dcon) loop
9565 Dval := Node (Dcon);
9567 -- Check if this is the matching discriminant and if the
9568 -- discriminant value is simple enough to make sense to
9569 -- copy. We don't want to copy complex expressions, and
9570 -- indeed to do so can cause trouble (before we put in
9571 -- this guard, a discriminant expression containing an
9572 -- AND THEN was copied, causing problems for coverage
9575 -- However, if the reference is part of the initialization
9576 -- code generated for an object declaration, we must use
9577 -- the discriminant value from the subtype constraint,
9578 -- because the selected component may be a reference to the
9579 -- object being initialized, whose discriminant is not yet
9580 -- set. This only happens in complex cases involving changes
9581 -- or representation.
9583 if Disc = Entity (Selector_Name (N))
9584 and then (Is_Entity_Name (Dval)
9585 or else Compile_Time_Known_Value (Dval)
9586 or else Is_Subtype_Declaration)
9588 -- Here we have the matching discriminant. Check for
9589 -- the case of a discriminant of a component that is
9590 -- constrained by an outer discriminant, which cannot
9591 -- be optimized away.
9593 if Denotes_Discriminant
9594 (Dval, Check_Concurrent => True)
9598 elsif Nkind (Original_Node (Dval)) = N_Selected_Component
9600 Denotes_Discriminant
9601 (Selector_Name (Original_Node (Dval)), True)
9605 -- Do not retrieve value if constraint is not static. It
9606 -- is generally not useful, and the constraint may be a
9607 -- rewritten outer discriminant in which case it is in
9610 elsif Is_Entity_Name (Dval)
9612 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
9613 and then Present (Expression (Parent (Entity (Dval))))
9615 Is_Static_Expression
9616 (Expression (Parent (Entity (Dval))))
9620 -- In the context of a case statement, the expression may
9621 -- have the base type of the discriminant, and we need to
9622 -- preserve the constraint to avoid spurious errors on
9625 elsif Nkind (Parent (N)) = N_Case_Statement
9626 and then Etype (Dval) /= Etype (Disc)
9629 Make_Qualified_Expression (Loc,
9631 New_Occurrence_Of (Etype (Disc), Loc),
9633 New_Copy_Tree (Dval)));
9634 Analyze_And_Resolve (N, Etype (Disc));
9636 -- In case that comes out as a static expression,
9637 -- reset it (a selected component is never static).
9639 Set_Is_Static_Expression (N, False);
9642 -- Otherwise we can just copy the constraint, but the
9643 -- result is certainly not static. In some cases the
9644 -- discriminant constraint has been analyzed in the
9645 -- context of the original subtype indication, but for
9646 -- itypes the constraint might not have been analyzed
9647 -- yet, and this must be done now.
9650 Rewrite (N, New_Copy_Tree (Dval));
9651 Analyze_And_Resolve (N);
9652 Set_Is_Static_Expression (N, False);
9658 Next_Discriminant (Disc);
9659 end loop Discr_Loop;
9661 -- Note: the above loop should always find a matching
9662 -- discriminant, but if it does not, we just missed an
9663 -- optimization due to some glitch (perhaps a previous
9664 -- error), so ignore.
9669 -- The only remaining processing is in the case of a discriminant of
9670 -- a concurrent object, where we rewrite the prefix to denote the
9671 -- corresponding record type. If the type is derived and has renamed
9672 -- discriminants, use corresponding discriminant, which is the one
9673 -- that appears in the corresponding record.
9675 if not Is_Concurrent_Type (Ptyp) then
9679 Disc := Entity (Selector_Name (N));
9681 if Is_Derived_Type (Ptyp)
9682 and then Present (Corresponding_Discriminant (Disc))
9684 Disc := Corresponding_Discriminant (Disc);
9688 Make_Selected_Component (Loc,
9690 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
9692 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
9698 -- Set Atomic_Sync_Required if necessary for atomic component
9700 if Nkind (N) = N_Selected_Component then
9702 E : constant Entity_Id := Entity (Selector_Name (N));
9706 -- If component is atomic, but type is not, setting depends on
9707 -- disable/enable state for the component.
9709 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
9710 Set := not Atomic_Synchronization_Disabled (E);
9712 -- If component is not atomic, but its type is atomic, setting
9713 -- depends on disable/enable state for the type.
9715 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
9716 Set := not Atomic_Synchronization_Disabled (Etype (E));
9718 -- If both component and type are atomic, we disable if either
9719 -- component or its type have sync disabled.
9721 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
9722 Set := (not Atomic_Synchronization_Disabled (E))
9724 (not Atomic_Synchronization_Disabled (Etype (E)));
9730 -- Set flag if required
9733 Activate_Atomic_Synchronization (N);
9737 end Expand_N_Selected_Component;
9739 --------------------
9740 -- Expand_N_Slice --
9741 --------------------
9743 procedure Expand_N_Slice (N : Node_Id) is
9744 Loc : constant Source_Ptr := Sloc (N);
9745 Typ : constant Entity_Id := Etype (N);
9747 function Is_Procedure_Actual (N : Node_Id) return Boolean;
9748 -- Check whether the argument is an actual for a procedure call, in
9749 -- which case the expansion of a bit-packed slice is deferred until the
9750 -- call itself is expanded. The reason this is required is that we might
9751 -- have an IN OUT or OUT parameter, and the copy out is essential, and
9752 -- that copy out would be missed if we created a temporary here in
9753 -- Expand_N_Slice. Note that we don't bother to test specifically for an
9754 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9755 -- is harmless to defer expansion in the IN case, since the call
9756 -- processing will still generate the appropriate copy in operation,
9757 -- which will take care of the slice.
9759 procedure Make_Temporary_For_Slice;
9760 -- Create a named variable for the value of the slice, in cases where
9761 -- the back-end cannot handle it properly, e.g. when packed types or
9762 -- unaligned slices are involved.
9764 -------------------------
9765 -- Is_Procedure_Actual --
9766 -------------------------
9768 function Is_Procedure_Actual (N : Node_Id) return Boolean is
9769 Par : Node_Id := Parent (N);
9773 -- If our parent is a procedure call we can return
9775 if Nkind (Par) = N_Procedure_Call_Statement then
9778 -- If our parent is a type conversion, keep climbing the tree,
9779 -- since a type conversion can be a procedure actual. Also keep
9780 -- climbing if parameter association or a qualified expression,
9781 -- since these are additional cases that do can appear on
9782 -- procedure actuals.
9784 elsif Nkind_In (Par, N_Type_Conversion,
9785 N_Parameter_Association,
9786 N_Qualified_Expression)
9788 Par := Parent (Par);
9790 -- Any other case is not what we are looking for
9796 end Is_Procedure_Actual;
9798 ------------------------------
9799 -- Make_Temporary_For_Slice --
9800 ------------------------------
9802 procedure Make_Temporary_For_Slice is
9803 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
9808 Make_Object_Declaration (Loc,
9809 Defining_Identifier => Ent,
9810 Object_Definition => New_Occurrence_Of (Typ, Loc));
9812 Set_No_Initialization (Decl);
9814 Insert_Actions (N, New_List (
9816 Make_Assignment_Statement (Loc,
9817 Name => New_Occurrence_Of (Ent, Loc),
9818 Expression => Relocate_Node (N))));
9820 Rewrite (N, New_Occurrence_Of (Ent, Loc));
9821 Analyze_And_Resolve (N, Typ);
9822 end Make_Temporary_For_Slice;
9826 Pref : constant Node_Id := Prefix (N);
9827 Pref_Typ : Entity_Id := Etype (Pref);
9829 -- Start of processing for Expand_N_Slice
9832 -- Special handling for access types
9834 if Is_Access_Type (Pref_Typ) then
9835 Pref_Typ := Designated_Type (Pref_Typ);
9838 Make_Explicit_Dereference (Sloc (N),
9839 Prefix => Relocate_Node (Pref)));
9841 Analyze_And_Resolve (Pref, Pref_Typ);
9844 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9845 -- function, then additional actuals must be passed.
9847 if Ada_Version >= Ada_2005
9848 and then Is_Build_In_Place_Function_Call (Pref)
9850 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
9853 -- The remaining case to be handled is packed slices. We can leave
9854 -- packed slices as they are in the following situations:
9856 -- 1. Right or left side of an assignment (we can handle this
9857 -- situation correctly in the assignment statement expansion).
9859 -- 2. Prefix of indexed component (the slide is optimized away in this
9860 -- case, see the start of Expand_N_Slice.)
9862 -- 3. Object renaming declaration, since we want the name of the
9863 -- slice, not the value.
9865 -- 4. Argument to procedure call, since copy-in/copy-out handling may
9866 -- be required, and this is handled in the expansion of call
9869 -- 5. Prefix of an address attribute (this is an error which is caught
9870 -- elsewhere, and the expansion would interfere with generating the
9873 if not Is_Packed (Typ) then
9875 -- Apply transformation for actuals of a function call, where
9876 -- Expand_Actuals is not used.
9878 if Nkind (Parent (N)) = N_Function_Call
9879 and then Is_Possibly_Unaligned_Slice (N)
9881 Make_Temporary_For_Slice;
9884 elsif Nkind (Parent (N)) = N_Assignment_Statement
9885 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
9886 and then Parent (N) = Name (Parent (Parent (N))))
9890 elsif Nkind (Parent (N)) = N_Indexed_Component
9891 or else Is_Renamed_Object (N)
9892 or else Is_Procedure_Actual (N)
9896 elsif Nkind (Parent (N)) = N_Attribute_Reference
9897 and then Attribute_Name (Parent (N)) = Name_Address
9902 Make_Temporary_For_Slice;
9906 ------------------------------
9907 -- Expand_N_Type_Conversion --
9908 ------------------------------
9910 procedure Expand_N_Type_Conversion (N : Node_Id) is
9911 Loc : constant Source_Ptr := Sloc (N);
9912 Operand : constant Node_Id := Expression (N);
9913 Target_Type : constant Entity_Id := Etype (N);
9914 Operand_Type : Entity_Id := Etype (Operand);
9916 procedure Handle_Changed_Representation;
9917 -- This is called in the case of record and array type conversions to
9918 -- see if there is a change of representation to be handled. Change of
9919 -- representation is actually handled at the assignment statement level,
9920 -- and what this procedure does is rewrite node N conversion as an
9921 -- assignment to temporary. If there is no change of representation,
9922 -- then the conversion node is unchanged.
9924 procedure Raise_Accessibility_Error;
9925 -- Called when we know that an accessibility check will fail. Rewrites
9926 -- node N to an appropriate raise statement and outputs warning msgs.
9927 -- The Etype of the raise node is set to Target_Type.
9929 procedure Real_Range_Check;
9930 -- Handles generation of range check for real target value
9932 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
9933 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
9934 -- evaluates to True.
9936 -----------------------------------
9937 -- Handle_Changed_Representation --
9938 -----------------------------------
9940 procedure Handle_Changed_Representation is
9949 -- Nothing else to do if no change of representation
9951 if Same_Representation (Operand_Type, Target_Type) then
9954 -- The real change of representation work is done by the assignment
9955 -- statement processing. So if this type conversion is appearing as
9956 -- the expression of an assignment statement, nothing needs to be
9957 -- done to the conversion.
9959 elsif Nkind (Parent (N)) = N_Assignment_Statement then
9962 -- Otherwise we need to generate a temporary variable, and do the
9963 -- change of representation assignment into that temporary variable.
9964 -- The conversion is then replaced by a reference to this variable.
9969 -- If type is unconstrained we have to add a constraint, copied
9970 -- from the actual value of the left hand side.
9972 if not Is_Constrained (Target_Type) then
9973 if Has_Discriminants (Operand_Type) then
9974 Disc := First_Discriminant (Operand_Type);
9976 if Disc /= First_Stored_Discriminant (Operand_Type) then
9977 Disc := First_Stored_Discriminant (Operand_Type);
9981 while Present (Disc) loop
9983 Make_Selected_Component (Loc,
9985 Duplicate_Subexpr_Move_Checks (Operand),
9987 Make_Identifier (Loc, Chars (Disc))));
9988 Next_Discriminant (Disc);
9991 elsif Is_Array_Type (Operand_Type) then
9992 N_Ix := First_Index (Target_Type);
9995 for J in 1 .. Number_Dimensions (Operand_Type) loop
9997 -- We convert the bounds explicitly. We use an unchecked
9998 -- conversion because bounds checks are done elsewhere.
10003 Unchecked_Convert_To (Etype (N_Ix),
10004 Make_Attribute_Reference (Loc,
10006 Duplicate_Subexpr_No_Checks
10007 (Operand, Name_Req => True),
10008 Attribute_Name => Name_First,
10009 Expressions => New_List (
10010 Make_Integer_Literal (Loc, J)))),
10013 Unchecked_Convert_To (Etype (N_Ix),
10014 Make_Attribute_Reference (Loc,
10016 Duplicate_Subexpr_No_Checks
10017 (Operand, Name_Req => True),
10018 Attribute_Name => Name_Last,
10019 Expressions => New_List (
10020 Make_Integer_Literal (Loc, J))))));
10027 Odef := New_Occurrence_Of (Target_Type, Loc);
10029 if Present (Cons) then
10031 Make_Subtype_Indication (Loc,
10032 Subtype_Mark => Odef,
10034 Make_Index_Or_Discriminant_Constraint (Loc,
10035 Constraints => Cons));
10038 Temp := Make_Temporary (Loc, 'C');
10040 Make_Object_Declaration (Loc,
10041 Defining_Identifier => Temp,
10042 Object_Definition => Odef);
10044 Set_No_Initialization (Decl, True);
10046 -- Insert required actions. It is essential to suppress checks
10047 -- since we have suppressed default initialization, which means
10048 -- that the variable we create may have no discriminants.
10053 Make_Assignment_Statement (Loc,
10054 Name => New_Occurrence_Of (Temp, Loc),
10055 Expression => Relocate_Node (N))),
10056 Suppress => All_Checks);
10058 Rewrite (N, New_Occurrence_Of (Temp, Loc));
10061 end Handle_Changed_Representation;
10063 -------------------------------
10064 -- Raise_Accessibility_Error --
10065 -------------------------------
10067 procedure Raise_Accessibility_Error is
10069 Error_Msg_Warn := SPARK_Mode /= On;
10071 Make_Raise_Program_Error (Sloc (N),
10072 Reason => PE_Accessibility_Check_Failed));
10073 Set_Etype (N, Target_Type);
10075 Error_Msg_N ("<<accessibility check failure", N);
10076 Error_Msg_NE ("\<<& [", N, Standard_Program_Error);
10077 end Raise_Accessibility_Error;
10079 ----------------------
10080 -- Real_Range_Check --
10081 ----------------------
10083 -- Case of conversions to floating-point or fixed-point. If range checks
10084 -- are enabled and the target type has a range constraint, we convert:
10090 -- Tnn : typ'Base := typ'Base (x);
10091 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
10094 -- This is necessary when there is a conversion of integer to float or
10095 -- to fixed-point to ensure that the correct checks are made. It is not
10096 -- necessary for float to float where it is enough to simply set the
10097 -- Do_Range_Check flag.
10099 procedure Real_Range_Check is
10100 Btyp : constant Entity_Id := Base_Type (Target_Type);
10101 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
10102 Hi : constant Node_Id := Type_High_Bound (Target_Type);
10103 Xtyp : constant Entity_Id := Etype (Operand);
10108 -- Nothing to do if conversion was rewritten
10110 if Nkind (N) /= N_Type_Conversion then
10114 -- Nothing to do if range checks suppressed, or target has the same
10115 -- range as the base type (or is the base type).
10117 if Range_Checks_Suppressed (Target_Type)
10118 or else (Lo = Type_Low_Bound (Btyp)
10120 Hi = Type_High_Bound (Btyp))
10125 -- Nothing to do if expression is an entity on which checks have been
10128 if Is_Entity_Name (Operand)
10129 and then Range_Checks_Suppressed (Entity (Operand))
10134 -- Nothing to do if bounds are all static and we can tell that the
10135 -- expression is within the bounds of the target. Note that if the
10136 -- operand is of an unconstrained floating-point type, then we do
10137 -- not trust it to be in range (might be infinite)
10140 S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
10141 S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
10144 if (not Is_Floating_Point_Type (Xtyp)
10145 or else Is_Constrained (Xtyp))
10146 and then Compile_Time_Known_Value (S_Lo)
10147 and then Compile_Time_Known_Value (S_Hi)
10148 and then Compile_Time_Known_Value (Hi)
10149 and then Compile_Time_Known_Value (Lo)
10152 D_Lov : constant Ureal := Expr_Value_R (Lo);
10153 D_Hiv : constant Ureal := Expr_Value_R (Hi);
10158 if Is_Real_Type (Xtyp) then
10159 S_Lov := Expr_Value_R (S_Lo);
10160 S_Hiv := Expr_Value_R (S_Hi);
10162 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
10163 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
10167 and then S_Lov >= D_Lov
10168 and then S_Hiv <= D_Hiv
10170 Set_Do_Range_Check (Operand, False);
10177 -- For float to float conversions, we are done
10179 if Is_Floating_Point_Type (Xtyp)
10181 Is_Floating_Point_Type (Btyp)
10186 -- Otherwise rewrite the conversion as described above
10188 Conv := Relocate_Node (N);
10189 Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
10190 Set_Etype (Conv, Btyp);
10192 -- Enable overflow except for case of integer to float conversions,
10193 -- where it is never required, since we can never have overflow in
10196 if not Is_Integer_Type (Etype (Operand)) then
10197 Enable_Overflow_Check (Conv);
10200 Tnn := Make_Temporary (Loc, 'T', Conv);
10202 Insert_Actions (N, New_List (
10203 Make_Object_Declaration (Loc,
10204 Defining_Identifier => Tnn,
10205 Object_Definition => New_Occurrence_Of (Btyp, Loc),
10206 Constant_Present => True,
10207 Expression => Conv),
10209 Make_Raise_Constraint_Error (Loc,
10214 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
10216 Make_Attribute_Reference (Loc,
10217 Attribute_Name => Name_First,
10219 New_Occurrence_Of (Target_Type, Loc))),
10223 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
10225 Make_Attribute_Reference (Loc,
10226 Attribute_Name => Name_Last,
10228 New_Occurrence_Of (Target_Type, Loc)))),
10229 Reason => CE_Range_Check_Failed)));
10231 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
10232 Analyze_And_Resolve (N, Btyp);
10233 end Real_Range_Check;
10235 -----------------------------
10236 -- Has_Extra_Accessibility --
10237 -----------------------------
10239 -- Returns true for a formal of an anonymous access type or for
10240 -- an Ada 2012-style stand-alone object of an anonymous access type.
10242 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
10244 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
10245 return Present (Effective_Extra_Accessibility (Id));
10249 end Has_Extra_Accessibility;
10251 -- Start of processing for Expand_N_Type_Conversion
10254 -- First remove check marks put by the semantic analysis on the type
10255 -- conversion between array types. We need these checks, and they will
10256 -- be generated by this expansion routine, but we do not depend on these
10257 -- flags being set, and since we do intend to expand the checks in the
10258 -- front end, we don't want them on the tree passed to the back end.
10260 if Is_Array_Type (Target_Type) then
10261 if Is_Constrained (Target_Type) then
10262 Set_Do_Length_Check (N, False);
10264 Set_Do_Range_Check (Operand, False);
10268 -- Nothing at all to do if conversion is to the identical type so remove
10269 -- the conversion completely, it is useless, except that it may carry
10270 -- an Assignment_OK attribute, which must be propagated to the operand.
10272 if Operand_Type = Target_Type then
10273 if Assignment_OK (N) then
10274 Set_Assignment_OK (Operand);
10277 Rewrite (N, Relocate_Node (Operand));
10281 -- Nothing to do if this is the second argument of read. This is a
10282 -- "backwards" conversion that will be handled by the specialized code
10283 -- in attribute processing.
10285 if Nkind (Parent (N)) = N_Attribute_Reference
10286 and then Attribute_Name (Parent (N)) = Name_Read
10287 and then Next (First (Expressions (Parent (N)))) = N
10292 -- Check for case of converting to a type that has an invariant
10293 -- associated with it. This required an invariant check. We convert
10299 -- do invariant_check (typ (expr)) in typ (expr);
10301 -- using Duplicate_Subexpr to avoid multiple side effects
10303 -- Note: the Comes_From_Source check, and then the resetting of this
10304 -- flag prevents what would otherwise be an infinite recursion.
10306 if Has_Invariants (Target_Type)
10307 and then Present (Invariant_Procedure (Target_Type))
10308 and then Comes_From_Source (N)
10310 Set_Comes_From_Source (N, False);
10312 Make_Expression_With_Actions (Loc,
10313 Actions => New_List (
10314 Make_Invariant_Call (Duplicate_Subexpr (N))),
10315 Expression => Duplicate_Subexpr_No_Checks (N)));
10316 Analyze_And_Resolve (N, Target_Type);
10320 -- Here if we may need to expand conversion
10322 -- If the operand of the type conversion is an arithmetic operation on
10323 -- signed integers, and the based type of the signed integer type in
10324 -- question is smaller than Standard.Integer, we promote both of the
10325 -- operands to type Integer.
10327 -- For example, if we have
10329 -- target-type (opnd1 + opnd2)
10331 -- and opnd1 and opnd2 are of type short integer, then we rewrite
10334 -- target-type (integer(opnd1) + integer(opnd2))
10336 -- We do this because we are always allowed to compute in a larger type
10337 -- if we do the right thing with the result, and in this case we are
10338 -- going to do a conversion which will do an appropriate check to make
10339 -- sure that things are in range of the target type in any case. This
10340 -- avoids some unnecessary intermediate overflows.
10342 -- We might consider a similar transformation in the case where the
10343 -- target is a real type or a 64-bit integer type, and the operand
10344 -- is an arithmetic operation using a 32-bit integer type. However,
10345 -- we do not bother with this case, because it could cause significant
10346 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
10347 -- much cheaper, but we don't want different behavior on 32-bit and
10348 -- 64-bit machines. Note that the exclusion of the 64-bit case also
10349 -- handles the configurable run-time cases where 64-bit arithmetic
10350 -- may simply be unavailable.
10352 -- Note: this circuit is partially redundant with respect to the circuit
10353 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10354 -- the processing here. Also we still need the Checks circuit, since we
10355 -- have to be sure not to generate junk overflow checks in the first
10356 -- place, since it would be trick to remove them here.
10358 if Integer_Promotion_Possible (N) then
10360 -- All conditions met, go ahead with transformation
10368 Make_Type_Conversion (Loc,
10369 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
10370 Expression => Relocate_Node (Right_Opnd (Operand)));
10372 Opnd := New_Op_Node (Nkind (Operand), Loc);
10373 Set_Right_Opnd (Opnd, R);
10375 if Nkind (Operand) in N_Binary_Op then
10377 Make_Type_Conversion (Loc,
10378 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
10379 Expression => Relocate_Node (Left_Opnd (Operand)));
10381 Set_Left_Opnd (Opnd, L);
10385 Make_Type_Conversion (Loc,
10386 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
10387 Expression => Opnd));
10389 Analyze_And_Resolve (N, Target_Type);
10394 -- Do validity check if validity checking operands
10396 if Validity_Checks_On and Validity_Check_Operands then
10397 Ensure_Valid (Operand);
10400 -- Special case of converting from non-standard boolean type
10402 if Is_Boolean_Type (Operand_Type)
10403 and then (Nonzero_Is_True (Operand_Type))
10405 Adjust_Condition (Operand);
10406 Set_Etype (Operand, Standard_Boolean);
10407 Operand_Type := Standard_Boolean;
10410 -- Case of converting to an access type
10412 if Is_Access_Type (Target_Type) then
10414 -- Apply an accessibility check when the conversion operand is an
10415 -- access parameter (or a renaming thereof), unless conversion was
10416 -- expanded from an Unchecked_ or Unrestricted_Access attribute.
10417 -- Note that other checks may still need to be applied below (such
10418 -- as tagged type checks).
10420 if Is_Entity_Name (Operand)
10421 and then Has_Extra_Accessibility (Entity (Operand))
10422 and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
10423 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
10424 or else Attribute_Name (Original_Node (N)) = Name_Access)
10426 Apply_Accessibility_Check
10427 (Operand, Target_Type, Insert_Node => Operand);
10429 -- If the level of the operand type is statically deeper than the
10430 -- level of the target type, then force Program_Error. Note that this
10431 -- can only occur for cases where the attribute is within the body of
10432 -- an instantiation (otherwise the conversion will already have been
10433 -- rejected as illegal). Note: warnings are issued by the analyzer
10434 -- for the instance cases.
10436 elsif In_Instance_Body
10437 and then Type_Access_Level (Operand_Type) >
10438 Type_Access_Level (Target_Type)
10440 Raise_Accessibility_Error;
10442 -- When the operand is a selected access discriminant the check needs
10443 -- to be made against the level of the object denoted by the prefix
10444 -- of the selected name. Force Program_Error for this case as well
10445 -- (this accessibility violation can only happen if within the body
10446 -- of an instantiation).
10448 elsif In_Instance_Body
10449 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
10450 and then Nkind (Operand) = N_Selected_Component
10451 and then Object_Access_Level (Operand) >
10452 Type_Access_Level (Target_Type)
10454 Raise_Accessibility_Error;
10459 -- Case of conversions of tagged types and access to tagged types
10461 -- When needed, that is to say when the expression is class-wide, Add
10462 -- runtime a tag check for (strict) downward conversion by using the
10463 -- membership test, generating:
10465 -- [constraint_error when Operand not in Target_Type'Class]
10467 -- or in the access type case
10469 -- [constraint_error
10470 -- when Operand /= null
10471 -- and then Operand.all not in
10472 -- Designated_Type (Target_Type)'Class]
10474 if (Is_Access_Type (Target_Type)
10475 and then Is_Tagged_Type (Designated_Type (Target_Type)))
10476 or else Is_Tagged_Type (Target_Type)
10478 -- Do not do any expansion in the access type case if the parent is a
10479 -- renaming, since this is an error situation which will be caught by
10480 -- Sem_Ch8, and the expansion can interfere with this error check.
10482 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
10486 -- Otherwise, proceed with processing tagged conversion
10488 Tagged_Conversion : declare
10489 Actual_Op_Typ : Entity_Id;
10490 Actual_Targ_Typ : Entity_Id;
10491 Make_Conversion : Boolean := False;
10492 Root_Op_Typ : Entity_Id;
10494 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
10495 -- Create a membership check to test whether Operand is a member
10496 -- of Targ_Typ. If the original Target_Type is an access, include
10497 -- a test for null value. The check is inserted at N.
10499 --------------------
10500 -- Make_Tag_Check --
10501 --------------------
10503 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
10508 -- [Constraint_Error
10509 -- when Operand /= null
10510 -- and then Operand.all not in Targ_Typ]
10512 if Is_Access_Type (Target_Type) then
10514 Make_And_Then (Loc,
10517 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
10518 Right_Opnd => Make_Null (Loc)),
10523 Make_Explicit_Dereference (Loc,
10524 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
10525 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
10528 -- [Constraint_Error when Operand not in Targ_Typ]
10533 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
10534 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
10538 Make_Raise_Constraint_Error (Loc,
10540 Reason => CE_Tag_Check_Failed));
10541 end Make_Tag_Check;
10543 -- Start of processing for Tagged_Conversion
10546 -- Handle entities from the limited view
10548 if Is_Access_Type (Operand_Type) then
10550 Available_View (Designated_Type (Operand_Type));
10552 Actual_Op_Typ := Operand_Type;
10555 if Is_Access_Type (Target_Type) then
10557 Available_View (Designated_Type (Target_Type));
10559 Actual_Targ_Typ := Target_Type;
10562 Root_Op_Typ := Root_Type (Actual_Op_Typ);
10564 -- Ada 2005 (AI-251): Handle interface type conversion
10566 if Is_Interface (Actual_Op_Typ) then
10567 Expand_Interface_Conversion (N);
10571 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
10573 -- Create a runtime tag check for a downward class-wide type
10576 if Is_Class_Wide_Type (Actual_Op_Typ)
10577 and then Actual_Op_Typ /= Actual_Targ_Typ
10578 and then Root_Op_Typ /= Actual_Targ_Typ
10579 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
10580 Use_Full_View => True)
10582 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
10583 Make_Conversion := True;
10586 -- AI05-0073: If the result subtype of the function is defined
10587 -- by an access_definition designating a specific tagged type
10588 -- T, a check is made that the result value is null or the tag
10589 -- of the object designated by the result value identifies T.
10590 -- Constraint_Error is raised if this check fails.
10592 if Nkind (Parent (N)) = N_Simple_Return_Statement then
10595 Func_Typ : Entity_Id;
10598 -- Climb scope stack looking for the enclosing function
10600 Func := Current_Scope;
10601 while Present (Func)
10602 and then Ekind (Func) /= E_Function
10604 Func := Scope (Func);
10607 -- The function's return subtype must be defined using
10608 -- an access definition.
10610 if Nkind (Result_Definition (Parent (Func))) =
10611 N_Access_Definition
10613 Func_Typ := Directly_Designated_Type (Etype (Func));
10615 -- The return subtype denotes a specific tagged type,
10616 -- in other words, a non class-wide type.
10618 if Is_Tagged_Type (Func_Typ)
10619 and then not Is_Class_Wide_Type (Func_Typ)
10621 Make_Tag_Check (Actual_Targ_Typ);
10622 Make_Conversion := True;
10628 -- We have generated a tag check for either a class-wide type
10629 -- conversion or for AI05-0073.
10631 if Make_Conversion then
10636 Make_Unchecked_Type_Conversion (Loc,
10637 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
10638 Expression => Relocate_Node (Expression (N)));
10640 Analyze_And_Resolve (N, Target_Type);
10644 end Tagged_Conversion;
10646 -- Case of other access type conversions
10648 elsif Is_Access_Type (Target_Type) then
10649 Apply_Constraint_Check (Operand, Target_Type);
10651 -- Case of conversions from a fixed-point type
10653 -- These conversions require special expansion and processing, found in
10654 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10655 -- since from a semantic point of view, these are simple integer
10656 -- conversions, which do not need further processing.
10658 elsif Is_Fixed_Point_Type (Operand_Type)
10659 and then not Conversion_OK (N)
10661 -- We should never see universal fixed at this case, since the
10662 -- expansion of the constituent divide or multiply should have
10663 -- eliminated the explicit mention of universal fixed.
10665 pragma Assert (Operand_Type /= Universal_Fixed);
10667 -- Check for special case of the conversion to universal real that
10668 -- occurs as a result of the use of a round attribute. In this case,
10669 -- the real type for the conversion is taken from the target type of
10670 -- the Round attribute and the result must be marked as rounded.
10672 if Target_Type = Universal_Real
10673 and then Nkind (Parent (N)) = N_Attribute_Reference
10674 and then Attribute_Name (Parent (N)) = Name_Round
10676 Set_Rounded_Result (N);
10677 Set_Etype (N, Etype (Parent (N)));
10680 -- Otherwise do correct fixed-conversion, but skip these if the
10681 -- Conversion_OK flag is set, because from a semantic point of view
10682 -- these are simple integer conversions needing no further processing
10683 -- (the backend will simply treat them as integers).
10685 if not Conversion_OK (N) then
10686 if Is_Fixed_Point_Type (Etype (N)) then
10687 Expand_Convert_Fixed_To_Fixed (N);
10690 elsif Is_Integer_Type (Etype (N)) then
10691 Expand_Convert_Fixed_To_Integer (N);
10694 pragma Assert (Is_Floating_Point_Type (Etype (N)));
10695 Expand_Convert_Fixed_To_Float (N);
10700 -- Case of conversions to a fixed-point type
10702 -- These conversions require special expansion and processing, found in
10703 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10704 -- since from a semantic point of view, these are simple integer
10705 -- conversions, which do not need further processing.
10707 elsif Is_Fixed_Point_Type (Target_Type)
10708 and then not Conversion_OK (N)
10710 if Is_Integer_Type (Operand_Type) then
10711 Expand_Convert_Integer_To_Fixed (N);
10714 pragma Assert (Is_Floating_Point_Type (Operand_Type));
10715 Expand_Convert_Float_To_Fixed (N);
10719 -- Case of float-to-integer conversions
10721 -- We also handle float-to-fixed conversions with Conversion_OK set
10722 -- since semantically the fixed-point target is treated as though it
10723 -- were an integer in such cases.
10725 elsif Is_Floating_Point_Type (Operand_Type)
10727 (Is_Integer_Type (Target_Type)
10729 (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
10731 -- One more check here, gcc is still not able to do conversions of
10732 -- this type with proper overflow checking, and so gigi is doing an
10733 -- approximation of what is required by doing floating-point compares
10734 -- with the end-point. But that can lose precision in some cases, and
10735 -- give a wrong result. Converting the operand to Universal_Real is
10736 -- helpful, but still does not catch all cases with 64-bit integers
10737 -- on targets with only 64-bit floats.
10739 -- The above comment seems obsoleted by Apply_Float_Conversion_Check
10740 -- Can this code be removed ???
10742 if Do_Range_Check (Operand) then
10744 Make_Type_Conversion (Loc,
10746 New_Occurrence_Of (Universal_Real, Loc),
10748 Relocate_Node (Operand)));
10750 Set_Etype (Operand, Universal_Real);
10751 Enable_Range_Check (Operand);
10752 Set_Do_Range_Check (Expression (Operand), False);
10755 -- Case of array conversions
10757 -- Expansion of array conversions, add required length/range checks but
10758 -- only do this if there is no change of representation. For handling of
10759 -- this case, see Handle_Changed_Representation.
10761 elsif Is_Array_Type (Target_Type) then
10762 if Is_Constrained (Target_Type) then
10763 Apply_Length_Check (Operand, Target_Type);
10765 Apply_Range_Check (Operand, Target_Type);
10768 Handle_Changed_Representation;
10770 -- Case of conversions of discriminated types
10772 -- Add required discriminant checks if target is constrained. Again this
10773 -- change is skipped if we have a change of representation.
10775 elsif Has_Discriminants (Target_Type)
10776 and then Is_Constrained (Target_Type)
10778 Apply_Discriminant_Check (Operand, Target_Type);
10779 Handle_Changed_Representation;
10781 -- Case of all other record conversions. The only processing required
10782 -- is to check for a change of representation requiring the special
10783 -- assignment processing.
10785 elsif Is_Record_Type (Target_Type) then
10787 -- Ada 2005 (AI-216): Program_Error is raised when converting from
10788 -- a derived Unchecked_Union type to an unconstrained type that is
10789 -- not Unchecked_Union if the operand lacks inferable discriminants.
10791 if Is_Derived_Type (Operand_Type)
10792 and then Is_Unchecked_Union (Base_Type (Operand_Type))
10793 and then not Is_Constrained (Target_Type)
10794 and then not Is_Unchecked_Union (Base_Type (Target_Type))
10795 and then not Has_Inferable_Discriminants (Operand)
10797 -- To prevent Gigi from generating illegal code, we generate a
10798 -- Program_Error node, but we give it the target type of the
10799 -- conversion (is this requirement documented somewhere ???)
10802 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
10803 Reason => PE_Unchecked_Union_Restriction);
10806 Set_Etype (PE, Target_Type);
10811 Handle_Changed_Representation;
10814 -- Case of conversions of enumeration types
10816 elsif Is_Enumeration_Type (Target_Type) then
10818 -- Special processing is required if there is a change of
10819 -- representation (from enumeration representation clauses).
10821 if not Same_Representation (Target_Type, Operand_Type) then
10823 -- Convert: x(y) to x'val (ytyp'val (y))
10826 Make_Attribute_Reference (Loc,
10827 Prefix => New_Occurrence_Of (Target_Type, Loc),
10828 Attribute_Name => Name_Val,
10829 Expressions => New_List (
10830 Make_Attribute_Reference (Loc,
10831 Prefix => New_Occurrence_Of (Operand_Type, Loc),
10832 Attribute_Name => Name_Pos,
10833 Expressions => New_List (Operand)))));
10835 Analyze_And_Resolve (N, Target_Type);
10838 -- Case of conversions to floating-point
10840 elsif Is_Floating_Point_Type (Target_Type) then
10844 -- At this stage, either the conversion node has been transformed into
10845 -- some other equivalent expression, or left as a conversion that can be
10846 -- handled by Gigi, in the following cases:
10848 -- Conversions with no change of representation or type
10850 -- Numeric conversions involving integer, floating- and fixed-point
10851 -- values. Fixed-point values are allowed only if Conversion_OK is
10852 -- set, i.e. if the fixed-point values are to be treated as integers.
10854 -- No other conversions should be passed to Gigi
10856 -- Check: are these rules stated in sinfo??? if so, why restate here???
10858 -- The only remaining step is to generate a range check if we still have
10859 -- a type conversion at this stage and Do_Range_Check is set. For now we
10860 -- do this only for conversions of discrete types.
10862 if Nkind (N) = N_Type_Conversion
10863 and then Is_Discrete_Type (Etype (N))
10866 Expr : constant Node_Id := Expression (N);
10871 if Do_Range_Check (Expr)
10872 and then Is_Discrete_Type (Etype (Expr))
10874 Set_Do_Range_Check (Expr, False);
10876 -- Before we do a range check, we have to deal with treating a
10877 -- fixed-point operand as an integer. The way we do this is
10878 -- simply to do an unchecked conversion to an appropriate
10879 -- integer type large enough to hold the result.
10881 -- This code is not active yet, because we are only dealing
10882 -- with discrete types so far ???
10884 if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
10885 and then Treat_Fixed_As_Integer (Expr)
10887 Ftyp := Base_Type (Etype (Expr));
10889 if Esize (Ftyp) >= Esize (Standard_Integer) then
10890 Ityp := Standard_Long_Long_Integer;
10892 Ityp := Standard_Integer;
10895 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
10898 -- Reset overflow flag, since the range check will include
10899 -- dealing with possible overflow, and generate the check. If
10900 -- Address is either a source type or target type, suppress
10901 -- range check to avoid typing anomalies when it is a visible
10904 Set_Do_Overflow_Check (N, False);
10905 if not Is_Descendent_Of_Address (Etype (Expr))
10906 and then not Is_Descendent_Of_Address (Target_Type)
10908 Generate_Range_Check
10909 (Expr, Target_Type, CE_Range_Check_Failed);
10915 -- Final step, if the result is a type conversion involving Vax_Float
10916 -- types, then it is subject for further special processing.
10918 if Nkind (N) = N_Type_Conversion
10919 and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
10921 Expand_Vax_Conversion (N);
10925 -- Here at end of processing
10928 -- Apply predicate check if required. Note that we can't just call
10929 -- Apply_Predicate_Check here, because the type looks right after
10930 -- the conversion and it would omit the check. The Comes_From_Source
10931 -- guard is necessary to prevent infinite recursions when we generate
10932 -- internal conversions for the purpose of checking predicates.
10934 if Present (Predicate_Function (Target_Type))
10935 and then Target_Type /= Operand_Type
10936 and then Comes_From_Source (N)
10939 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
10942 -- Avoid infinite recursion on the subsequent expansion of
10943 -- of the copy of the original type conversion.
10945 Set_Comes_From_Source (New_Expr, False);
10946 Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr));
10949 end Expand_N_Type_Conversion;
10951 -----------------------------------
10952 -- Expand_N_Unchecked_Expression --
10953 -----------------------------------
10955 -- Remove the unchecked expression node from the tree. Its job was simply
10956 -- to make sure that its constituent expression was handled with checks
10957 -- off, and now that that is done, we can remove it from the tree, and
10958 -- indeed must, since Gigi does not expect to see these nodes.
10960 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
10961 Exp : constant Node_Id := Expression (N);
10963 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
10965 end Expand_N_Unchecked_Expression;
10967 ----------------------------------------
10968 -- Expand_N_Unchecked_Type_Conversion --
10969 ----------------------------------------
10971 -- If this cannot be handled by Gigi and we haven't already made a
10972 -- temporary for it, do it now.
10974 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
10975 Target_Type : constant Entity_Id := Etype (N);
10976 Operand : constant Node_Id := Expression (N);
10977 Operand_Type : constant Entity_Id := Etype (Operand);
10980 -- Nothing at all to do if conversion is to the identical type so remove
10981 -- the conversion completely, it is useless, except that it may carry
10982 -- an Assignment_OK indication which must be propagated to the operand.
10984 if Operand_Type = Target_Type then
10986 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
10988 if Assignment_OK (N) then
10989 Set_Assignment_OK (Operand);
10992 Rewrite (N, Relocate_Node (Operand));
10996 -- If we have a conversion of a compile time known value to a target
10997 -- type and the value is in range of the target type, then we can simply
10998 -- replace the construct by an integer literal of the correct type. We
10999 -- only apply this to integer types being converted. Possibly it may
11000 -- apply in other cases, but it is too much trouble to worry about.
11002 -- Note that we do not do this transformation if the Kill_Range_Check
11003 -- flag is set, since then the value may be outside the expected range.
11004 -- This happens in the Normalize_Scalars case.
11006 -- We also skip this if either the target or operand type is biased
11007 -- because in this case, the unchecked conversion is supposed to
11008 -- preserve the bit pattern, not the integer value.
11010 if Is_Integer_Type (Target_Type)
11011 and then not Has_Biased_Representation (Target_Type)
11012 and then Is_Integer_Type (Operand_Type)
11013 and then not Has_Biased_Representation (Operand_Type)
11014 and then Compile_Time_Known_Value (Operand)
11015 and then not Kill_Range_Check (N)
11018 Val : constant Uint := Expr_Value (Operand);
11021 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
11023 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
11025 Val >= Expr_Value (Type_Low_Bound (Target_Type))
11027 Val <= Expr_Value (Type_High_Bound (Target_Type))
11029 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
11031 -- If Address is the target type, just set the type to avoid a
11032 -- spurious type error on the literal when Address is a visible
11035 if Is_Descendent_Of_Address (Target_Type) then
11036 Set_Etype (N, Target_Type);
11038 Analyze_And_Resolve (N, Target_Type);
11046 -- Nothing to do if conversion is safe
11048 if Safe_Unchecked_Type_Conversion (N) then
11052 -- Otherwise force evaluation unless Assignment_OK flag is set (this
11053 -- flag indicates ??? More comments needed here)
11055 if Assignment_OK (N) then
11058 Force_Evaluation (N);
11060 end Expand_N_Unchecked_Type_Conversion;
11062 ----------------------------
11063 -- Expand_Record_Equality --
11064 ----------------------------
11066 -- For non-variant records, Equality is expanded when needed into:
11068 -- and then Lhs.Discr1 = Rhs.Discr1
11070 -- and then Lhs.Discrn = Rhs.Discrn
11071 -- and then Lhs.Cmp1 = Rhs.Cmp1
11073 -- and then Lhs.Cmpn = Rhs.Cmpn
11075 -- The expression is folded by the back-end for adjacent fields. This
11076 -- function is called for tagged record in only one occasion: for imple-
11077 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
11078 -- otherwise the primitive "=" is used directly.
11080 function Expand_Record_Equality
11085 Bodies : List_Id) return Node_Id
11087 Loc : constant Source_Ptr := Sloc (Nod);
11092 First_Time : Boolean := True;
11094 function Element_To_Compare (C : Entity_Id) return Entity_Id;
11095 -- Return the next discriminant or component to compare, starting with
11096 -- C, skipping inherited components.
11098 ------------------------
11099 -- Element_To_Compare --
11100 ------------------------
11102 function Element_To_Compare (C : Entity_Id) return Entity_Id is
11108 -- Exit loop when the next element to be compared is found, or
11109 -- there is no more such element.
11111 exit when No (Comp);
11113 exit when Ekind_In (Comp, E_Discriminant, E_Component)
11116 -- Skip inherited components
11118 -- Note: for a tagged type, we always generate the "=" primitive
11119 -- for the base type (not on the first subtype), so the test for
11120 -- Comp /= Original_Record_Component (Comp) is True for
11121 -- inherited components only.
11123 (Is_Tagged_Type (Typ)
11124 and then Comp /= Original_Record_Component (Comp))
11128 or else Chars (Comp) = Name_uTag
11130 -- The .NET/JVM version of type Root_Controlled contains two
11131 -- fields which should not be considered part of the object. To
11132 -- achieve proper equiality between two controlled objects on
11133 -- .NET/JVM, skip _Parent whenever it has type Root_Controlled.
11135 or else (Chars (Comp) = Name_uParent
11136 and then VM_Target /= No_VM
11137 and then Etype (Comp) = RTE (RE_Root_Controlled))
11139 -- Skip interface elements (secondary tags???)
11141 or else Is_Interface (Etype (Comp)));
11143 Next_Entity (Comp);
11147 end Element_To_Compare;
11149 -- Start of processing for Expand_Record_Equality
11152 -- Generates the following code: (assuming that Typ has one Discr and
11153 -- component C2 is also a record)
11156 -- and then Lhs.Discr1 = Rhs.Discr1
11157 -- and then Lhs.C1 = Rhs.C1
11158 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
11160 -- and then Lhs.Cmpn = Rhs.Cmpn
11162 Result := New_Occurrence_Of (Standard_True, Loc);
11163 C := Element_To_Compare (First_Entity (Typ));
11164 while Present (C) loop
11172 First_Time := False;
11176 New_Lhs := New_Copy_Tree (Lhs);
11177 New_Rhs := New_Copy_Tree (Rhs);
11181 Expand_Composite_Equality (Nod, Etype (C),
11183 Make_Selected_Component (Loc,
11185 Selector_Name => New_Occurrence_Of (C, Loc)),
11187 Make_Selected_Component (Loc,
11189 Selector_Name => New_Occurrence_Of (C, Loc)),
11192 -- If some (sub)component is an unchecked_union, the whole
11193 -- operation will raise program error.
11195 if Nkind (Check) = N_Raise_Program_Error then
11197 Set_Etype (Result, Standard_Boolean);
11201 Make_And_Then (Loc,
11202 Left_Opnd => Result,
11203 Right_Opnd => Check);
11207 C := Element_To_Compare (Next_Entity (C));
11211 end Expand_Record_Equality;
11213 ---------------------------
11214 -- Expand_Set_Membership --
11215 ---------------------------
11217 procedure Expand_Set_Membership (N : Node_Id) is
11218 Lop : constant Node_Id := Left_Opnd (N);
11222 function Make_Cond (Alt : Node_Id) return Node_Id;
11223 -- If the alternative is a subtype mark, create a simple membership
11224 -- test. Otherwise create an equality test for it.
11230 function Make_Cond (Alt : Node_Id) return Node_Id is
11232 L : constant Node_Id := New_Copy (Lop);
11233 R : constant Node_Id := Relocate_Node (Alt);
11236 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
11237 or else Nkind (Alt) = N_Range
11240 Make_In (Sloc (Alt),
11245 Make_Op_Eq (Sloc (Alt),
11253 -- Start of processing for Expand_Set_Membership
11256 Remove_Side_Effects (Lop);
11258 Alt := Last (Alternatives (N));
11259 Res := Make_Cond (Alt);
11262 while Present (Alt) loop
11264 Make_Or_Else (Sloc (Alt),
11265 Left_Opnd => Make_Cond (Alt),
11266 Right_Opnd => Res);
11271 Analyze_And_Resolve (N, Standard_Boolean);
11272 end Expand_Set_Membership;
11274 -----------------------------------
11275 -- Expand_Short_Circuit_Operator --
11276 -----------------------------------
11278 -- Deal with special expansion if actions are present for the right operand
11279 -- and deal with optimizing case of arguments being True or False. We also
11280 -- deal with the special case of non-standard boolean values.
11282 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
11283 Loc : constant Source_Ptr := Sloc (N);
11284 Typ : constant Entity_Id := Etype (N);
11285 Left : constant Node_Id := Left_Opnd (N);
11286 Right : constant Node_Id := Right_Opnd (N);
11287 LocR : constant Source_Ptr := Sloc (Right);
11290 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
11291 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
11292 -- If Left = Shortcut_Value then Right need not be evaluated
11295 -- Deal with non-standard booleans
11297 if Is_Boolean_Type (Typ) then
11298 Adjust_Condition (Left);
11299 Adjust_Condition (Right);
11300 Set_Etype (N, Standard_Boolean);
11303 -- Check for cases where left argument is known to be True or False
11305 if Compile_Time_Known_Value (Left) then
11307 -- Mark SCO for left condition as compile time known
11309 if Generate_SCO and then Comes_From_Source (Left) then
11310 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
11313 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
11314 -- Any actions associated with Right will be executed unconditionally
11315 -- and can thus be inserted into the tree unconditionally.
11317 if Expr_Value_E (Left) /= Shortcut_Ent then
11318 if Present (Actions (N)) then
11319 Insert_Actions (N, Actions (N));
11322 Rewrite (N, Right);
11324 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
11325 -- In this case we can forget the actions associated with Right,
11326 -- since they will never be executed.
11329 Kill_Dead_Code (Right);
11330 Kill_Dead_Code (Actions (N));
11331 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11334 Adjust_Result_Type (N, Typ);
11338 -- If Actions are present for the right operand, we have to do some
11339 -- special processing. We can't just let these actions filter back into
11340 -- code preceding the short circuit (which is what would have happened
11341 -- if we had not trapped them in the short-circuit form), since they
11342 -- must only be executed if the right operand of the short circuit is
11343 -- executed and not otherwise.
11345 if Present (Actions (N)) then
11346 Actlist := Actions (N);
11348 -- We now use an Expression_With_Actions node for the right operand
11349 -- of the short-circuit form. Note that this solves the traceability
11350 -- problems for coverage analysis.
11353 Make_Expression_With_Actions (LocR,
11354 Expression => Relocate_Node (Right),
11355 Actions => Actlist));
11356 Set_Actions (N, No_List);
11357 Analyze_And_Resolve (Right, Standard_Boolean);
11359 Adjust_Result_Type (N, Typ);
11363 -- No actions present, check for cases of right argument True/False
11365 if Compile_Time_Known_Value (Right) then
11367 -- Mark SCO for left condition as compile time known
11369 if Generate_SCO and then Comes_From_Source (Right) then
11370 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
11373 -- Change (Left and then True), (Left or else False) to Left.
11374 -- Note that we know there are no actions associated with the right
11375 -- operand, since we just checked for this case above.
11377 if Expr_Value_E (Right) /= Shortcut_Ent then
11380 -- Change (Left and then False), (Left or else True) to Right,
11381 -- making sure to preserve any side effects associated with the Left
11385 Remove_Side_Effects (Left);
11386 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11390 Adjust_Result_Type (N, Typ);
11391 end Expand_Short_Circuit_Operator;
11393 -------------------------------------
11394 -- Fixup_Universal_Fixed_Operation --
11395 -------------------------------------
11397 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
11398 Conv : constant Node_Id := Parent (N);
11401 -- We must have a type conversion immediately above us
11403 pragma Assert (Nkind (Conv) = N_Type_Conversion);
11405 -- Normally the type conversion gives our target type. The exception
11406 -- occurs in the case of the Round attribute, where the conversion
11407 -- will be to universal real, and our real type comes from the Round
11408 -- attribute (as well as an indication that we must round the result)
11410 if Nkind (Parent (Conv)) = N_Attribute_Reference
11411 and then Attribute_Name (Parent (Conv)) = Name_Round
11413 Set_Etype (N, Etype (Parent (Conv)));
11414 Set_Rounded_Result (N);
11416 -- Normal case where type comes from conversion above us
11419 Set_Etype (N, Etype (Conv));
11421 end Fixup_Universal_Fixed_Operation;
11423 ---------------------------------
11424 -- Has_Inferable_Discriminants --
11425 ---------------------------------
11427 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
11429 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
11430 -- Determines whether the left-most prefix of a selected component is a
11431 -- formal parameter in a subprogram. Assumes N is a selected component.
11433 --------------------------------
11434 -- Prefix_Is_Formal_Parameter --
11435 --------------------------------
11437 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
11438 Sel_Comp : Node_Id;
11441 -- Move to the left-most prefix by climbing up the tree
11444 while Present (Parent (Sel_Comp))
11445 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
11447 Sel_Comp := Parent (Sel_Comp);
11450 return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
11451 end Prefix_Is_Formal_Parameter;
11453 -- Start of processing for Has_Inferable_Discriminants
11456 -- For selected components, the subtype of the selector must be a
11457 -- constrained Unchecked_Union. If the component is subject to a
11458 -- per-object constraint, then the enclosing object must have inferable
11461 if Nkind (N) = N_Selected_Component then
11462 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
11464 -- A small hack. If we have a per-object constrained selected
11465 -- component of a formal parameter, return True since we do not
11466 -- know the actual parameter association yet.
11468 if Prefix_Is_Formal_Parameter (N) then
11471 -- Otherwise, check the enclosing object and the selector
11474 return Has_Inferable_Discriminants (Prefix (N))
11475 and then Has_Inferable_Discriminants (Selector_Name (N));
11478 -- The call to Has_Inferable_Discriminants will determine whether
11479 -- the selector has a constrained Unchecked_Union nominal type.
11482 return Has_Inferable_Discriminants (Selector_Name (N));
11485 -- A qualified expression has inferable discriminants if its subtype
11486 -- mark is a constrained Unchecked_Union subtype.
11488 elsif Nkind (N) = N_Qualified_Expression then
11489 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
11490 and then Is_Constrained (Etype (Subtype_Mark (N)));
11492 -- For all other names, it is sufficient to have a constrained
11493 -- Unchecked_Union nominal subtype.
11496 return Is_Unchecked_Union (Base_Type (Etype (N)))
11497 and then Is_Constrained (Etype (N));
11499 end Has_Inferable_Discriminants;
11501 -------------------------------
11502 -- Insert_Dereference_Action --
11503 -------------------------------
11505 procedure Insert_Dereference_Action (N : Node_Id) is
11507 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
11508 -- Return true if type of P is derived from Checked_Pool;
11510 -----------------------------
11511 -- Is_Checked_Storage_Pool --
11512 -----------------------------
11514 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
11523 while T /= Etype (T) loop
11524 if Is_RTE (T, RE_Checked_Pool) then
11532 end Is_Checked_Storage_Pool;
11536 Typ : constant Entity_Id := Etype (N);
11537 Desig : constant Entity_Id := Available_View (Designated_Type (Typ));
11538 Loc : constant Source_Ptr := Sloc (N);
11539 Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
11540 Pnod : constant Node_Id := Parent (N);
11548 -- Start of processing for Insert_Dereference_Action
11551 pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
11553 -- Do not re-expand a dereference which has already been processed by
11556 if Has_Dereference_Action (Pnod) then
11559 -- Do not perform this type of expansion for internally-generated
11562 elsif not Comes_From_Source (Original_Node (Pnod)) then
11565 -- A dereference action is only applicable to objects which have been
11566 -- allocated on a checked pool.
11568 elsif not Is_Checked_Storage_Pool (Pool) then
11572 -- Extract the address of the dereferenced object. Generate:
11574 -- Addr : System.Address := <N>'Pool_Address;
11576 Addr := Make_Temporary (Loc, 'P');
11579 Make_Object_Declaration (Loc,
11580 Defining_Identifier => Addr,
11581 Object_Definition =>
11582 New_Occurrence_Of (RTE (RE_Address), Loc),
11584 Make_Attribute_Reference (Loc,
11585 Prefix => Duplicate_Subexpr_Move_Checks (N),
11586 Attribute_Name => Name_Pool_Address)));
11588 -- Calculate the size of the dereferenced object. Generate:
11590 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
11593 Make_Explicit_Dereference (Loc,
11594 Prefix => Duplicate_Subexpr_Move_Checks (N));
11595 Set_Has_Dereference_Action (Deref);
11597 Size := Make_Temporary (Loc, 'S');
11600 Make_Object_Declaration (Loc,
11601 Defining_Identifier => Size,
11603 Object_Definition =>
11604 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
11607 Make_Op_Divide (Loc,
11609 Make_Attribute_Reference (Loc,
11611 Attribute_Name => Name_Size),
11613 Make_Integer_Literal (Loc, System_Storage_Unit))));
11615 -- Calculate the alignment of the dereferenced object. Generate:
11616 -- Alig : constant Storage_Count := <N>.all'Alignment;
11619 Make_Explicit_Dereference (Loc,
11620 Prefix => Duplicate_Subexpr_Move_Checks (N));
11621 Set_Has_Dereference_Action (Deref);
11623 Alig := Make_Temporary (Loc, 'A');
11626 Make_Object_Declaration (Loc,
11627 Defining_Identifier => Alig,
11628 Object_Definition =>
11629 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
11631 Make_Attribute_Reference (Loc,
11633 Attribute_Name => Name_Alignment)));
11635 -- A dereference of a controlled object requires special processing. The
11636 -- finalization machinery requests additional space from the underlying
11637 -- pool to allocate and hide two pointers. As a result, a checked pool
11638 -- may mark the wrong memory as valid. Since checked pools do not have
11639 -- knowledge of hidden pointers, we have to bring the two pointers back
11640 -- in view in order to restore the original state of the object.
11642 if Needs_Finalization (Desig) then
11644 -- Adjust the address and size of the dereferenced object. Generate:
11645 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
11648 Make_Procedure_Call_Statement (Loc,
11650 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
11651 Parameter_Associations => New_List (
11652 New_Occurrence_Of (Addr, Loc),
11653 New_Occurrence_Of (Size, Loc),
11654 New_Occurrence_Of (Alig, Loc)));
11656 -- Class-wide types complicate things because we cannot determine
11657 -- statically whether the actual object is truly controlled. We must
11658 -- generate a runtime check to detect this property. Generate:
11660 -- if Needs_Finalization (<N>.all'Tag) then
11664 if Is_Class_Wide_Type (Desig) then
11666 Make_Explicit_Dereference (Loc,
11667 Prefix => Duplicate_Subexpr_Move_Checks (N));
11668 Set_Has_Dereference_Action (Deref);
11671 Make_Implicit_If_Statement (N,
11673 Make_Function_Call (Loc,
11675 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
11676 Parameter_Associations => New_List (
11677 Make_Attribute_Reference (Loc,
11679 Attribute_Name => Name_Tag))),
11680 Then_Statements => New_List (Stmt));
11683 Insert_Action (N, Stmt);
11687 -- Dereference (Pool, Addr, Size, Alig);
11690 Make_Procedure_Call_Statement (Loc,
11693 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
11694 Parameter_Associations => New_List (
11695 New_Occurrence_Of (Pool, Loc),
11696 New_Occurrence_Of (Addr, Loc),
11697 New_Occurrence_Of (Size, Loc),
11698 New_Occurrence_Of (Alig, Loc))));
11700 -- Mark the explicit dereference as processed to avoid potential
11701 -- infinite expansion.
11703 Set_Has_Dereference_Action (Pnod);
11706 when RE_Not_Available =>
11708 end Insert_Dereference_Action;
11710 --------------------------------
11711 -- Integer_Promotion_Possible --
11712 --------------------------------
11714 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
11715 Operand : constant Node_Id := Expression (N);
11716 Operand_Type : constant Entity_Id := Etype (Operand);
11717 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
11720 pragma Assert (Nkind (N) = N_Type_Conversion);
11724 -- We only do the transformation for source constructs. We assume
11725 -- that the expander knows what it is doing when it generates code.
11727 Comes_From_Source (N)
11729 -- If the operand type is Short_Integer or Short_Short_Integer,
11730 -- then we will promote to Integer, which is available on all
11731 -- targets, and is sufficient to ensure no intermediate overflow.
11732 -- Furthermore it is likely to be as efficient or more efficient
11733 -- than using the smaller type for the computation so we do this
11734 -- unconditionally.
11737 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
11739 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
11741 -- Test for interesting operation, which includes addition,
11742 -- division, exponentiation, multiplication, subtraction, absolute
11743 -- value and unary negation. Unary "+" is omitted since it is a
11744 -- no-op and thus can't overflow.
11746 and then Nkind_In (Operand, N_Op_Abs,
11753 end Integer_Promotion_Possible;
11755 ------------------------------
11756 -- Make_Array_Comparison_Op --
11757 ------------------------------
11759 -- This is a hand-coded expansion of the following generic function:
11762 -- type elem is (<>);
11763 -- type index is (<>);
11764 -- type a is array (index range <>) of elem;
11766 -- function Gnnn (X : a; Y: a) return boolean is
11767 -- J : index := Y'first;
11770 -- if X'length = 0 then
11773 -- elsif Y'length = 0 then
11777 -- for I in X'range loop
11778 -- if X (I) = Y (J) then
11779 -- if J = Y'last then
11782 -- J := index'succ (J);
11786 -- return X (I) > Y (J);
11790 -- return X'length > Y'length;
11794 -- Note that since we are essentially doing this expansion by hand, we
11795 -- do not need to generate an actual or formal generic part, just the
11796 -- instantiated function itself.
11798 function Make_Array_Comparison_Op
11800 Nod : Node_Id) return Node_Id
11802 Loc : constant Source_Ptr := Sloc (Nod);
11804 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
11805 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
11806 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
11807 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
11809 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
11811 Loop_Statement : Node_Id;
11812 Loop_Body : Node_Id;
11814 Inner_If : Node_Id;
11815 Final_Expr : Node_Id;
11816 Func_Body : Node_Id;
11817 Func_Name : Entity_Id;
11823 -- if J = Y'last then
11826 -- J := index'succ (J);
11830 Make_Implicit_If_Statement (Nod,
11833 Left_Opnd => New_Occurrence_Of (J, Loc),
11835 Make_Attribute_Reference (Loc,
11836 Prefix => New_Occurrence_Of (Y, Loc),
11837 Attribute_Name => Name_Last)),
11839 Then_Statements => New_List (
11840 Make_Exit_Statement (Loc)),
11844 Make_Assignment_Statement (Loc,
11845 Name => New_Occurrence_Of (J, Loc),
11847 Make_Attribute_Reference (Loc,
11848 Prefix => New_Occurrence_Of (Index, Loc),
11849 Attribute_Name => Name_Succ,
11850 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
11852 -- if X (I) = Y (J) then
11855 -- return X (I) > Y (J);
11859 Make_Implicit_If_Statement (Nod,
11863 Make_Indexed_Component (Loc,
11864 Prefix => New_Occurrence_Of (X, Loc),
11865 Expressions => New_List (New_Occurrence_Of (I, Loc))),
11868 Make_Indexed_Component (Loc,
11869 Prefix => New_Occurrence_Of (Y, Loc),
11870 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
11872 Then_Statements => New_List (Inner_If),
11874 Else_Statements => New_List (
11875 Make_Simple_Return_Statement (Loc,
11879 Make_Indexed_Component (Loc,
11880 Prefix => New_Occurrence_Of (X, Loc),
11881 Expressions => New_List (New_Occurrence_Of (I, Loc))),
11884 Make_Indexed_Component (Loc,
11885 Prefix => New_Occurrence_Of (Y, Loc),
11886 Expressions => New_List (
11887 New_Occurrence_Of (J, Loc)))))));
11889 -- for I in X'range loop
11894 Make_Implicit_Loop_Statement (Nod,
11895 Identifier => Empty,
11897 Iteration_Scheme =>
11898 Make_Iteration_Scheme (Loc,
11899 Loop_Parameter_Specification =>
11900 Make_Loop_Parameter_Specification (Loc,
11901 Defining_Identifier => I,
11902 Discrete_Subtype_Definition =>
11903 Make_Attribute_Reference (Loc,
11904 Prefix => New_Occurrence_Of (X, Loc),
11905 Attribute_Name => Name_Range))),
11907 Statements => New_List (Loop_Body));
11909 -- if X'length = 0 then
11911 -- elsif Y'length = 0 then
11914 -- for ... loop ... end loop;
11915 -- return X'length > Y'length;
11919 Make_Attribute_Reference (Loc,
11920 Prefix => New_Occurrence_Of (X, Loc),
11921 Attribute_Name => Name_Length);
11924 Make_Attribute_Reference (Loc,
11925 Prefix => New_Occurrence_Of (Y, Loc),
11926 Attribute_Name => Name_Length);
11930 Left_Opnd => Length1,
11931 Right_Opnd => Length2);
11934 Make_Implicit_If_Statement (Nod,
11938 Make_Attribute_Reference (Loc,
11939 Prefix => New_Occurrence_Of (X, Loc),
11940 Attribute_Name => Name_Length),
11942 Make_Integer_Literal (Loc, 0)),
11946 Make_Simple_Return_Statement (Loc,
11947 Expression => New_Occurrence_Of (Standard_False, Loc))),
11949 Elsif_Parts => New_List (
11950 Make_Elsif_Part (Loc,
11954 Make_Attribute_Reference (Loc,
11955 Prefix => New_Occurrence_Of (Y, Loc),
11956 Attribute_Name => Name_Length),
11958 Make_Integer_Literal (Loc, 0)),
11962 Make_Simple_Return_Statement (Loc,
11963 Expression => New_Occurrence_Of (Standard_True, Loc))))),
11965 Else_Statements => New_List (
11967 Make_Simple_Return_Statement (Loc,
11968 Expression => Final_Expr)));
11972 Formals := New_List (
11973 Make_Parameter_Specification (Loc,
11974 Defining_Identifier => X,
11975 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
11977 Make_Parameter_Specification (Loc,
11978 Defining_Identifier => Y,
11979 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
11981 -- function Gnnn (...) return boolean is
11982 -- J : index := Y'first;
11987 Func_Name := Make_Temporary (Loc, 'G');
11990 Make_Subprogram_Body (Loc,
11992 Make_Function_Specification (Loc,
11993 Defining_Unit_Name => Func_Name,
11994 Parameter_Specifications => Formals,
11995 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
11997 Declarations => New_List (
11998 Make_Object_Declaration (Loc,
11999 Defining_Identifier => J,
12000 Object_Definition => New_Occurrence_Of (Index, Loc),
12002 Make_Attribute_Reference (Loc,
12003 Prefix => New_Occurrence_Of (Y, Loc),
12004 Attribute_Name => Name_First))),
12006 Handled_Statement_Sequence =>
12007 Make_Handled_Sequence_Of_Statements (Loc,
12008 Statements => New_List (If_Stat)));
12011 end Make_Array_Comparison_Op;
12013 ---------------------------
12014 -- Make_Boolean_Array_Op --
12015 ---------------------------
12017 -- For logical operations on boolean arrays, expand in line the following,
12018 -- replacing 'and' with 'or' or 'xor' where needed:
12020 -- function Annn (A : typ; B: typ) return typ is
12023 -- for J in A'range loop
12024 -- C (J) := A (J) op B (J);
12029 -- Here typ is the boolean array type
12031 function Make_Boolean_Array_Op
12033 N : Node_Id) return Node_Id
12035 Loc : constant Source_Ptr := Sloc (N);
12037 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
12038 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
12039 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
12040 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
12048 Func_Name : Entity_Id;
12049 Func_Body : Node_Id;
12050 Loop_Statement : Node_Id;
12054 Make_Indexed_Component (Loc,
12055 Prefix => New_Occurrence_Of (A, Loc),
12056 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12059 Make_Indexed_Component (Loc,
12060 Prefix => New_Occurrence_Of (B, Loc),
12061 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12064 Make_Indexed_Component (Loc,
12065 Prefix => New_Occurrence_Of (C, Loc),
12066 Expressions => New_List (New_Occurrence_Of (J, Loc)));
12068 if Nkind (N) = N_Op_And then
12072 Right_Opnd => B_J);
12074 elsif Nkind (N) = N_Op_Or then
12078 Right_Opnd => B_J);
12084 Right_Opnd => B_J);
12088 Make_Implicit_Loop_Statement (N,
12089 Identifier => Empty,
12091 Iteration_Scheme =>
12092 Make_Iteration_Scheme (Loc,
12093 Loop_Parameter_Specification =>
12094 Make_Loop_Parameter_Specification (Loc,
12095 Defining_Identifier => J,
12096 Discrete_Subtype_Definition =>
12097 Make_Attribute_Reference (Loc,
12098 Prefix => New_Occurrence_Of (A, Loc),
12099 Attribute_Name => Name_Range))),
12101 Statements => New_List (
12102 Make_Assignment_Statement (Loc,
12104 Expression => Op)));
12106 Formals := New_List (
12107 Make_Parameter_Specification (Loc,
12108 Defining_Identifier => A,
12109 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
12111 Make_Parameter_Specification (Loc,
12112 Defining_Identifier => B,
12113 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
12115 Func_Name := Make_Temporary (Loc, 'A');
12116 Set_Is_Inlined (Func_Name);
12119 Make_Subprogram_Body (Loc,
12121 Make_Function_Specification (Loc,
12122 Defining_Unit_Name => Func_Name,
12123 Parameter_Specifications => Formals,
12124 Result_Definition => New_Occurrence_Of (Typ, Loc)),
12126 Declarations => New_List (
12127 Make_Object_Declaration (Loc,
12128 Defining_Identifier => C,
12129 Object_Definition => New_Occurrence_Of (Typ, Loc))),
12131 Handled_Statement_Sequence =>
12132 Make_Handled_Sequence_Of_Statements (Loc,
12133 Statements => New_List (
12135 Make_Simple_Return_Statement (Loc,
12136 Expression => New_Occurrence_Of (C, Loc)))));
12139 end Make_Boolean_Array_Op;
12141 -----------------------------------------
12142 -- Minimized_Eliminated_Overflow_Check --
12143 -----------------------------------------
12145 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
12148 Is_Signed_Integer_Type (Etype (N))
12149 and then Overflow_Check_Mode in Minimized_Or_Eliminated;
12150 end Minimized_Eliminated_Overflow_Check;
12152 --------------------------------
12153 -- Optimize_Length_Comparison --
12154 --------------------------------
12156 procedure Optimize_Length_Comparison (N : Node_Id) is
12157 Loc : constant Source_Ptr := Sloc (N);
12158 Typ : constant Entity_Id := Etype (N);
12163 -- First and Last attribute reference nodes, which end up as left and
12164 -- right operands of the optimized result.
12167 -- True for comparison operand of zero
12170 -- Comparison operand, set only if Is_Zero is false
12173 -- Entity whose length is being compared
12176 -- Integer_Literal node for length attribute expression, or Empty
12177 -- if there is no such expression present.
12180 -- Type of array index to which 'Length is applied
12182 Op : Node_Kind := Nkind (N);
12183 -- Kind of comparison operator, gets flipped if operands backwards
12185 function Is_Optimizable (N : Node_Id) return Boolean;
12186 -- Tests N to see if it is an optimizable comparison value (defined as
12187 -- constant zero or one, or something else where the value is known to
12188 -- be positive and in the range of 32-bits, and where the corresponding
12189 -- Length value is also known to be 32-bits. If result is true, sets
12190 -- Is_Zero, Ityp, and Comp accordingly.
12192 function Is_Entity_Length (N : Node_Id) return Boolean;
12193 -- Tests if N is a length attribute applied to a simple entity. If so,
12194 -- returns True, and sets Ent to the entity, and Index to the integer
12195 -- literal provided as an attribute expression, or to Empty if none.
12196 -- Also returns True if the expression is a generated type conversion
12197 -- whose expression is of the desired form. This latter case arises
12198 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
12199 -- to check for being in range, which is not needed in this context.
12200 -- Returns False if neither condition holds.
12202 function Prepare_64 (N : Node_Id) return Node_Id;
12203 -- Given a discrete expression, returns a Long_Long_Integer typed
12204 -- expression representing the underlying value of the expression.
12205 -- This is done with an unchecked conversion to the result type. We
12206 -- use unchecked conversion to handle the enumeration type case.
12208 ----------------------
12209 -- Is_Entity_Length --
12210 ----------------------
12212 function Is_Entity_Length (N : Node_Id) return Boolean is
12214 if Nkind (N) = N_Attribute_Reference
12215 and then Attribute_Name (N) = Name_Length
12216 and then Is_Entity_Name (Prefix (N))
12218 Ent := Entity (Prefix (N));
12220 if Present (Expressions (N)) then
12221 Index := First (Expressions (N));
12228 elsif Nkind (N) = N_Type_Conversion
12229 and then not Comes_From_Source (N)
12231 return Is_Entity_Length (Expression (N));
12236 end Is_Entity_Length;
12238 --------------------
12239 -- Is_Optimizable --
12240 --------------------
12242 function Is_Optimizable (N : Node_Id) return Boolean is
12250 if Compile_Time_Known_Value (N) then
12251 Val := Expr_Value (N);
12253 if Val = Uint_0 then
12258 elsif Val = Uint_1 then
12265 -- Here we have to make sure of being within 32-bits
12267 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
12270 or else Lo < Uint_1
12271 or else Hi > UI_From_Int (Int'Last)
12276 -- Comparison value was within range, so now we must check the index
12277 -- value to make sure it is also within 32-bits.
12279 Indx := First_Index (Etype (Ent));
12281 if Present (Index) then
12282 for J in 2 .. UI_To_Int (Intval (Index)) loop
12287 Ityp := Etype (Indx);
12289 if Esize (Ityp) > 32 then
12296 end Is_Optimizable;
12302 function Prepare_64 (N : Node_Id) return Node_Id is
12304 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
12307 -- Start of processing for Optimize_Length_Comparison
12310 -- Nothing to do if not a comparison
12312 if Op not in N_Op_Compare then
12316 -- Nothing to do if special -gnatd.P debug flag set
12318 if Debug_Flag_Dot_PP then
12322 -- Ent'Length op 0/1
12324 if Is_Entity_Length (Left_Opnd (N))
12325 and then Is_Optimizable (Right_Opnd (N))
12329 -- 0/1 op Ent'Length
12331 elsif Is_Entity_Length (Right_Opnd (N))
12332 and then Is_Optimizable (Left_Opnd (N))
12334 -- Flip comparison to opposite sense
12337 when N_Op_Lt => Op := N_Op_Gt;
12338 when N_Op_Le => Op := N_Op_Ge;
12339 when N_Op_Gt => Op := N_Op_Lt;
12340 when N_Op_Ge => Op := N_Op_Le;
12341 when others => null;
12344 -- Else optimization not possible
12350 -- Fall through if we will do the optimization
12352 -- Cases to handle:
12354 -- X'Length = 0 => X'First > X'Last
12355 -- X'Length = 1 => X'First = X'Last
12356 -- X'Length = n => X'First + (n - 1) = X'Last
12358 -- X'Length /= 0 => X'First <= X'Last
12359 -- X'Length /= 1 => X'First /= X'Last
12360 -- X'Length /= n => X'First + (n - 1) /= X'Last
12362 -- X'Length >= 0 => always true, warn
12363 -- X'Length >= 1 => X'First <= X'Last
12364 -- X'Length >= n => X'First + (n - 1) <= X'Last
12366 -- X'Length > 0 => X'First <= X'Last
12367 -- X'Length > 1 => X'First < X'Last
12368 -- X'Length > n => X'First + (n - 1) < X'Last
12370 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
12371 -- X'Length <= 1 => X'First >= X'Last
12372 -- X'Length <= n => X'First + (n - 1) >= X'Last
12374 -- X'Length < 0 => always false (warn)
12375 -- X'Length < 1 => X'First > X'Last
12376 -- X'Length < n => X'First + (n - 1) > X'Last
12378 -- Note: for the cases of n (not constant 0,1), we require that the
12379 -- corresponding index type be integer or shorter (i.e. not 64-bit),
12380 -- and the same for the comparison value. Then we do the comparison
12381 -- using 64-bit arithmetic (actually long long integer), so that we
12382 -- cannot have overflow intefering with the result.
12384 -- First deal with warning cases
12393 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
12394 Analyze_And_Resolve (N, Typ);
12395 Warn_On_Known_Condition (N);
12402 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
12403 Analyze_And_Resolve (N, Typ);
12404 Warn_On_Known_Condition (N);
12408 if Constant_Condition_Warnings
12409 and then Comes_From_Source (Original_Node (N))
12411 Error_Msg_N ("could replace by ""'=""?c?", N);
12421 -- Build the First reference we will use
12424 Make_Attribute_Reference (Loc,
12425 Prefix => New_Occurrence_Of (Ent, Loc),
12426 Attribute_Name => Name_First);
12428 if Present (Index) then
12429 Set_Expressions (Left, New_List (New_Copy (Index)));
12432 -- If general value case, then do the addition of (n - 1), and
12433 -- also add the needed conversions to type Long_Long_Integer.
12435 if Present (Comp) then
12438 Left_Opnd => Prepare_64 (Left),
12440 Make_Op_Subtract (Loc,
12441 Left_Opnd => Prepare_64 (Comp),
12442 Right_Opnd => Make_Integer_Literal (Loc, 1)));
12445 -- Build the Last reference we will use
12448 Make_Attribute_Reference (Loc,
12449 Prefix => New_Occurrence_Of (Ent, Loc),
12450 Attribute_Name => Name_Last);
12452 if Present (Index) then
12453 Set_Expressions (Right, New_List (New_Copy (Index)));
12456 -- If general operand, convert Last reference to Long_Long_Integer
12458 if Present (Comp) then
12459 Right := Prepare_64 (Right);
12462 -- Check for cases to optimize
12464 -- X'Length = 0 => X'First > X'Last
12465 -- X'Length < 1 => X'First > X'Last
12466 -- X'Length < n => X'First + (n - 1) > X'Last
12468 if (Is_Zero and then Op = N_Op_Eq)
12469 or else (not Is_Zero and then Op = N_Op_Lt)
12474 Right_Opnd => Right);
12476 -- X'Length = 1 => X'First = X'Last
12477 -- X'Length = n => X'First + (n - 1) = X'Last
12479 elsif not Is_Zero and then Op = N_Op_Eq then
12483 Right_Opnd => Right);
12485 -- X'Length /= 0 => X'First <= X'Last
12486 -- X'Length > 0 => X'First <= X'Last
12488 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
12492 Right_Opnd => Right);
12494 -- X'Length /= 1 => X'First /= X'Last
12495 -- X'Length /= n => X'First + (n - 1) /= X'Last
12497 elsif not Is_Zero and then Op = N_Op_Ne then
12501 Right_Opnd => Right);
12503 -- X'Length >= 1 => X'First <= X'Last
12504 -- X'Length >= n => X'First + (n - 1) <= X'Last
12506 elsif not Is_Zero and then Op = N_Op_Ge then
12510 Right_Opnd => Right);
12512 -- X'Length > 1 => X'First < X'Last
12513 -- X'Length > n => X'First + (n = 1) < X'Last
12515 elsif not Is_Zero and then Op = N_Op_Gt then
12519 Right_Opnd => Right);
12521 -- X'Length <= 1 => X'First >= X'Last
12522 -- X'Length <= n => X'First + (n - 1) >= X'Last
12524 elsif not Is_Zero and then Op = N_Op_Le then
12528 Right_Opnd => Right);
12530 -- Should not happen at this stage
12533 raise Program_Error;
12536 -- Rewrite and finish up
12538 Rewrite (N, Result);
12539 Analyze_And_Resolve (N, Typ);
12541 end Optimize_Length_Comparison;
12543 ------------------------------
12544 -- Process_Transient_Object --
12545 ------------------------------
12547 procedure Process_Transient_Object
12549 Rel_Node : Node_Id)
12551 Hook_Context : Node_Id;
12552 -- Node on which to insert the hook pointer (as an action)
12554 Finalization_Context : Node_Id;
12555 -- Node after which to insert finalization actions
12557 Finalize_Always : Boolean;
12558 -- If False, call to finalizer includes a test of whether the
12559 -- hook pointer is null.
12561 procedure Find_Enclosing_Contexts (N : Node_Id);
12562 -- Find the logical context where N appears, and initializae
12563 -- Hook_Context and Finalization_Context accordingly. Also
12564 -- sets Finalize_Always.
12566 -----------------------------
12567 -- Find_Enclosing_Contexts --
12568 -----------------------------
12570 procedure Find_Enclosing_Contexts (N : Node_Id) is
12574 Wrapped_Node : Node_Id;
12575 -- Note: if we are in a transient scope, we want to reuse it as
12576 -- the context for actions insertion, if possible. But if N is itself
12577 -- part of the stored actions for the current transient scope,
12578 -- then we need to insert at the appropriate (inner) location in
12579 -- the not as an action on Node_To_Be_Wrapped.
12581 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
12584 -- When the node is inside a case/if expression, the lifetime of any
12585 -- temporary controlled object is extended. Find a suitable insertion
12586 -- node by locating the topmost case or if expressions.
12588 if In_Cond_Expr then
12591 while Present (Par) loop
12592 if Nkind_In (Original_Node (Par), N_Case_Expression,
12597 -- Prevent the search from going too far
12599 elsif Is_Body_Or_Package_Declaration (Par) then
12603 Par := Parent (Par);
12606 -- The topmost case or if expression is now recovered, but it may
12607 -- still not be the correct place to add generated code. Climb to
12608 -- find a parent that is part of a declarative or statement list,
12609 -- and is not a list of actuals in a call.
12612 while Present (Par) loop
12613 if Is_List_Member (Par)
12614 and then not Nkind_In (Par, N_Component_Association,
12615 N_Discriminant_Association,
12616 N_Parameter_Association,
12617 N_Pragma_Argument_Association)
12618 and then not Nkind_In
12619 (Parent (Par), N_Function_Call,
12620 N_Procedure_Call_Statement,
12621 N_Entry_Call_Statement)
12624 Hook_Context := Par;
12625 goto Hook_Context_Found;
12627 -- Prevent the search from going too far
12629 elsif Is_Body_Or_Package_Declaration (Par) then
12633 Par := Parent (Par);
12636 Hook_Context := Par;
12637 goto Hook_Context_Found;
12641 while Present (Par) loop
12643 -- Keep climbing past various operators
12645 if Nkind (Parent (Par)) in N_Op
12646 or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
12648 Par := Parent (Par);
12656 -- The node may be located in a pragma in which case return the
12659 -- pragma Precondition (... and then Ctrl_Func_Call ...);
12661 -- Similar case occurs when the node is related to an object
12662 -- declaration or assignment:
12664 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
12666 -- Another case to consider is when the node is part of a return
12669 -- return ... and then Ctrl_Func_Call ...;
12671 -- Another case is when the node acts as a formal in a procedure
12674 -- Proc (... and then Ctrl_Func_Call ...);
12676 if Scope_Is_Transient then
12677 Wrapped_Node := Node_To_Be_Wrapped;
12679 Wrapped_Node := Empty;
12682 while Present (Par) loop
12683 if Par = Wrapped_Node
12684 or else Nkind_In (Par, N_Assignment_Statement,
12685 N_Object_Declaration,
12687 N_Procedure_Call_Statement,
12688 N_Simple_Return_Statement)
12690 Hook_Context := Par;
12691 goto Hook_Context_Found;
12693 -- Prevent the search from going too far
12695 elsif Is_Body_Or_Package_Declaration (Par) then
12699 Par := Parent (Par);
12702 -- Return the topmost short circuit operator
12704 Hook_Context := Top;
12707 <<Hook_Context_Found>>
12709 -- Special case for Boolean EWAs: capture expression in a temporary,
12710 -- whose declaration will serve as the context around which to insert
12711 -- finalization code. The finalization thus remains local to the
12712 -- specific condition being evaluated.
12714 if Is_Boolean_Type (Etype (N)) then
12716 -- In this case, the finalization context is chosen so that
12717 -- we know at finalization point that the hook pointer is
12718 -- never null, so no need for a test, we can call the finalizer
12719 -- unconditionally, except in the case where the object is
12720 -- created in a specific branch of a conditional expression.
12725 Nkind_In (Original_Node (N), N_Case_Expression,
12729 Loc : constant Source_Ptr := Sloc (N);
12730 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
12733 Append_To (Actions (N),
12734 Make_Object_Declaration (Loc,
12735 Defining_Identifier => Temp,
12736 Constant_Present => True,
12737 Object_Definition =>
12738 New_Occurrence_Of (Etype (N), Loc),
12739 Expression => Expression (N)));
12740 Finalization_Context := Last (Actions (N));
12742 Analyze (Last (Actions (N)));
12744 Set_Expression (N, New_Occurrence_Of (Temp, Loc));
12745 Analyze (Expression (N));
12749 Finalize_Always := False;
12750 Finalization_Context := Hook_Context;
12752 end Find_Enclosing_Contexts;
12756 Loc : constant Source_Ptr := Sloc (Decl);
12757 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
12758 Obj_Typ : constant Node_Id := Etype (Obj_Id);
12759 Desig_Typ : Entity_Id;
12761 Fin_Stmts : List_Id;
12762 Ptr_Id : Entity_Id;
12763 Temp_Id : Entity_Id;
12764 Temp_Ins : Node_Id;
12766 -- Start of processing for Process_Transient_Object
12769 Find_Enclosing_Contexts (Rel_Node);
12771 -- Step 1: Create the access type which provides a reference to the
12772 -- transient controlled object.
12774 if Is_Access_Type (Obj_Typ) then
12775 Desig_Typ := Directly_Designated_Type (Obj_Typ);
12777 Desig_Typ := Obj_Typ;
12780 Desig_Typ := Base_Type (Desig_Typ);
12783 -- Ann : access [all] <Desig_Typ>;
12785 Ptr_Id := Make_Temporary (Loc, 'A');
12787 Insert_Action (Hook_Context,
12788 Make_Full_Type_Declaration (Loc,
12789 Defining_Identifier => Ptr_Id,
12791 Make_Access_To_Object_Definition (Loc,
12792 All_Present => Ekind (Obj_Typ) = E_General_Access_Type,
12793 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))));
12795 -- Step 2: Create a temporary which acts as a hook to the transient
12796 -- controlled object. Generate:
12798 -- Temp : Ptr_Id := null;
12800 Temp_Id := Make_Temporary (Loc, 'T');
12802 Insert_Action (Hook_Context,
12803 Make_Object_Declaration (Loc,
12804 Defining_Identifier => Temp_Id,
12805 Object_Definition => New_Occurrence_Of (Ptr_Id, Loc)));
12807 -- Mark the temporary as created for the purposes of exporting the
12808 -- transient controlled object out of the expression_with_action or if
12809 -- expression. This signals the machinery in Build_Finalizer to treat
12810 -- this case specially.
12812 Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl);
12814 -- Step 3: Hook the transient object to the temporary
12816 -- This must be inserted right after the object declaration, so that
12817 -- the assignment is executed if, and only if, the object is actually
12818 -- created (whereas the declaration of the hook pointer, and the
12819 -- finalization call, may be inserted at an outer level, and may
12820 -- remain unused for some executions, if the actual creation of
12821 -- the object is conditional).
12823 -- The use of unchecked conversion / unrestricted access is needed to
12824 -- avoid an accessibility violation. Note that the finalization code is
12825 -- structured in such a way that the "hook" is processed only when it
12826 -- points to an existing object.
12828 if Is_Access_Type (Obj_Typ) then
12830 Unchecked_Convert_To (Ptr_Id, New_Occurrence_Of (Obj_Id, Loc));
12833 Make_Attribute_Reference (Loc,
12834 Prefix => New_Occurrence_Of (Obj_Id, Loc),
12835 Attribute_Name => Name_Unrestricted_Access);
12839 -- Temp := Ptr_Id (Obj_Id);
12841 -- Temp := Obj_Id'Unrestricted_Access;
12843 -- When the transient object is initialized by an aggregate, the hook
12844 -- must capture the object after the last component assignment takes
12845 -- place. Only then is the object fully initialized.
12847 if Ekind (Obj_Id) = E_Variable
12848 and then Present (Last_Aggregate_Assignment (Obj_Id))
12850 Temp_Ins := Last_Aggregate_Assignment (Obj_Id);
12852 -- Otherwise the hook seizes the related object immediately
12858 Insert_After_And_Analyze (Temp_Ins,
12859 Make_Assignment_Statement (Loc,
12860 Name => New_Occurrence_Of (Temp_Id, Loc),
12861 Expression => Expr));
12863 -- Step 4: Finalize the transient controlled object after the context
12864 -- has been evaluated/elaborated. Generate:
12866 -- if Temp /= null then
12867 -- [Deep_]Finalize (Temp.all);
12871 -- When the node is part of a return statement, there is no need to
12872 -- insert a finalization call, as the general finalization mechanism
12873 -- (see Build_Finalizer) would take care of the transient controlled
12874 -- object on subprogram exit. Note that it would also be impossible to
12875 -- insert the finalization code after the return statement as this will
12876 -- render it unreachable.
12878 if Nkind (Finalization_Context) /= N_Simple_Return_Statement then
12879 Fin_Stmts := New_List (
12882 Make_Explicit_Dereference (Loc,
12883 Prefix => New_Occurrence_Of (Temp_Id, Loc)),
12886 Make_Assignment_Statement (Loc,
12887 Name => New_Occurrence_Of (Temp_Id, Loc),
12888 Expression => Make_Null (Loc)));
12890 if not Finalize_Always then
12891 Fin_Stmts := New_List (
12892 Make_Implicit_If_Statement (Decl,
12895 Left_Opnd => New_Occurrence_Of (Temp_Id, Loc),
12896 Right_Opnd => Make_Null (Loc)),
12897 Then_Statements => Fin_Stmts));
12900 Insert_Actions_After (Finalization_Context, Fin_Stmts);
12902 end Process_Transient_Object;
12904 ------------------------
12905 -- Rewrite_Comparison --
12906 ------------------------
12908 procedure Rewrite_Comparison (N : Node_Id) is
12909 Warning_Generated : Boolean := False;
12910 -- Set to True if first pass with Assume_Valid generates a warning in
12911 -- which case we skip the second pass to avoid warning overloaded.
12914 -- Set to Standard_True or Standard_False
12917 if Nkind (N) = N_Type_Conversion then
12918 Rewrite_Comparison (Expression (N));
12921 elsif Nkind (N) not in N_Op_Compare then
12925 -- Now start looking at the comparison in detail. We potentially go
12926 -- through this loop twice. The first time, Assume_Valid is set False
12927 -- in the call to Compile_Time_Compare. If this call results in a
12928 -- clear result of always True or Always False, that's decisive and
12929 -- we are done. Otherwise we repeat the processing with Assume_Valid
12930 -- set to True to generate additional warnings. We can skip that step
12931 -- if Constant_Condition_Warnings is False.
12933 for AV in False .. True loop
12935 Typ : constant Entity_Id := Etype (N);
12936 Op1 : constant Node_Id := Left_Opnd (N);
12937 Op2 : constant Node_Id := Right_Opnd (N);
12939 Res : constant Compare_Result :=
12940 Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
12941 -- Res indicates if compare outcome can be compile time determined
12943 True_Result : Boolean;
12944 False_Result : Boolean;
12947 case N_Op_Compare (Nkind (N)) is
12949 True_Result := Res = EQ;
12950 False_Result := Res = LT or else Res = GT or else Res = NE;
12953 True_Result := Res in Compare_GE;
12954 False_Result := Res = LT;
12957 and then Constant_Condition_Warnings
12958 and then Comes_From_Source (Original_Node (N))
12959 and then Nkind (Original_Node (N)) = N_Op_Ge
12960 and then not In_Instance
12961 and then Is_Integer_Type (Etype (Left_Opnd (N)))
12962 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
12965 ("can never be greater than, could replace by ""'=""?c?",
12967 Warning_Generated := True;
12971 True_Result := Res = GT;
12972 False_Result := Res in Compare_LE;
12975 True_Result := Res = LT;
12976 False_Result := Res in Compare_GE;
12979 True_Result := Res in Compare_LE;
12980 False_Result := Res = GT;
12983 and then Constant_Condition_Warnings
12984 and then Comes_From_Source (Original_Node (N))
12985 and then Nkind (Original_Node (N)) = N_Op_Le
12986 and then not In_Instance
12987 and then Is_Integer_Type (Etype (Left_Opnd (N)))
12988 and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
12991 ("can never be less than, could replace by ""'=""?c?", N);
12992 Warning_Generated := True;
12996 True_Result := Res = NE or else Res = GT or else Res = LT;
12997 False_Result := Res = EQ;
13000 -- If this is the first iteration, then we actually convert the
13001 -- comparison into True or False, if the result is certain.
13004 if True_Result or False_Result then
13005 Result := Boolean_Literals (True_Result);
13008 New_Occurrence_Of (Result, Sloc (N))));
13009 Analyze_And_Resolve (N, Typ);
13010 Warn_On_Known_Condition (N);
13014 -- If this is the second iteration (AV = True), and the original
13015 -- node comes from source and we are not in an instance, then give
13016 -- a warning if we know result would be True or False. Note: we
13017 -- know Constant_Condition_Warnings is set if we get here.
13019 elsif Comes_From_Source (Original_Node (N))
13020 and then not In_Instance
13022 if True_Result then
13024 ("condition can only be False if invalid values present??",
13026 elsif False_Result then
13028 ("condition can only be True if invalid values present??",
13034 -- Skip second iteration if not warning on constant conditions or
13035 -- if the first iteration already generated a warning of some kind or
13036 -- if we are in any case assuming all values are valid (so that the
13037 -- first iteration took care of the valid case).
13039 exit when not Constant_Condition_Warnings;
13040 exit when Warning_Generated;
13041 exit when Assume_No_Invalid_Values;
13043 end Rewrite_Comparison;
13045 ----------------------------
13046 -- Safe_In_Place_Array_Op --
13047 ----------------------------
13049 function Safe_In_Place_Array_Op
13052 Op2 : Node_Id) return Boolean
13054 Target : Entity_Id;
13056 function Is_Safe_Operand (Op : Node_Id) return Boolean;
13057 -- Operand is safe if it cannot overlap part of the target of the
13058 -- operation. If the operand and the target are identical, the operand
13059 -- is safe. The operand can be empty in the case of negation.
13061 function Is_Unaliased (N : Node_Id) return Boolean;
13062 -- Check that N is a stand-alone entity
13068 function Is_Unaliased (N : Node_Id) return Boolean is
13072 and then No (Address_Clause (Entity (N)))
13073 and then No (Renamed_Object (Entity (N)));
13076 ---------------------
13077 -- Is_Safe_Operand --
13078 ---------------------
13080 function Is_Safe_Operand (Op : Node_Id) return Boolean is
13085 elsif Is_Entity_Name (Op) then
13086 return Is_Unaliased (Op);
13088 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
13089 return Is_Unaliased (Prefix (Op));
13091 elsif Nkind (Op) = N_Slice then
13093 Is_Unaliased (Prefix (Op))
13094 and then Entity (Prefix (Op)) /= Target;
13096 elsif Nkind (Op) = N_Op_Not then
13097 return Is_Safe_Operand (Right_Opnd (Op));
13102 end Is_Safe_Operand;
13104 -- Start of processing for Safe_In_Place_Array_Op
13107 -- Skip this processing if the component size is different from system
13108 -- storage unit (since at least for NOT this would cause problems).
13110 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
13113 -- Cannot do in place stuff on VM_Target since cannot pass addresses
13115 elsif VM_Target /= No_VM then
13118 -- Cannot do in place stuff if non-standard Boolean representation
13120 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
13123 elsif not Is_Unaliased (Lhs) then
13127 Target := Entity (Lhs);
13128 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
13130 end Safe_In_Place_Array_Op;
13132 -----------------------
13133 -- Tagged_Membership --
13134 -----------------------
13136 -- There are two different cases to consider depending on whether the right
13137 -- operand is a class-wide type or not. If not we just compare the actual
13138 -- tag of the left expr to the target type tag:
13140 -- Left_Expr.Tag = Right_Type'Tag;
13142 -- If it is a class-wide type we use the RT function CW_Membership which is
13143 -- usually implemented by looking in the ancestor tables contained in the
13144 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
13146 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
13147 -- function IW_Membership which is usually implemented by looking in the
13148 -- table of abstract interface types plus the ancestor table contained in
13149 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
13151 procedure Tagged_Membership
13153 SCIL_Node : out Node_Id;
13154 Result : out Node_Id)
13156 Left : constant Node_Id := Left_Opnd (N);
13157 Right : constant Node_Id := Right_Opnd (N);
13158 Loc : constant Source_Ptr := Sloc (N);
13160 Full_R_Typ : Entity_Id;
13161 Left_Type : Entity_Id;
13162 New_Node : Node_Id;
13163 Right_Type : Entity_Id;
13167 SCIL_Node := Empty;
13169 -- Handle entities from the limited view
13171 Left_Type := Available_View (Etype (Left));
13172 Right_Type := Available_View (Etype (Right));
13174 -- In the case where the type is an access type, the test is applied
13175 -- using the designated types (needed in Ada 2012 for implicit anonymous
13176 -- access conversions, for AI05-0149).
13178 if Is_Access_Type (Right_Type) then
13179 Left_Type := Designated_Type (Left_Type);
13180 Right_Type := Designated_Type (Right_Type);
13183 if Is_Class_Wide_Type (Left_Type) then
13184 Left_Type := Root_Type (Left_Type);
13187 if Is_Class_Wide_Type (Right_Type) then
13188 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
13190 Full_R_Typ := Underlying_Type (Right_Type);
13194 Make_Selected_Component (Loc,
13195 Prefix => Relocate_Node (Left),
13197 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
13199 if Is_Class_Wide_Type (Right_Type) then
13201 -- No need to issue a run-time check if we statically know that the
13202 -- result of this membership test is always true. For example,
13203 -- considering the following declarations:
13205 -- type Iface is interface;
13206 -- type T is tagged null record;
13207 -- type DT is new T and Iface with null record;
13212 -- These membership tests are always true:
13215 -- Obj2 in T'Class;
13216 -- Obj2 in Iface'Class;
13218 -- We do not need to handle cases where the membership is illegal.
13221 -- Obj1 in DT'Class; -- Compile time error
13222 -- Obj1 in Iface'Class; -- Compile time error
13224 if not Is_Class_Wide_Type (Left_Type)
13225 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
13226 Use_Full_View => True)
13227 or else (Is_Interface (Etype (Right_Type))
13228 and then Interface_Present_In_Ancestor
13230 Iface => Etype (Right_Type))))
13232 Result := New_Occurrence_Of (Standard_True, Loc);
13236 -- Ada 2005 (AI-251): Class-wide applied to interfaces
13238 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
13240 -- Support to: "Iface_CW_Typ in Typ'Class"
13242 or else Is_Interface (Left_Type)
13244 -- Issue error if IW_Membership operation not available in a
13245 -- configurable run time setting.
13247 if not RTE_Available (RE_IW_Membership) then
13249 ("dynamic membership test on interface types", N);
13255 Make_Function_Call (Loc,
13256 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
13257 Parameter_Associations => New_List (
13258 Make_Attribute_Reference (Loc,
13260 Attribute_Name => Name_Address),
13261 New_Occurrence_Of (
13262 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
13265 -- Ada 95: Normal case
13268 Build_CW_Membership (Loc,
13269 Obj_Tag_Node => Obj_Tag,
13271 New_Occurrence_Of (
13272 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
13274 New_Node => New_Node);
13276 -- Generate the SCIL node for this class-wide membership test.
13277 -- Done here because the previous call to Build_CW_Membership
13278 -- relocates Obj_Tag.
13280 if Generate_SCIL then
13281 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
13282 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
13283 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
13286 Result := New_Node;
13289 -- Right_Type is not a class-wide type
13292 -- No need to check the tag of the object if Right_Typ is abstract
13294 if Is_Abstract_Type (Right_Type) then
13295 Result := New_Occurrence_Of (Standard_False, Loc);
13300 Left_Opnd => Obj_Tag,
13303 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
13306 end Tagged_Membership;
13308 ------------------------------
13309 -- Unary_Op_Validity_Checks --
13310 ------------------------------
13312 procedure Unary_Op_Validity_Checks (N : Node_Id) is
13314 if Validity_Checks_On and Validity_Check_Operands then
13315 Ensure_Valid (Right_Opnd (N));
13317 end Unary_Op_Validity_Checks;