1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Aggr; use Exp_Aggr;
33 with Exp_Atag; use Exp_Atag;
34 with Exp_Ch3; use Exp_Ch3;
35 with Exp_Ch6; use Exp_Ch6;
36 with Exp_Ch7; use Exp_Ch7;
37 with Exp_Ch9; use Exp_Ch9;
38 with Exp_Disp; use Exp_Disp;
39 with Exp_Fixd; use Exp_Fixd;
40 with Exp_Intr; use Exp_Intr;
41 with Exp_Pakd; use Exp_Pakd;
42 with Exp_Tss; use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
45 with Inline; use Inline;
46 with Namet; use Namet;
47 with Nlists; use Nlists;
48 with Nmake; use Nmake;
50 with Par_SCO; use Par_SCO;
51 with Restrict; use Restrict;
52 with Rident; use Rident;
53 with Rtsfind; use Rtsfind;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Cat; use Sem_Cat;
57 with Sem_Ch3; use Sem_Ch3;
58 with Sem_Ch13; use Sem_Ch13;
59 with Sem_Eval; use Sem_Eval;
60 with Sem_Res; use Sem_Res;
61 with Sem_Type; use Sem_Type;
62 with Sem_Util; use Sem_Util;
63 with Sem_Warn; use Sem_Warn;
64 with Sinfo; use Sinfo;
65 with Snames; use Snames;
66 with Stand; use Stand;
67 with SCIL_LL; use SCIL_LL;
68 with Targparm; use Targparm;
69 with Tbuild; use Tbuild;
70 with Ttypes; use Ttypes;
71 with Uintp; use Uintp;
72 with Urealp; use Urealp;
73 with Validsw; use Validsw;
74 with Warnsw; use Warnsw;
76 package body Exp_Ch4 is
78 -----------------------
79 -- Local Subprograms --
80 -----------------------
82 procedure Binary_Op_Validity_Checks (N : Node_Id);
83 pragma Inline (Binary_Op_Validity_Checks);
84 -- Performs validity checks for a binary operator
86 procedure Build_Boolean_Array_Proc_Call
90 -- If a boolean array assignment can be done in place, build call to
91 -- corresponding library procedure.
93 procedure Displace_Allocator_Pointer (N : Node_Id);
94 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
95 -- Expand_Allocator_Expression. Allocating class-wide interface objects
96 -- this routine displaces the pointer to the allocated object to reference
97 -- the component referencing the corresponding secondary dispatch table.
99 procedure Expand_Allocator_Expression (N : Node_Id);
100 -- Subsidiary to Expand_N_Allocator, for the case when the expression
101 -- is a qualified expression.
103 procedure Expand_Array_Comparison (N : Node_Id);
104 -- This routine handles expansion of the comparison operators (N_Op_Lt,
105 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
106 -- code for these operators is similar, differing only in the details of
107 -- the actual comparison call that is made. Special processing (call a
110 function Expand_Array_Equality
115 Typ : Entity_Id) return Node_Id;
116 -- Expand an array equality into a call to a function implementing this
117 -- equality, and a call to it. Loc is the location for the generated nodes.
118 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
119 -- on which to attach bodies of local functions that are created in the
120 -- process. It is the responsibility of the caller to insert those bodies
121 -- at the right place. Nod provides the Sloc value for the generated code.
122 -- Normally the types used for the generated equality routine are taken
123 -- from Lhs and Rhs. However, in some situations of generated code, the
124 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
125 -- the type to be used for the formal parameters.
127 procedure Expand_Boolean_Operator (N : Node_Id);
128 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
129 -- case of array type arguments.
131 procedure Expand_Nonbinary_Modular_Op (N : Node_Id);
132 -- When generating C code, convert nonbinary modular arithmetic operations
133 -- into code that relies on the front-end expansion of operator Mod. No
134 -- expansion is performed if N is not a nonbinary modular operand.
136 procedure Expand_Short_Circuit_Operator (N : Node_Id);
137 -- Common expansion processing for short-circuit boolean operators
139 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
140 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
141 -- where we allow comparison of "out of range" values.
143 function Expand_Composite_Equality
148 Bodies : List_Id) return Node_Id;
149 -- Local recursive function used to expand equality for nested composite
150 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
151 -- to attach bodies of local functions that are created in the process. It
152 -- is the responsibility of the caller to insert those bodies at the right
153 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
154 -- the left and right sides for the comparison, and Typ is the type of the
155 -- objects to compare.
157 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
158 -- Routine to expand concatenation of a sequence of two or more operands
159 -- (in the list Operands) and replace node Cnode with the result of the
160 -- concatenation. The operands can be of any appropriate type, and can
161 -- include both arrays and singleton elements.
163 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
164 -- N is an N_In membership test mode, with the overflow check mode set to
165 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
166 -- integer type. This is a case where top level processing is required to
167 -- handle overflow checks in subtrees.
169 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
170 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
171 -- fixed. We do not have such a type at runtime, so the purpose of this
172 -- routine is to find the real type by looking up the tree. We also
173 -- determine if the operation must be rounded.
175 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
176 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
177 -- discriminants if it has a constrained nominal type, unless the object
178 -- is a component of an enclosing Unchecked_Union object that is subject
179 -- to a per-object constraint and the enclosing object lacks inferable
182 -- An expression of an Unchecked_Union type has inferable discriminants
183 -- if it is either a name of an object with inferable discriminants or a
184 -- qualified expression whose subtype mark denotes a constrained subtype.
186 procedure Insert_Dereference_Action (N : Node_Id);
187 -- N is an expression whose type is an access. When the type of the
188 -- associated storage pool is derived from Checked_Pool, generate a
189 -- call to the 'Dereference' primitive operation.
191 function Make_Array_Comparison_Op
193 Nod : Node_Id) return Node_Id;
194 -- Comparisons between arrays are expanded in line. This function produces
195 -- the body of the implementation of (a > b), where a and b are one-
196 -- dimensional arrays of some discrete type. The original node is then
197 -- expanded into the appropriate call to this function. Nod provides the
198 -- Sloc value for the generated code.
200 function Make_Boolean_Array_Op
202 N : Node_Id) return Node_Id;
203 -- Boolean operations on boolean arrays are expanded in line. This function
204 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
205 -- b). It is used only the normal case and not the packed case. The type
206 -- involved, Typ, is the Boolean array type, and the logical operations in
207 -- the body are simple boolean operations. Note that Typ is always a
208 -- constrained type (the caller has ensured this by using
209 -- Convert_To_Actual_Subtype if necessary).
211 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
212 -- For signed arithmetic operations when the current overflow mode is
213 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
214 -- as the first thing we do. We then return. We count on the recursive
215 -- apparatus for overflow checks to call us back with an equivalent
216 -- operation that is in CHECKED mode, avoiding a recursive entry into this
217 -- routine, and that is when we will proceed with the expansion of the
218 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
219 -- these optimizations without first making this check, since there may be
220 -- operands further down the tree that are relying on the recursive calls
221 -- triggered by the top level nodes to properly process overflow checking
222 -- and remaining expansion on these nodes. Note that this call back may be
223 -- skipped if the operation is done in Bignum mode but that's fine, since
224 -- the Bignum call takes care of everything.
226 procedure Narrow_Large_Operation (N : Node_Id);
227 -- Try to compute the result of a large operation in a narrower type than
228 -- its nominal type. This is mainly aimed at getting rid of operations done
229 -- in Universal_Integer that can be generated for attributes.
231 procedure Optimize_Length_Comparison (N : Node_Id);
232 -- Given an expression, if it is of the form X'Length op N (or the other
233 -- way round), where N is known at compile time to be 0 or 1, or something
234 -- else where the value is known to be nonnegative and in the 32-bit range,
235 -- and X is a simple entity, and op is a comparison operator, optimizes it
236 -- into a comparison of X'First and X'Last.
238 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
239 -- Inspect and process statement list Stmt of if or case expression N for
240 -- transient objects. If such objects are found, the routine generates code
241 -- to clean them up when the context of the expression is evaluated.
243 procedure Process_Transient_In_Expression
247 -- Subsidiary routine to the expansion of expression_with_actions, if and
248 -- case expressions. Generate all necessary code to finalize a transient
249 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
250 -- denotes the declaration of the transient object, which is usually the
251 -- result of a controlled function call. Expr denotes the expression with
252 -- actions, if expression, or case expression node. Stmts denotes the
253 -- statement list which contains Decl, either at the top level or within a
256 procedure Rewrite_Comparison (N : Node_Id);
257 -- If N is the node for a comparison whose outcome can be determined at
258 -- compile time, then the node N can be rewritten with True or False. If
259 -- the outcome cannot be determined at compile time, the call has no
260 -- effect. If N is a type conversion, then this processing is applied to
261 -- its expression. If N is neither comparison nor a type conversion, the
262 -- call has no effect.
264 procedure Tagged_Membership
266 SCIL_Node : out Node_Id;
267 Result : out Node_Id);
268 -- Construct the expression corresponding to the tagged membership test.
269 -- Deals with a second operand being (or not) a class-wide type.
271 function Safe_In_Place_Array_Op
274 Op2 : Node_Id) return Boolean;
275 -- In the context of an assignment, where the right-hand side is a boolean
276 -- operation on arrays, check whether operation can be performed in place.
278 procedure Unary_Op_Validity_Checks (N : Node_Id);
279 pragma Inline (Unary_Op_Validity_Checks);
280 -- Performs validity checks for a unary operator
282 -------------------------------
283 -- Binary_Op_Validity_Checks --
284 -------------------------------
286 procedure Binary_Op_Validity_Checks (N : Node_Id) is
288 if Validity_Checks_On and Validity_Check_Operands then
289 Ensure_Valid (Left_Opnd (N));
290 Ensure_Valid (Right_Opnd (N));
292 end Binary_Op_Validity_Checks;
294 ------------------------------------
295 -- Build_Boolean_Array_Proc_Call --
296 ------------------------------------
298 procedure Build_Boolean_Array_Proc_Call
303 Loc : constant Source_Ptr := Sloc (N);
304 Kind : constant Node_Kind := Nkind (Expression (N));
305 Target : constant Node_Id :=
306 Make_Attribute_Reference (Loc,
308 Attribute_Name => Name_Address);
310 Arg1 : Node_Id := Op1;
311 Arg2 : Node_Id := Op2;
313 Proc_Name : Entity_Id;
316 if Kind = N_Op_Not then
317 if Nkind (Op1) in N_Binary_Op then
319 -- Use negated version of the binary operators
321 if Nkind (Op1) = N_Op_And then
322 Proc_Name := RTE (RE_Vector_Nand);
324 elsif Nkind (Op1) = N_Op_Or then
325 Proc_Name := RTE (RE_Vector_Nor);
327 else pragma Assert (Nkind (Op1) = N_Op_Xor);
328 Proc_Name := RTE (RE_Vector_Xor);
332 Make_Procedure_Call_Statement (Loc,
333 Name => New_Occurrence_Of (Proc_Name, Loc),
335 Parameter_Associations => New_List (
337 Make_Attribute_Reference (Loc,
338 Prefix => Left_Opnd (Op1),
339 Attribute_Name => Name_Address),
341 Make_Attribute_Reference (Loc,
342 Prefix => Right_Opnd (Op1),
343 Attribute_Name => Name_Address),
345 Make_Attribute_Reference (Loc,
346 Prefix => Left_Opnd (Op1),
347 Attribute_Name => Name_Length)));
350 Proc_Name := RTE (RE_Vector_Not);
353 Make_Procedure_Call_Statement (Loc,
354 Name => New_Occurrence_Of (Proc_Name, Loc),
355 Parameter_Associations => New_List (
358 Make_Attribute_Reference (Loc,
360 Attribute_Name => Name_Address),
362 Make_Attribute_Reference (Loc,
364 Attribute_Name => Name_Length)));
368 -- We use the following equivalences:
370 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
371 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
372 -- (not X) xor (not Y) = X xor Y
373 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
375 if Nkind (Op1) = N_Op_Not then
376 Arg1 := Right_Opnd (Op1);
377 Arg2 := Right_Opnd (Op2);
379 if Kind = N_Op_And then
380 Proc_Name := RTE (RE_Vector_Nor);
381 elsif Kind = N_Op_Or then
382 Proc_Name := RTE (RE_Vector_Nand);
384 Proc_Name := RTE (RE_Vector_Xor);
388 if Kind = N_Op_And then
389 Proc_Name := RTE (RE_Vector_And);
390 elsif Kind = N_Op_Or then
391 Proc_Name := RTE (RE_Vector_Or);
392 elsif Nkind (Op2) = N_Op_Not then
393 Proc_Name := RTE (RE_Vector_Nxor);
394 Arg2 := Right_Opnd (Op2);
396 Proc_Name := RTE (RE_Vector_Xor);
401 Make_Procedure_Call_Statement (Loc,
402 Name => New_Occurrence_Of (Proc_Name, Loc),
403 Parameter_Associations => New_List (
405 Make_Attribute_Reference (Loc,
407 Attribute_Name => Name_Address),
408 Make_Attribute_Reference (Loc,
410 Attribute_Name => Name_Address),
411 Make_Attribute_Reference (Loc,
413 Attribute_Name => Name_Length)));
416 Rewrite (N, Call_Node);
420 when RE_Not_Available =>
422 end Build_Boolean_Array_Proc_Call;
424 -----------------------
426 -----------------------
428 function Build_Eq_Call
432 Rhs : Node_Id) return Node_Id
438 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
439 while Present (Prim_E) loop
440 Prim := Node (Prim_E);
442 -- Locate primitive equality with the right signature
444 if Chars (Prim) = Name_Op_Eq
445 and then Etype (First_Formal (Prim)) =
446 Etype (Next_Formal (First_Formal (Prim)))
447 and then Etype (Prim) = Standard_Boolean
449 if Is_Abstract_Subprogram (Prim) then
451 Make_Raise_Program_Error (Loc,
452 Reason => PE_Explicit_Raise);
456 Make_Function_Call (Loc,
457 Name => New_Occurrence_Of (Prim, Loc),
458 Parameter_Associations => New_List (Lhs, Rhs));
465 -- If not found, predefined operation will be used
470 --------------------------------
471 -- Displace_Allocator_Pointer --
472 --------------------------------
474 procedure Displace_Allocator_Pointer (N : Node_Id) is
475 Loc : constant Source_Ptr := Sloc (N);
476 Orig_Node : constant Node_Id := Original_Node (N);
482 -- Do nothing in case of VM targets: the virtual machine will handle
483 -- interfaces directly.
485 if not Tagged_Type_Expansion then
489 pragma Assert (Nkind (N) = N_Identifier
490 and then Nkind (Orig_Node) = N_Allocator);
492 PtrT := Etype (Orig_Node);
493 Dtyp := Available_View (Designated_Type (PtrT));
494 Etyp := Etype (Expression (Orig_Node));
496 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
498 -- If the type of the allocator expression is not an interface type
499 -- we can generate code to reference the record component containing
500 -- the pointer to the secondary dispatch table.
502 if not Is_Interface (Etyp) then
504 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
507 -- 1) Get access to the allocated object
510 Make_Explicit_Dereference (Loc, Relocate_Node (N)));
514 -- 2) Add the conversion to displace the pointer to reference
515 -- the secondary dispatch table.
517 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
518 Analyze_And_Resolve (N, Dtyp);
520 -- 3) The 'access to the secondary dispatch table will be used
521 -- as the value returned by the allocator.
524 Make_Attribute_Reference (Loc,
525 Prefix => Relocate_Node (N),
526 Attribute_Name => Name_Access));
527 Set_Etype (N, Saved_Typ);
531 -- If the type of the allocator expression is an interface type we
532 -- generate a run-time call to displace "this" to reference the
533 -- component containing the pointer to the secondary dispatch table
534 -- or else raise Constraint_Error if the actual object does not
535 -- implement the target interface. This case corresponds to the
536 -- following example:
538 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
540 -- return new Iface_2'Class'(Obj);
545 Unchecked_Convert_To (PtrT,
546 Make_Function_Call (Loc,
547 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
548 Parameter_Associations => New_List (
549 Unchecked_Convert_To (RTE (RE_Address),
555 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
557 Analyze_And_Resolve (N, PtrT);
560 end Displace_Allocator_Pointer;
562 ---------------------------------
563 -- Expand_Allocator_Expression --
564 ---------------------------------
566 procedure Expand_Allocator_Expression (N : Node_Id) is
567 Loc : constant Source_Ptr := Sloc (N);
568 Exp : constant Node_Id := Expression (Expression (N));
569 PtrT : constant Entity_Id := Etype (N);
570 DesigT : constant Entity_Id := Designated_Type (PtrT);
572 procedure Apply_Accessibility_Check
574 Built_In_Place : Boolean := False);
575 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
576 -- type, generate an accessibility check to verify that the level of the
577 -- type of the created object is not deeper than the level of the access
578 -- type. If the type of the qualified expression is class-wide, then
579 -- always generate the check (except in the case where it is known to be
580 -- unnecessary, see comment below). Otherwise, only generate the check
581 -- if the level of the qualified expression type is statically deeper
582 -- than the access type.
584 -- Although the static accessibility will generally have been performed
585 -- as a legality check, it won't have been done in cases where the
586 -- allocator appears in generic body, so a run-time check is needed in
587 -- general. One special case is when the access type is declared in the
588 -- same scope as the class-wide allocator, in which case the check can
589 -- never fail, so it need not be generated.
591 -- As an open issue, there seem to be cases where the static level
592 -- associated with the class-wide object's underlying type is not
593 -- sufficient to perform the proper accessibility check, such as for
594 -- allocators in nested subprograms or accept statements initialized by
595 -- class-wide formals when the actual originates outside at a deeper
596 -- static level. The nested subprogram case might require passing
597 -- accessibility levels along with class-wide parameters, and the task
598 -- case seems to be an actual gap in the language rules that needs to
599 -- be fixed by the ARG. ???
601 -------------------------------
602 -- Apply_Accessibility_Check --
603 -------------------------------
605 procedure Apply_Accessibility_Check
607 Built_In_Place : Boolean := False)
609 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
617 if Ada_Version >= Ada_2005
618 and then Is_Class_Wide_Type (DesigT)
619 and then Tagged_Type_Expansion
620 and then not Scope_Suppress.Suppress (Accessibility_Check)
622 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
624 (Is_Class_Wide_Type (Etype (Exp))
625 and then Scope (PtrT) /= Current_Scope))
627 -- If the allocator was built in place, Ref is already a reference
628 -- to the access object initialized to the result of the allocator
629 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
630 -- Remove_Side_Effects for cases where the build-in-place call may
631 -- still be the prefix of the reference (to avoid generating
632 -- duplicate calls). Otherwise, it is the entity associated with
633 -- the object containing the address of the allocated object.
635 if Built_In_Place then
636 Remove_Side_Effects (Ref);
637 Obj_Ref := New_Copy_Tree (Ref);
639 Obj_Ref := New_Occurrence_Of (Ref, Loc);
642 -- For access to interface types we must generate code to displace
643 -- the pointer to the base of the object since the subsequent code
644 -- references components located in the TSD of the object (which
645 -- is associated with the primary dispatch table --see a-tags.ads)
646 -- and also generates code invoking Free, which requires also a
647 -- reference to the base of the unallocated object.
649 if Is_Interface (DesigT) and then Tagged_Type_Expansion then
651 Unchecked_Convert_To (Etype (Obj_Ref),
652 Make_Function_Call (Loc,
654 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
655 Parameter_Associations => New_List (
656 Unchecked_Convert_To (RTE (RE_Address),
657 New_Copy_Tree (Obj_Ref)))));
660 -- Step 1: Create the object clean up code
664 -- Deallocate the object if the accessibility check fails. This
665 -- is done only on targets or profiles that support deallocation.
669 if RTE_Available (RE_Free) then
670 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
671 Set_Storage_Pool (Free_Stmt, Pool_Id);
673 Append_To (Stmts, Free_Stmt);
675 -- The target or profile cannot deallocate objects
681 -- Finalize the object if applicable. Generate:
683 -- [Deep_]Finalize (Obj_Ref.all);
685 if Needs_Finalization (DesigT)
686 and then not No_Heap_Finalization (PtrT)
691 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
694 -- Guard against a missing [Deep_]Finalize when the designated
695 -- type was not properly frozen.
697 if No (Fin_Call) then
698 Fin_Call := Make_Null_Statement (Loc);
701 -- When the target or profile supports deallocation, wrap the
702 -- finalization call in a block to ensure proper deallocation
703 -- even if finalization fails. Generate:
713 if Present (Free_Stmt) then
715 Make_Block_Statement (Loc,
716 Handled_Statement_Sequence =>
717 Make_Handled_Sequence_Of_Statements (Loc,
718 Statements => New_List (Fin_Call),
720 Exception_Handlers => New_List (
721 Make_Exception_Handler (Loc,
722 Exception_Choices => New_List (
723 Make_Others_Choice (Loc)),
724 Statements => New_List (
725 New_Copy_Tree (Free_Stmt),
726 Make_Raise_Statement (Loc))))));
729 Prepend_To (Stmts, Fin_Call);
732 -- Signal the accessibility failure through a Program_Error
735 Make_Raise_Program_Error (Loc,
736 Condition => New_Occurrence_Of (Standard_True, Loc),
737 Reason => PE_Accessibility_Check_Failed));
739 -- Step 2: Create the accessibility comparison
745 Make_Attribute_Reference (Loc,
747 Attribute_Name => Name_Tag);
749 -- For tagged types, determine the accessibility level by looking
750 -- at the type specific data of the dispatch table. Generate:
752 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
754 if Tagged_Type_Expansion then
755 Cond := Build_Get_Access_Level (Loc, Obj_Ref);
757 -- Use a runtime call to determine the accessibility level when
758 -- compiling on virtual machine targets. Generate:
760 -- Get_Access_Level (Ref'Tag)
764 Make_Function_Call (Loc,
766 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
767 Parameter_Associations => New_List (Obj_Ref));
774 Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
776 -- Due to the complexity and side effects of the check, utilize an
777 -- if statement instead of the regular Program_Error circuitry.
780 Make_Implicit_If_Statement (N,
782 Then_Statements => Stmts));
784 end Apply_Accessibility_Check;
788 Indic : constant Node_Id := Subtype_Mark (Expression (N));
789 T : constant Entity_Id := Entity (Indic);
791 Aggr_In_Place : Boolean;
793 Tag_Assign : Node_Id;
797 TagT : Entity_Id := Empty;
798 -- Type used as source for tag assignment
800 TagR : Node_Id := Empty;
801 -- Target reference for tag assignment
803 -- Start of processing for Expand_Allocator_Expression
806 -- Handle call to C++ constructor
808 if Is_CPP_Constructor_Call (Exp) then
809 Make_CPP_Constructor_Call_In_Allocator
811 Function_Call => Exp);
816 -- type A is access T1;
817 -- X : A := new T2'(...);
818 -- T1 and T2 can be different subtypes, and we might need to check
819 -- both constraints. First check against the type of the qualified
822 Apply_Constraint_Check (Exp, T, No_Sliding => True);
824 Apply_Predicate_Check (Exp, T);
826 -- Check that any anonymous access discriminants are suitable
827 -- for use in an allocator.
829 -- Note: This check is performed here instead of during analysis so that
830 -- we can check against the fully resolved etype of Exp.
832 if Is_Entity_Name (Exp)
833 and then Has_Anonymous_Access_Discriminant (Etype (Exp))
834 and then Static_Accessibility_Level (Exp, Object_Decl_Level)
835 > Static_Accessibility_Level (N, Object_Decl_Level)
837 -- A dynamic check and a warning are generated when we are within
842 Make_Raise_Program_Error (Loc,
843 Reason => PE_Accessibility_Check_Failed));
845 Error_Msg_N ("anonymous access discriminant is too deep for use"
846 & " in allocator<<", N);
847 Error_Msg_N ("\Program_Error [<<", N);
849 -- Otherwise, make the error static
852 Error_Msg_N ("anonymous access discriminant is too deep for use"
853 & " in allocator", N);
857 if Do_Range_Check (Exp) then
858 Generate_Range_Check (Exp, T, CE_Range_Check_Failed);
861 -- A check is also needed in cases where the designated subtype is
862 -- constrained and differs from the subtype given in the qualified
863 -- expression. Note that the check on the qualified expression does
864 -- not allow sliding, but this check does (a relaxation from Ada 83).
866 if Is_Constrained (DesigT)
867 and then not Subtypes_Statically_Match (T, DesigT)
869 Apply_Constraint_Check (Exp, DesigT, No_Sliding => False);
871 Apply_Predicate_Check (Exp, DesigT);
873 if Do_Range_Check (Exp) then
874 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
878 if Nkind (Exp) = N_Raise_Constraint_Error then
879 Rewrite (N, New_Copy (Exp));
884 Aggr_In_Place := Is_Delayed_Aggregate (Exp);
886 -- Case of tagged type or type requiring finalization
888 if Is_Tagged_Type (T) or else Needs_Finalization (T) then
890 -- Ada 2005 (AI-318-02): If the initialization expression is a call
891 -- to a build-in-place function, then access to the allocated object
892 -- must be passed to the function.
894 if Is_Build_In_Place_Function_Call (Exp) then
895 Make_Build_In_Place_Call_In_Allocator (N, Exp);
896 Apply_Accessibility_Check (N, Built_In_Place => True);
899 -- Ada 2005 (AI-318-02): Specialization of the previous case for
900 -- expressions containing a build-in-place function call whose
901 -- returned object covers interface types, and Expr has calls to
902 -- Ada.Tags.Displace to displace the pointer to the returned build-
903 -- in-place object to reference the secondary dispatch table of a
904 -- covered interface type.
906 elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then
907 Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
908 Apply_Accessibility_Check (N, Built_In_Place => True);
912 -- Actions inserted before:
913 -- Temp : constant ptr_T := new T'(Expression);
914 -- Temp._tag = T'tag; -- when not class-wide
915 -- [Deep_]Adjust (Temp.all);
917 -- We analyze by hand the new internal allocator to avoid any
918 -- recursion and inappropriate call to Initialize.
920 -- We don't want to remove side effects when the expression must be
921 -- built in place. In the case of a build-in-place function call,
922 -- that could lead to a duplication of the call, which was already
923 -- substituted for the allocator.
925 if not Aggr_In_Place then
926 Remove_Side_Effects (Exp);
929 Temp := Make_Temporary (Loc, 'P', N);
931 -- For a class wide allocation generate the following code:
933 -- type Equiv_Record is record ... end record;
934 -- implicit subtype CW is <Class_Wide_Subytpe>;
935 -- temp : PtrT := new CW'(CW!(expr));
937 if Is_Class_Wide_Type (T) then
938 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
940 -- Ada 2005 (AI-251): If the expression is a class-wide interface
941 -- object we generate code to move up "this" to reference the
942 -- base of the object before allocating the new object.
944 -- Note that Exp'Address is recursively expanded into a call
945 -- to Base_Address (Exp.Tag)
947 if Is_Class_Wide_Type (Etype (Exp))
948 and then Is_Interface (Etype (Exp))
949 and then Tagged_Type_Expansion
953 Unchecked_Convert_To (Entity (Indic),
954 Make_Explicit_Dereference (Loc,
955 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
956 Make_Attribute_Reference (Loc,
958 Attribute_Name => Name_Address)))));
962 Unchecked_Convert_To (Entity (Indic), Exp));
965 Analyze_And_Resolve (Expression (N), Entity (Indic));
968 -- Processing for allocators returning non-interface types
970 if not Is_Interface (Directly_Designated_Type (PtrT)) then
971 if Aggr_In_Place then
973 Make_Object_Declaration (Loc,
974 Defining_Identifier => Temp,
975 Object_Definition => New_Occurrence_Of (PtrT, Loc),
979 New_Occurrence_Of (Etype (Exp), Loc)));
981 -- Copy the Comes_From_Source flag for the allocator we just
982 -- built, since logically this allocator is a replacement of
983 -- the original allocator node. This is for proper handling of
984 -- restriction No_Implicit_Heap_Allocations.
986 Preserve_Comes_From_Source
987 (Expression (Temp_Decl), N);
989 Set_No_Initialization (Expression (Temp_Decl));
990 Insert_Action (N, Temp_Decl);
992 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
993 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
996 Node := Relocate_Node (N);
1000 Make_Object_Declaration (Loc,
1001 Defining_Identifier => Temp,
1002 Constant_Present => True,
1003 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1004 Expression => Node);
1006 Insert_Action (N, Temp_Decl);
1007 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1010 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
1011 -- interface type. In this case we use the type of the qualified
1012 -- expression to allocate the object.
1016 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
1021 Make_Full_Type_Declaration (Loc,
1022 Defining_Identifier => Def_Id,
1024 Make_Access_To_Object_Definition (Loc,
1025 All_Present => True,
1026 Null_Exclusion_Present => False,
1028 Is_Access_Constant (Etype (N)),
1029 Subtype_Indication =>
1030 New_Occurrence_Of (Etype (Exp), Loc)));
1032 Insert_Action (N, New_Decl);
1034 -- Inherit the allocation-related attributes from the original
1037 Set_Finalization_Master
1038 (Def_Id, Finalization_Master (PtrT));
1040 Set_Associated_Storage_Pool
1041 (Def_Id, Associated_Storage_Pool (PtrT));
1043 -- Declare the object using the previous type declaration
1045 if Aggr_In_Place then
1047 Make_Object_Declaration (Loc,
1048 Defining_Identifier => Temp,
1049 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1051 Make_Allocator (Loc,
1052 New_Occurrence_Of (Etype (Exp), Loc)));
1054 -- Copy the Comes_From_Source flag for the allocator we just
1055 -- built, since logically this allocator is a replacement of
1056 -- the original allocator node. This is for proper handling
1057 -- of restriction No_Implicit_Heap_Allocations.
1059 Set_Comes_From_Source
1060 (Expression (Temp_Decl), Comes_From_Source (N));
1062 Set_No_Initialization (Expression (Temp_Decl));
1063 Insert_Action (N, Temp_Decl);
1065 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1066 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1069 Node := Relocate_Node (N);
1070 Set_Analyzed (Node);
1073 Make_Object_Declaration (Loc,
1074 Defining_Identifier => Temp,
1075 Constant_Present => True,
1076 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1077 Expression => Node);
1079 Insert_Action (N, Temp_Decl);
1080 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1083 -- Generate an additional object containing the address of the
1084 -- returned object. The type of this second object declaration
1085 -- is the correct type required for the common processing that
1086 -- is still performed by this subprogram. The displacement of
1087 -- this pointer to reference the component associated with the
1088 -- interface type will be done at the end of common processing.
1091 Make_Object_Declaration (Loc,
1092 Defining_Identifier => Make_Temporary (Loc, 'P'),
1093 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1095 Unchecked_Convert_To (PtrT,
1096 New_Occurrence_Of (Temp, Loc)));
1098 Insert_Action (N, New_Decl);
1100 Temp_Decl := New_Decl;
1101 Temp := Defining_Identifier (New_Decl);
1105 -- Generate the tag assignment
1107 -- Suppress the tag assignment for VM targets because VM tags are
1108 -- represented implicitly in objects.
1110 if not Tagged_Type_Expansion then
1113 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1114 -- interface objects because in this case the tag does not change.
1116 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1117 pragma Assert (Is_Class_Wide_Type
1118 (Directly_Designated_Type (Etype (N))));
1121 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1124 Make_Explicit_Dereference (Loc,
1125 Prefix => New_Occurrence_Of (Temp, Loc));
1127 elsif Is_Private_Type (T)
1128 and then Is_Tagged_Type (Underlying_Type (T))
1130 TagT := Underlying_Type (T);
1132 Unchecked_Convert_To (Underlying_Type (T),
1133 Make_Explicit_Dereference (Loc,
1134 Prefix => New_Occurrence_Of (Temp, Loc)));
1137 if Present (TagT) then
1139 Full_T : constant Entity_Id := Underlying_Type (TagT);
1143 Make_Assignment_Statement (Loc,
1145 Make_Selected_Component (Loc,
1149 (First_Tag_Component (Full_T), Loc)),
1152 Unchecked_Convert_To (RTE (RE_Tag),
1155 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1158 -- The previous assignment has to be done in any case
1160 Set_Assignment_OK (Name (Tag_Assign));
1161 Insert_Action (N, Tag_Assign);
1164 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1165 -- the object may be inherently limited, in which case there is no
1166 -- Adjust procedure, and the object is built in place. In Ada 95, the
1167 -- object can be limited but not inherently limited if this allocator
1168 -- came from a return statement (we're allocating the result on the
1169 -- secondary stack). In that case, the object will be moved, so we do
1170 -- want to Adjust. However, if it's a nonlimited build-in-place
1171 -- function call, Adjust is not wanted.
1173 if Needs_Finalization (DesigT)
1174 and then Needs_Finalization (T)
1175 and then not Aggr_In_Place
1176 and then not Is_Limited_View (T)
1177 and then not Alloc_For_BIP_Return (N)
1178 and then not Is_Build_In_Place_Function_Call (Expression (N))
1180 -- An unchecked conversion is needed in the classwide case because
1181 -- the designated type can be an ancestor of the subtype mark of
1187 Unchecked_Convert_To (T,
1188 Make_Explicit_Dereference (Loc,
1189 Prefix => New_Occurrence_Of (Temp, Loc))),
1192 if Present (Adj_Call) then
1193 Insert_Action (N, Adj_Call);
1197 -- Note: the accessibility check must be inserted after the call to
1198 -- [Deep_]Adjust to ensure proper completion of the assignment.
1200 Apply_Accessibility_Check (Temp);
1202 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1203 Analyze_And_Resolve (N, PtrT);
1205 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1206 -- component containing the secondary dispatch table of the interface
1209 if Is_Interface (Directly_Designated_Type (PtrT)) then
1210 Displace_Allocator_Pointer (N);
1213 -- Always force the generation of a temporary for aggregates when
1214 -- generating C code, to simplify the work in the code generator.
1217 or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate)
1219 Temp := Make_Temporary (Loc, 'P', N);
1221 Make_Object_Declaration (Loc,
1222 Defining_Identifier => Temp,
1223 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1225 Make_Allocator (Loc,
1226 Expression => New_Occurrence_Of (Etype (Exp), Loc)));
1228 -- Copy the Comes_From_Source flag for the allocator we just built,
1229 -- since logically this allocator is a replacement of the original
1230 -- allocator node. This is for proper handling of restriction
1231 -- No_Implicit_Heap_Allocations.
1233 Set_Comes_From_Source
1234 (Expression (Temp_Decl), Comes_From_Source (N));
1236 Set_No_Initialization (Expression (Temp_Decl));
1237 Insert_Action (N, Temp_Decl);
1239 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1240 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1242 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1243 Analyze_And_Resolve (N, PtrT);
1245 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
1246 Install_Null_Excluding_Check (Exp);
1248 elsif Is_Access_Type (DesigT)
1249 and then Nkind (Exp) = N_Allocator
1250 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1252 -- Apply constraint to designated subtype indication
1254 Apply_Constraint_Check
1255 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True);
1257 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1259 -- Propagate constraint_error to enclosing allocator
1261 Rewrite (Exp, New_Copy (Expression (Exp)));
1265 Build_Allocate_Deallocate_Proc (N, True);
1267 -- For an access to unconstrained packed array, GIGI needs to see an
1268 -- expression with a constrained subtype in order to compute the
1269 -- proper size for the allocator.
1271 if Is_Packed_Array (T)
1272 and then not Is_Constrained (T)
1275 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
1276 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1279 Make_Subtype_Declaration (Loc,
1280 Defining_Identifier => ConstrT,
1281 Subtype_Indication =>
1282 Make_Subtype_From_Expr (Internal_Exp, T)));
1283 Freeze_Itype (ConstrT, Exp);
1284 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1288 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1289 -- to a build-in-place function, then access to the allocated object
1290 -- must be passed to the function.
1292 if Is_Build_In_Place_Function_Call (Exp) then
1293 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1298 when RE_Not_Available =>
1300 end Expand_Allocator_Expression;
1302 -----------------------------
1303 -- Expand_Array_Comparison --
1304 -----------------------------
1306 -- Expansion is only required in the case of array types. For the unpacked
1307 -- case, an appropriate runtime routine is called. For packed cases, and
1308 -- also in some other cases where a runtime routine cannot be called, the
1309 -- form of the expansion is:
1311 -- [body for greater_nn; boolean_expression]
1313 -- The body is built by Make_Array_Comparison_Op, and the form of the
1314 -- Boolean expression depends on the operator involved.
1316 procedure Expand_Array_Comparison (N : Node_Id) is
1317 Loc : constant Source_Ptr := Sloc (N);
1318 Op1 : Node_Id := Left_Opnd (N);
1319 Op2 : Node_Id := Right_Opnd (N);
1320 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1321 Ctyp : constant Entity_Id := Component_Type (Typ1);
1324 Func_Body : Node_Id;
1325 Func_Name : Entity_Id;
1329 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1330 -- True for byte addressable target
1332 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1333 -- Returns True if the length of the given operand is known to be less
1334 -- than 4. Returns False if this length is known to be four or greater
1335 -- or is not known at compile time.
1337 ------------------------
1338 -- Length_Less_Than_4 --
1339 ------------------------
1341 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1342 Otyp : constant Entity_Id := Etype (Opnd);
1345 if Ekind (Otyp) = E_String_Literal_Subtype then
1346 return String_Literal_Length (Otyp) < 4;
1350 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1351 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1352 Hi : constant Node_Id := Type_High_Bound (Ityp);
1357 if Compile_Time_Known_Value (Lo) then
1358 Lov := Expr_Value (Lo);
1363 if Compile_Time_Known_Value (Hi) then
1364 Hiv := Expr_Value (Hi);
1369 return Hiv < Lov + 3;
1372 end Length_Less_Than_4;
1374 -- Start of processing for Expand_Array_Comparison
1377 -- Deal first with unpacked case, where we can call a runtime routine
1378 -- except that we avoid this for targets for which are not addressable
1381 if not Is_Bit_Packed_Array (Typ1) and then Byte_Addressable then
1382 -- The call we generate is:
1384 -- Compare_Array_xn[_Unaligned]
1385 -- (left'address, right'address, left'length, right'length) <op> 0
1387 -- x = U for unsigned, S for signed
1388 -- n = 8,16,32,64,128 for component size
1389 -- Add _Unaligned if length < 4 and component size is 8.
1390 -- <op> is the standard comparison operator
1392 if Component_Size (Typ1) = 8 then
1393 if Length_Less_Than_4 (Op1)
1395 Length_Less_Than_4 (Op2)
1397 if Is_Unsigned_Type (Ctyp) then
1398 Comp := RE_Compare_Array_U8_Unaligned;
1400 Comp := RE_Compare_Array_S8_Unaligned;
1404 if Is_Unsigned_Type (Ctyp) then
1405 Comp := RE_Compare_Array_U8;
1407 Comp := RE_Compare_Array_S8;
1411 elsif Component_Size (Typ1) = 16 then
1412 if Is_Unsigned_Type (Ctyp) then
1413 Comp := RE_Compare_Array_U16;
1415 Comp := RE_Compare_Array_S16;
1418 elsif Component_Size (Typ1) = 32 then
1419 if Is_Unsigned_Type (Ctyp) then
1420 Comp := RE_Compare_Array_U32;
1422 Comp := RE_Compare_Array_S32;
1425 elsif Component_Size (Typ1) = 64 then
1426 if Is_Unsigned_Type (Ctyp) then
1427 Comp := RE_Compare_Array_U64;
1429 Comp := RE_Compare_Array_S64;
1432 else pragma Assert (Component_Size (Typ1) = 128);
1433 if Is_Unsigned_Type (Ctyp) then
1434 Comp := RE_Compare_Array_U128;
1436 Comp := RE_Compare_Array_S128;
1440 if RTE_Available (Comp) then
1442 -- Expand to a call only if the runtime function is available,
1443 -- otherwise fall back to inline code.
1445 Remove_Side_Effects (Op1, Name_Req => True);
1446 Remove_Side_Effects (Op2, Name_Req => True);
1449 Make_Function_Call (Sloc (Op1),
1450 Name => New_Occurrence_Of (RTE (Comp), Loc),
1452 Parameter_Associations => New_List (
1453 Make_Attribute_Reference (Loc,
1454 Prefix => Relocate_Node (Op1),
1455 Attribute_Name => Name_Address),
1457 Make_Attribute_Reference (Loc,
1458 Prefix => Relocate_Node (Op2),
1459 Attribute_Name => Name_Address),
1461 Make_Attribute_Reference (Loc,
1462 Prefix => Relocate_Node (Op1),
1463 Attribute_Name => Name_Length),
1465 Make_Attribute_Reference (Loc,
1466 Prefix => Relocate_Node (Op2),
1467 Attribute_Name => Name_Length))));
1470 Make_Integer_Literal (Sloc (Op2),
1473 Analyze_And_Resolve (Op1, Standard_Integer);
1474 Analyze_And_Resolve (Op2, Standard_Integer);
1479 -- Cases where we cannot make runtime call
1481 -- For (a <= b) we convert to not (a > b)
1483 if Chars (N) = Name_Op_Le then
1489 Right_Opnd => Op2)));
1490 Analyze_And_Resolve (N, Standard_Boolean);
1493 -- For < the Boolean expression is
1494 -- greater__nn (op2, op1)
1496 elsif Chars (N) = Name_Op_Lt then
1497 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1501 Op1 := Right_Opnd (N);
1502 Op2 := Left_Opnd (N);
1504 -- For (a >= b) we convert to not (a < b)
1506 elsif Chars (N) = Name_Op_Ge then
1512 Right_Opnd => Op2)));
1513 Analyze_And_Resolve (N, Standard_Boolean);
1516 -- For > the Boolean expression is
1517 -- greater__nn (op1, op2)
1520 pragma Assert (Chars (N) = Name_Op_Gt);
1521 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1524 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1526 Make_Function_Call (Loc,
1527 Name => New_Occurrence_Of (Func_Name, Loc),
1528 Parameter_Associations => New_List (Op1, Op2));
1530 Insert_Action (N, Func_Body);
1532 Analyze_And_Resolve (N, Standard_Boolean);
1533 end Expand_Array_Comparison;
1535 ---------------------------
1536 -- Expand_Array_Equality --
1537 ---------------------------
1539 -- Expand an equality function for multi-dimensional arrays. Here is an
1540 -- example of such a function for Nb_Dimension = 2
1542 -- function Enn (A : atyp; B : btyp) return boolean is
1544 -- if (A'length (1) = 0 or else A'length (2) = 0)
1546 -- (B'length (1) = 0 or else B'length (2) = 0)
1548 -- return True; -- RM 4.5.2(22)
1551 -- if A'length (1) /= B'length (1)
1553 -- A'length (2) /= B'length (2)
1555 -- return False; -- RM 4.5.2(23)
1559 -- A1 : Index_T1 := A'first (1);
1560 -- B1 : Index_T1 := B'first (1);
1564 -- A2 : Index_T2 := A'first (2);
1565 -- B2 : Index_T2 := B'first (2);
1568 -- if A (A1, A2) /= B (B1, B2) then
1572 -- exit when A2 = A'last (2);
1573 -- A2 := Index_T2'succ (A2);
1574 -- B2 := Index_T2'succ (B2);
1578 -- exit when A1 = A'last (1);
1579 -- A1 := Index_T1'succ (A1);
1580 -- B1 := Index_T1'succ (B1);
1587 -- Note on the formal types used (atyp and btyp). If either of the arrays
1588 -- is of a private type, we use the underlying type, and do an unchecked
1589 -- conversion of the actual. If either of the arrays has a bound depending
1590 -- on a discriminant, then we use the base type since otherwise we have an
1591 -- escaped discriminant in the function.
1593 -- If both arrays are constrained and have the same bounds, we can generate
1594 -- a loop with an explicit iteration scheme using a 'Range attribute over
1597 function Expand_Array_Equality
1602 Typ : Entity_Id) return Node_Id
1604 Loc : constant Source_Ptr := Sloc (Nod);
1605 Decls : constant List_Id := New_List;
1606 Index_List1 : constant List_Id := New_List;
1607 Index_List2 : constant List_Id := New_List;
1609 First_Idx : Node_Id;
1611 Func_Name : Entity_Id;
1612 Func_Body : Node_Id;
1614 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1615 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1619 -- The parameter types to be used for the formals
1623 -- The LHS and RHS converted to the parameter types
1628 Num : Int) return Node_Id;
1629 -- This builds the attribute reference Arr'Nam (Expr)
1631 function Component_Equality (Typ : Entity_Id) return Node_Id;
1632 -- Create one statement to compare corresponding components, designated
1633 -- by a full set of indexes.
1635 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1636 -- Given one of the arguments, computes the appropriate type to be used
1637 -- for that argument in the corresponding function formal
1639 function Handle_One_Dimension
1641 Index : Node_Id) return Node_Id;
1642 -- This procedure returns the following code
1645 -- Bn : Index_T := B'First (N);
1649 -- exit when An = A'Last (N);
1650 -- An := Index_T'Succ (An)
1651 -- Bn := Index_T'Succ (Bn)
1655 -- If both indexes are constrained and identical, the procedure
1656 -- returns a simpler loop:
1658 -- for An in A'Range (N) loop
1662 -- N is the dimension for which we are generating a loop. Index is the
1663 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1664 -- xxx statement is either the loop or declare for the next dimension
1665 -- or if this is the last dimension the comparison of corresponding
1666 -- components of the arrays.
1668 -- The actual way the code works is to return the comparison of
1669 -- corresponding components for the N+1 call. That's neater.
1671 function Test_Empty_Arrays return Node_Id;
1672 -- This function constructs the test for both arrays being empty
1673 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1675 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1677 function Test_Lengths_Correspond return Node_Id;
1678 -- This function constructs the test for arrays having different lengths
1679 -- in at least one index position, in which case the resulting code is:
1681 -- A'length (1) /= B'length (1)
1683 -- A'length (2) /= B'length (2)
1694 Num : Int) return Node_Id
1698 Make_Attribute_Reference (Loc,
1699 Attribute_Name => Nam,
1700 Prefix => New_Occurrence_Of (Arr, Loc),
1701 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1704 ------------------------
1705 -- Component_Equality --
1706 ------------------------
1708 function Component_Equality (Typ : Entity_Id) return Node_Id is
1713 -- if a(i1...) /= b(j1...) then return false; end if;
1716 Make_Indexed_Component (Loc,
1717 Prefix => Make_Identifier (Loc, Chars (A)),
1718 Expressions => Index_List1);
1721 Make_Indexed_Component (Loc,
1722 Prefix => Make_Identifier (Loc, Chars (B)),
1723 Expressions => Index_List2);
1725 Test := Expand_Composite_Equality
1726 (Nod, Component_Type (Typ), L, R, Decls);
1728 -- If some (sub)component is an unchecked_union, the whole operation
1729 -- will raise program error.
1731 if Nkind (Test) = N_Raise_Program_Error then
1733 -- This node is going to be inserted at a location where a
1734 -- statement is expected: clear its Etype so analysis will set
1735 -- it to the expected Standard_Void_Type.
1737 Set_Etype (Test, Empty);
1742 Make_Implicit_If_Statement (Nod,
1743 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1744 Then_Statements => New_List (
1745 Make_Simple_Return_Statement (Loc,
1746 Expression => New_Occurrence_Of (Standard_False, Loc))));
1748 end Component_Equality;
1754 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1765 T := Underlying_Type (T);
1767 X := First_Index (T);
1768 while Present (X) loop
1769 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1771 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1784 --------------------------
1785 -- Handle_One_Dimension --
1786 ---------------------------
1788 function Handle_One_Dimension
1790 Index : Node_Id) return Node_Id
1792 Need_Separate_Indexes : constant Boolean :=
1793 Ltyp /= Rtyp or else not Is_Constrained (Ltyp);
1794 -- If the index types are identical, and we are working with
1795 -- constrained types, then we can use the same index for both
1798 An : constant Entity_Id := Make_Temporary (Loc, 'A');
1801 Index_T : Entity_Id;
1806 if N > Number_Dimensions (Ltyp) then
1807 return Component_Equality (Ltyp);
1810 -- Case where we generate a loop
1812 Index_T := Base_Type (Etype (Index));
1814 if Need_Separate_Indexes then
1815 Bn := Make_Temporary (Loc, 'B');
1820 Append (New_Occurrence_Of (An, Loc), Index_List1);
1821 Append (New_Occurrence_Of (Bn, Loc), Index_List2);
1823 Stm_List := New_List (
1824 Handle_One_Dimension (N + 1, Next_Index (Index)));
1826 if Need_Separate_Indexes then
1828 -- Generate guard for loop, followed by increments of indexes
1830 Append_To (Stm_List,
1831 Make_Exit_Statement (Loc,
1834 Left_Opnd => New_Occurrence_Of (An, Loc),
1835 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1837 Append_To (Stm_List,
1838 Make_Assignment_Statement (Loc,
1839 Name => New_Occurrence_Of (An, Loc),
1841 Make_Attribute_Reference (Loc,
1842 Prefix => New_Occurrence_Of (Index_T, Loc),
1843 Attribute_Name => Name_Succ,
1844 Expressions => New_List (
1845 New_Occurrence_Of (An, Loc)))));
1847 Append_To (Stm_List,
1848 Make_Assignment_Statement (Loc,
1849 Name => New_Occurrence_Of (Bn, Loc),
1851 Make_Attribute_Reference (Loc,
1852 Prefix => New_Occurrence_Of (Index_T, Loc),
1853 Attribute_Name => Name_Succ,
1854 Expressions => New_List (
1855 New_Occurrence_Of (Bn, Loc)))));
1858 -- If separate indexes, we need a declare block for An and Bn, and a
1859 -- loop without an iteration scheme.
1861 if Need_Separate_Indexes then
1863 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1866 Make_Block_Statement (Loc,
1867 Declarations => New_List (
1868 Make_Object_Declaration (Loc,
1869 Defining_Identifier => An,
1870 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1871 Expression => Arr_Attr (A, Name_First, N)),
1873 Make_Object_Declaration (Loc,
1874 Defining_Identifier => Bn,
1875 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1876 Expression => Arr_Attr (B, Name_First, N))),
1878 Handled_Statement_Sequence =>
1879 Make_Handled_Sequence_Of_Statements (Loc,
1880 Statements => New_List (Loop_Stm)));
1882 -- If no separate indexes, return loop statement with explicit
1883 -- iteration scheme on its own.
1887 Make_Implicit_Loop_Statement (Nod,
1888 Statements => Stm_List,
1890 Make_Iteration_Scheme (Loc,
1891 Loop_Parameter_Specification =>
1892 Make_Loop_Parameter_Specification (Loc,
1893 Defining_Identifier => An,
1894 Discrete_Subtype_Definition =>
1895 Arr_Attr (A, Name_Range, N))));
1898 end Handle_One_Dimension;
1900 -----------------------
1901 -- Test_Empty_Arrays --
1902 -----------------------
1904 function Test_Empty_Arrays return Node_Id is
1914 for J in 1 .. Number_Dimensions (Ltyp) loop
1917 Left_Opnd => Arr_Attr (A, Name_Length, J),
1918 Right_Opnd => Make_Integer_Literal (Loc, 0));
1922 Left_Opnd => Arr_Attr (B, Name_Length, J),
1923 Right_Opnd => Make_Integer_Literal (Loc, 0));
1932 Left_Opnd => Relocate_Node (Alist),
1933 Right_Opnd => Atest);
1937 Left_Opnd => Relocate_Node (Blist),
1938 Right_Opnd => Btest);
1945 Right_Opnd => Blist);
1946 end Test_Empty_Arrays;
1948 -----------------------------
1949 -- Test_Lengths_Correspond --
1950 -----------------------------
1952 function Test_Lengths_Correspond return Node_Id is
1958 for J in 1 .. Number_Dimensions (Ltyp) loop
1961 Left_Opnd => Arr_Attr (A, Name_Length, J),
1962 Right_Opnd => Arr_Attr (B, Name_Length, J));
1969 Left_Opnd => Relocate_Node (Result),
1970 Right_Opnd => Rtest);
1975 end Test_Lengths_Correspond;
1977 -- Start of processing for Expand_Array_Equality
1980 Ltyp := Get_Arg_Type (Lhs);
1981 Rtyp := Get_Arg_Type (Rhs);
1983 -- For now, if the argument types are not the same, go to the base type,
1984 -- since the code assumes that the formals have the same type. This is
1985 -- fixable in future ???
1987 if Ltyp /= Rtyp then
1988 Ltyp := Base_Type (Ltyp);
1989 Rtyp := Base_Type (Rtyp);
1990 pragma Assert (Ltyp = Rtyp);
1993 -- If the array type is distinct from the type of the arguments, it
1994 -- is the full view of a private type. Apply an unchecked conversion
1995 -- to ensure that analysis of the code below succeeds.
1998 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
2000 New_Lhs := OK_Convert_To (Ltyp, Lhs);
2006 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
2008 New_Rhs := OK_Convert_To (Rtyp, Rhs);
2013 First_Idx := First_Index (Ltyp);
2015 -- If optimization is enabled and the array boils down to a couple of
2016 -- consecutive elements, generate a simple conjunction of comparisons
2017 -- which should be easier to optimize by the code generator.
2019 if Optimization_Level > 0
2020 and then Ltyp = Rtyp
2021 and then Is_Constrained (Ltyp)
2022 and then Number_Dimensions (Ltyp) = 1
2023 and then Nkind (First_Idx) = N_Range
2024 and then Compile_Time_Known_Value (Low_Bound (First_Idx))
2025 and then Compile_Time_Known_Value (High_Bound (First_Idx))
2026 and then Expr_Value (High_Bound (First_Idx)) =
2027 Expr_Value (Low_Bound (First_Idx)) + 1
2030 Ctyp : constant Entity_Id := Component_Type (Ltyp);
2032 TestL, TestH : Node_Id;
2036 Make_Indexed_Component (Loc,
2037 Prefix => New_Copy_Tree (New_Lhs),
2039 New_List (New_Copy_Tree (Low_Bound (First_Idx))));
2042 Make_Indexed_Component (Loc,
2043 Prefix => New_Copy_Tree (New_Rhs),
2045 New_List (New_Copy_Tree (Low_Bound (First_Idx))));
2047 TestL := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies);
2050 Make_Indexed_Component (Loc,
2053 New_List (New_Copy_Tree (High_Bound (First_Idx))));
2056 Make_Indexed_Component (Loc,
2059 New_List (New_Copy_Tree (High_Bound (First_Idx))));
2061 TestH := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies);
2064 Make_And_Then (Loc, Left_Opnd => TestL, Right_Opnd => TestH);
2068 -- Build list of formals for function
2070 Formals := New_List (
2071 Make_Parameter_Specification (Loc,
2072 Defining_Identifier => A,
2073 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)),
2075 Make_Parameter_Specification (Loc,
2076 Defining_Identifier => B,
2077 Parameter_Type => New_Occurrence_Of (Rtyp, Loc)));
2079 Func_Name := Make_Temporary (Loc, 'E');
2081 -- Build statement sequence for function
2084 Make_Subprogram_Body (Loc,
2086 Make_Function_Specification (Loc,
2087 Defining_Unit_Name => Func_Name,
2088 Parameter_Specifications => Formals,
2089 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
2091 Declarations => Decls,
2093 Handled_Statement_Sequence =>
2094 Make_Handled_Sequence_Of_Statements (Loc,
2095 Statements => New_List (
2097 Make_Implicit_If_Statement (Nod,
2098 Condition => Test_Empty_Arrays,
2099 Then_Statements => New_List (
2100 Make_Simple_Return_Statement (Loc,
2102 New_Occurrence_Of (Standard_True, Loc)))),
2104 Make_Implicit_If_Statement (Nod,
2105 Condition => Test_Lengths_Correspond,
2106 Then_Statements => New_List (
2107 Make_Simple_Return_Statement (Loc,
2108 Expression => New_Occurrence_Of (Standard_False, Loc)))),
2110 Handle_One_Dimension (1, First_Idx),
2112 Make_Simple_Return_Statement (Loc,
2113 Expression => New_Occurrence_Of (Standard_True, Loc)))));
2115 Set_Has_Completion (Func_Name, True);
2116 Set_Is_Inlined (Func_Name);
2118 Append_To (Bodies, Func_Body);
2121 Make_Function_Call (Loc,
2122 Name => New_Occurrence_Of (Func_Name, Loc),
2123 Parameter_Associations => New_List (New_Lhs, New_Rhs));
2124 end Expand_Array_Equality;
2126 -----------------------------
2127 -- Expand_Boolean_Operator --
2128 -----------------------------
2130 -- Note that we first get the actual subtypes of the operands, since we
2131 -- always want to deal with types that have bounds.
2133 procedure Expand_Boolean_Operator (N : Node_Id) is
2134 Typ : constant Entity_Id := Etype (N);
2137 -- Special case of bit packed array where both operands are known to be
2138 -- properly aligned. In this case we use an efficient run time routine
2139 -- to carry out the operation (see System.Bit_Ops).
2141 if Is_Bit_Packed_Array (Typ)
2142 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2143 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2145 Expand_Packed_Boolean_Operator (N);
2149 -- For the normal non-packed case, the general expansion is to build
2150 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2151 -- and then inserting it into the tree. The original operator node is
2152 -- then rewritten as a call to this function. We also use this in the
2153 -- packed case if either operand is a possibly unaligned object.
2156 Loc : constant Source_Ptr := Sloc (N);
2157 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2158 R : Node_Id := Relocate_Node (Right_Opnd (N));
2159 Func_Body : Node_Id;
2160 Func_Name : Entity_Id;
2163 Convert_To_Actual_Subtype (L);
2164 Convert_To_Actual_Subtype (R);
2165 Ensure_Defined (Etype (L), N);
2166 Ensure_Defined (Etype (R), N);
2167 Apply_Length_Check (R, Etype (L));
2169 if Nkind (N) = N_Op_Xor then
2170 R := Duplicate_Subexpr (R);
2171 Silly_Boolean_Array_Xor_Test (N, R, Etype (L));
2174 if Nkind (Parent (N)) = N_Assignment_Statement
2175 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2177 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2179 elsif Nkind (Parent (N)) = N_Op_Not
2180 and then Nkind (N) = N_Op_And
2181 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2182 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2186 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2187 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2188 Insert_Action (N, Func_Body);
2190 -- Now rewrite the expression with a call
2192 if Transform_Function_Array then
2194 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
2203 Make_Object_Declaration (Loc,
2204 Defining_Identifier => Temp_Id,
2205 Object_Definition =>
2206 New_Occurrence_Of (Etype (L), Loc));
2209 -- Proc_Call (L, R, Temp);
2212 Make_Procedure_Call_Statement (Loc,
2213 Name => New_Occurrence_Of (Func_Name, Loc),
2214 Parameter_Associations =>
2217 Make_Type_Conversion
2218 (Loc, New_Occurrence_Of (Etype (L), Loc), R),
2219 New_Occurrence_Of (Temp_Id, Loc)));
2221 Insert_Actions (Parent (N), New_List (Decl, Call));
2222 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
2226 Make_Function_Call (Loc,
2227 Name => New_Occurrence_Of (Func_Name, Loc),
2228 Parameter_Associations =>
2231 Make_Type_Conversion
2232 (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
2235 Analyze_And_Resolve (N, Typ);
2238 end Expand_Boolean_Operator;
2240 ------------------------------------------------
2241 -- Expand_Compare_Minimize_Eliminate_Overflow --
2242 ------------------------------------------------
2244 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2245 Loc : constant Source_Ptr := Sloc (N);
2247 Result_Type : constant Entity_Id := Etype (N);
2248 -- Capture result type (could be a derived boolean type)
2253 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2254 -- Entity for Long_Long_Integer'Base
2256 Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
2257 -- Current overflow checking mode
2260 procedure Set_False;
2261 -- These procedures rewrite N with an occurrence of Standard_True or
2262 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2268 procedure Set_False is
2270 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2271 Warn_On_Known_Condition (N);
2278 procedure Set_True is
2280 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2281 Warn_On_Known_Condition (N);
2284 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2287 -- Nothing to do unless we have a comparison operator with operands
2288 -- that are signed integer types, and we are operating in either
2289 -- MINIMIZED or ELIMINATED overflow checking mode.
2291 if Nkind (N) not in N_Op_Compare
2292 or else Check not in Minimized_Or_Eliminated
2293 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
2298 -- OK, this is the case we are interested in. First step is to process
2299 -- our operands using the Minimize_Eliminate circuitry which applies
2300 -- this processing to the two operand subtrees.
2302 Minimize_Eliminate_Overflows
2303 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
2304 Minimize_Eliminate_Overflows
2305 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
2307 -- See if the range information decides the result of the comparison.
2308 -- We can only do this if we in fact have full range information (which
2309 -- won't be the case if either operand is bignum at this stage).
2311 if Llo /= No_Uint and then Rlo /= No_Uint then
2312 case N_Op_Compare (Nkind (N)) is
2314 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2316 elsif Llo > Rhi or else Lhi < Rlo then
2323 elsif Lhi < Rlo then
2330 elsif Lhi <= Rlo then
2337 elsif Lhi <= Rlo then
2344 elsif Lhi < Rlo then
2349 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2351 elsif Llo > Rhi or else Lhi < Rlo then
2356 -- All done if we did the rewrite
2358 if Nkind (N) not in N_Op_Compare then
2363 -- Otherwise, time to do the comparison
2366 Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2367 Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2370 -- If the two operands have the same signed integer type we are
2371 -- all set, nothing more to do. This is the case where either
2372 -- both operands were unchanged, or we rewrote both of them to
2373 -- be Long_Long_Integer.
2375 -- Note: Entity for the comparison may be wrong, but it's not worth
2376 -- the effort to change it, since the back end does not use it.
2378 if Is_Signed_Integer_Type (Ltype)
2379 and then Base_Type (Ltype) = Base_Type (Rtype)
2383 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2385 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2387 Left : Node_Id := Left_Opnd (N);
2388 Right : Node_Id := Right_Opnd (N);
2389 -- Bignum references for left and right operands
2392 if not Is_RTE (Ltype, RE_Bignum) then
2393 Left := Convert_To_Bignum (Left);
2394 elsif not Is_RTE (Rtype, RE_Bignum) then
2395 Right := Convert_To_Bignum (Right);
2398 -- We rewrite our node with:
2401 -- Bnn : Result_Type;
2403 -- M : Mark_Id := SS_Mark;
2405 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2413 Blk : constant Node_Id := Make_Bignum_Block (Loc);
2414 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2418 case N_Op_Compare (Nkind (N)) is
2419 when N_Op_Eq => Ent := RE_Big_EQ;
2420 when N_Op_Ge => Ent := RE_Big_GE;
2421 when N_Op_Gt => Ent := RE_Big_GT;
2422 when N_Op_Le => Ent := RE_Big_LE;
2423 when N_Op_Lt => Ent := RE_Big_LT;
2424 when N_Op_Ne => Ent := RE_Big_NE;
2427 -- Insert assignment to Bnn into the bignum block
2430 (First (Statements (Handled_Statement_Sequence (Blk))),
2431 Make_Assignment_Statement (Loc,
2432 Name => New_Occurrence_Of (Bnn, Loc),
2434 Make_Function_Call (Loc,
2436 New_Occurrence_Of (RTE (Ent), Loc),
2437 Parameter_Associations => New_List (Left, Right))));
2439 -- Now do the rewrite with expression actions
2442 Make_Expression_With_Actions (Loc,
2443 Actions => New_List (
2444 Make_Object_Declaration (Loc,
2445 Defining_Identifier => Bnn,
2446 Object_Definition =>
2447 New_Occurrence_Of (Result_Type, Loc)),
2449 Expression => New_Occurrence_Of (Bnn, Loc)));
2450 Analyze_And_Resolve (N, Result_Type);
2454 -- No bignums involved, but types are different, so we must have
2455 -- rewritten one of the operands as a Long_Long_Integer but not
2458 -- If left operand is Long_Long_Integer, convert right operand
2459 -- and we are done (with a comparison of two Long_Long_Integers).
2461 elsif Ltype = LLIB then
2462 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2463 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2466 -- If right operand is Long_Long_Integer, convert left operand
2467 -- and we are done (with a comparison of two Long_Long_Integers).
2469 -- This is the only remaining possibility
2471 else pragma Assert (Rtype = LLIB);
2472 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2473 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2477 end Expand_Compare_Minimize_Eliminate_Overflow;
2479 -------------------------------
2480 -- Expand_Composite_Equality --
2481 -------------------------------
2483 -- This function is only called for comparing internal fields of composite
2484 -- types when these fields are themselves composites. This is a special
2485 -- case because it is not possible to respect normal Ada visibility rules.
2487 function Expand_Composite_Equality
2492 Bodies : List_Id) return Node_Id
2494 Loc : constant Source_Ptr := Sloc (Nod);
2495 Full_Type : Entity_Id;
2498 -- Start of processing for Expand_Composite_Equality
2501 if Is_Private_Type (Typ) then
2502 Full_Type := Underlying_Type (Typ);
2507 -- If the private type has no completion the context may be the
2508 -- expansion of a composite equality for a composite type with some
2509 -- still incomplete components. The expression will not be analyzed
2510 -- until the enclosing type is completed, at which point this will be
2511 -- properly expanded, unless there is a bona fide completion error.
2513 if No (Full_Type) then
2514 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2517 Full_Type := Base_Type (Full_Type);
2519 -- When the base type itself is private, use the full view to expand
2520 -- the composite equality.
2522 if Is_Private_Type (Full_Type) then
2523 Full_Type := Underlying_Type (Full_Type);
2526 -- Case of array types
2528 if Is_Array_Type (Full_Type) then
2530 -- If the operand is an elementary type other than a floating-point
2531 -- type, then we can simply use the built-in block bitwise equality,
2532 -- since the predefined equality operators always apply and bitwise
2533 -- equality is fine for all these cases.
2535 if Is_Elementary_Type (Component_Type (Full_Type))
2536 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2538 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2540 -- For composite component types, and floating-point types, use the
2541 -- expansion. This deals with tagged component types (where we use
2542 -- the applicable equality routine) and floating-point (where we
2543 -- need to worry about negative zeroes), and also the case of any
2544 -- composite type recursively containing such fields.
2548 Comp_Typ : Entity_Id;
2555 -- Do the comparison in the type (or its full view) and not in
2556 -- its unconstrained base type, because the latter operation is
2557 -- more complex and would also require an unchecked conversion.
2559 if Is_Private_Type (Typ) then
2560 Comp_Typ := Underlying_Type (Typ);
2565 -- Except for the case where the bounds of the type depend on a
2566 -- discriminant, or else we would run into scoping issues.
2568 Indx := First_Index (Comp_Typ);
2569 while Present (Indx) loop
2570 Ityp := Etype (Indx);
2572 Lo := Type_Low_Bound (Ityp);
2573 Hi := Type_High_Bound (Ityp);
2575 if (Nkind (Lo) = N_Identifier
2576 and then Ekind (Entity (Lo)) = E_Discriminant)
2578 (Nkind (Hi) = N_Identifier
2579 and then Ekind (Entity (Hi)) = E_Discriminant)
2581 Comp_Typ := Full_Type;
2588 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Comp_Typ);
2592 -- Case of tagged record types
2594 elsif Is_Tagged_Type (Full_Type) then
2595 Eq_Op := Find_Primitive_Eq (Typ);
2596 pragma Assert (Present (Eq_Op));
2599 Make_Function_Call (Loc,
2600 Name => New_Occurrence_Of (Eq_Op, Loc),
2601 Parameter_Associations =>
2603 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2604 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2606 -- Case of untagged record types
2608 elsif Is_Record_Type (Full_Type) then
2609 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2611 if Present (Eq_Op) then
2612 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2614 -- Inherited equality from parent type. Convert the actuals to
2615 -- match signature of operation.
2618 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2622 Make_Function_Call (Loc,
2623 Name => New_Occurrence_Of (Eq_Op, Loc),
2624 Parameter_Associations => New_List (
2625 OK_Convert_To (T, Lhs),
2626 OK_Convert_To (T, Rhs)));
2630 -- Comparison between Unchecked_Union components
2632 if Is_Unchecked_Union (Full_Type) then
2634 Lhs_Type : Node_Id := Full_Type;
2635 Rhs_Type : Node_Id := Full_Type;
2636 Lhs_Discr_Val : Node_Id;
2637 Rhs_Discr_Val : Node_Id;
2642 if Nkind (Lhs) = N_Selected_Component then
2643 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2648 if Nkind (Rhs) = N_Selected_Component then
2649 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2652 -- Lhs of the composite equality
2654 if Is_Constrained (Lhs_Type) then
2656 -- Since the enclosing record type can never be an
2657 -- Unchecked_Union (this code is executed for records
2658 -- that do not have variants), we may reference its
2661 if Nkind (Lhs) = N_Selected_Component
2662 and then Has_Per_Object_Constraint
2663 (Entity (Selector_Name (Lhs)))
2666 Make_Selected_Component (Loc,
2667 Prefix => Prefix (Lhs),
2670 (Get_Discriminant_Value
2671 (First_Discriminant (Lhs_Type),
2673 Stored_Constraint (Lhs_Type))));
2678 (Get_Discriminant_Value
2679 (First_Discriminant (Lhs_Type),
2681 Stored_Constraint (Lhs_Type)));
2685 -- It is not possible to infer the discriminant since
2686 -- the subtype is not constrained.
2689 Make_Raise_Program_Error (Loc,
2690 Reason => PE_Unchecked_Union_Restriction);
2693 -- Rhs of the composite equality
2695 if Is_Constrained (Rhs_Type) then
2696 if Nkind (Rhs) = N_Selected_Component
2697 and then Has_Per_Object_Constraint
2698 (Entity (Selector_Name (Rhs)))
2701 Make_Selected_Component (Loc,
2702 Prefix => Prefix (Rhs),
2705 (Get_Discriminant_Value
2706 (First_Discriminant (Rhs_Type),
2708 Stored_Constraint (Rhs_Type))));
2713 (Get_Discriminant_Value
2714 (First_Discriminant (Rhs_Type),
2716 Stored_Constraint (Rhs_Type)));
2721 Make_Raise_Program_Error (Loc,
2722 Reason => PE_Unchecked_Union_Restriction);
2725 -- Call the TSS equality function with the inferred
2726 -- discriminant values.
2729 Make_Function_Call (Loc,
2730 Name => New_Occurrence_Of (Eq_Op, Loc),
2731 Parameter_Associations => New_List (
2738 -- All cases other than comparing Unchecked_Union types
2742 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2745 Make_Function_Call (Loc,
2747 New_Occurrence_Of (Eq_Op, Loc),
2748 Parameter_Associations => New_List (
2749 OK_Convert_To (T, Lhs),
2750 OK_Convert_To (T, Rhs)));
2755 -- Equality composes in Ada 2012 for untagged record types. It also
2756 -- composes for bounded strings, because they are part of the
2757 -- predefined environment. We could make it compose for bounded
2758 -- strings by making them tagged, or by making sure all subcomponents
2759 -- are set to the same value, even when not used. Instead, we have
2760 -- this special case in the compiler, because it's more efficient.
2762 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
2764 -- If no TSS has been created for the type, check whether there is
2765 -- a primitive equality declared for it.
2768 Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
2771 -- Use user-defined primitive if it exists, otherwise use
2772 -- predefined equality.
2774 if Present (Op) then
2777 return Make_Op_Eq (Loc, Lhs, Rhs);
2782 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2785 -- Non-composite types (always use predefined equality)
2788 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2790 end Expand_Composite_Equality;
2792 ------------------------
2793 -- Expand_Concatenate --
2794 ------------------------
2796 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2797 Loc : constant Source_Ptr := Sloc (Cnode);
2799 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2800 -- Result type of concatenation
2802 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2803 -- Component type. Elements of this component type can appear as one
2804 -- of the operands of concatenation as well as arrays.
2806 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2809 Ityp : constant Entity_Id := Base_Type (Istyp);
2810 -- Index type. This is the base type of the index subtype, and is used
2811 -- for all computed bounds (which may be out of range of Istyp in the
2812 -- case of null ranges).
2815 -- This is the type we use to do arithmetic to compute the bounds and
2816 -- lengths of operands. The choice of this type is a little subtle and
2817 -- is discussed in a separate section at the start of the body code.
2819 Concatenation_Error : exception;
2820 -- Raised if concatenation is sure to raise a CE
2822 Result_May_Be_Null : Boolean := True;
2823 -- Reset to False if at least one operand is encountered which is known
2824 -- at compile time to be non-null. Used for handling the special case
2825 -- of setting the high bound to the last operand high bound for a null
2826 -- result, thus ensuring a proper high bound in the super-flat case.
2828 N : constant Nat := List_Length (Opnds);
2829 -- Number of concatenation operands including possibly null operands
2832 -- Number of operands excluding any known to be null, except that the
2833 -- last operand is always retained, in case it provides the bounds for
2836 Opnd : Node_Id := Empty;
2837 -- Current operand being processed in the loop through operands. After
2838 -- this loop is complete, always contains the last operand (which is not
2839 -- the same as Operands (NN), since null operands are skipped).
2841 -- Arrays describing the operands, only the first NN entries of each
2842 -- array are set (NN < N when we exclude known null operands).
2844 Is_Fixed_Length : array (1 .. N) of Boolean;
2845 -- True if length of corresponding operand known at compile time
2847 Operands : array (1 .. N) of Node_Id;
2848 -- Set to the corresponding entry in the Opnds list (but note that null
2849 -- operands are excluded, so not all entries in the list are stored).
2851 Fixed_Length : array (1 .. N) of Uint;
2852 -- Set to length of operand. Entries in this array are set only if the
2853 -- corresponding entry in Is_Fixed_Length is True.
2855 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2856 -- Set to lower bound of operand. Either an integer literal in the case
2857 -- where the bound is known at compile time, else actual lower bound.
2858 -- The operand low bound is of type Ityp.
2860 Var_Length : array (1 .. N) of Entity_Id;
2861 -- Set to an entity of type Natural that contains the length of an
2862 -- operand whose length is not known at compile time. Entries in this
2863 -- array are set only if the corresponding entry in Is_Fixed_Length
2864 -- is False. The entity is of type Artyp.
2866 Aggr_Length : array (0 .. N) of Node_Id;
2867 -- The J'th entry in an expression node that represents the total length
2868 -- of operands 1 through J. It is either an integer literal node, or a
2869 -- reference to a constant entity with the right value, so it is fine
2870 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth
2871 -- entry always is set to zero. The length is of type Artyp.
2873 Low_Bound : Node_Id := Empty;
2874 -- A tree node representing the low bound of the result (of type Ityp).
2875 -- This is either an integer literal node, or an identifier reference to
2876 -- a constant entity initialized to the appropriate value.
2878 Last_Opnd_Low_Bound : Node_Id := Empty;
2879 -- A tree node representing the low bound of the last operand. This
2880 -- need only be set if the result could be null. It is used for the
2881 -- special case of setting the right low bound for a null result.
2882 -- This is of type Ityp.
2884 Last_Opnd_High_Bound : Node_Id := Empty;
2885 -- A tree node representing the high bound of the last operand. This
2886 -- need only be set if the result could be null. It is used for the
2887 -- special case of setting the right high bound for a null result.
2888 -- This is of type Ityp.
2890 High_Bound : Node_Id := Empty;
2891 -- A tree node representing the high bound of the result (of type Ityp)
2893 Result : Node_Id := Empty;
2894 -- Result of the concatenation (of type Ityp)
2896 Actions : constant List_Id := New_List;
2897 -- Collect actions to be inserted
2899 Known_Non_Null_Operand_Seen : Boolean;
2900 -- Set True during generation of the assignments of operands into
2901 -- result once an operand known to be non-null has been seen.
2903 function Library_Level_Target return Boolean;
2904 -- Return True if the concatenation is within the expression of the
2905 -- declaration of a library-level object.
2907 function Make_Artyp_Literal (Val : Nat) return Node_Id;
2908 -- This function makes an N_Integer_Literal node that is returned in
2909 -- analyzed form with the type set to Artyp. Importantly this literal
2910 -- is not flagged as static, so that if we do computations with it that
2911 -- result in statically detected out of range conditions, we will not
2912 -- generate error messages but instead warning messages.
2914 function To_Artyp (X : Node_Id) return Node_Id;
2915 -- Given a node of type Ityp, returns the corresponding value of type
2916 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2917 -- For enum types, the Pos of the value is returned.
2919 function To_Ityp (X : Node_Id) return Node_Id;
2920 -- The inverse function (uses Val in the case of enumeration types)
2922 --------------------------
2923 -- Library_Level_Target --
2924 --------------------------
2926 function Library_Level_Target return Boolean is
2927 P : Node_Id := Parent (Cnode);
2930 while Present (P) loop
2931 if Nkind (P) = N_Object_Declaration then
2932 return Is_Library_Level_Entity (Defining_Identifier (P));
2934 -- Prevent the search from going too far
2936 elsif Is_Body_Or_Package_Declaration (P) then
2944 end Library_Level_Target;
2946 ------------------------
2947 -- Make_Artyp_Literal --
2948 ------------------------
2950 function Make_Artyp_Literal (Val : Nat) return Node_Id is
2951 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2953 Set_Etype (Result, Artyp);
2954 Set_Analyzed (Result, True);
2955 Set_Is_Static_Expression (Result, False);
2957 end Make_Artyp_Literal;
2963 function To_Artyp (X : Node_Id) return Node_Id is
2965 if Ityp = Base_Type (Artyp) then
2968 elsif Is_Enumeration_Type (Ityp) then
2970 Make_Attribute_Reference (Loc,
2971 Prefix => New_Occurrence_Of (Ityp, Loc),
2972 Attribute_Name => Name_Pos,
2973 Expressions => New_List (X));
2976 return Convert_To (Artyp, X);
2984 function To_Ityp (X : Node_Id) return Node_Id is
2986 if Is_Enumeration_Type (Ityp) then
2988 Make_Attribute_Reference (Loc,
2989 Prefix => New_Occurrence_Of (Ityp, Loc),
2990 Attribute_Name => Name_Val,
2991 Expressions => New_List (X));
2993 -- Case where we will do a type conversion
2996 if Ityp = Base_Type (Artyp) then
2999 return Convert_To (Ityp, X);
3004 -- Local Declarations
3006 Opnd_Typ : Entity_Id;
3007 Subtyp_Ind : Entity_Id;
3014 -- Start of processing for Expand_Concatenate
3017 -- Choose an appropriate computational type
3019 -- We will be doing calculations of lengths and bounds in this routine
3020 -- and computing one from the other in some cases, e.g. getting the high
3021 -- bound by adding the length-1 to the low bound.
3023 -- We can't just use the index type, or even its base type for this
3024 -- purpose for two reasons. First it might be an enumeration type which
3025 -- is not suitable for computations of any kind, and second it may
3026 -- simply not have enough range. For example if the index type is
3027 -- -128..+127 then lengths can be up to 256, which is out of range of
3030 -- For enumeration types, we can simply use Standard_Integer, this is
3031 -- sufficient since the actual number of enumeration literals cannot
3032 -- possibly exceed the range of integer (remember we will be doing the
3033 -- arithmetic with POS values, not representation values).
3035 if Is_Enumeration_Type (Ityp) then
3036 Artyp := Standard_Integer;
3038 -- If index type is Positive, we use the standard unsigned type, to give
3039 -- more room on the top of the range, obviating the need for an overflow
3040 -- check when creating the upper bound. This is needed to avoid junk
3041 -- overflow checks in the common case of String types.
3043 -- ??? Disabled for now
3045 -- elsif Istyp = Standard_Positive then
3046 -- Artyp := Standard_Unsigned;
3048 -- For modular types, we use a 32-bit modular type for types whose size
3049 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
3050 -- identity type, and for larger unsigned types we use a 64-bit type.
3052 elsif Is_Modular_Integer_Type (Ityp) then
3053 if RM_Size (Ityp) < Standard_Integer_Size then
3054 Artyp := Standard_Unsigned;
3055 elsif RM_Size (Ityp) = Standard_Integer_Size then
3058 Artyp := Standard_Long_Long_Unsigned;
3061 -- Similar treatment for signed types
3064 if RM_Size (Ityp) < Standard_Integer_Size then
3065 Artyp := Standard_Integer;
3066 elsif RM_Size (Ityp) = Standard_Integer_Size then
3069 Artyp := Standard_Long_Long_Integer;
3073 -- Supply dummy entry at start of length array
3075 Aggr_Length (0) := Make_Artyp_Literal (0);
3077 -- Go through operands setting up the above arrays
3081 Opnd := Remove_Head (Opnds);
3082 Opnd_Typ := Etype (Opnd);
3084 -- The parent got messed up when we put the operands in a list,
3085 -- so now put back the proper parent for the saved operand, that
3086 -- is to say the concatenation node, to make sure that each operand
3087 -- is seen as a subexpression, e.g. if actions must be inserted.
3089 Set_Parent (Opnd, Cnode);
3091 -- Set will be True when we have setup one entry in the array
3095 -- Singleton element (or character literal) case
3097 if Base_Type (Opnd_Typ) = Ctyp then
3099 Operands (NN) := Opnd;
3100 Is_Fixed_Length (NN) := True;
3101 Fixed_Length (NN) := Uint_1;
3102 Result_May_Be_Null := False;
3104 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3105 -- since we know that the result cannot be null).
3107 Opnd_Low_Bound (NN) :=
3108 Make_Attribute_Reference (Loc,
3109 Prefix => New_Occurrence_Of (Istyp, Loc),
3110 Attribute_Name => Name_First);
3114 -- String literal case (can only occur for strings of course)
3116 elsif Nkind (Opnd) = N_String_Literal then
3117 Len := String_Literal_Length (Opnd_Typ);
3120 Result_May_Be_Null := False;
3123 -- Capture last operand low and high bound if result could be null
3125 if J = N and then Result_May_Be_Null then
3126 Last_Opnd_Low_Bound :=
3127 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3129 Last_Opnd_High_Bound :=
3130 Make_Op_Subtract (Loc,
3132 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
3133 Right_Opnd => Make_Integer_Literal (Loc, 1));
3136 -- Skip null string literal
3138 if J < N and then Len = 0 then
3143 Operands (NN) := Opnd;
3144 Is_Fixed_Length (NN) := True;
3146 -- Set length and bounds
3148 Fixed_Length (NN) := Len;
3150 Opnd_Low_Bound (NN) :=
3151 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3158 -- Check constrained case with known bounds
3160 if Is_Constrained (Opnd_Typ) then
3162 Index : constant Node_Id := First_Index (Opnd_Typ);
3163 Indx_Typ : constant Entity_Id := Etype (Index);
3164 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
3165 Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
3168 -- Fixed length constrained array type with known at compile
3169 -- time bounds is last case of fixed length operand.
3171 if Compile_Time_Known_Value (Lo)
3173 Compile_Time_Known_Value (Hi)
3176 Loval : constant Uint := Expr_Value (Lo);
3177 Hival : constant Uint := Expr_Value (Hi);
3178 Len : constant Uint :=
3179 UI_Max (Hival - Loval + 1, Uint_0);
3183 Result_May_Be_Null := False;
3186 -- Capture last operand bounds if result could be null
3188 if J = N and then Result_May_Be_Null then
3189 Last_Opnd_Low_Bound :=
3191 Make_Integer_Literal (Loc, Expr_Value (Lo)));
3193 Last_Opnd_High_Bound :=
3195 Make_Integer_Literal (Loc, Expr_Value (Hi)));
3198 -- Exclude null length case unless last operand
3200 if J < N and then Len = 0 then
3205 Operands (NN) := Opnd;
3206 Is_Fixed_Length (NN) := True;
3207 Fixed_Length (NN) := Len;
3209 Opnd_Low_Bound (NN) :=
3211 (Make_Integer_Literal (Loc, Expr_Value (Lo)));
3218 -- All cases where the length is not known at compile time, or the
3219 -- special case of an operand which is known to be null but has a
3220 -- lower bound other than 1 or is other than a string type.
3225 -- Capture operand bounds
3227 Opnd_Low_Bound (NN) :=
3228 Make_Attribute_Reference (Loc,
3230 Duplicate_Subexpr (Opnd, Name_Req => True),
3231 Attribute_Name => Name_First);
3233 -- Capture last operand bounds if result could be null
3235 if J = N and Result_May_Be_Null then
3236 Last_Opnd_Low_Bound :=
3238 Make_Attribute_Reference (Loc,
3240 Duplicate_Subexpr (Opnd, Name_Req => True),
3241 Attribute_Name => Name_First));
3243 Last_Opnd_High_Bound :=
3245 Make_Attribute_Reference (Loc,
3247 Duplicate_Subexpr (Opnd, Name_Req => True),
3248 Attribute_Name => Name_Last));
3251 -- Capture length of operand in entity
3253 Operands (NN) := Opnd;
3254 Is_Fixed_Length (NN) := False;
3256 Var_Length (NN) := Make_Temporary (Loc, 'L');
3259 Make_Object_Declaration (Loc,
3260 Defining_Identifier => Var_Length (NN),
3261 Constant_Present => True,
3262 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3264 Make_Attribute_Reference (Loc,
3266 Duplicate_Subexpr (Opnd, Name_Req => True),
3267 Attribute_Name => Name_Length)));
3271 -- Set next entry in aggregate length array
3273 -- For first entry, make either integer literal for fixed length
3274 -- or a reference to the saved length for variable length.
3277 if Is_Fixed_Length (1) then
3278 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
3280 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
3283 -- If entry is fixed length and only fixed lengths so far, make
3284 -- appropriate new integer literal adding new length.
3286 elsif Is_Fixed_Length (NN)
3287 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3290 Make_Integer_Literal (Loc,
3291 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3293 -- All other cases, construct an addition node for the length and
3294 -- create an entity initialized to this length.
3297 Ent := Make_Temporary (Loc, 'L');
3299 if Is_Fixed_Length (NN) then
3300 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3302 Clen := New_Occurrence_Of (Var_Length (NN), Loc);
3306 Make_Object_Declaration (Loc,
3307 Defining_Identifier => Ent,
3308 Constant_Present => True,
3309 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3312 Left_Opnd => New_Copy_Tree (Aggr_Length (NN - 1)),
3313 Right_Opnd => Clen)));
3315 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
3322 -- If we have only skipped null operands, return the last operand
3329 -- If we have only one non-null operand, return it and we are done.
3330 -- There is one case in which this cannot be done, and that is when
3331 -- the sole operand is of the element type, in which case it must be
3332 -- converted to an array, and the easiest way of doing that is to go
3333 -- through the normal general circuit.
3335 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
3336 Result := Operands (1);
3340 -- Cases where we have a real concatenation
3342 -- Next step is to find the low bound for the result array that we
3343 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3345 -- If the ultimate ancestor of the index subtype is a constrained array
3346 -- definition, then the lower bound is that of the index subtype as
3347 -- specified by (RM 4.5.3(6)).
3349 -- The right test here is to go to the root type, and then the ultimate
3350 -- ancestor is the first subtype of this root type.
3352 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
3354 Make_Attribute_Reference (Loc,
3356 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
3357 Attribute_Name => Name_First);
3359 -- If the first operand in the list has known length we know that
3360 -- the lower bound of the result is the lower bound of this operand.
3362 elsif Is_Fixed_Length (1) then
3363 Low_Bound := Opnd_Low_Bound (1);
3365 -- OK, we don't know the lower bound, we have to build a horrible
3366 -- if expression node of the form
3368 -- if Cond1'Length /= 0 then
3371 -- if Opnd2'Length /= 0 then
3376 -- The nesting ends either when we hit an operand whose length is known
3377 -- at compile time, or on reaching the last operand, whose low bound we
3378 -- take unconditionally whether or not it is null. It's easiest to do
3379 -- this with a recursive procedure:
3383 function Get_Known_Bound (J : Nat) return Node_Id;
3384 -- Returns the lower bound determined by operands J .. NN
3386 ---------------------
3387 -- Get_Known_Bound --
3388 ---------------------
3390 function Get_Known_Bound (J : Nat) return Node_Id is
3392 if Is_Fixed_Length (J) or else J = NN then
3393 return New_Copy_Tree (Opnd_Low_Bound (J));
3397 Make_If_Expression (Loc,
3398 Expressions => New_List (
3402 New_Occurrence_Of (Var_Length (J), Loc),
3404 Make_Integer_Literal (Loc, 0)),
3406 New_Copy_Tree (Opnd_Low_Bound (J)),
3407 Get_Known_Bound (J + 1)));
3409 end Get_Known_Bound;
3412 Ent := Make_Temporary (Loc, 'L');
3415 Make_Object_Declaration (Loc,
3416 Defining_Identifier => Ent,
3417 Constant_Present => True,
3418 Object_Definition => New_Occurrence_Of (Ityp, Loc),
3419 Expression => Get_Known_Bound (1)));
3421 Low_Bound := New_Occurrence_Of (Ent, Loc);
3425 pragma Assert (Present (Low_Bound));
3427 -- Now we can safely compute the upper bound, normally
3428 -- Low_Bound + Length - 1.
3433 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3435 Make_Op_Subtract (Loc,
3436 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3437 Right_Opnd => Make_Artyp_Literal (1))));
3439 -- Note that calculation of the high bound may cause overflow in some
3440 -- very weird cases, so in the general case we need an overflow check on
3441 -- the high bound. We can avoid this for the common case of string types
3442 -- and other types whose index is Positive, since we chose a wider range
3443 -- for the arithmetic type. If checks are suppressed we do not set the
3444 -- flag, and possibly superfluous warnings will be omitted.
3446 if Istyp /= Standard_Positive
3447 and then not Overflow_Checks_Suppressed (Istyp)
3449 Activate_Overflow_Check (High_Bound);
3452 -- Handle the exceptional case where the result is null, in which case
3453 -- case the bounds come from the last operand (so that we get the proper
3454 -- bounds if the last operand is super-flat).
3456 if Result_May_Be_Null then
3458 Make_If_Expression (Loc,
3459 Expressions => New_List (
3461 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3462 Right_Opnd => Make_Artyp_Literal (0)),
3463 Last_Opnd_Low_Bound,
3467 Make_If_Expression (Loc,
3468 Expressions => New_List (
3470 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3471 Right_Opnd => Make_Artyp_Literal (0)),
3472 Last_Opnd_High_Bound,
3476 -- Here is where we insert the saved up actions
3478 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3480 -- Now we construct an array object with appropriate bounds. We mark
3481 -- the target as internal to prevent useless initialization when
3482 -- Initialize_Scalars is enabled. Also since this is the actual result
3483 -- entity, we make sure we have debug information for the result.
3486 Make_Subtype_Indication (Loc,
3487 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3489 Make_Index_Or_Discriminant_Constraint (Loc,
3490 Constraints => New_List (
3492 Low_Bound => Low_Bound,
3493 High_Bound => High_Bound))));
3495 Ent := Make_Temporary (Loc, 'S');
3496 Set_Is_Internal (Ent);
3497 Set_Debug_Info_Needed (Ent);
3499 -- If we are concatenating strings and the current scope already uses
3500 -- the secondary stack, allocate the resulting string also on the
3501 -- secondary stack to avoid putting too much pressure on the primary
3503 -- Don't do this if -gnatd.h is set, as this will break the wrapping of
3504 -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat.
3506 if Atyp = Standard_String
3507 and then Uses_Sec_Stack (Current_Scope)
3508 and then RTE_Available (RE_SS_Pool)
3509 and then not Debug_Flag_Dot_H
3512 -- subtype Axx is ...;
3513 -- type Ayy is access Axx;
3514 -- Rxx : Ayy := new <subtype> [storage_pool = ss_pool];
3515 -- Sxx : <subtype> renames Rxx.all;
3519 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
3520 Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
3524 Insert_Action (Cnode,
3525 Make_Subtype_Declaration (Loc,
3526 Defining_Identifier => ConstrT,
3527 Subtype_Indication => Subtyp_Ind),
3528 Suppress => All_Checks);
3529 Freeze_Itype (ConstrT, Cnode);
3531 Insert_Action (Cnode,
3532 Make_Full_Type_Declaration (Loc,
3533 Defining_Identifier => Acc_Typ,
3535 Make_Access_To_Object_Definition (Loc,
3536 Subtype_Indication => New_Occurrence_Of (ConstrT, Loc))),
3537 Suppress => All_Checks);
3539 Make_Allocator (Loc,
3540 Expression => New_Occurrence_Of (ConstrT, Loc));
3542 -- Allocate on the secondary stack. This is currently done
3543 -- only for type String, which normally doesn't have default
3544 -- initialization, but we need to Set_No_Initialization in case
3545 -- of Initialize_Scalars or Normalize_Scalars; otherwise, the
3546 -- allocator will get transformed and will not use the secondary
3549 Set_Storage_Pool (Alloc, RTE (RE_SS_Pool));
3550 Set_Procedure_To_Call (Alloc, RTE (RE_SS_Allocate));
3551 Set_No_Initialization (Alloc);
3553 Temp := Make_Temporary (Loc, 'R', Alloc);
3554 Insert_Action (Cnode,
3555 Make_Object_Declaration (Loc,
3556 Defining_Identifier => Temp,
3557 Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
3558 Expression => Alloc),
3559 Suppress => All_Checks);
3561 Insert_Action (Cnode,
3562 Make_Object_Renaming_Declaration (Loc,
3563 Defining_Identifier => Ent,
3564 Subtype_Mark => New_Occurrence_Of (ConstrT, Loc),
3566 Make_Explicit_Dereference (Loc,
3567 Prefix => New_Occurrence_Of (Temp, Loc))),
3568 Suppress => All_Checks);
3571 -- If the bound is statically known to be out of range, we do not
3572 -- want to abort, we want a warning and a runtime constraint error.
3573 -- Note that we have arranged that the result will not be treated as
3574 -- a static constant, so we won't get an illegality during this
3576 -- We also enable checks (in particular range checks) in case the
3577 -- bounds of Subtyp_Ind are out of range.
3579 Insert_Action (Cnode,
3580 Make_Object_Declaration (Loc,
3581 Defining_Identifier => Ent,
3582 Object_Definition => Subtyp_Ind));
3585 -- If the result of the concatenation appears as the initializing
3586 -- expression of an object declaration, we can just rename the
3587 -- result, rather than copying it.
3589 Set_OK_To_Rename (Ent);
3591 -- Catch the static out of range case now
3593 if Raises_Constraint_Error (High_Bound) then
3594 raise Concatenation_Error;
3597 -- Now we will generate the assignments to do the actual concatenation
3599 -- There is one case in which we will not do this, namely when all the
3600 -- following conditions are met:
3602 -- The result type is Standard.String
3604 -- There are nine or fewer retained (non-null) operands
3606 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3607 -- and the debug flag gnatd.c is not set.
3609 -- The corresponding System.Concat_n.Str_Concat_n routine is
3610 -- available in the run time.
3612 -- If all these conditions are met then we generate a call to the
3613 -- relevant concatenation routine. The purpose of this is to avoid
3614 -- undesirable code bloat at -O0.
3616 -- If the concatenation is within the declaration of a library-level
3617 -- object, we call the built-in concatenation routines to prevent code
3618 -- bloat, regardless of the optimization level. This is space efficient
3619 -- and prevents linking problems when units are compiled with different
3620 -- optimization levels.
3622 if Atyp = Standard_String
3623 and then NN in 2 .. 9
3624 and then (((Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3625 and then not Debug_Flag_Dot_C)
3626 or else Library_Level_Target)
3629 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3640 if RTE_Available (RR (NN)) then
3642 Opnds : constant List_Id :=
3643 New_List (New_Occurrence_Of (Ent, Loc));
3646 for J in 1 .. NN loop
3647 if Is_List_Member (Operands (J)) then
3648 Remove (Operands (J));
3651 if Base_Type (Etype (Operands (J))) = Ctyp then
3653 Make_Aggregate (Loc,
3654 Component_Associations => New_List (
3655 Make_Component_Association (Loc,
3656 Choices => New_List (
3657 Make_Integer_Literal (Loc, 1)),
3658 Expression => Operands (J)))));
3661 Append_To (Opnds, Operands (J));
3665 Insert_Action (Cnode,
3666 Make_Procedure_Call_Statement (Loc,
3667 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
3668 Parameter_Associations => Opnds));
3670 Result := New_Occurrence_Of (Ent, Loc);
3677 -- Not special case so generate the assignments
3679 Known_Non_Null_Operand_Seen := False;
3681 for J in 1 .. NN loop
3683 Lo : constant Node_Id :=
3685 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3686 Right_Opnd => Aggr_Length (J - 1));
3688 Hi : constant Node_Id :=
3690 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3692 Make_Op_Subtract (Loc,
3693 Left_Opnd => Aggr_Length (J),
3694 Right_Opnd => Make_Artyp_Literal (1)));
3697 -- Singleton case, simple assignment
3699 if Base_Type (Etype (Operands (J))) = Ctyp then
3700 Known_Non_Null_Operand_Seen := True;
3701 Insert_Action (Cnode,
3702 Make_Assignment_Statement (Loc,
3704 Make_Indexed_Component (Loc,
3705 Prefix => New_Occurrence_Of (Ent, Loc),
3706 Expressions => New_List (To_Ityp (Lo))),
3707 Expression => Operands (J)),
3708 Suppress => All_Checks);
3710 -- Array case, slice assignment, skipped when argument is fixed
3711 -- length and known to be null.
3713 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3716 Make_Assignment_Statement (Loc,
3720 New_Occurrence_Of (Ent, Loc),
3723 Low_Bound => To_Ityp (Lo),
3724 High_Bound => To_Ityp (Hi))),
3725 Expression => Operands (J));
3727 if Is_Fixed_Length (J) then
3728 Known_Non_Null_Operand_Seen := True;
3730 elsif not Known_Non_Null_Operand_Seen then
3732 -- Here if operand length is not statically known and no
3733 -- operand known to be non-null has been processed yet.
3734 -- If operand length is 0, we do not need to perform the
3735 -- assignment, and we must avoid the evaluation of the
3736 -- high bound of the slice, since it may underflow if the
3737 -- low bound is Ityp'First.
3740 Make_Implicit_If_Statement (Cnode,
3744 New_Occurrence_Of (Var_Length (J), Loc),
3745 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3746 Then_Statements => New_List (Assign));
3749 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3755 -- Finally we build the result, which is a reference to the array object
3757 Result := New_Occurrence_Of (Ent, Loc);
3760 pragma Assert (Present (Result));
3761 Rewrite (Cnode, Result);
3762 Analyze_And_Resolve (Cnode, Atyp);
3765 when Concatenation_Error =>
3767 -- Kill warning generated for the declaration of the static out of
3768 -- range high bound, and instead generate a Constraint_Error with
3769 -- an appropriate specific message.
3771 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3772 Apply_Compile_Time_Constraint_Error
3774 Msg => "concatenation result upper bound out of range??",
3775 Reason => CE_Range_Check_Failed);
3776 end Expand_Concatenate;
3778 ---------------------------------------------------
3779 -- Expand_Membership_Minimize_Eliminate_Overflow --
3780 ---------------------------------------------------
3782 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3783 pragma Assert (Nkind (N) = N_In);
3784 -- Despite the name, this routine applies only to N_In, not to
3785 -- N_Not_In. The latter is always rewritten as not (X in Y).
3787 Result_Type : constant Entity_Id := Etype (N);
3788 -- Capture result type, may be a derived boolean type
3790 Loc : constant Source_Ptr := Sloc (N);
3791 Lop : constant Node_Id := Left_Opnd (N);
3792 Rop : constant Node_Id := Right_Opnd (N);
3794 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3795 -- is thus tempting to capture these values, but due to the rewrites
3796 -- that occur as a result of overflow checking, these values change
3797 -- as we go along, and it is safe just to always use Etype explicitly.
3799 Restype : constant Entity_Id := Etype (N);
3803 -- Bounds in Minimize calls, not used currently
3805 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3806 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3809 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3811 -- If right operand is a subtype name, and the subtype name has no
3812 -- predicate, then we can just replace the right operand with an
3813 -- explicit range T'First .. T'Last, and use the explicit range code.
3815 if Nkind (Rop) /= N_Range
3816 and then No (Predicate_Function (Etype (Rop)))
3819 Rtyp : constant Entity_Id := Etype (Rop);
3824 Make_Attribute_Reference (Loc,
3825 Attribute_Name => Name_First,
3826 Prefix => New_Occurrence_Of (Rtyp, Loc)),
3828 Make_Attribute_Reference (Loc,
3829 Attribute_Name => Name_Last,
3830 Prefix => New_Occurrence_Of (Rtyp, Loc))));
3831 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3835 -- Here for the explicit range case. Note that the bounds of the range
3836 -- have not been processed for minimized or eliminated checks.
3838 if Nkind (Rop) = N_Range then
3839 Minimize_Eliminate_Overflows
3840 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3841 Minimize_Eliminate_Overflows
3842 (High_Bound (Rop), Lo, Hi, Top_Level => False);
3844 -- We have A in B .. C, treated as A >= B and then A <= C
3848 if Is_RTE (Etype (Lop), RE_Bignum)
3849 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3850 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3853 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3854 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3855 L : constant Entity_Id :=
3856 Make_Defining_Identifier (Loc, Name_uL);
3857 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3858 Lbound : constant Node_Id :=
3859 Convert_To_Bignum (Low_Bound (Rop));
3860 Hbound : constant Node_Id :=
3861 Convert_To_Bignum (High_Bound (Rop));
3863 -- Now we rewrite the membership test node to look like
3866 -- Bnn : Result_Type;
3868 -- M : Mark_Id := SS_Mark;
3869 -- L : Bignum := Lopnd;
3871 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3879 -- Insert declaration of L into declarations of bignum block
3882 (Last (Declarations (Blk)),
3883 Make_Object_Declaration (Loc,
3884 Defining_Identifier => L,
3885 Object_Definition =>
3886 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3887 Expression => Lopnd));
3889 -- Insert assignment to Bnn into expressions of bignum block
3892 (First (Statements (Handled_Statement_Sequence (Blk))),
3893 Make_Assignment_Statement (Loc,
3894 Name => New_Occurrence_Of (Bnn, Loc),
3898 Make_Function_Call (Loc,
3900 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3901 Parameter_Associations => New_List (
3902 New_Occurrence_Of (L, Loc),
3906 Make_Function_Call (Loc,
3908 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3909 Parameter_Associations => New_List (
3910 New_Occurrence_Of (L, Loc),
3913 -- Now rewrite the node
3916 Make_Expression_With_Actions (Loc,
3917 Actions => New_List (
3918 Make_Object_Declaration (Loc,
3919 Defining_Identifier => Bnn,
3920 Object_Definition =>
3921 New_Occurrence_Of (Result_Type, Loc)),
3923 Expression => New_Occurrence_Of (Bnn, Loc)));
3924 Analyze_And_Resolve (N, Result_Type);
3928 -- Here if no bignums around
3931 -- Case where types are all the same
3933 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3935 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3939 -- If types are not all the same, it means that we have rewritten
3940 -- at least one of them to be of type Long_Long_Integer, and we
3941 -- will convert the other operands to Long_Long_Integer.
3944 Convert_To_And_Rewrite (LLIB, Lop);
3945 Set_Analyzed (Lop, False);
3946 Analyze_And_Resolve (Lop, LLIB);
3948 -- For the right operand, avoid unnecessary recursion into
3949 -- this routine, we know that overflow is not possible.
3951 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3952 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3953 Set_Analyzed (Rop, False);
3954 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3957 -- Now the three operands are of the same signed integer type,
3958 -- so we can use the normal expansion routine for membership,
3959 -- setting the flag to prevent recursion into this procedure.
3961 Set_No_Minimize_Eliminate (N);
3965 -- Right operand is a subtype name and the subtype has a predicate. We
3966 -- have to make sure the predicate is checked, and for that we need to
3967 -- use the standard N_In circuitry with appropriate types.
3970 pragma Assert (Present (Predicate_Function (Etype (Rop))));
3972 -- If types are "right", just call Expand_N_In preventing recursion
3974 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3975 Set_No_Minimize_Eliminate (N);
3980 elsif Is_RTE (Etype (Lop), RE_Bignum) then
3982 -- For X in T, we want to rewrite our node as
3985 -- Bnn : Result_Type;
3988 -- M : Mark_Id := SS_Mark;
3989 -- Lnn : Long_Long_Integer'Base
3995 -- if not Bignum_In_LLI_Range (Nnn) then
3998 -- Lnn := From_Bignum (Nnn);
4000 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4001 -- and then T'Base (Lnn) in T;
4010 -- A bit gruesome, but there doesn't seem to be a simpler way
4013 Blk : constant Node_Id := Make_Bignum_Block (Loc);
4014 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
4015 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
4016 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
4017 T : constant Entity_Id := Etype (Rop);
4018 TB : constant Entity_Id := Base_Type (T);
4022 -- Mark the last membership operation to prevent recursion
4026 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
4027 Right_Opnd => New_Occurrence_Of (T, Loc));
4028 Set_No_Minimize_Eliminate (Nin);
4030 -- Now decorate the block
4033 (Last (Declarations (Blk)),
4034 Make_Object_Declaration (Loc,
4035 Defining_Identifier => Lnn,
4036 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
4039 (Last (Declarations (Blk)),
4040 Make_Object_Declaration (Loc,
4041 Defining_Identifier => Nnn,
4042 Object_Definition =>
4043 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
4046 (First (Statements (Handled_Statement_Sequence (Blk))),
4048 Make_Assignment_Statement (Loc,
4049 Name => New_Occurrence_Of (Nnn, Loc),
4050 Expression => Relocate_Node (Lop)),
4052 Make_Implicit_If_Statement (N,
4056 Make_Function_Call (Loc,
4059 (RTE (RE_Bignum_In_LLI_Range), Loc),
4060 Parameter_Associations => New_List (
4061 New_Occurrence_Of (Nnn, Loc)))),
4063 Then_Statements => New_List (
4064 Make_Assignment_Statement (Loc,
4065 Name => New_Occurrence_Of (Bnn, Loc),
4067 New_Occurrence_Of (Standard_False, Loc))),
4069 Else_Statements => New_List (
4070 Make_Assignment_Statement (Loc,
4071 Name => New_Occurrence_Of (Lnn, Loc),
4073 Make_Function_Call (Loc,
4075 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
4076 Parameter_Associations => New_List (
4077 New_Occurrence_Of (Nnn, Loc)))),
4079 Make_Assignment_Statement (Loc,
4080 Name => New_Occurrence_Of (Bnn, Loc),
4085 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4090 Make_Attribute_Reference (Loc,
4091 Attribute_Name => Name_First,
4093 New_Occurrence_Of (TB, Loc))),
4097 Make_Attribute_Reference (Loc,
4098 Attribute_Name => Name_Last,
4100 New_Occurrence_Of (TB, Loc))))),
4102 Right_Opnd => Nin))))));
4104 -- Now we can do the rewrite
4107 Make_Expression_With_Actions (Loc,
4108 Actions => New_List (
4109 Make_Object_Declaration (Loc,
4110 Defining_Identifier => Bnn,
4111 Object_Definition =>
4112 New_Occurrence_Of (Result_Type, Loc)),
4114 Expression => New_Occurrence_Of (Bnn, Loc)));
4115 Analyze_And_Resolve (N, Result_Type);
4119 -- Not bignum case, but types don't match (this means we rewrote the
4120 -- left operand to be Long_Long_Integer).
4123 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
4125 -- We rewrite the membership test as (where T is the type with
4126 -- the predicate, i.e. the type of the right operand)
4128 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4129 -- and then T'Base (Lop) in T
4132 T : constant Entity_Id := Etype (Rop);
4133 TB : constant Entity_Id := Base_Type (T);
4137 -- The last membership test is marked to prevent recursion
4141 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
4142 Right_Opnd => New_Occurrence_Of (T, Loc));
4143 Set_No_Minimize_Eliminate (Nin);
4145 -- Now do the rewrite
4156 Make_Attribute_Reference (Loc,
4157 Attribute_Name => Name_First,
4159 New_Occurrence_Of (TB, Loc))),
4162 Make_Attribute_Reference (Loc,
4163 Attribute_Name => Name_Last,
4165 New_Occurrence_Of (TB, Loc))))),
4166 Right_Opnd => Nin));
4167 Set_Analyzed (N, False);
4168 Analyze_And_Resolve (N, Restype);
4172 end Expand_Membership_Minimize_Eliminate_Overflow;
4174 ---------------------------------
4175 -- Expand_Nonbinary_Modular_Op --
4176 ---------------------------------
4178 procedure Expand_Nonbinary_Modular_Op (N : Node_Id) is
4179 Loc : constant Source_Ptr := Sloc (N);
4180 Typ : constant Entity_Id := Etype (N);
4182 procedure Expand_Modular_Addition;
4183 -- Expand the modular addition, handling the special case of adding a
4186 procedure Expand_Modular_Op;
4187 -- Compute the general rule: (lhs OP rhs) mod Modulus
4189 procedure Expand_Modular_Subtraction;
4190 -- Expand the modular addition, handling the special case of subtracting
4193 -----------------------------
4194 -- Expand_Modular_Addition --
4195 -----------------------------
4197 procedure Expand_Modular_Addition is
4199 -- If this is not the addition of a constant then compute it using
4200 -- the general rule: (lhs + rhs) mod Modulus
4202 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4205 -- If this is an addition of a constant, convert it to a subtraction
4206 -- plus a conditional expression since we can compute it faster than
4207 -- computing the modulus.
4209 -- modMinusRhs = Modulus - rhs
4210 -- if lhs < modMinusRhs then lhs + rhs
4211 -- else lhs - modMinusRhs
4215 Mod_Minus_Right : constant Uint :=
4216 Modulus (Typ) - Intval (Right_Opnd (N));
4218 Exprs : constant List_Id := New_List;
4219 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4220 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4221 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4224 -- To prevent spurious visibility issues, convert all
4225 -- operands to Standard.Unsigned.
4227 Set_Left_Opnd (Cond_Expr,
4228 Unchecked_Convert_To (Standard_Unsigned,
4229 New_Copy_Tree (Left_Opnd (N))));
4230 Set_Right_Opnd (Cond_Expr,
4231 Make_Integer_Literal (Loc, Mod_Minus_Right));
4232 Append_To (Exprs, Cond_Expr);
4234 Set_Left_Opnd (Then_Expr,
4235 Unchecked_Convert_To (Standard_Unsigned,
4236 New_Copy_Tree (Left_Opnd (N))));
4237 Set_Right_Opnd (Then_Expr,
4238 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4239 Append_To (Exprs, Then_Expr);
4241 Set_Left_Opnd (Else_Expr,
4242 Unchecked_Convert_To (Standard_Unsigned,
4243 New_Copy_Tree (Left_Opnd (N))));
4244 Set_Right_Opnd (Else_Expr,
4245 Make_Integer_Literal (Loc, Mod_Minus_Right));
4246 Append_To (Exprs, Else_Expr);
4249 Unchecked_Convert_To (Typ,
4250 Make_If_Expression (Loc, Expressions => Exprs)));
4253 end Expand_Modular_Addition;
4255 -----------------------
4256 -- Expand_Modular_Op --
4257 -----------------------
4259 procedure Expand_Modular_Op is
4260 Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc);
4261 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc);
4263 Target_Type : Entity_Id;
4266 -- Convert nonbinary modular type operands into integer values. Thus
4267 -- we avoid never-ending loops expanding them, and we also ensure
4268 -- the back end never receives nonbinary modular type expressions.
4270 if Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor then
4271 Set_Left_Opnd (Op_Expr,
4272 Unchecked_Convert_To (Standard_Unsigned,
4273 New_Copy_Tree (Left_Opnd (N))));
4274 Set_Right_Opnd (Op_Expr,
4275 Unchecked_Convert_To (Standard_Unsigned,
4276 New_Copy_Tree (Right_Opnd (N))));
4277 Set_Left_Opnd (Mod_Expr,
4278 Unchecked_Convert_To (Standard_Integer, Op_Expr));
4281 -- If the modulus of the type is larger than Integer'Last use a
4282 -- larger type for the operands, to prevent spurious constraint
4283 -- errors on large legal literals of the type.
4285 if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then
4286 Target_Type := Standard_Long_Long_Integer;
4288 Target_Type := Standard_Integer;
4291 Set_Left_Opnd (Op_Expr,
4292 Unchecked_Convert_To (Target_Type,
4293 New_Copy_Tree (Left_Opnd (N))));
4294 Set_Right_Opnd (Op_Expr,
4295 Unchecked_Convert_To (Target_Type,
4296 New_Copy_Tree (Right_Opnd (N))));
4298 -- Link this node to the tree to analyze it
4300 -- If the parent node is an expression with actions we link it to
4301 -- N since otherwise Force_Evaluation cannot identify if this node
4302 -- comes from the Expression and rejects generating the temporary.
4304 if Nkind (Parent (N)) = N_Expression_With_Actions then
4305 Set_Parent (Op_Expr, N);
4310 Set_Parent (Op_Expr, Parent (N));
4315 -- Force generating a temporary because in the expansion of this
4316 -- expression we may generate code that performs this computation
4319 Force_Evaluation (Op_Expr, Mode => Strict);
4321 Set_Left_Opnd (Mod_Expr, Op_Expr);
4324 Set_Right_Opnd (Mod_Expr,
4325 Make_Integer_Literal (Loc, Modulus (Typ)));
4328 Unchecked_Convert_To (Typ, Mod_Expr));
4329 end Expand_Modular_Op;
4331 --------------------------------
4332 -- Expand_Modular_Subtraction --
4333 --------------------------------
4335 procedure Expand_Modular_Subtraction is
4337 -- If this is not the addition of a constant then compute it using
4338 -- the general rule: (lhs + rhs) mod Modulus
4340 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4343 -- If this is an addition of a constant, convert it to a subtraction
4344 -- plus a conditional expression since we can compute it faster than
4345 -- computing the modulus.
4347 -- modMinusRhs = Modulus - rhs
4348 -- if lhs < rhs then lhs + modMinusRhs
4353 Mod_Minus_Right : constant Uint :=
4354 Modulus (Typ) - Intval (Right_Opnd (N));
4356 Exprs : constant List_Id := New_List;
4357 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4358 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4359 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4362 Set_Left_Opnd (Cond_Expr,
4363 Unchecked_Convert_To (Standard_Unsigned,
4364 New_Copy_Tree (Left_Opnd (N))));
4365 Set_Right_Opnd (Cond_Expr,
4366 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4367 Append_To (Exprs, Cond_Expr);
4369 Set_Left_Opnd (Then_Expr,
4370 Unchecked_Convert_To (Standard_Unsigned,
4371 New_Copy_Tree (Left_Opnd (N))));
4372 Set_Right_Opnd (Then_Expr,
4373 Make_Integer_Literal (Loc, Mod_Minus_Right));
4374 Append_To (Exprs, Then_Expr);
4376 Set_Left_Opnd (Else_Expr,
4377 Unchecked_Convert_To (Standard_Unsigned,
4378 New_Copy_Tree (Left_Opnd (N))));
4379 Set_Right_Opnd (Else_Expr,
4380 Unchecked_Convert_To (Standard_Unsigned,
4381 New_Copy_Tree (Right_Opnd (N))));
4382 Append_To (Exprs, Else_Expr);
4385 Unchecked_Convert_To (Typ,
4386 Make_If_Expression (Loc, Expressions => Exprs)));
4389 end Expand_Modular_Subtraction;
4391 -- Start of processing for Expand_Nonbinary_Modular_Op
4394 -- No action needed if front-end expansion is not required or if we
4395 -- have a binary modular operand.
4397 if not Expand_Nonbinary_Modular_Ops
4398 or else not Non_Binary_Modulus (Typ)
4405 Expand_Modular_Addition;
4407 when N_Op_Subtract =>
4408 Expand_Modular_Subtraction;
4412 -- Expand -expr into (0 - expr)
4415 Make_Op_Subtract (Loc,
4416 Left_Opnd => Make_Integer_Literal (Loc, 0),
4417 Right_Opnd => Right_Opnd (N)));
4418 Analyze_And_Resolve (N, Typ);
4424 Analyze_And_Resolve (N, Typ);
4425 end Expand_Nonbinary_Modular_Op;
4427 ------------------------
4428 -- Expand_N_Allocator --
4429 ------------------------
4431 procedure Expand_N_Allocator (N : Node_Id) is
4432 Etyp : constant Entity_Id := Etype (Expression (N));
4433 Loc : constant Source_Ptr := Sloc (N);
4434 PtrT : constant Entity_Id := Etype (N);
4436 procedure Rewrite_Coextension (N : Node_Id);
4437 -- Static coextensions have the same lifetime as the entity they
4438 -- constrain. Such occurrences can be rewritten as aliased objects
4439 -- and their unrestricted access used instead of the coextension.
4441 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
4442 -- Given a constrained array type E, returns a node representing the
4443 -- code to compute a close approximation of the size in storage elements
4444 -- for the given type; for indexes that are modular types we compute
4445 -- 'Last - First (instead of 'Length) because for large arrays computing
4446 -- 'Last -'First + 1 causes overflow. This is done without using the
4447 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4450 -------------------------
4451 -- Rewrite_Coextension --
4452 -------------------------
4454 procedure Rewrite_Coextension (N : Node_Id) is
4455 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
4456 Temp_Decl : Node_Id;
4460 -- Cnn : aliased Etyp;
4463 Make_Object_Declaration (Loc,
4464 Defining_Identifier => Temp_Id,
4465 Aliased_Present => True,
4466 Object_Definition => New_Occurrence_Of (Etyp, Loc));
4468 if Nkind (Expression (N)) = N_Qualified_Expression then
4469 Set_Expression (Temp_Decl, Expression (Expression (N)));
4472 Insert_Action (N, Temp_Decl);
4474 Make_Attribute_Reference (Loc,
4475 Prefix => New_Occurrence_Of (Temp_Id, Loc),
4476 Attribute_Name => Name_Unrestricted_Access));
4478 Analyze_And_Resolve (N, PtrT);
4479 end Rewrite_Coextension;
4481 ------------------------------
4482 -- Size_In_Storage_Elements --
4483 ------------------------------
4485 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
4487 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4488 -- However, the reason for the existence of this function is
4489 -- to construct a test for sizes too large, which means near the
4490 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4491 -- is that we get overflows when sizes are greater than 2**31.
4493 -- So what we end up doing for array types is to use the expression:
4495 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4497 -- which avoids this problem. All this is a bit bogus, but it does
4498 -- mean we catch common cases of trying to allocate arrays that
4499 -- are too large, and which in the absence of a check results in
4500 -- undetected chaos ???
4502 -- Note in particular that this is a pessimistic estimate in the
4503 -- case of packed array types, where an array element might occupy
4504 -- just a fraction of a storage element???
4507 Idx : Node_Id := First_Index (E);
4509 Res : Node_Id := Empty;
4512 for J in 1 .. Number_Dimensions (E) loop
4514 if not Is_Modular_Integer_Type (Etype (Idx)) then
4516 Make_Attribute_Reference (Loc,
4517 Prefix => New_Occurrence_Of (E, Loc),
4518 Attribute_Name => Name_Length,
4519 Expressions => New_List
4520 (Make_Integer_Literal (Loc, J)));
4522 -- For indexes that are modular types we cannot generate code
4523 -- to compute 'Length since for large arrays 'Last -'First + 1
4524 -- causes overflow; therefore we compute 'Last - 'First (which
4525 -- is not the exact number of components but it is valid for
4526 -- the purpose of this runtime check on 32-bit targets).
4530 Len_Minus_1_Expr : Node_Id;
4536 Make_Attribute_Reference (Loc,
4537 Prefix => New_Occurrence_Of (E, Loc),
4538 Attribute_Name => Name_Last,
4540 New_List (Make_Integer_Literal (Loc, J))),
4541 Make_Attribute_Reference (Loc,
4542 Prefix => New_Occurrence_Of (E, Loc),
4543 Attribute_Name => Name_First,
4545 New_List (Make_Integer_Literal (Loc, J))));
4548 Convert_To (Standard_Unsigned,
4549 Make_Op_Subtract (Loc,
4550 Make_Attribute_Reference (Loc,
4551 Prefix => New_Occurrence_Of (E, Loc),
4552 Attribute_Name => Name_Last,
4555 (Make_Integer_Literal (Loc, J))),
4556 Make_Attribute_Reference (Loc,
4557 Prefix => New_Occurrence_Of (E, Loc),
4558 Attribute_Name => Name_First,
4561 (Make_Integer_Literal (Loc, J)))));
4563 -- Handle superflat arrays, i.e. arrays with such bounds
4564 -- as 4 .. 2, to ensure that the result is correct.
4567 -- (if X'Last > X'First then X'Last - X'First else 0)
4570 Make_If_Expression (Loc,
4571 Expressions => New_List (
4574 Make_Integer_Literal (Loc, Uint_0)));
4582 pragma Assert (Present (Res));
4584 Make_Op_Multiply (Loc,
4593 Make_Op_Multiply (Loc,
4596 Make_Attribute_Reference (Loc,
4597 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4598 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4600 end Size_In_Storage_Elements;
4604 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
4608 Rel_Typ : Entity_Id;
4611 -- Start of processing for Expand_N_Allocator
4614 -- Warn on the presence of an allocator of an anonymous access type when
4615 -- enabled, except when it's an object declaration at library level.
4617 if Warn_On_Anonymous_Allocators
4618 and then Ekind (PtrT) = E_Anonymous_Access_Type
4619 and then not (Is_Library_Level_Entity (PtrT)
4620 and then Nkind (Associated_Node_For_Itype (PtrT)) =
4621 N_Object_Declaration)
4623 Error_Msg_N ("??use of an anonymous access type allocator", N);
4626 -- RM E.2.2(17). We enforce that the expected type of an allocator
4627 -- shall not be a remote access-to-class-wide-limited-private type
4629 -- Why is this being done at expansion time, seems clearly wrong ???
4631 Validate_Remote_Access_To_Class_Wide_Type (N);
4633 -- Processing for anonymous access-to-controlled types. These access
4634 -- types receive a special finalization master which appears in the
4635 -- declarations of the enclosing semantic unit. This expansion is done
4636 -- now to ensure that any additional types generated by this routine or
4637 -- Expand_Allocator_Expression inherit the proper type attributes.
4639 if (Ekind (PtrT) = E_Anonymous_Access_Type
4640 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4641 and then Needs_Finalization (Dtyp)
4643 -- Detect the allocation of an anonymous controlled object where the
4644 -- type of the context is named. For example:
4646 -- procedure Proc (Ptr : Named_Access_Typ);
4647 -- Proc (new Designated_Typ);
4649 -- Regardless of the anonymous-to-named access type conversion, the
4650 -- lifetime of the object must be associated with the named access
4651 -- type. Use the finalization-related attributes of this type.
4653 if Nkind (Parent (N)) in N_Type_Conversion
4654 | N_Unchecked_Type_Conversion
4655 and then Ekind (Etype (Parent (N))) in E_Access_Subtype
4657 | E_General_Access_Type
4659 Rel_Typ := Etype (Parent (N));
4664 -- Anonymous access-to-controlled types allocate on the global pool.
4665 -- Note that this is a "root type only" attribute.
4667 if No (Associated_Storage_Pool (PtrT)) then
4668 if Present (Rel_Typ) then
4669 Set_Associated_Storage_Pool
4670 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
4672 Set_Associated_Storage_Pool
4673 (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
4677 -- The finalization master must be inserted and analyzed as part of
4678 -- the current semantic unit. Note that the master is updated when
4679 -- analysis changes current units. Note that this is a "root type
4682 if Present (Rel_Typ) then
4683 Set_Finalization_Master
4684 (Root_Type (PtrT), Finalization_Master (Rel_Typ));
4686 Build_Anonymous_Master (Root_Type (PtrT));
4690 -- Set the storage pool and find the appropriate version of Allocate to
4691 -- call. Do not overwrite the storage pool if it is already set, which
4692 -- can happen for build-in-place function returns (see
4693 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4695 if No (Storage_Pool (N)) then
4696 Pool := Associated_Storage_Pool (Root_Type (PtrT));
4698 if Present (Pool) then
4699 Set_Storage_Pool (N, Pool);
4701 if Is_RTE (Pool, RE_SS_Pool) then
4702 Check_Restriction (No_Secondary_Stack, N);
4703 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4705 -- In the case of an allocator for a simple storage pool, locate
4706 -- and save a reference to the pool type's Allocate routine.
4708 elsif Present (Get_Rep_Pragma
4709 (Etype (Pool), Name_Simple_Storage_Pool_Type))
4712 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4713 Alloc_Op : Entity_Id;
4715 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4716 while Present (Alloc_Op) loop
4717 if Scope (Alloc_Op) = Scope (Pool_Type)
4718 and then Present (First_Formal (Alloc_Op))
4719 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4721 Set_Procedure_To_Call (N, Alloc_Op);
4724 Alloc_Op := Homonym (Alloc_Op);
4729 elsif Is_Class_Wide_Type (Etype (Pool)) then
4730 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4733 Set_Procedure_To_Call (N,
4734 Find_Prim_Op (Etype (Pool), Name_Allocate));
4739 -- Under certain circumstances we can replace an allocator by an access
4740 -- to statically allocated storage. The conditions, as noted in AARM
4741 -- 3.10 (10c) are as follows:
4743 -- Size and initial value is known at compile time
4744 -- Access type is access-to-constant
4746 -- The allocator is not part of a constraint on a record component,
4747 -- because in that case the inserted actions are delayed until the
4748 -- record declaration is fully analyzed, which is too late for the
4749 -- analysis of the rewritten allocator.
4751 if Is_Access_Constant (PtrT)
4752 and then Nkind (Expression (N)) = N_Qualified_Expression
4753 and then Compile_Time_Known_Value (Expression (Expression (N)))
4754 and then Size_Known_At_Compile_Time
4755 (Etype (Expression (Expression (N))))
4756 and then not Is_Record_Type (Current_Scope)
4758 -- Here we can do the optimization. For the allocator
4762 -- We insert an object declaration
4764 -- Tnn : aliased x := y;
4766 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4767 -- marked as requiring static allocation.
4769 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4770 Desig := Subtype_Mark (Expression (N));
4772 -- If context is constrained, use constrained subtype directly,
4773 -- so that the constant is not labelled as having a nominally
4774 -- unconstrained subtype.
4776 if Entity (Desig) = Base_Type (Dtyp) then
4777 Desig := New_Occurrence_Of (Dtyp, Loc);
4781 Make_Object_Declaration (Loc,
4782 Defining_Identifier => Temp,
4783 Aliased_Present => True,
4784 Constant_Present => Is_Access_Constant (PtrT),
4785 Object_Definition => Desig,
4786 Expression => Expression (Expression (N))));
4789 Make_Attribute_Reference (Loc,
4790 Prefix => New_Occurrence_Of (Temp, Loc),
4791 Attribute_Name => Name_Unrestricted_Access));
4793 Analyze_And_Resolve (N, PtrT);
4795 -- We set the variable as statically allocated, since we don't want
4796 -- it going on the stack of the current procedure.
4798 Set_Is_Statically_Allocated (Temp);
4802 -- Same if the allocator is an access discriminant for a local object:
4803 -- instead of an allocator we create a local value and constrain the
4804 -- enclosing object with the corresponding access attribute.
4806 if Is_Static_Coextension (N) then
4807 Rewrite_Coextension (N);
4811 -- Check for size too large, we do this because the back end misses
4812 -- proper checks here and can generate rubbish allocation calls when
4813 -- we are near the limit. We only do this for the 32-bit address case
4814 -- since that is from a practical point of view where we see a problem.
4816 if System_Address_Size = 32
4817 and then not Storage_Checks_Suppressed (PtrT)
4818 and then not Storage_Checks_Suppressed (Dtyp)
4819 and then not Storage_Checks_Suppressed (Etyp)
4821 -- The check we want to generate should look like
4823 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4824 -- raise Storage_Error;
4827 -- where 3.5 gigabytes is a constant large enough to accommodate any
4828 -- reasonable request for. But we can't do it this way because at
4829 -- least at the moment we don't compute this attribute right, and
4830 -- can silently give wrong results when the result gets large. Since
4831 -- this is all about large results, that's bad, so instead we only
4832 -- apply the check for constrained arrays, and manually compute the
4833 -- value of the attribute ???
4835 -- The check on No_Initialization is used here to prevent generating
4836 -- this runtime check twice when the allocator is locally replaced by
4837 -- the expander with another one.
4839 if Is_Array_Type (Etyp) and then not No_Initialization (N) then
4842 Ins_Nod : Node_Id := N;
4843 Siz_Typ : Entity_Id := Etyp;
4847 -- For unconstrained array types initialized with a qualified
4848 -- expression we use its type to perform this check
4850 if not Is_Constrained (Etyp)
4851 and then not No_Initialization (N)
4852 and then Nkind (Expression (N)) = N_Qualified_Expression
4854 Expr := Expression (Expression (N));
4855 Siz_Typ := Etype (Expression (Expression (N)));
4857 -- If the qualified expression has been moved to an internal
4858 -- temporary (to remove side effects) then we must insert
4859 -- the runtime check before its declaration to ensure that
4860 -- the check is performed before the execution of the code
4861 -- computing the qualified expression.
4863 if Nkind (Expr) = N_Identifier
4864 and then Is_Internal_Name (Chars (Expr))
4866 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
4868 Ins_Nod := Parent (Entity (Expr));
4874 if Is_Constrained (Siz_Typ)
4875 and then Ekind (Siz_Typ) /= E_String_Literal_Subtype
4877 -- For CCG targets, the largest array may have up to 2**31-1
4878 -- components (i.e. 2 gigabytes if each array component is
4879 -- one byte). This ensures that fat pointer fields do not
4880 -- overflow, since they are 32-bit integer types, and also
4881 -- ensures that 'Length can be computed at run time.
4883 if Modify_Tree_For_C then
4886 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4887 Right_Opnd => Make_Integer_Literal (Loc,
4888 Uint_2 ** 31 - Uint_1));
4890 -- For native targets the largest object is 3.5 gigabytes
4895 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4896 Right_Opnd => Make_Integer_Literal (Loc,
4897 Uint_7 * (Uint_2 ** 29)));
4900 Insert_Action (Ins_Nod,
4901 Make_Raise_Storage_Error (Loc,
4903 Reason => SE_Object_Too_Large));
4905 if Entity (Cond) = Standard_True then
4907 ("object too large: Storage_Error will be raised at "
4915 -- If no storage pool has been specified, or the storage pool
4916 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4917 -- No_Standard_Allocators_After_Elaboration is present, then generate
4918 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4920 if Nkind (N) = N_Allocator
4921 and then (No (Storage_Pool (N))
4922 or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object))
4923 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
4926 Make_Procedure_Call_Statement (Loc,
4928 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc)));
4931 -- Handle case of qualified expression (other than optimization above)
4933 if Nkind (Expression (N)) = N_Qualified_Expression then
4934 Expand_Allocator_Expression (N);
4938 -- If the allocator is for a type which requires initialization, and
4939 -- there is no initial value (i.e. operand is a subtype indication
4940 -- rather than a qualified expression), then we must generate a call to
4941 -- the initialization routine using an expressions action node:
4943 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4945 -- Here ptr_T is the pointer type for the allocator, and T is the
4946 -- subtype of the allocator. A special case arises if the designated
4947 -- type of the access type is a task or contains tasks. In this case
4948 -- the call to Init (Temp.all ...) is replaced by code that ensures
4949 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4950 -- for details). In addition, if the type T is a task type, then the
4951 -- first argument to Init must be converted to the task record type.
4954 T : constant Entity_Id := Etype (Expression (N));
4960 Init_Arg1 : Node_Id;
4961 Init_Call : Node_Id;
4962 Temp_Decl : Node_Id;
4963 Temp_Type : Entity_Id;
4966 -- Apply constraint checks against designated subtype (RM 4.8(10/2))
4967 -- but ignore the expression if the No_Initialization flag is set.
4968 -- Discriminant checks will be generated by the expansion below.
4970 if Is_Array_Type (Dtyp) and then not No_Initialization (N) then
4971 Apply_Constraint_Check (Expression (N), Dtyp, No_Sliding => True);
4973 Apply_Predicate_Check (Expression (N), Dtyp);
4975 if Nkind (Expression (N)) = N_Raise_Constraint_Error then
4976 Rewrite (N, New_Copy (Expression (N)));
4977 Set_Etype (N, PtrT);
4982 if No_Initialization (N) then
4984 -- Even though this might be a simple allocation, create a custom
4985 -- Allocate if the context requires it.
4987 if Present (Finalization_Master (PtrT)) then
4988 Build_Allocate_Deallocate_Proc
4990 Is_Allocate => True);
4993 -- Optimize the default allocation of an array object when pragma
4994 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4995 -- in-place initialization aggregate which may be convert into a fast
4996 -- memset by the backend.
4998 elsif Init_Or_Norm_Scalars
4999 and then Is_Array_Type (T)
5001 -- The array must lack atomic components because they are treated
5002 -- as non-static, and as a result the backend will not initialize
5003 -- the memory in one go.
5005 and then not Has_Atomic_Components (T)
5007 -- The array must not be packed because the invalid values in
5008 -- System.Scalar_Values are multiples of Storage_Unit.
5010 and then not Is_Packed (T)
5012 -- The array must have static non-empty ranges, otherwise the
5013 -- backend cannot initialize the memory in one go.
5015 and then Has_Static_Non_Empty_Array_Bounds (T)
5017 -- The optimization is only relevant for arrays of scalar types
5019 and then Is_Scalar_Type (Component_Type (T))
5021 -- Similar to regular array initialization using a type init proc,
5022 -- predicate checks are not performed because the initialization
5023 -- values are intentionally invalid, and may violate the predicate.
5025 and then not Has_Predicates (Component_Type (T))
5027 -- The component type must have a single initialization value
5029 and then Needs_Simple_Initialization
5030 (Typ => Component_Type (T),
5031 Consider_IS => True)
5034 Temp := Make_Temporary (Loc, 'P');
5037 -- Temp : Ptr_Typ := new ...;
5042 Make_Object_Declaration (Loc,
5043 Defining_Identifier => Temp,
5044 Object_Definition => New_Occurrence_Of (PtrT, Loc),
5045 Expression => Relocate_Node (N)),
5046 Suppress => All_Checks);
5049 -- Temp.all := (others => ...);
5054 Make_Assignment_Statement (Loc,
5056 Make_Explicit_Dereference (Loc,
5057 Prefix => New_Occurrence_Of (Temp, Loc)),
5062 Size => Esize (Component_Type (T)))),
5063 Suppress => All_Checks);
5065 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5066 Analyze_And_Resolve (N, PtrT);
5068 -- Case of no initialization procedure present
5070 elsif not Has_Non_Null_Base_Init_Proc (T) then
5072 -- Case of simple initialization required
5074 if Needs_Simple_Initialization (T) then
5075 Check_Restriction (No_Default_Initialization, N);
5076 Rewrite (Expression (N),
5077 Make_Qualified_Expression (Loc,
5078 Subtype_Mark => New_Occurrence_Of (T, Loc),
5079 Expression => Get_Simple_Init_Val (T, N)));
5081 Analyze_And_Resolve (Expression (Expression (N)), T);
5082 Analyze_And_Resolve (Expression (N), T);
5083 Set_Paren_Count (Expression (Expression (N)), 1);
5084 Expand_N_Allocator (N);
5086 -- No initialization required
5089 Build_Allocate_Deallocate_Proc
5091 Is_Allocate => True);
5094 -- Case of initialization procedure present, must be called
5096 -- NOTE: There is a *huge* amount of code duplication here from
5097 -- Build_Initialization_Call. We should probably refactor???
5100 Check_Restriction (No_Default_Initialization, N);
5102 if not Restriction_Active (No_Default_Initialization) then
5103 Init := Base_Init_Proc (T);
5105 Temp := Make_Temporary (Loc, 'P');
5107 -- Construct argument list for the initialization routine call
5110 Make_Explicit_Dereference (Loc,
5112 New_Occurrence_Of (Temp, Loc));
5114 Set_Assignment_OK (Init_Arg1);
5117 -- The initialization procedure expects a specific type. if the
5118 -- context is access to class wide, indicate that the object
5119 -- being allocated has the right specific type.
5121 if Is_Class_Wide_Type (Dtyp) then
5122 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
5125 -- If designated type is a concurrent type or if it is private
5126 -- type whose definition is a concurrent type, the first
5127 -- argument in the Init routine has to be unchecked conversion
5128 -- to the corresponding record type. If the designated type is
5129 -- a derived type, also convert the argument to its root type.
5131 if Is_Concurrent_Type (T) then
5133 Unchecked_Convert_To (
5134 Corresponding_Record_Type (T), Init_Arg1);
5136 elsif Is_Private_Type (T)
5137 and then Present (Full_View (T))
5138 and then Is_Concurrent_Type (Full_View (T))
5141 Unchecked_Convert_To
5142 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
5144 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
5146 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
5149 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
5150 Set_Etype (Init_Arg1, Ftyp);
5154 Args := New_List (Init_Arg1);
5156 -- For the task case, pass the Master_Id of the access type as
5157 -- the value of the _Master parameter, and _Chain as the value
5158 -- of the _Chain parameter (_Chain will be defined as part of
5159 -- the generated code for the allocator).
5161 -- In Ada 2005, the context may be a function that returns an
5162 -- anonymous access type. In that case the Master_Id has been
5163 -- created when expanding the function declaration.
5165 if Has_Task (T) then
5166 if No (Master_Id (Base_Type (PtrT))) then
5168 -- The designated type was an incomplete type, and the
5169 -- access type did not get expanded. Salvage it now.
5171 if Present (Parent (Base_Type (PtrT))) then
5172 Expand_N_Full_Type_Declaration
5173 (Parent (Base_Type (PtrT)));
5175 -- The only other possibility is an itype. For this
5176 -- case, the master must exist in the context. This is
5177 -- the case when the allocator initializes an access
5178 -- component in an init-proc.
5181 pragma Assert (Is_Itype (PtrT));
5182 Build_Master_Renaming (PtrT, N);
5186 -- If the context of the allocator is a declaration or an
5187 -- assignment, we can generate a meaningful image for it,
5188 -- even though subsequent assignments might remove the
5189 -- connection between task and entity. We build this image
5190 -- when the left-hand side is a simple variable, a simple
5191 -- indexed assignment or a simple selected component.
5193 if Nkind (Parent (N)) = N_Assignment_Statement then
5195 Nam : constant Node_Id := Name (Parent (N));
5198 if Is_Entity_Name (Nam) then
5200 Build_Task_Image_Decls
5203 (Entity (Nam), Sloc (Nam)), T);
5205 elsif Nkind (Nam) in N_Indexed_Component
5206 | N_Selected_Component
5207 and then Is_Entity_Name (Prefix (Nam))
5210 Build_Task_Image_Decls
5211 (Loc, Nam, Etype (Prefix (Nam)));
5213 Decls := Build_Task_Image_Decls (Loc, T, T);
5217 elsif Nkind (Parent (N)) = N_Object_Declaration then
5219 Build_Task_Image_Decls
5220 (Loc, Defining_Identifier (Parent (N)), T);
5223 Decls := Build_Task_Image_Decls (Loc, T, T);
5226 if Restriction_Active (No_Task_Hierarchy) then
5228 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
5232 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
5235 Append_To (Args, Make_Identifier (Loc, Name_uChain));
5237 Decl := Last (Decls);
5239 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
5241 -- Has_Task is false, Decls not used
5247 -- Add discriminants if discriminated type
5250 Dis : Boolean := False;
5251 Typ : Entity_Id := Empty;
5254 if Has_Discriminants (T) then
5258 -- Type may be a private type with no visible discriminants
5259 -- in which case check full view if in scope, or the
5260 -- underlying_full_view if dealing with a type whose full
5261 -- view may be derived from a private type whose own full
5262 -- view has discriminants.
5264 elsif Is_Private_Type (T) then
5265 if Present (Full_View (T))
5266 and then Has_Discriminants (Full_View (T))
5269 Typ := Full_View (T);
5271 elsif Present (Underlying_Full_View (T))
5272 and then Has_Discriminants (Underlying_Full_View (T))
5275 Typ := Underlying_Full_View (T);
5281 -- If the allocated object will be constrained by the
5282 -- default values for discriminants, then build a subtype
5283 -- with those defaults, and change the allocated subtype
5284 -- to that. Note that this happens in fewer cases in Ada
5287 if not Is_Constrained (Typ)
5288 and then Present (Discriminant_Default_Value
5289 (First_Discriminant (Typ)))
5290 and then (Ada_Version < Ada_2005
5292 Object_Type_Has_Constrained_Partial_View
5293 (Typ, Current_Scope))
5295 Typ := Build_Default_Subtype (Typ, N);
5296 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
5299 Discr := First_Elmt (Discriminant_Constraint (Typ));
5300 while Present (Discr) loop
5301 Nod := Node (Discr);
5302 Append (New_Copy_Tree (Node (Discr)), Args);
5304 -- AI-416: when the discriminant constraint is an
5305 -- anonymous access type make sure an accessibility
5306 -- check is inserted if necessary (3.10.2(22.q/2))
5308 if Ada_Version >= Ada_2005
5310 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
5312 Apply_Accessibility_Check
5313 (Nod, Typ, Insert_Node => Nod);
5321 -- We set the allocator as analyzed so that when we analyze
5322 -- the if expression node, we do not get an unwanted recursive
5323 -- expansion of the allocator expression.
5325 Set_Analyzed (N, True);
5326 Nod := Relocate_Node (N);
5328 -- Here is the transformation:
5329 -- input: new Ctrl_Typ
5330 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5331 -- Ctrl_TypIP (Temp.all, ...);
5332 -- [Deep_]Initialize (Temp.all);
5334 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5335 -- is the subtype of the allocator.
5338 Make_Object_Declaration (Loc,
5339 Defining_Identifier => Temp,
5340 Constant_Present => True,
5341 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
5344 Set_Assignment_OK (Temp_Decl);
5345 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
5347 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
5349 -- If the designated type is a task type or contains tasks,
5350 -- create block to activate created tasks, and insert
5351 -- declaration for Task_Image variable ahead of call.
5353 if Has_Task (T) then
5355 L : constant List_Id := New_List;
5358 Build_Task_Allocate_Block (L, Nod, Args);
5360 Insert_List_Before (First (Declarations (Blk)), Decls);
5361 Insert_Actions (N, L);
5366 Make_Procedure_Call_Statement (Loc,
5367 Name => New_Occurrence_Of (Init, Loc),
5368 Parameter_Associations => Args));
5371 if Needs_Finalization (T) then
5374 -- [Deep_]Initialize (Init_Arg1);
5378 (Obj_Ref => New_Copy_Tree (Init_Arg1),
5381 -- Guard against a missing [Deep_]Initialize when the
5382 -- designated type was not properly frozen.
5384 if Present (Init_Call) then
5385 Insert_Action (N, Init_Call);
5389 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5390 Analyze_And_Resolve (N, PtrT);
5392 -- When designated type has Default_Initial_Condition aspects,
5393 -- make a call to the type's DIC procedure to perform the
5394 -- checks. Theoretically this might also be needed for cases
5395 -- where the type doesn't have an init proc, but those should
5396 -- be very uncommon, and for now we only support the init proc
5400 and then Present (DIC_Procedure (Dtyp))
5401 and then not Has_Null_Body (DIC_Procedure (Dtyp))
5404 Build_DIC_Call (Loc,
5405 Make_Explicit_Dereference (Loc,
5406 Prefix => New_Occurrence_Of (Temp, Loc)),
5413 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5414 -- object that has been rewritten as a reference, we displace "this"
5415 -- to reference properly its secondary dispatch table.
5417 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
5418 Displace_Allocator_Pointer (N);
5422 when RE_Not_Available =>
5424 end Expand_N_Allocator;
5426 -----------------------
5427 -- Expand_N_And_Then --
5428 -----------------------
5430 procedure Expand_N_And_Then (N : Node_Id)
5431 renames Expand_Short_Circuit_Operator;
5433 ------------------------------
5434 -- Expand_N_Case_Expression --
5435 ------------------------------
5437 procedure Expand_N_Case_Expression (N : Node_Id) is
5438 function Is_Copy_Type (Typ : Entity_Id) return Boolean;
5439 -- Return True if we can copy objects of this type when expanding a case
5446 function Is_Copy_Type (Typ : Entity_Id) return Boolean is
5448 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5449 -- large objects, as long as they are constrained and not limited.
5452 Is_Elementary_Type (Underlying_Type (Typ))
5454 (Minimize_Expression_With_Actions
5455 and then Is_Constrained (Underlying_Type (Typ))
5456 and then not Is_Limited_Type (Underlying_Type (Typ)));
5461 Loc : constant Source_Ptr := Sloc (N);
5462 Par : constant Node_Id := Parent (N);
5463 Typ : constant Entity_Id := Etype (N);
5467 Case_Stmt : Node_Id;
5470 Target : Entity_Id := Empty;
5471 Target_Typ : Entity_Id;
5473 In_Predicate : Boolean := False;
5474 -- Flag set when the case expression appears within a predicate
5476 Optimize_Return_Stmt : Boolean := False;
5477 -- Flag set when the case expression can be optimized in the context of
5478 -- a simple return statement.
5480 -- Start of processing for Expand_N_Case_Expression
5483 -- Check for MINIMIZED/ELIMINATED overflow mode
5485 if Minimized_Eliminated_Overflow_Check (N) then
5486 Apply_Arithmetic_Overflow_Check (N);
5490 -- If the case expression is a predicate specification, and the type
5491 -- to which it applies has a static predicate aspect, do not expand,
5492 -- because it will be converted to the proper predicate form later.
5494 if Ekind (Current_Scope) in E_Function | E_Procedure
5495 and then Is_Predicate_Function (Current_Scope)
5497 In_Predicate := True;
5499 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
5505 -- When the type of the case expression is elementary, expand
5507 -- (case X is when A => AX, when B => BX ...)
5522 -- In all other cases expand into
5525 -- type Ptr_Typ is access all Typ;
5526 -- Target : Ptr_Typ;
5529 -- Target := AX'Unrestricted_Access;
5531 -- Target := BX'Unrestricted_Access;
5534 -- in Target.all end;
5536 -- This approach avoids extra copies of potentially large objects. It
5537 -- also allows handling of values of limited or unconstrained types.
5538 -- Note that we do the copy also for constrained, nonlimited types
5539 -- when minimizing expressions with actions (e.g. when generating C
5540 -- code) since it allows us to do the optimization below in more cases.
5542 -- Small optimization: when the case expression appears in the context
5543 -- of a simple return statement, expand into
5554 Make_Case_Statement (Loc,
5555 Expression => Expression (N),
5556 Alternatives => New_List);
5558 -- Preserve the original context for which the case statement is being
5559 -- generated. This is needed by the finalization machinery to prevent
5560 -- the premature finalization of controlled objects found within the
5563 Set_From_Conditional_Expression (Case_Stmt);
5568 if Is_Copy_Type (Typ) then
5571 -- ??? Do not perform the optimization when the return statement is
5572 -- within a predicate function, as this causes spurious errors. Could
5573 -- this be a possible mismatch in handling this case somewhere else
5574 -- in semantic analysis?
5576 Optimize_Return_Stmt :=
5577 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
5579 -- Otherwise create an access type to handle the general case using
5580 -- 'Unrestricted_Access.
5583 -- type Ptr_Typ is access all Typ;
5586 if Generate_C_Code then
5588 -- We cannot ensure that correct C code will be generated if any
5589 -- temporary is created down the line (to e.g. handle checks or
5590 -- capture values) since we might end up with dangling references
5591 -- to local variables, so better be safe and reject the construct.
5594 ("case expression too complex, use case statement instead", N);
5597 Target_Typ := Make_Temporary (Loc, 'P');
5600 Make_Full_Type_Declaration (Loc,
5601 Defining_Identifier => Target_Typ,
5603 Make_Access_To_Object_Definition (Loc,
5604 All_Present => True,
5605 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5608 -- Create the declaration of the target which captures the value of the
5612 -- Target : [Ptr_]Typ;
5614 if not Optimize_Return_Stmt then
5615 Target := Make_Temporary (Loc, 'T');
5618 Make_Object_Declaration (Loc,
5619 Defining_Identifier => Target,
5620 Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
5621 Set_No_Initialization (Decl);
5623 Append_To (Acts, Decl);
5626 -- Process the alternatives
5628 Alt := First (Alternatives (N));
5629 while Present (Alt) loop
5631 Alt_Expr : Node_Id := Expression (Alt);
5632 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
5637 -- Take the unrestricted access of the expression value for non-
5638 -- scalar types. This approach avoids big copies and covers the
5639 -- limited and unconstrained cases.
5642 -- AX'Unrestricted_Access
5644 if not Is_Copy_Type (Typ) then
5646 Make_Attribute_Reference (Alt_Loc,
5647 Prefix => Relocate_Node (Alt_Expr),
5648 Attribute_Name => Name_Unrestricted_Access);
5652 -- return AX['Unrestricted_Access];
5654 if Optimize_Return_Stmt then
5656 Make_Simple_Return_Statement (Alt_Loc,
5657 Expression => Alt_Expr));
5660 -- Target := AX['Unrestricted_Access];
5663 LHS := New_Occurrence_Of (Target, Loc);
5664 Set_Assignment_OK (LHS);
5667 Make_Assignment_Statement (Alt_Loc,
5669 Expression => Alt_Expr));
5672 -- Propagate declarations inserted in the node by Insert_Actions
5673 -- (for example, temporaries generated to remove side effects).
5674 -- These actions must remain attached to the alternative, given
5675 -- that they are generated by the corresponding expression.
5677 if Present (Actions (Alt)) then
5678 Prepend_List (Actions (Alt), Stmts);
5681 -- Finalize any transient objects on exit from the alternative.
5682 -- This is done only in the return optimization case because
5683 -- otherwise the case expression is converted into an expression
5684 -- with actions which already contains this form of processing.
5686 if Optimize_Return_Stmt then
5687 Process_If_Case_Statements (N, Stmts);
5691 (Alternatives (Case_Stmt),
5692 Make_Case_Statement_Alternative (Sloc (Alt),
5693 Discrete_Choices => Discrete_Choices (Alt),
5694 Statements => Stmts));
5700 -- Rewrite the parent return statement as a case statement
5702 if Optimize_Return_Stmt then
5703 Rewrite (Par, Case_Stmt);
5706 -- Otherwise convert the case expression into an expression with actions
5709 Append_To (Acts, Case_Stmt);
5711 if Is_Copy_Type (Typ) then
5712 Expr := New_Occurrence_Of (Target, Loc);
5716 Make_Explicit_Dereference (Loc,
5717 Prefix => New_Occurrence_Of (Target, Loc));
5723 -- in Target[.all] end;
5726 Make_Expression_With_Actions (Loc,
5730 Analyze_And_Resolve (N, Typ);
5732 end Expand_N_Case_Expression;
5734 -----------------------------------
5735 -- Expand_N_Explicit_Dereference --
5736 -----------------------------------
5738 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
5740 -- Insert explicit dereference call for the checked storage pool case
5742 Insert_Dereference_Action (Prefix (N));
5744 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5745 -- we set the atomic sync flag.
5747 if Is_Atomic (Etype (N))
5748 and then not Atomic_Synchronization_Disabled (Etype (N))
5750 Activate_Atomic_Synchronization (N);
5752 end Expand_N_Explicit_Dereference;
5754 --------------------------------------
5755 -- Expand_N_Expression_With_Actions --
5756 --------------------------------------
5758 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
5759 Acts : constant List_Id := Actions (N);
5761 procedure Force_Boolean_Evaluation (Expr : Node_Id);
5762 -- Force the evaluation of Boolean expression Expr
5764 function Process_Action (Act : Node_Id) return Traverse_Result;
5765 -- Inspect and process a single action of an expression_with_actions for
5766 -- transient objects. If such objects are found, the routine generates
5767 -- code to clean them up when the context of the expression is evaluated
5770 ------------------------------
5771 -- Force_Boolean_Evaluation --
5772 ------------------------------
5774 procedure Force_Boolean_Evaluation (Expr : Node_Id) is
5775 Loc : constant Source_Ptr := Sloc (N);
5776 Flag_Decl : Node_Id;
5777 Flag_Id : Entity_Id;
5780 -- Relocate the expression to the actions list by capturing its value
5781 -- in a Boolean flag. Generate:
5782 -- Flag : constant Boolean := Expr;
5784 Flag_Id := Make_Temporary (Loc, 'F');
5787 Make_Object_Declaration (Loc,
5788 Defining_Identifier => Flag_Id,
5789 Constant_Present => True,
5790 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
5791 Expression => Relocate_Node (Expr));
5793 Append (Flag_Decl, Acts);
5794 Analyze (Flag_Decl);
5796 -- Replace the expression with a reference to the flag
5798 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc));
5799 Analyze (Expression (N));
5800 end Force_Boolean_Evaluation;
5802 --------------------
5803 -- Process_Action --
5804 --------------------
5806 function Process_Action (Act : Node_Id) return Traverse_Result is
5808 if Nkind (Act) = N_Object_Declaration
5809 and then Is_Finalizable_Transient (Act, N)
5811 Process_Transient_In_Expression (Act, N, Acts);
5814 -- Avoid processing temporary function results multiple times when
5815 -- dealing with nested expression_with_actions.
5817 elsif Nkind (Act) = N_Expression_With_Actions then
5820 -- Do not process temporary function results in loops. This is done
5821 -- by Expand_N_Loop_Statement and Build_Finalizer.
5823 elsif Nkind (Act) = N_Loop_Statement then
5830 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5836 -- Start of processing for Expand_N_Expression_With_Actions
5839 -- Do not evaluate the expression when it denotes an entity because the
5840 -- expression_with_actions node will be replaced by the reference.
5842 if Is_Entity_Name (Expression (N)) then
5845 -- Do not evaluate the expression when there are no actions because the
5846 -- expression_with_actions node will be replaced by the expression.
5848 elsif No (Acts) or else Is_Empty_List (Acts) then
5851 -- Force the evaluation of the expression by capturing its value in a
5852 -- temporary. This ensures that aliases of transient objects do not leak
5853 -- to the expression of the expression_with_actions node:
5856 -- Trans_Id : Ctrl_Typ := ...;
5857 -- Alias : ... := Trans_Id;
5858 -- in ... Alias ... end;
5860 -- In the example above, Trans_Id cannot be finalized at the end of the
5861 -- actions list because this may affect the alias and the final value of
5862 -- the expression_with_actions. Forcing the evaluation encapsulates the
5863 -- reference to the Alias within the actions list:
5866 -- Trans_Id : Ctrl_Typ := ...;
5867 -- Alias : ... := Trans_Id;
5868 -- Val : constant Boolean := ... Alias ...;
5869 -- <finalize Trans_Id>
5872 -- Once this transformation is performed, it is safe to finalize the
5873 -- transient object at the end of the actions list.
5875 -- Note that Force_Evaluation does not remove side effects in operators
5876 -- because it assumes that all operands are evaluated and side effect
5877 -- free. This is not the case when an operand depends implicitly on the
5878 -- transient object through the use of access types.
5880 elsif Is_Boolean_Type (Etype (Expression (N))) then
5881 Force_Boolean_Evaluation (Expression (N));
5883 -- The expression of an expression_with_actions node may not necessarily
5884 -- be Boolean when the node appears in an if expression. In this case do
5885 -- the usual forced evaluation to encapsulate potential aliasing.
5888 Force_Evaluation (Expression (N));
5891 -- Process all transient objects found within the actions of the EWA
5894 Act := First (Acts);
5895 while Present (Act) loop
5896 Process_Single_Action (Act);
5900 -- Deal with case where there are no actions. In this case we simply
5901 -- rewrite the node with its expression since we don't need the actions
5902 -- and the specification of this node does not allow a null action list.
5904 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5905 -- the expanded tree and relying on being able to retrieve the original
5906 -- tree in cases like this. This raises a whole lot of issues of whether
5907 -- we have problems elsewhere, which will be addressed in the future???
5909 if Is_Empty_List (Acts) then
5910 Rewrite (N, Relocate_Node (Expression (N)));
5912 end Expand_N_Expression_With_Actions;
5914 ----------------------------
5915 -- Expand_N_If_Expression --
5916 ----------------------------
5918 -- Deal with limited types and condition actions
5920 procedure Expand_N_If_Expression (N : Node_Id) is
5921 Cond : constant Node_Id := First (Expressions (N));
5922 Loc : constant Source_Ptr := Sloc (N);
5923 Thenx : constant Node_Id := Next (Cond);
5924 Elsex : constant Node_Id := Next (Thenx);
5925 Typ : constant Entity_Id := Etype (N);
5933 -- Determine if we are dealing with a special case of a conditional
5934 -- expression used as an actual for an anonymous access type which
5935 -- forces us to transform the if expression into an expression with
5936 -- actions in order to create a temporary to capture the level of the
5937 -- expression in each branch.
5939 Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N);
5941 -- Start of processing for Expand_N_If_Expression
5944 -- Check for MINIMIZED/ELIMINATED overflow mode
5946 if Minimized_Eliminated_Overflow_Check (N) then
5947 Apply_Arithmetic_Overflow_Check (N);
5951 -- Fold at compile time if condition known. We have already folded
5952 -- static if expressions, but it is possible to fold any case in which
5953 -- the condition is known at compile time, even though the result is
5956 -- Note that we don't do the fold of such cases in Sem_Elab because
5957 -- it can cause infinite loops with the expander adding a conditional
5958 -- expression, and Sem_Elab circuitry removing it repeatedly.
5960 if Compile_Time_Known_Value (Cond) then
5962 function Fold_Known_Value (Cond : Node_Id) return Boolean;
5963 -- Fold at compile time. Assumes condition known. Return True if
5964 -- folding occurred, meaning we're done.
5966 ----------------------
5967 -- Fold_Known_Value --
5968 ----------------------
5970 function Fold_Known_Value (Cond : Node_Id) return Boolean is
5972 if Is_True (Expr_Value (Cond)) then
5974 Actions := Then_Actions (N);
5977 Actions := Else_Actions (N);
5982 if Present (Actions) then
5984 -- To minimize the use of Expression_With_Actions, just skip
5985 -- the optimization as it is not critical for correctness.
5987 if Minimize_Expression_With_Actions then
5992 Make_Expression_With_Actions (Loc,
5993 Expression => Relocate_Node (Expr),
5994 Actions => Actions));
5995 Analyze_And_Resolve (N, Typ);
5998 Rewrite (N, Relocate_Node (Expr));
6001 -- Note that the result is never static (legitimate cases of
6002 -- static if expressions were folded in Sem_Eval).
6004 Set_Is_Static_Expression (N, False);
6006 end Fold_Known_Value;
6009 if Fold_Known_Value (Cond) then
6015 -- If the type is limited, and the back end does not handle limited
6016 -- types, then we expand as follows to avoid the possibility of
6017 -- improper copying.
6019 -- type Ptr is access all Typ;
6023 -- Cnn := then-expr'Unrestricted_Access;
6026 -- Cnn := else-expr'Unrestricted_Access;
6029 -- and replace the if expression by a reference to Cnn.all.
6031 -- This special case can be skipped if the back end handles limited
6032 -- types properly and ensures that no incorrect copies are made.
6034 if Is_By_Reference_Type (Typ)
6035 and then not Back_End_Handles_Limited_Types
6037 -- When the "then" or "else" expressions involve controlled function
6038 -- calls, generated temporaries are chained on the corresponding list
6039 -- of actions. These temporaries need to be finalized after the if
6040 -- expression is evaluated.
6042 Process_If_Case_Statements (N, Then_Actions (N));
6043 Process_If_Case_Statements (N, Else_Actions (N));
6046 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N);
6047 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
6051 -- type Ann is access all Typ;
6054 Make_Full_Type_Declaration (Loc,
6055 Defining_Identifier => Ptr_Typ,
6057 Make_Access_To_Object_Definition (Loc,
6058 All_Present => True,
6059 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
6065 Make_Object_Declaration (Loc,
6066 Defining_Identifier => Cnn,
6067 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
6071 -- Cnn := <Thenx>'Unrestricted_Access;
6073 -- Cnn := <Elsex>'Unrestricted_Access;
6077 Make_Implicit_If_Statement (N,
6078 Condition => Relocate_Node (Cond),
6079 Then_Statements => New_List (
6080 Make_Assignment_Statement (Sloc (Thenx),
6081 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
6083 Make_Attribute_Reference (Loc,
6084 Prefix => Relocate_Node (Thenx),
6085 Attribute_Name => Name_Unrestricted_Access))),
6087 Else_Statements => New_List (
6088 Make_Assignment_Statement (Sloc (Elsex),
6089 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
6091 Make_Attribute_Reference (Loc,
6092 Prefix => Relocate_Node (Elsex),
6093 Attribute_Name => Name_Unrestricted_Access))));
6095 -- Preserve the original context for which the if statement is
6096 -- being generated. This is needed by the finalization machinery
6097 -- to prevent the premature finalization of controlled objects
6098 -- found within the if statement.
6100 Set_From_Conditional_Expression (New_If);
6103 Make_Explicit_Dereference (Loc,
6104 Prefix => New_Occurrence_Of (Cnn, Loc));
6107 -- If the result is an unconstrained array and the if expression is in a
6108 -- context other than the initializing expression of the declaration of
6109 -- an object, then we pull out the if expression as follows:
6111 -- Cnn : constant typ := if-expression
6113 -- and then replace the if expression with an occurrence of Cnn. This
6114 -- avoids the need in the back end to create on-the-fly variable length
6115 -- temporaries (which it cannot do!)
6117 -- Note that the test for being in an object declaration avoids doing an
6118 -- unnecessary expansion, and also avoids infinite recursion.
6120 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ)
6121 and then (Nkind (Parent (N)) /= N_Object_Declaration
6122 or else Expression (Parent (N)) /= N)
6125 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
6129 Make_Object_Declaration (Loc,
6130 Defining_Identifier => Cnn,
6131 Constant_Present => True,
6132 Object_Definition => New_Occurrence_Of (Typ, Loc),
6133 Expression => Relocate_Node (N),
6134 Has_Init_Expression => True));
6136 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
6140 -- For other types, we only need to expand if there are other actions
6141 -- associated with either branch or we need to force expansion to deal
6142 -- with if expressions used as an actual of an anonymous access type.
6144 elsif Present (Then_Actions (N))
6145 or else Present (Else_Actions (N))
6146 or else Force_Expand
6149 -- We now wrap the actions into the appropriate expression
6151 if Minimize_Expression_With_Actions
6152 and then (Is_Elementary_Type (Underlying_Type (Typ))
6153 or else Is_Constrained (Underlying_Type (Typ)))
6155 -- If we can't use N_Expression_With_Actions nodes, then we insert
6156 -- the following sequence of actions (using Insert_Actions):
6161 -- Cnn := then-expr;
6167 -- and replace the if expression by a reference to Cnn
6170 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
6174 Make_Object_Declaration (Loc,
6175 Defining_Identifier => Cnn,
6176 Object_Definition => New_Occurrence_Of (Typ, Loc));
6179 Make_Implicit_If_Statement (N,
6180 Condition => Relocate_Node (Cond),
6182 Then_Statements => New_List (
6183 Make_Assignment_Statement (Sloc (Thenx),
6184 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
6185 Expression => Relocate_Node (Thenx))),
6187 Else_Statements => New_List (
6188 Make_Assignment_Statement (Sloc (Elsex),
6189 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
6190 Expression => Relocate_Node (Elsex))));
6192 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
6193 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
6195 New_N := New_Occurrence_Of (Cnn, Loc);
6198 -- Regular path using Expression_With_Actions
6201 if Present (Then_Actions (N)) then
6203 Make_Expression_With_Actions (Sloc (Thenx),
6204 Actions => Then_Actions (N),
6205 Expression => Relocate_Node (Thenx)));
6207 Set_Then_Actions (N, No_List);
6208 Analyze_And_Resolve (Thenx, Typ);
6211 if Present (Else_Actions (N)) then
6213 Make_Expression_With_Actions (Sloc (Elsex),
6214 Actions => Else_Actions (N),
6215 Expression => Relocate_Node (Elsex)));
6217 Set_Else_Actions (N, No_List);
6218 Analyze_And_Resolve (Elsex, Typ);
6221 -- We must force expansion into an expression with actions when
6222 -- an if expression gets used directly as an actual for an
6223 -- anonymous access type.
6225 if Force_Expand then
6227 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C');
6236 Make_Object_Declaration (Loc,
6237 Defining_Identifier => Cnn,
6238 Object_Definition => New_Occurrence_Of (Typ, Loc));
6239 Append_To (Acts, Decl);
6241 Set_No_Initialization (Decl);
6251 Make_Implicit_If_Statement (N,
6252 Condition => Relocate_Node (Cond),
6253 Then_Statements => New_List (
6254 Make_Assignment_Statement (Sloc (Thenx),
6255 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
6256 Expression => Relocate_Node (Thenx))),
6258 Else_Statements => New_List (
6259 Make_Assignment_Statement (Sloc (Elsex),
6260 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
6261 Expression => Relocate_Node (Elsex))));
6262 Append_To (Acts, New_If);
6270 Make_Expression_With_Actions (Loc,
6271 Expression => New_Occurrence_Of (Cnn, Loc),
6273 Analyze_And_Resolve (N, Typ);
6280 -- If no actions then no expansion needed, gigi will handle it using the
6281 -- same approach as a C conditional expression.
6287 -- Fall through here for either the limited expansion, or the case of
6288 -- inserting actions for nonlimited types. In both these cases, we must
6289 -- move the SLOC of the parent If statement to the newly created one and
6290 -- change it to the SLOC of the expression which, after expansion, will
6291 -- correspond to what is being evaluated.
6293 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
6294 Set_Sloc (New_If, Sloc (Parent (N)));
6295 Set_Sloc (Parent (N), Loc);
6298 -- Make sure Then_Actions and Else_Actions are appropriately moved
6299 -- to the new if statement.
6301 if Present (Then_Actions (N)) then
6303 (First (Then_Statements (New_If)), Then_Actions (N));
6306 if Present (Else_Actions (N)) then
6308 (First (Else_Statements (New_If)), Else_Actions (N));
6311 Insert_Action (N, Decl);
6312 Insert_Action (N, New_If);
6314 Analyze_And_Resolve (N, Typ);
6315 end Expand_N_If_Expression;
6321 procedure Expand_N_In (N : Node_Id) is
6322 Loc : constant Source_Ptr := Sloc (N);
6323 Restyp : constant Entity_Id := Etype (N);
6324 Lop : constant Node_Id := Left_Opnd (N);
6325 Rop : constant Node_Id := Right_Opnd (N);
6326 Static : constant Boolean := Is_OK_Static_Expression (N);
6328 procedure Substitute_Valid_Check;
6329 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6330 -- test for the left operand being in range of its subtype.
6332 ----------------------------
6333 -- Substitute_Valid_Check --
6334 ----------------------------
6336 procedure Substitute_Valid_Check is
6337 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
6338 -- Determine whether arbitrary node Nod denotes a source object that
6339 -- may safely act as prefix of attribute 'Valid.
6341 ----------------------------
6342 -- Is_OK_Object_Reference --
6343 ----------------------------
6345 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is
6349 -- Inspect the original operand
6351 Obj_Ref := Original_Node (Nod);
6353 -- The object reference must be a source construct, otherwise the
6354 -- codefix suggestion may refer to nonexistent code from a user
6357 if Comes_From_Source (Obj_Ref) then
6359 -- Recover the actual object reference. There may be more cases
6363 if Nkind (Obj_Ref) in
6364 N_Type_Conversion | N_Unchecked_Type_Conversion
6366 Obj_Ref := Expression (Obj_Ref);
6372 return Is_Object_Reference (Obj_Ref);
6376 end Is_OK_Object_Reference;
6378 -- Start of processing for Substitute_Valid_Check
6382 Make_Attribute_Reference (Loc,
6383 Prefix => Relocate_Node (Lop),
6384 Attribute_Name => Name_Valid));
6386 Analyze_And_Resolve (N, Restyp);
6388 -- Emit a warning when the left-hand operand of the membership test
6389 -- is a source object, otherwise the use of attribute 'Valid would be
6390 -- illegal. The warning is not given when overflow checking is either
6391 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6392 -- eliminated above.
6394 if Is_OK_Object_Reference (Lop)
6395 and then Overflow_Check_Mode not in Minimized_Or_Eliminated
6398 ("??explicit membership test may be optimized away", N);
6399 Error_Msg_N -- CODEFIX
6400 ("\??use ''Valid attribute instead", N);
6402 end Substitute_Valid_Check;
6409 -- Start of processing for Expand_N_In
6412 -- If set membership case, expand with separate procedure
6414 if Present (Alternatives (N)) then
6415 Expand_Set_Membership (N);
6419 -- Not set membership, proceed with expansion
6421 Ltyp := Etype (Left_Opnd (N));
6422 Rtyp := Etype (Right_Opnd (N));
6424 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6425 -- type, then expand with a separate procedure. Note the use of the
6426 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6428 if Overflow_Check_Mode in Minimized_Or_Eliminated
6429 and then Is_Signed_Integer_Type (Ltyp)
6430 and then not No_Minimize_Eliminate (N)
6432 Expand_Membership_Minimize_Eliminate_Overflow (N);
6436 -- Check case of explicit test for an expression in range of its
6437 -- subtype. This is suspicious usage and we replace it with a 'Valid
6438 -- test and give a warning for scalar types.
6440 if Is_Scalar_Type (Ltyp)
6442 -- Only relevant for source comparisons
6444 and then Comes_From_Source (N)
6446 -- In floating-point this is a standard way to check for finite values
6447 -- and using 'Valid would typically be a pessimization.
6449 and then not Is_Floating_Point_Type (Ltyp)
6451 -- Don't give the message unless right operand is a type entity and
6452 -- the type of the left operand matches this type. Note that this
6453 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6454 -- checks have changed the type of the left operand.
6456 and then Nkind (Rop) in N_Has_Entity
6457 and then Ltyp = Entity (Rop)
6459 -- Skip this for predicated types, where such expressions are a
6460 -- reasonable way of testing if something meets the predicate.
6462 and then not Present (Predicate_Function (Ltyp))
6464 Substitute_Valid_Check;
6468 -- Do validity check on operands
6470 if Validity_Checks_On and Validity_Check_Operands then
6471 Ensure_Valid (Left_Opnd (N));
6472 Validity_Check_Range (Right_Opnd (N));
6475 -- Case of explicit range
6477 if Nkind (Rop) = N_Range then
6479 Lo : constant Node_Id := Low_Bound (Rop);
6480 Hi : constant Node_Id := High_Bound (Rop);
6482 Lo_Orig : constant Node_Id := Original_Node (Lo);
6483 Hi_Orig : constant Node_Id := Original_Node (Hi);
6485 Lcheck : Compare_Result;
6486 Ucheck : Compare_Result;
6488 Warn1 : constant Boolean :=
6489 Constant_Condition_Warnings
6490 and then Comes_From_Source (N)
6491 and then not In_Instance;
6492 -- This must be true for any of the optimization warnings, we
6493 -- clearly want to give them only for source with the flag on. We
6494 -- also skip these warnings in an instance since it may be the
6495 -- case that different instantiations have different ranges.
6497 Warn2 : constant Boolean :=
6499 and then Nkind (Original_Node (Rop)) = N_Range
6500 and then Is_Integer_Type (Etype (Lo));
6501 -- For the case where only one bound warning is elided, we also
6502 -- insist on an explicit range and an integer type. The reason is
6503 -- that the use of enumeration ranges including an end point is
6504 -- common, as is the use of a subtype name, one of whose bounds is
6505 -- the same as the type of the expression.
6508 -- If test is explicit x'First .. x'Last, replace by valid check
6510 -- Could use some individual comments for this complex test ???
6512 if Is_Scalar_Type (Ltyp)
6514 -- And left operand is X'First where X matches left operand
6515 -- type (this eliminates cases of type mismatch, including
6516 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6517 -- type of the left operand.
6519 and then Nkind (Lo_Orig) = N_Attribute_Reference
6520 and then Attribute_Name (Lo_Orig) = Name_First
6521 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
6522 and then Entity (Prefix (Lo_Orig)) = Ltyp
6524 -- Same tests for right operand
6526 and then Nkind (Hi_Orig) = N_Attribute_Reference
6527 and then Attribute_Name (Hi_Orig) = Name_Last
6528 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
6529 and then Entity (Prefix (Hi_Orig)) = Ltyp
6531 -- Relevant only for source cases
6533 and then Comes_From_Source (N)
6535 Substitute_Valid_Check;
6539 -- If bounds of type are known at compile time, and the end points
6540 -- are known at compile time and identical, this is another case
6541 -- for substituting a valid test. We only do this for discrete
6542 -- types, since it won't arise in practice for float types.
6544 if Comes_From_Source (N)
6545 and then Is_Discrete_Type (Ltyp)
6546 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
6547 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
6548 and then Compile_Time_Known_Value (Lo)
6549 and then Compile_Time_Known_Value (Hi)
6550 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
6551 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
6553 -- Kill warnings in instances, since they may be cases where we
6554 -- have a test in the generic that makes sense with some types
6555 -- and not with other types.
6557 -- Similarly, do not rewrite membership as a validity check if
6558 -- within the predicate function for the type.
6560 -- Finally, if the original bounds are type conversions, even
6561 -- if they have been folded into constants, there are different
6562 -- types involved and 'Valid is not appropriate.
6566 or else (Ekind (Current_Scope) = E_Function
6567 and then Is_Predicate_Function (Current_Scope))
6571 elsif Nkind (Lo_Orig) = N_Type_Conversion
6572 or else Nkind (Hi_Orig) = N_Type_Conversion
6577 Substitute_Valid_Check;
6582 -- If we have an explicit range, do a bit of optimization based on
6583 -- range analysis (we may be able to kill one or both checks).
6585 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
6586 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
6588 -- If either check is known to fail, replace result by False since
6589 -- the other check does not matter. Preserve the static flag for
6590 -- legality checks, because we are constant-folding beyond RM 4.9.
6592 if Lcheck = LT or else Ucheck = GT then
6594 Error_Msg_N ("?c?range test optimized away", N);
6595 Error_Msg_N ("\?c?value is known to be out of range", N);
6598 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6599 Analyze_And_Resolve (N, Restyp);
6600 Set_Is_Static_Expression (N, Static);
6603 -- If both checks are known to succeed, replace result by True,
6604 -- since we know we are in range.
6606 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6608 Error_Msg_N ("?c?range test optimized away", N);
6609 Error_Msg_N ("\?c?value is known to be in range", N);
6612 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6613 Analyze_And_Resolve (N, Restyp);
6614 Set_Is_Static_Expression (N, Static);
6617 -- If lower bound check succeeds and upper bound check is not
6618 -- known to succeed or fail, then replace the range check with
6619 -- a comparison against the upper bound.
6621 elsif Lcheck in Compare_GE then
6622 if Warn2 and then not In_Instance then
6623 Error_Msg_N ("??lower bound test optimized away", Lo);
6624 Error_Msg_N ("\??value is known to be in range", Lo);
6630 Right_Opnd => High_Bound (Rop)));
6631 Analyze_And_Resolve (N, Restyp);
6634 -- If upper bound check succeeds and lower bound check is not
6635 -- known to succeed or fail, then replace the range check with
6636 -- a comparison against the lower bound.
6638 elsif Ucheck in Compare_LE then
6639 if Warn2 and then not In_Instance then
6640 Error_Msg_N ("??upper bound test optimized away", Hi);
6641 Error_Msg_N ("\??value is known to be in range", Hi);
6647 Right_Opnd => Low_Bound (Rop)));
6648 Analyze_And_Resolve (N, Restyp);
6652 -- We couldn't optimize away the range check, but there is one
6653 -- more issue. If we are checking constant conditionals, then we
6654 -- see if we can determine the outcome assuming everything is
6655 -- valid, and if so give an appropriate warning.
6657 if Warn1 and then not Assume_No_Invalid_Values then
6658 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
6659 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
6661 -- Result is out of range for valid value
6663 if Lcheck = LT or else Ucheck = GT then
6665 ("?c?value can only be in range if it is invalid", N);
6667 -- Result is in range for valid value
6669 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6671 ("?c?value can only be out of range if it is invalid", N);
6673 -- Lower bound check succeeds if value is valid
6675 elsif Warn2 and then Lcheck in Compare_GE then
6677 ("?c?lower bound check only fails if it is invalid", Lo);
6679 -- Upper bound check succeeds if value is valid
6681 elsif Warn2 and then Ucheck in Compare_LE then
6683 ("?c?upper bound check only fails for invalid values", Hi);
6688 -- Try to narrow the operation
6690 if Ltyp = Universal_Integer and then Nkind (N) = N_In then
6691 Narrow_Large_Operation (N);
6694 -- For all other cases of an explicit range, nothing to be done
6698 -- Here right operand is a subtype mark
6702 Typ : Entity_Id := Etype (Rop);
6703 Is_Acc : constant Boolean := Is_Access_Type (Typ);
6704 Check_Null_Exclusion : Boolean;
6705 Cond : Node_Id := Empty;
6707 Obj : Node_Id := Lop;
6708 SCIL_Node : Node_Id;
6711 Remove_Side_Effects (Obj);
6713 -- For tagged type, do tagged membership operation
6715 if Is_Tagged_Type (Typ) then
6717 -- No expansion will be performed for VM targets, as the VM
6718 -- back ends will handle the membership tests directly.
6720 if Tagged_Type_Expansion then
6721 Tagged_Membership (N, SCIL_Node, New_N);
6723 Analyze_And_Resolve (N, Restyp, Suppress => All_Checks);
6725 -- Update decoration of relocated node referenced by the
6728 if Generate_SCIL and then Present (SCIL_Node) then
6729 Set_SCIL_Node (N, SCIL_Node);
6735 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6736 -- This reason we do this is that the bounds may have the wrong
6737 -- type if they come from the original type definition. Also this
6738 -- way we get all the processing above for an explicit range.
6740 -- Don't do this for predicated types, since in this case we
6741 -- want to check the predicate.
6743 elsif Is_Scalar_Type (Typ) then
6744 if No (Predicate_Function (Typ)) then
6748 Make_Attribute_Reference (Loc,
6749 Attribute_Name => Name_First,
6750 Prefix => New_Occurrence_Of (Typ, Loc)),
6753 Make_Attribute_Reference (Loc,
6754 Attribute_Name => Name_Last,
6755 Prefix => New_Occurrence_Of (Typ, Loc))));
6756 Analyze_And_Resolve (N, Restyp);
6761 -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is
6762 -- raised when evaluating an individual membership test if the
6763 -- subtype mark denotes a constrained Unchecked_Union subtype
6764 -- and the expression lacks inferable discriminants.
6766 elsif Is_Unchecked_Union (Base_Type (Typ))
6767 and then Is_Constrained (Typ)
6768 and then not Has_Inferable_Discriminants (Lop)
6771 Make_Expression_With_Actions (Loc,
6773 New_List (Make_Raise_Program_Error (Loc,
6774 Reason => PE_Unchecked_Union_Restriction)),
6776 New_Occurrence_Of (Standard_False, Loc)));
6777 Analyze_And_Resolve (N, Restyp);
6782 -- Here we have a non-scalar type
6786 -- If the null exclusion checks are not compatible, need to
6787 -- perform further checks. In other words, we cannot have
6788 -- Ltyp including null and Typ excluding null. All other cases
6791 Check_Null_Exclusion :=
6792 Can_Never_Be_Null (Typ) and then not Can_Never_Be_Null (Ltyp);
6793 Typ := Designated_Type (Typ);
6796 if not Is_Constrained (Typ) then
6797 Cond := New_Occurrence_Of (Standard_True, Loc);
6799 -- For the constrained array case, we have to check the subscripts
6800 -- for an exact match if the lengths are non-zero (the lengths
6801 -- must match in any case).
6803 elsif Is_Array_Type (Typ) then
6804 Check_Subscripts : declare
6805 function Build_Attribute_Reference
6808 Dim : Nat) return Node_Id;
6809 -- Build attribute reference E'Nam (Dim)
6811 -------------------------------
6812 -- Build_Attribute_Reference --
6813 -------------------------------
6815 function Build_Attribute_Reference
6818 Dim : Nat) return Node_Id
6822 Make_Attribute_Reference (Loc,
6824 Attribute_Name => Nam,
6825 Expressions => New_List (
6826 Make_Integer_Literal (Loc, Dim)));
6827 end Build_Attribute_Reference;
6829 -- Start of processing for Check_Subscripts
6832 for J in 1 .. Number_Dimensions (Typ) loop
6833 Evolve_And_Then (Cond,
6836 Build_Attribute_Reference
6837 (Duplicate_Subexpr_No_Checks (Obj),
6840 Build_Attribute_Reference
6841 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
6843 Evolve_And_Then (Cond,
6846 Build_Attribute_Reference
6847 (Duplicate_Subexpr_No_Checks (Obj),
6850 Build_Attribute_Reference
6851 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
6853 end Check_Subscripts;
6855 -- These are the cases where constraint checks may be required,
6856 -- e.g. records with possible discriminants
6859 -- Expand the test into a series of discriminant comparisons.
6860 -- The expression that is built is the negation of the one that
6861 -- is used for checking discriminant constraints.
6863 Obj := Relocate_Node (Left_Opnd (N));
6865 if Has_Discriminants (Typ) then
6866 Cond := Make_Op_Not (Loc,
6867 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
6869 Cond := New_Occurrence_Of (Standard_True, Loc);
6874 if Check_Null_Exclusion then
6875 Cond := Make_And_Then (Loc,
6879 Right_Opnd => Make_Null (Loc)),
6880 Right_Opnd => Cond);
6882 Cond := Make_Or_Else (Loc,
6886 Right_Opnd => Make_Null (Loc)),
6887 Right_Opnd => Cond);
6892 Analyze_And_Resolve (N, Restyp);
6894 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6895 -- expression of an anonymous access type. This can involve an
6896 -- accessibility test and a tagged type membership test in the
6897 -- case of tagged designated types.
6899 if Ada_Version >= Ada_2012
6901 and then Ekind (Ltyp) = E_Anonymous_Access_Type
6904 Expr_Entity : Entity_Id := Empty;
6906 Param_Level : Node_Id;
6907 Type_Level : Node_Id;
6910 if Is_Entity_Name (Lop) then
6911 Expr_Entity := Param_Entity (Lop);
6913 if not Present (Expr_Entity) then
6914 Expr_Entity := Entity (Lop);
6918 -- If a conversion of the anonymous access value to the
6919 -- tested type would be illegal, then the result is False.
6921 if not Valid_Conversion
6922 (Lop, Rtyp, Lop, Report_Errs => False)
6924 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6925 Analyze_And_Resolve (N, Restyp);
6927 -- Apply an accessibility check if the access object has an
6928 -- associated access level and when the level of the type is
6929 -- less deep than the level of the access parameter. This
6930 -- can only occur for access parameters and stand-alone
6931 -- objects of an anonymous access type.
6934 Param_Level := Accessibility_Level
6935 (Expr_Entity, Dynamic_Level);
6938 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
6940 -- Return True only if the accessibility level of the
6941 -- expression entity is not deeper than the level of
6942 -- the tested access type.
6946 Left_Opnd => Relocate_Node (N),
6947 Right_Opnd => Make_Op_Le (Loc,
6948 Left_Opnd => Param_Level,
6949 Right_Opnd => Type_Level)));
6951 Analyze_And_Resolve (N);
6953 -- If the designated type is tagged, do tagged membership
6956 if Is_Tagged_Type (Typ) then
6958 -- No expansion will be performed for VM targets, as
6959 -- the VM back ends will handle the membership tests
6962 if Tagged_Type_Expansion then
6964 -- Note that we have to pass Original_Node, because
6965 -- the membership test might already have been
6966 -- rewritten by earlier parts of membership test.
6969 (Original_Node (N), SCIL_Node, New_N);
6971 -- Update decoration of relocated node referenced
6972 -- by the SCIL node.
6974 if Generate_SCIL and then Present (SCIL_Node) then
6975 Set_SCIL_Node (New_N, SCIL_Node);
6980 Left_Opnd => Relocate_Node (N),
6981 Right_Opnd => New_N));
6983 Analyze_And_Resolve (N, Restyp);
6992 -- At this point, we have done the processing required for the basic
6993 -- membership test, but not yet dealt with the predicate.
6997 -- If a predicate is present, then we do the predicate test, but we
6998 -- most certainly want to omit this if we are within the predicate
6999 -- function itself, since otherwise we have an infinite recursion.
7000 -- The check should also not be emitted when testing against a range
7001 -- (the check is only done when the right operand is a subtype; see
7002 -- RM12-4.5.2 (28.1/3-30/3)).
7004 Predicate_Check : declare
7005 function In_Range_Check return Boolean;
7006 -- Within an expanded range check that may raise Constraint_Error do
7007 -- not generate a predicate check as well. It is redundant because
7008 -- the context will add an explicit predicate check, and it will
7009 -- raise the wrong exception if it fails.
7011 --------------------
7012 -- In_Range_Check --
7013 --------------------
7015 function In_Range_Check return Boolean is
7019 while Present (P) loop
7020 if Nkind (P) = N_Raise_Constraint_Error then
7023 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call
7024 or else Nkind (P) = N_Procedure_Call_Statement
7025 or else Nkind (P) in N_Declaration
7038 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
7041 -- Start of processing for Predicate_Check
7045 and then Current_Scope /= PFunc
7046 and then Nkind (Rop) /= N_Range
7048 if not In_Range_Check then
7049 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True);
7051 R_Op := New_Occurrence_Of (Standard_True, Loc);
7056 Left_Opnd => Relocate_Node (N),
7057 Right_Opnd => R_Op));
7059 -- Analyze new expression, mark left operand as analyzed to
7060 -- avoid infinite recursion adding predicate calls. Similarly,
7061 -- suppress further range checks on the call.
7063 Set_Analyzed (Left_Opnd (N));
7064 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7066 -- All done, skip attempt at compile time determination of result
7070 end Predicate_Check;
7073 --------------------------------
7074 -- Expand_N_Indexed_Component --
7075 --------------------------------
7077 procedure Expand_N_Indexed_Component (N : Node_Id) is
7078 Loc : constant Source_Ptr := Sloc (N);
7079 Typ : constant Entity_Id := Etype (N);
7080 P : constant Node_Id := Prefix (N);
7081 T : constant Entity_Id := Etype (P);
7084 -- A special optimization, if we have an indexed component that is
7085 -- selecting from a slice, then we can eliminate the slice, since, for
7086 -- example, x (i .. j)(k) is identical to x(k). The only difference is
7087 -- the range check required by the slice. The range check for the slice
7088 -- itself has already been generated. The range check for the
7089 -- subscripting operation is ensured by converting the subject to
7090 -- the subtype of the slice.
7092 -- This optimization not only generates better code, avoiding slice
7093 -- messing especially in the packed case, but more importantly bypasses
7094 -- some problems in handling this peculiar case, for example, the issue
7095 -- of dealing specially with object renamings.
7097 if Nkind (P) = N_Slice
7099 -- This optimization is disabled for CodePeer because it can transform
7100 -- an index-check constraint_error into a range-check constraint_error
7101 -- and CodePeer cares about that distinction.
7103 and then not CodePeer_Mode
7106 Make_Indexed_Component (Loc,
7107 Prefix => Prefix (P),
7108 Expressions => New_List (
7110 (Etype (First_Index (Etype (P))),
7111 First (Expressions (N))))));
7112 Analyze_And_Resolve (N, Typ);
7116 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7117 -- function, then additional actuals must be passed.
7119 if Is_Build_In_Place_Function_Call (P) then
7120 Make_Build_In_Place_Call_In_Anonymous_Context (P);
7122 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
7123 -- containing build-in-place function calls whose returned object covers
7126 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
7127 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
7130 -- Generate index and validity checks
7132 Generate_Index_Checks (N);
7134 if Validity_Checks_On and then Validity_Check_Subscripts then
7135 Apply_Subscript_Validity_Checks (N);
7138 -- If selecting from an array with atomic components, and atomic sync
7139 -- is not suppressed for this array type, set atomic sync flag.
7141 if (Has_Atomic_Components (T)
7142 and then not Atomic_Synchronization_Disabled (T))
7143 or else (Is_Atomic (Typ)
7144 and then not Atomic_Synchronization_Disabled (Typ))
7145 or else (Is_Entity_Name (P)
7146 and then Has_Atomic_Components (Entity (P))
7147 and then not Atomic_Synchronization_Disabled (Entity (P)))
7149 Activate_Atomic_Synchronization (N);
7152 -- All done if the prefix is not a packed array implemented specially
7154 if not (Is_Packed (Etype (Prefix (N)))
7155 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N)))))
7160 -- For packed arrays that are not bit-packed (i.e. the case of an array
7161 -- with one or more index types with a non-contiguous enumeration type),
7162 -- we can always use the normal packed element get circuit.
7164 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
7165 Expand_Packed_Element_Reference (N);
7169 -- For a reference to a component of a bit packed array, we convert it
7170 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
7171 -- want to do this for simple references, and not for:
7173 -- Left side of assignment, or prefix of left side of assignment, or
7174 -- prefix of the prefix, to handle packed arrays of packed arrays,
7175 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
7177 -- Renaming objects in renaming associations
7178 -- This case is handled when a use of the renamed variable occurs
7180 -- Actual parameters for a subprogram call
7181 -- This case is handled in Exp_Ch6.Expand_Actuals
7183 -- The second expression in a 'Read attribute reference
7185 -- The prefix of an address or bit or size attribute reference
7187 -- The following circuit detects these exceptions. Note that we need to
7188 -- deal with implicit dereferences when climbing up the parent chain,
7189 -- with the additional difficulty that the type of parents may have yet
7190 -- to be resolved since prefixes are usually resolved first.
7193 Child : Node_Id := N;
7194 Parnt : Node_Id := Parent (N);
7198 if Nkind (Parnt) = N_Unchecked_Expression then
7201 elsif Nkind (Parnt) = N_Object_Renaming_Declaration then
7204 elsif Nkind (Parnt) in N_Subprogram_Call
7205 or else (Nkind (Parnt) = N_Parameter_Association
7206 and then Nkind (Parent (Parnt)) in N_Subprogram_Call)
7210 elsif Nkind (Parnt) = N_Attribute_Reference
7211 and then Attribute_Name (Parnt) in Name_Address
7214 and then Prefix (Parnt) = Child
7218 elsif Nkind (Parnt) = N_Assignment_Statement
7219 and then Name (Parnt) = Child
7223 -- If the expression is an index of an indexed component, it must
7224 -- be expanded regardless of context.
7226 elsif Nkind (Parnt) = N_Indexed_Component
7227 and then Child /= Prefix (Parnt)
7229 Expand_Packed_Element_Reference (N);
7232 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
7233 and then Name (Parent (Parnt)) = Parnt
7237 elsif Nkind (Parnt) = N_Attribute_Reference
7238 and then Attribute_Name (Parnt) = Name_Read
7239 and then Next (First (Expressions (Parnt))) = Child
7243 elsif Nkind (Parnt) = N_Indexed_Component
7244 and then Prefix (Parnt) = Child
7248 elsif Nkind (Parnt) = N_Selected_Component
7249 and then Prefix (Parnt) = Child
7250 and then not (Present (Etype (Selector_Name (Parnt)))
7252 Is_Access_Type (Etype (Selector_Name (Parnt))))
7256 -- If the parent is a dereference, either implicit or explicit,
7257 -- then the packed reference needs to be expanded.
7260 Expand_Packed_Element_Reference (N);
7264 -- Keep looking up tree for unchecked expression, or if we are the
7265 -- prefix of a possible assignment left side.
7268 Parnt := Parent (Child);
7271 end Expand_N_Indexed_Component;
7273 ---------------------
7274 -- Expand_N_Not_In --
7275 ---------------------
7277 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7278 -- can be done. This avoids needing to duplicate this expansion code.
7280 procedure Expand_N_Not_In (N : Node_Id) is
7281 Loc : constant Source_Ptr := Sloc (N);
7282 Typ : constant Entity_Id := Etype (N);
7283 Cfs : constant Boolean := Comes_From_Source (N);
7290 Left_Opnd => Left_Opnd (N),
7291 Right_Opnd => Right_Opnd (N))));
7293 -- If this is a set membership, preserve list of alternatives
7295 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
7297 -- We want this to appear as coming from source if original does (see
7298 -- transformations in Expand_N_In).
7300 Set_Comes_From_Source (N, Cfs);
7301 Set_Comes_From_Source (Right_Opnd (N), Cfs);
7303 -- Now analyze transformed node
7305 Analyze_And_Resolve (N, Typ);
7306 end Expand_N_Not_In;
7312 -- The only replacement required is for the case of a null of a type that
7313 -- is an access to protected subprogram, or a subtype thereof. We represent
7314 -- such access values as a record, and so we must replace the occurrence of
7315 -- null by the equivalent record (with a null address and a null pointer in
7316 -- it), so that the back end creates the proper value.
7318 procedure Expand_N_Null (N : Node_Id) is
7319 Loc : constant Source_Ptr := Sloc (N);
7320 Typ : constant Entity_Id := Base_Type (Etype (N));
7324 if Is_Access_Protected_Subprogram_Type (Typ) then
7326 Make_Aggregate (Loc,
7327 Expressions => New_List (
7328 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
7332 Analyze_And_Resolve (N, Equivalent_Type (Typ));
7334 -- For subsequent semantic analysis, the node must retain its type.
7335 -- Gigi in any case replaces this type by the corresponding record
7336 -- type before processing the node.
7342 when RE_Not_Available =>
7346 ---------------------
7347 -- Expand_N_Op_Abs --
7348 ---------------------
7350 procedure Expand_N_Op_Abs (N : Node_Id) is
7351 Loc : constant Source_Ptr := Sloc (N);
7352 Expr : constant Node_Id := Right_Opnd (N);
7353 Typ : constant Entity_Id := Etype (N);
7356 Unary_Op_Validity_Checks (N);
7358 -- Check for MINIMIZED/ELIMINATED overflow mode
7360 if Minimized_Eliminated_Overflow_Check (N) then
7361 Apply_Arithmetic_Overflow_Check (N);
7365 -- Try to narrow the operation
7367 if Typ = Universal_Integer then
7368 Narrow_Large_Operation (N);
7370 if Nkind (N) /= N_Op_Abs then
7375 -- Deal with software overflow checking
7377 if Is_Signed_Integer_Type (Typ)
7378 and then Do_Overflow_Check (N)
7380 -- The only case to worry about is when the argument is equal to the
7381 -- largest negative number, so what we do is to insert the check:
7383 -- [constraint_error when Expr = typ'Base'First]
7385 -- with the usual Duplicate_Subexpr use coding for expr
7388 Make_Raise_Constraint_Error (Loc,
7391 Left_Opnd => Duplicate_Subexpr (Expr),
7393 Make_Attribute_Reference (Loc,
7395 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
7396 Attribute_Name => Name_First)),
7397 Reason => CE_Overflow_Check_Failed));
7399 Set_Do_Overflow_Check (N, False);
7401 end Expand_N_Op_Abs;
7403 ---------------------
7404 -- Expand_N_Op_Add --
7405 ---------------------
7407 procedure Expand_N_Op_Add (N : Node_Id) is
7408 Typ : constant Entity_Id := Etype (N);
7411 Binary_Op_Validity_Checks (N);
7413 -- Check for MINIMIZED/ELIMINATED overflow mode
7415 if Minimized_Eliminated_Overflow_Check (N) then
7416 Apply_Arithmetic_Overflow_Check (N);
7420 -- N + 0 = 0 + N = N for integer types
7422 if Is_Integer_Type (Typ) then
7423 if Compile_Time_Known_Value (Right_Opnd (N))
7424 and then Expr_Value (Right_Opnd (N)) = Uint_0
7426 Rewrite (N, Left_Opnd (N));
7429 elsif Compile_Time_Known_Value (Left_Opnd (N))
7430 and then Expr_Value (Left_Opnd (N)) = Uint_0
7432 Rewrite (N, Right_Opnd (N));
7437 -- Try to narrow the operation
7439 if Typ = Universal_Integer then
7440 Narrow_Large_Operation (N);
7442 if Nkind (N) /= N_Op_Add then
7447 -- Arithmetic overflow checks for signed integer/fixed point types
7449 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
7450 Apply_Arithmetic_Overflow_Check (N);
7454 -- Overflow checks for floating-point if -gnateF mode active
7456 Check_Float_Op_Overflow (N);
7458 Expand_Nonbinary_Modular_Op (N);
7459 end Expand_N_Op_Add;
7461 ---------------------
7462 -- Expand_N_Op_And --
7463 ---------------------
7465 procedure Expand_N_Op_And (N : Node_Id) is
7466 Typ : constant Entity_Id := Etype (N);
7469 Binary_Op_Validity_Checks (N);
7471 if Is_Array_Type (Etype (N)) then
7472 Expand_Boolean_Operator (N);
7474 elsif Is_Boolean_Type (Etype (N)) then
7475 Adjust_Condition (Left_Opnd (N));
7476 Adjust_Condition (Right_Opnd (N));
7477 Set_Etype (N, Standard_Boolean);
7478 Adjust_Result_Type (N, Typ);
7480 elsif Is_Intrinsic_Subprogram (Entity (N)) then
7481 Expand_Intrinsic_Call (N, Entity (N));
7484 Expand_Nonbinary_Modular_Op (N);
7485 end Expand_N_Op_And;
7487 ------------------------
7488 -- Expand_N_Op_Concat --
7489 ------------------------
7491 procedure Expand_N_Op_Concat (N : Node_Id) is
7493 -- List of operands to be concatenated
7496 -- Node which is to be replaced by the result of concatenating the nodes
7497 -- in the list Opnds.
7500 -- Ensure validity of both operands
7502 Binary_Op_Validity_Checks (N);
7504 -- If we are the left operand of a concatenation higher up the tree,
7505 -- then do nothing for now, since we want to deal with a series of
7506 -- concatenations as a unit.
7508 if Nkind (Parent (N)) = N_Op_Concat
7509 and then N = Left_Opnd (Parent (N))
7514 -- We get here with a concatenation whose left operand may be a
7515 -- concatenation itself with a consistent type. We need to process
7516 -- these concatenation operands from left to right, which means
7517 -- from the deepest node in the tree to the highest node.
7520 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
7521 Cnode := Left_Opnd (Cnode);
7524 -- Now Cnode is the deepest concatenation, and its parents are the
7525 -- concatenation nodes above, so now we process bottom up, doing the
7528 -- The outer loop runs more than once if more than one concatenation
7529 -- type is involved.
7532 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
7533 Set_Parent (Opnds, N);
7535 -- The inner loop gathers concatenation operands
7537 Inner : while Cnode /= N
7538 and then Base_Type (Etype (Cnode)) =
7539 Base_Type (Etype (Parent (Cnode)))
7541 Cnode := Parent (Cnode);
7542 Append (Right_Opnd (Cnode), Opnds);
7545 -- Note: The following code is a temporary workaround for N731-034
7546 -- and N829-028 and will be kept until the general issue of internal
7547 -- symbol serialization is addressed. The workaround is kept under a
7548 -- debug switch to avoid permiating into the general case.
7550 -- Wrap the node to concatenate into an expression actions node to
7551 -- keep it nicely packaged. This is useful in the case of an assert
7552 -- pragma with a concatenation where we want to be able to delete
7553 -- the concatenation and all its expansion stuff.
7555 if Debug_Flag_Dot_H then
7557 Cnod : constant Node_Id := New_Copy_Tree (Cnode);
7558 Typ : constant Entity_Id := Base_Type (Etype (Cnode));
7561 -- Note: use Rewrite rather than Replace here, so that for
7562 -- example Why_Not_Static can find the original concatenation
7566 Make_Expression_With_Actions (Sloc (Cnode),
7567 Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
7568 Expression => Cnod));
7570 Expand_Concatenate (Cnod, Opnds);
7571 Analyze_And_Resolve (Cnode, Typ);
7577 Expand_Concatenate (Cnode, Opnds);
7580 exit Outer when Cnode = N;
7581 Cnode := Parent (Cnode);
7583 end Expand_N_Op_Concat;
7585 ------------------------
7586 -- Expand_N_Op_Divide --
7587 ------------------------
7589 procedure Expand_N_Op_Divide (N : Node_Id) is
7590 Loc : constant Source_Ptr := Sloc (N);
7591 Lopnd : constant Node_Id := Left_Opnd (N);
7592 Ropnd : constant Node_Id := Right_Opnd (N);
7593 Ltyp : constant Entity_Id := Etype (Lopnd);
7594 Rtyp : constant Entity_Id := Etype (Ropnd);
7595 Typ : Entity_Id := Etype (N);
7596 Rknow : constant Boolean := Is_Integer_Type (Typ)
7598 Compile_Time_Known_Value (Ropnd);
7602 Binary_Op_Validity_Checks (N);
7604 -- Check for MINIMIZED/ELIMINATED overflow mode
7606 if Minimized_Eliminated_Overflow_Check (N) then
7607 Apply_Arithmetic_Overflow_Check (N);
7611 -- Otherwise proceed with expansion of division
7614 Rval := Expr_Value (Ropnd);
7617 -- N / 1 = N for integer types
7619 if Rknow and then Rval = Uint_1 then
7624 -- Try to narrow the operation
7626 if Typ = Universal_Integer then
7627 Narrow_Large_Operation (N);
7629 if Nkind (N) /= N_Op_Divide then
7634 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7635 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7636 -- operand is an unsigned integer, as required for this to work.
7638 if Nkind (Ropnd) = N_Op_Expon
7639 and then Is_Power_Of_2_For_Shift (Ropnd)
7641 -- We cannot do this transformation in configurable run time mode if we
7642 -- have 64-bit integers and long shifts are not available.
7644 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
7647 Make_Op_Shift_Right (Loc,
7650 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
7651 Analyze_And_Resolve (N, Typ);
7655 -- Do required fixup of universal fixed operation
7657 if Typ = Universal_Fixed then
7658 Fixup_Universal_Fixed_Operation (N);
7662 -- Divisions with fixed-point results
7664 if Is_Fixed_Point_Type (Typ) then
7666 if Is_Integer_Type (Rtyp) then
7667 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
7669 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
7672 -- Deal with divide-by-zero check if back end cannot handle them
7673 -- and the flag is set indicating that we need such a check. Note
7674 -- that we don't need to bother here with the case of mixed-mode
7675 -- (Right operand an integer type), since these will be rewritten
7676 -- with conversions to a divide with a fixed-point right operand.
7678 if Nkind (N) = N_Op_Divide
7679 and then Do_Division_Check (N)
7680 and then not Backend_Divide_Checks_On_Target
7681 and then not Is_Integer_Type (Rtyp)
7683 Set_Do_Division_Check (N, False);
7685 Make_Raise_Constraint_Error (Loc,
7688 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd),
7689 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
7690 Reason => CE_Divide_By_Zero));
7693 -- Other cases of division of fixed-point operands
7695 elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then
7696 if Is_Integer_Type (Typ) then
7697 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
7699 pragma Assert (Is_Floating_Point_Type (Typ));
7700 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
7703 -- Mixed-mode operations can appear in a non-static universal context,
7704 -- in which case the integer argument must be converted explicitly.
7706 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
7708 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
7710 Analyze_And_Resolve (Ropnd, Universal_Real);
7712 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
7714 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
7716 Analyze_And_Resolve (Lopnd, Universal_Real);
7718 -- Non-fixed point cases, do integer zero divide and overflow checks
7720 elsif Is_Integer_Type (Typ) then
7721 Apply_Divide_Checks (N);
7724 -- Overflow checks for floating-point if -gnateF mode active
7726 Check_Float_Op_Overflow (N);
7728 Expand_Nonbinary_Modular_Op (N);
7729 end Expand_N_Op_Divide;
7731 --------------------
7732 -- Expand_N_Op_Eq --
7733 --------------------
7735 procedure Expand_N_Op_Eq (N : Node_Id) is
7736 Loc : constant Source_Ptr := Sloc (N);
7737 Typ : constant Entity_Id := Etype (N);
7738 Lhs : constant Node_Id := Left_Opnd (N);
7739 Rhs : constant Node_Id := Right_Opnd (N);
7740 Bodies : constant List_Id := New_List;
7741 A_Typ : constant Entity_Id := Etype (Lhs);
7743 procedure Build_Equality_Call (Eq : Entity_Id);
7744 -- If a constructed equality exists for the type or for its parent,
7745 -- build and analyze call, adding conversions if the operation is
7748 function Is_Equality (Subp : Entity_Id;
7749 Typ : Entity_Id := Empty) return Boolean;
7750 -- Determine whether arbitrary Entity_Id denotes a function with the
7751 -- right name and profile for an equality op, specifically for the
7752 -- base type Typ if Typ is nonempty.
7754 function Find_Equality (Prims : Elist_Id) return Entity_Id;
7755 -- Find a primitive equality function within primitive operation list
7758 function User_Defined_Primitive_Equality_Op
7759 (Typ : Entity_Id) return Entity_Id;
7760 -- Find a user-defined primitive equality function for a given untagged
7761 -- record type, ignoring visibility. Return Empty if no such op found.
7763 function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean;
7764 -- Determines whether a type has a subcomponent of an unconstrained
7765 -- Unchecked_Union subtype. Typ is a record type.
7767 -------------------------
7768 -- Build_Equality_Call --
7769 -------------------------
7771 procedure Build_Equality_Call (Eq : Entity_Id) is
7772 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
7773 L_Exp : Node_Id := Relocate_Node (Lhs);
7774 R_Exp : Node_Id := Relocate_Node (Rhs);
7777 -- Adjust operands if necessary to comparison type
7779 if Base_Type (Op_Type) /= Base_Type (A_Typ)
7780 and then not Is_Class_Wide_Type (A_Typ)
7782 L_Exp := OK_Convert_To (Op_Type, L_Exp);
7783 R_Exp := OK_Convert_To (Op_Type, R_Exp);
7786 -- If we have an Unchecked_Union, we need to add the inferred
7787 -- discriminant values as actuals in the function call. At this
7788 -- point, the expansion has determined that both operands have
7789 -- inferable discriminants.
7791 if Is_Unchecked_Union (Op_Type) then
7793 Lhs_Type : constant Node_Id := Etype (L_Exp);
7794 Rhs_Type : constant Node_Id := Etype (R_Exp);
7796 Lhs_Discr_Vals : Elist_Id;
7797 -- List of inferred discriminant values for left operand.
7799 Rhs_Discr_Vals : Elist_Id;
7800 -- List of inferred discriminant values for right operand.
7805 Lhs_Discr_Vals := New_Elmt_List;
7806 Rhs_Discr_Vals := New_Elmt_List;
7808 -- Per-object constrained selected components require special
7809 -- attention. If the enclosing scope of the component is an
7810 -- Unchecked_Union, we cannot reference its discriminants
7811 -- directly. This is why we use the extra parameters of the
7812 -- equality function of the enclosing Unchecked_Union.
7814 -- type UU_Type (Discr : Integer := 0) is
7817 -- pragma Unchecked_Union (UU_Type);
7819 -- 1. Unchecked_Union enclosing record:
7821 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
7823 -- Comp : UU_Type (Discr);
7825 -- end Enclosing_UU_Type;
7826 -- pragma Unchecked_Union (Enclosing_UU_Type);
7828 -- Obj1 : Enclosing_UU_Type;
7829 -- Obj2 : Enclosing_UU_Type (1);
7831 -- [. . .] Obj1 = Obj2 [. . .]
7835 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
7837 -- A and B are the formal parameters of the equality function
7838 -- of Enclosing_UU_Type. The function always has two extra
7839 -- formals to capture the inferred discriminant values for
7840 -- each discriminant of the type.
7842 -- 2. Non-Unchecked_Union enclosing record:
7845 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
7848 -- Comp : UU_Type (Discr);
7850 -- end Enclosing_Non_UU_Type;
7852 -- Obj1 : Enclosing_Non_UU_Type;
7853 -- Obj2 : Enclosing_Non_UU_Type (1);
7855 -- ... Obj1 = Obj2 ...
7859 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
7860 -- obj1.discr, obj2.discr)) then
7862 -- In this case we can directly reference the discriminants of
7863 -- the enclosing record.
7865 -- Process left operand of equality
7867 if Nkind (Lhs) = N_Selected_Component
7869 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
7871 -- If enclosing record is an Unchecked_Union, use formals
7872 -- corresponding to each discriminant. The name of the
7873 -- formal is that of the discriminant, with added suffix,
7874 -- see Exp_Ch3.Build_Record_Equality for details.
7876 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
7880 (Scope (Entity (Selector_Name (Lhs))));
7881 while Present (Discr) loop
7883 (Make_Identifier (Loc,
7884 Chars => New_External_Name (Chars (Discr), 'A')),
7885 To => Lhs_Discr_Vals);
7886 Next_Discriminant (Discr);
7889 -- If enclosing record is of a non-Unchecked_Union type, it
7890 -- is possible to reference its discriminants directly.
7893 Discr := First_Discriminant (Lhs_Type);
7894 while Present (Discr) loop
7896 (Make_Selected_Component (Loc,
7897 Prefix => Prefix (Lhs),
7900 (Get_Discriminant_Value (Discr,
7902 Stored_Constraint (Lhs_Type)))),
7903 To => Lhs_Discr_Vals);
7904 Next_Discriminant (Discr);
7908 -- Otherwise operand is on object with a constrained type.
7909 -- Infer the discriminant values from the constraint.
7912 Discr := First_Discriminant (Lhs_Type);
7913 while Present (Discr) loop
7916 (Get_Discriminant_Value (Discr,
7918 Stored_Constraint (Lhs_Type))),
7919 To => Lhs_Discr_Vals);
7920 Next_Discriminant (Discr);
7924 -- Similar processing for right operand of equality
7926 if Nkind (Rhs) = N_Selected_Component
7928 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
7930 if Is_Unchecked_Union
7931 (Scope (Entity (Selector_Name (Rhs))))
7935 (Scope (Entity (Selector_Name (Rhs))));
7936 while Present (Discr) loop
7938 (Make_Identifier (Loc,
7939 Chars => New_External_Name (Chars (Discr), 'B')),
7940 To => Rhs_Discr_Vals);
7941 Next_Discriminant (Discr);
7945 Discr := First_Discriminant (Rhs_Type);
7946 while Present (Discr) loop
7948 (Make_Selected_Component (Loc,
7949 Prefix => Prefix (Rhs),
7951 New_Copy (Get_Discriminant_Value
7954 Stored_Constraint (Rhs_Type)))),
7955 To => Rhs_Discr_Vals);
7956 Next_Discriminant (Discr);
7961 Discr := First_Discriminant (Rhs_Type);
7962 while Present (Discr) loop
7964 (New_Copy (Get_Discriminant_Value
7967 Stored_Constraint (Rhs_Type))),
7968 To => Rhs_Discr_Vals);
7969 Next_Discriminant (Discr);
7973 -- Now merge the list of discriminant values so that values
7974 -- of corresponding discriminants are adjacent.
7982 Params := New_List (L_Exp, R_Exp);
7983 L_Elmt := First_Elmt (Lhs_Discr_Vals);
7984 R_Elmt := First_Elmt (Rhs_Discr_Vals);
7985 while Present (L_Elmt) loop
7986 Append_To (Params, Node (L_Elmt));
7987 Append_To (Params, Node (R_Elmt));
7993 Make_Function_Call (Loc,
7994 Name => New_Occurrence_Of (Eq, Loc),
7995 Parameter_Associations => Params));
7999 -- Normal case, not an unchecked union
8003 Make_Function_Call (Loc,
8004 Name => New_Occurrence_Of (Eq, Loc),
8005 Parameter_Associations => New_List (L_Exp, R_Exp)));
8008 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8009 end Build_Equality_Call;
8015 function Is_Equality (Subp : Entity_Id;
8016 Typ : Entity_Id := Empty) return Boolean is
8017 Formal_1 : Entity_Id;
8018 Formal_2 : Entity_Id;
8020 -- The equality function carries name "=", returns Boolean, and has
8021 -- exactly two formal parameters of an identical type.
8023 if Ekind (Subp) = E_Function
8024 and then Chars (Subp) = Name_Op_Eq
8025 and then Base_Type (Etype (Subp)) = Standard_Boolean
8027 Formal_1 := First_Formal (Subp);
8030 if Present (Formal_1) then
8031 Formal_2 := Next_Formal (Formal_1);
8036 and then Present (Formal_2)
8037 and then No (Next_Formal (Formal_2))
8038 and then Base_Type (Etype (Formal_1)) =
8039 Base_Type (Etype (Formal_2))
8042 or else Implementation_Base_Type (Etype (Formal_1)) = Typ);
8052 function Find_Equality (Prims : Elist_Id) return Entity_Id is
8053 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id;
8054 -- Find an equality in a possible alias chain starting from primitive
8057 ---------------------------
8058 -- Find_Aliased_Equality --
8059 ---------------------------
8061 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id is
8065 -- Inspect each candidate in the alias chain, checking whether it
8066 -- denotes an equality.
8069 while Present (Candid) loop
8070 if Is_Equality (Candid) then
8074 Candid := Alias (Candid);
8078 end Find_Aliased_Equality;
8082 Eq_Prim : Entity_Id;
8083 Prim_Elmt : Elmt_Id;
8085 -- Start of processing for Find_Equality
8088 -- Assume that the tagged type lacks an equality
8092 -- Inspect the list of primitives looking for a suitable equality
8093 -- within a possible chain of aliases.
8095 Prim_Elmt := First_Elmt (Prims);
8096 while Present (Prim_Elmt) and then No (Eq_Prim) loop
8097 Eq_Prim := Find_Aliased_Equality (Node (Prim_Elmt));
8099 Next_Elmt (Prim_Elmt);
8102 -- A tagged type should always have an equality
8104 pragma Assert (Present (Eq_Prim));
8109 ----------------------------------------
8110 -- User_Defined_Primitive_Equality_Op --
8111 ----------------------------------------
8113 function User_Defined_Primitive_Equality_Op
8114 (Typ : Entity_Id) return Entity_Id
8116 Enclosing_Scope : constant Node_Id := Scope (Typ);
8119 -- Prune this search by somehow not looking at decls that precede
8120 -- the declaration of the first view of Typ (which might be a partial
8123 for Private_Entities in Boolean loop
8124 if Private_Entities then
8125 if Ekind (Enclosing_Scope) /= E_Package then
8128 E := First_Private_Entity (Enclosing_Scope);
8131 E := First_Entity (Enclosing_Scope);
8134 while Present (E) loop
8135 if Is_Equality (E, Typ) then
8142 if Is_Derived_Type (Typ) then
8143 return User_Defined_Primitive_Equality_Op
8144 (Implementation_Base_Type (Etype (Typ)));
8148 end User_Defined_Primitive_Equality_Op;
8150 ------------------------------------
8151 -- Has_Unconstrained_UU_Component --
8152 ------------------------------------
8154 function Has_Unconstrained_UU_Component
8155 (Typ : Entity_Id) return Boolean
8157 Tdef : constant Node_Id :=
8158 Type_Definition (Declaration_Node (Base_Type (Typ)));
8162 function Component_Is_Unconstrained_UU
8163 (Comp : Node_Id) return Boolean;
8164 -- Determines whether the subtype of the component is an
8165 -- unconstrained Unchecked_Union.
8167 function Variant_Is_Unconstrained_UU
8168 (Variant : Node_Id) return Boolean;
8169 -- Determines whether a component of the variant has an unconstrained
8170 -- Unchecked_Union subtype.
8172 -----------------------------------
8173 -- Component_Is_Unconstrained_UU --
8174 -----------------------------------
8176 function Component_Is_Unconstrained_UU
8177 (Comp : Node_Id) return Boolean
8180 if Nkind (Comp) /= N_Component_Declaration then
8185 Sindic : constant Node_Id :=
8186 Subtype_Indication (Component_Definition (Comp));
8189 -- Unconstrained nominal type. In the case of a constraint
8190 -- present, the node kind would have been N_Subtype_Indication.
8192 if Nkind (Sindic) = N_Identifier then
8193 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
8198 end Component_Is_Unconstrained_UU;
8200 ---------------------------------
8201 -- Variant_Is_Unconstrained_UU --
8202 ---------------------------------
8204 function Variant_Is_Unconstrained_UU
8205 (Variant : Node_Id) return Boolean
8207 Clist : constant Node_Id := Component_List (Variant);
8210 if Is_Empty_List (Component_Items (Clist)) then
8214 -- We only need to test one component
8217 Comp : Node_Id := First (Component_Items (Clist));
8220 while Present (Comp) loop
8221 if Component_Is_Unconstrained_UU (Comp) then
8229 -- None of the components withing the variant were of
8230 -- unconstrained Unchecked_Union type.
8233 end Variant_Is_Unconstrained_UU;
8235 -- Start of processing for Has_Unconstrained_UU_Component
8238 if Null_Present (Tdef) then
8242 Clist := Component_List (Tdef);
8243 Vpart := Variant_Part (Clist);
8245 -- Inspect available components
8247 if Present (Component_Items (Clist)) then
8249 Comp : Node_Id := First (Component_Items (Clist));
8252 while Present (Comp) loop
8254 -- One component is sufficient
8256 if Component_Is_Unconstrained_UU (Comp) then
8265 -- Inspect available components withing variants
8267 if Present (Vpart) then
8269 Variant : Node_Id := First (Variants (Vpart));
8272 while Present (Variant) loop
8274 -- One component within a variant is sufficient
8276 if Variant_Is_Unconstrained_UU (Variant) then
8285 -- Neither the available components, nor the components inside the
8286 -- variant parts were of an unconstrained Unchecked_Union subtype.
8289 end Has_Unconstrained_UU_Component;
8295 -- Start of processing for Expand_N_Op_Eq
8298 Binary_Op_Validity_Checks (N);
8300 -- Deal with private types
8304 if Ekind (Typl) = E_Private_Type then
8305 Typl := Underlying_Type (Typl);
8307 elsif Ekind (Typl) = E_Private_Subtype then
8308 Typl := Underlying_Type (Base_Type (Typl));
8311 -- It may happen in error situations that the underlying type is not
8312 -- set. The error will be detected later, here we just defend the
8319 -- Now get the implementation base type (note that plain Base_Type here
8320 -- might lead us back to the private type, which is not what we want!)
8322 Typl := Implementation_Base_Type (Typl);
8324 -- Equality between variant records results in a call to a routine
8325 -- that has conditional tests of the discriminant value(s), and hence
8326 -- violates the No_Implicit_Conditionals restriction.
8328 if Has_Variant_Part (Typl) then
8333 Check_Restriction (Msg, No_Implicit_Conditionals, N);
8337 ("\comparison of variant records tests discriminants", N);
8343 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8344 -- means we no longer have a comparison operation, we are all done.
8346 Expand_Compare_Minimize_Eliminate_Overflow (N);
8348 if Nkind (N) /= N_Op_Eq then
8352 -- Boolean types (requiring handling of non-standard case)
8354 if Is_Boolean_Type (Typl) then
8355 Adjust_Condition (Left_Opnd (N));
8356 Adjust_Condition (Right_Opnd (N));
8357 Set_Etype (N, Standard_Boolean);
8358 Adjust_Result_Type (N, Typ);
8362 elsif Is_Array_Type (Typl) then
8364 -- If we are doing full validity checking, and it is possible for the
8365 -- array elements to be invalid then expand out array comparisons to
8366 -- make sure that we check the array elements.
8368 if Validity_Check_Operands
8369 and then not Is_Known_Valid (Component_Type (Typl))
8372 Save_Force_Validity_Checks : constant Boolean :=
8373 Force_Validity_Checks;
8375 Force_Validity_Checks := True;
8377 Expand_Array_Equality
8379 Relocate_Node (Lhs),
8380 Relocate_Node (Rhs),
8383 Insert_Actions (N, Bodies);
8384 Analyze_And_Resolve (N, Standard_Boolean);
8385 Force_Validity_Checks := Save_Force_Validity_Checks;
8388 -- Packed case where both operands are known aligned
8390 elsif Is_Bit_Packed_Array (Typl)
8391 and then not Is_Possibly_Unaligned_Object (Lhs)
8392 and then not Is_Possibly_Unaligned_Object (Rhs)
8394 Expand_Packed_Eq (N);
8396 -- Where the component type is elementary we can use a block bit
8397 -- comparison (if supported on the target) exception in the case
8398 -- of floating-point (negative zero issues require element by
8399 -- element comparison), and full access types (where we must be sure
8400 -- to load elements independently) and possibly unaligned arrays.
8402 elsif Is_Elementary_Type (Component_Type (Typl))
8403 and then not Is_Floating_Point_Type (Component_Type (Typl))
8404 and then not Is_Full_Access (Component_Type (Typl))
8405 and then not Is_Possibly_Unaligned_Object (Lhs)
8406 and then not Is_Possibly_Unaligned_Slice (Lhs)
8407 and then not Is_Possibly_Unaligned_Object (Rhs)
8408 and then not Is_Possibly_Unaligned_Slice (Rhs)
8409 and then Support_Composite_Compare_On_Target
8413 -- For composite and floating-point cases, expand equality loop to
8414 -- make sure of using proper comparisons for tagged types, and
8415 -- correctly handling the floating-point case.
8419 Expand_Array_Equality
8421 Relocate_Node (Lhs),
8422 Relocate_Node (Rhs),
8425 Insert_Actions (N, Bodies, Suppress => All_Checks);
8426 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8431 elsif Is_Record_Type (Typl) then
8433 -- For tagged types, use the primitive "="
8435 if Is_Tagged_Type (Typl) then
8437 -- No need to do anything else compiling under restriction
8438 -- No_Dispatching_Calls. During the semantic analysis we
8439 -- already notified such violation.
8441 if Restriction_Active (No_Dispatching_Calls) then
8445 -- If this is an untagged private type completed with a derivation
8446 -- of an untagged private type whose full view is a tagged type,
8447 -- we use the primitive operations of the private type (since it
8448 -- does not have a full view, and also because its equality
8449 -- primitive may have been overridden in its untagged full view).
8451 if Inherits_From_Tagged_Full_View (A_Typ) then
8453 (Find_Equality (Collect_Primitive_Operations (A_Typ)));
8455 -- Find the type's predefined equality or an overriding
8456 -- user-defined equality. The reason for not simply calling
8457 -- Find_Prim_Op here is that there may be a user-defined
8458 -- overloaded equality op that precedes the equality that we
8459 -- want, so we have to explicitly search (e.g., there could be
8460 -- an equality with two different parameter types).
8463 if Is_Class_Wide_Type (Typl) then
8464 Typl := Find_Specific_Type (Typl);
8468 (Find_Equality (Primitive_Operations (Typl)));
8471 -- See AI12-0101 (which only removes a legality rule) and then
8472 -- AI05-0123 (which then applies in the previously illegal case).
8473 -- AI12-0101 is a binding interpretation.
8475 elsif Ada_Version >= Ada_2012
8476 and then Present (User_Defined_Primitive_Equality_Op (Typl))
8478 Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl));
8480 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8481 -- predefined equality operator for a type which has a subcomponent
8482 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
8484 elsif Has_Unconstrained_UU_Component (Typl) then
8486 Make_Raise_Program_Error (Loc,
8487 Reason => PE_Unchecked_Union_Restriction));
8489 -- Prevent Gigi from generating incorrect code by rewriting the
8490 -- equality as a standard False. (is this documented somewhere???)
8493 New_Occurrence_Of (Standard_False, Loc));
8495 elsif Is_Unchecked_Union (Typl) then
8497 -- If we can infer the discriminants of the operands, we make a
8498 -- call to the TSS equality function.
8500 if Has_Inferable_Discriminants (Lhs)
8502 Has_Inferable_Discriminants (Rhs)
8505 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8508 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
8509 -- the predefined equality operator for an Unchecked_Union type
8510 -- if either of the operands lack inferable discriminants.
8513 Make_Raise_Program_Error (Loc,
8514 Reason => PE_Unchecked_Union_Restriction));
8516 -- Emit a warning on source equalities only, otherwise the
8517 -- message may appear out of place due to internal use. The
8518 -- warning is unconditional because it is required by the
8521 if Comes_From_Source (N) then
8523 ("Unchecked_Union discriminants cannot be determined??",
8526 ("\Program_Error will be raised for equality operation??",
8530 -- Prevent Gigi from generating incorrect code by rewriting
8531 -- the equality as a standard False (documented where???).
8534 New_Occurrence_Of (Standard_False, Loc));
8537 -- If a type support function is present (for complex cases), use it
8539 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
8541 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8543 -- When comparing two Bounded_Strings, use the primitive equality of
8544 -- the root Super_String type.
8546 elsif Is_Bounded_String (Typl) then
8549 (Collect_Primitive_Operations (Root_Type (Typl))));
8551 -- Otherwise expand the component by component equality. Note that
8552 -- we never use block-bit comparisons for records, because of the
8553 -- problems with gaps. The back end will often be able to recombine
8554 -- the separate comparisons that we generate here.
8557 Remove_Side_Effects (Lhs);
8558 Remove_Side_Effects (Rhs);
8560 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
8562 Insert_Actions (N, Bodies, Suppress => All_Checks);
8563 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8566 -- If unnesting, handle elementary types whose Equivalent_Types are
8567 -- records because there may be padding or undefined fields.
8569 elsif Unnest_Subprogram_Mode
8570 and then Ekind (Typl) in E_Class_Wide_Type
8571 | E_Class_Wide_Subtype
8572 | E_Access_Subprogram_Type
8573 | E_Access_Protected_Subprogram_Type
8574 | E_Anonymous_Access_Protected_Subprogram_Type
8576 and then Present (Equivalent_Type (Typl))
8577 and then Is_Record_Type (Equivalent_Type (Typl))
8579 Typl := Equivalent_Type (Typl);
8580 Remove_Side_Effects (Lhs);
8581 Remove_Side_Effects (Rhs);
8583 Expand_Record_Equality (N, Typl,
8584 Unchecked_Convert_To (Typl, Lhs),
8585 Unchecked_Convert_To (Typl, Rhs),
8588 Insert_Actions (N, Bodies, Suppress => All_Checks);
8589 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8592 -- Test if result is known at compile time
8594 Rewrite_Comparison (N);
8596 -- Try to narrow the operation
8598 if Typl = Universal_Integer and then Nkind (N) = N_Op_Eq then
8599 Narrow_Large_Operation (N);
8602 -- Special optimization of length comparison
8604 Optimize_Length_Comparison (N);
8606 -- One more special case: if we have a comparison of X'Result = expr
8607 -- in floating-point, then if not already there, change expr to be
8608 -- f'Machine (expr) to eliminate surprise from extra precision.
8610 if Is_Floating_Point_Type (Typl)
8611 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference
8612 and then Attribute_Name (Original_Node (Lhs)) = Name_Result
8614 -- Stick in the Typ'Machine call if not already there
8616 if Nkind (Rhs) /= N_Attribute_Reference
8617 or else Attribute_Name (Rhs) /= Name_Machine
8620 Make_Attribute_Reference (Loc,
8621 Prefix => New_Occurrence_Of (Typl, Loc),
8622 Attribute_Name => Name_Machine,
8623 Expressions => New_List (Relocate_Node (Rhs))));
8624 Analyze_And_Resolve (Rhs, Typl);
8629 -----------------------
8630 -- Expand_N_Op_Expon --
8631 -----------------------
8633 procedure Expand_N_Op_Expon (N : Node_Id) is
8634 Loc : constant Source_Ptr := Sloc (N);
8635 Ovflo : constant Boolean := Do_Overflow_Check (N);
8636 Typ : constant Entity_Id := Etype (N);
8637 Rtyp : constant Entity_Id := Root_Type (Typ);
8641 function Wrap_MA (Exp : Node_Id) return Node_Id;
8642 -- Given an expression Exp, if the root type is Float or Long_Float,
8643 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8644 -- extra precision. This is done to ensure that X**A = X**B when A is
8645 -- a static constant and B is a variable with the same value. For any
8646 -- other type, the node Exp is returned unchanged.
8652 function Wrap_MA (Exp : Node_Id) return Node_Id is
8653 Loc : constant Source_Ptr := Sloc (Exp);
8656 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then
8658 Make_Attribute_Reference (Loc,
8659 Attribute_Name => Name_Machine,
8660 Prefix => New_Occurrence_Of (Bastyp, Loc),
8661 Expressions => New_List (Relocate_Node (Exp)));
8679 -- Start of processing for Expand_N_Op_Expon
8682 Binary_Op_Validity_Checks (N);
8684 -- CodePeer wants to see the unexpanded N_Op_Expon node
8686 if CodePeer_Mode then
8690 -- Relocation of left and right operands must be done after performing
8691 -- the validity checks since the generation of validation checks may
8692 -- remove side effects.
8694 Base := Relocate_Node (Left_Opnd (N));
8695 Bastyp := Etype (Base);
8696 Exp := Relocate_Node (Right_Opnd (N));
8697 Exptyp := Etype (Exp);
8699 -- If either operand is of a private type, then we have the use of an
8700 -- intrinsic operator, and we get rid of the privateness, by using root
8701 -- types of underlying types for the actual operation. Otherwise the
8702 -- private types will cause trouble if we expand multiplications or
8703 -- shifts etc. We also do this transformation if the result type is
8704 -- different from the base type.
8706 if Is_Private_Type (Etype (Base))
8707 or else Is_Private_Type (Typ)
8708 or else Is_Private_Type (Exptyp)
8709 or else Rtyp /= Root_Type (Bastyp)
8712 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
8713 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
8716 Unchecked_Convert_To (Typ,
8718 Left_Opnd => Unchecked_Convert_To (Bt, Base),
8719 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
8720 Analyze_And_Resolve (N, Typ);
8725 -- Check for MINIMIZED/ELIMINATED overflow mode
8727 if Minimized_Eliminated_Overflow_Check (N) then
8728 Apply_Arithmetic_Overflow_Check (N);
8732 -- Test for case of known right argument where we can replace the
8733 -- exponentiation by an equivalent expression using multiplication.
8735 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8736 -- configurable run-time mode, we may not have the exponentiation
8737 -- routine available, and we don't want the legality of the program
8738 -- to depend on how clever the compiler is in knowing values.
8740 if CRT_Safe_Compile_Time_Known_Value (Exp) then
8741 Expv := Expr_Value (Exp);
8743 -- We only fold small non-negative exponents. You might think we
8744 -- could fold small negative exponents for the real case, but we
8745 -- can't because we are required to raise Constraint_Error for
8746 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8747 -- See ACVC test C4A012B, and it is not worth generating the test.
8749 -- For small negative exponents, we return the reciprocal of
8750 -- the folding of the exponentiation for the opposite (positive)
8751 -- exponent, as required by Ada RM 4.5.6(11/3).
8753 if abs Expv <= 4 then
8755 -- X ** 0 = 1 (or 1.0)
8759 -- Call Remove_Side_Effects to ensure that any side effects
8760 -- in the ignored left operand (in particular function calls
8761 -- to user defined functions) are properly executed.
8763 Remove_Side_Effects (Base);
8765 if Ekind (Typ) in Integer_Kind then
8766 Xnode := Make_Integer_Literal (Loc, Intval => 1);
8768 Xnode := Make_Real_Literal (Loc, Ureal_1);
8781 Make_Op_Multiply (Loc,
8782 Left_Opnd => Duplicate_Subexpr (Base),
8783 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
8785 -- X ** 3 = X * X * X
8790 Make_Op_Multiply (Loc,
8792 Make_Op_Multiply (Loc,
8793 Left_Opnd => Duplicate_Subexpr (Base),
8794 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
8795 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
8800 -- En : constant base'type := base * base;
8805 Temp := Make_Temporary (Loc, 'E', Base);
8808 Make_Expression_With_Actions (Loc,
8809 Actions => New_List (
8810 Make_Object_Declaration (Loc,
8811 Defining_Identifier => Temp,
8812 Constant_Present => True,
8813 Object_Definition => New_Occurrence_Of (Typ, Loc),
8816 Make_Op_Multiply (Loc,
8818 Duplicate_Subexpr (Base),
8820 Duplicate_Subexpr_No_Checks (Base))))),
8824 Make_Op_Multiply (Loc,
8825 Left_Opnd => New_Occurrence_Of (Temp, Loc),
8826 Right_Opnd => New_Occurrence_Of (Temp, Loc))));
8828 -- X ** N = 1.0 / X ** (-N)
8833 (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4);
8836 Make_Op_Divide (Loc,
8838 Make_Float_Literal (Loc,
8840 Significand => Uint_1,
8841 Exponent => Uint_0),
8844 Left_Opnd => Duplicate_Subexpr (Base),
8846 Make_Integer_Literal (Loc,
8851 Analyze_And_Resolve (N, Typ);
8856 -- Deal with optimizing 2 ** expression to shift where possible
8858 -- Note: we used to check that Exptyp was an unsigned type. But that is
8859 -- an unnecessary check, since if Exp is negative, we have a run-time
8860 -- error that is either caught (so we get the right result) or we have
8861 -- suppressed the check, in which case the code is erroneous anyway.
8863 if Is_Integer_Type (Rtyp)
8865 -- The base value must be "safe compile-time known", and exactly 2
8867 and then Nkind (Base) = N_Integer_Literal
8868 and then CRT_Safe_Compile_Time_Known_Value (Base)
8869 and then Expr_Value (Base) = Uint_2
8871 -- We only handle cases where the right type is a integer
8873 and then Is_Integer_Type (Root_Type (Exptyp))
8874 and then Esize (Root_Type (Exptyp)) <= Standard_Integer_Size
8876 -- This transformation is not applicable for a modular type with a
8877 -- nonbinary modulus because we do not handle modular reduction in
8878 -- a correct manner if we attempt this transformation in this case.
8880 and then not Non_Binary_Modulus (Typ)
8882 -- Handle the cases where our parent is a division or multiplication
8883 -- specially. In these cases we can convert to using a shift at the
8884 -- parent level if we are not doing overflow checking, since it is
8885 -- too tricky to combine the overflow check at the parent level.
8888 and then Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply
8891 P : constant Node_Id := Parent (N);
8892 L : constant Node_Id := Left_Opnd (P);
8893 R : constant Node_Id := Right_Opnd (P);
8896 if (Nkind (P) = N_Op_Multiply
8898 ((Is_Integer_Type (Etype (L)) and then R = N)
8900 (Is_Integer_Type (Etype (R)) and then L = N))
8901 and then not Do_Overflow_Check (P))
8904 (Nkind (P) = N_Op_Divide
8905 and then Is_Integer_Type (Etype (L))
8906 and then Is_Unsigned_Type (Etype (L))
8908 and then not Do_Overflow_Check (P))
8910 Set_Is_Power_Of_2_For_Shift (N);
8915 -- Here we just have 2 ** N on its own, so we can convert this to a
8916 -- shift node. We are prepared to deal with overflow here, and we
8917 -- also have to handle proper modular reduction for binary modular.
8926 -- Maximum shift count with no overflow
8929 -- Set True if we must test the shift count
8932 -- Node for test against TestS
8935 -- Compute maximum shift based on the underlying size. For a
8936 -- modular type this is one less than the size.
8938 if Is_Modular_Integer_Type (Typ) then
8940 -- For modular integer types, this is the size of the value
8941 -- being shifted minus one. Any larger values will cause
8942 -- modular reduction to a result of zero. Note that we do
8943 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
8944 -- of 6, since 2**7 should be reduced to zero).
8946 MaxS := RM_Size (Rtyp) - 1;
8948 -- For signed integer types, we use the size of the value
8949 -- being shifted minus 2. Larger values cause overflow.
8952 MaxS := Esize (Rtyp) - 2;
8955 -- Determine range to see if it can be larger than MaxS
8957 Determine_Range (Exp, OK, Lo, Hi, Assume_Valid => True);
8958 TestS := (not OK) or else Hi > MaxS;
8960 -- Signed integer case
8962 if Is_Signed_Integer_Type (Typ) then
8964 -- Generate overflow check if overflow is active. Note that
8965 -- we can simply ignore the possibility of overflow if the
8966 -- flag is not set (means that overflow cannot happen or
8967 -- that overflow checks are suppressed).
8969 if Ovflo and TestS then
8971 Make_Raise_Constraint_Error (Loc,
8974 Left_Opnd => Duplicate_Subexpr (Exp),
8975 Right_Opnd => Make_Integer_Literal (Loc, MaxS)),
8976 Reason => CE_Overflow_Check_Failed));
8979 -- Now rewrite node as Shift_Left (1, right-operand)
8982 Make_Op_Shift_Left (Loc,
8983 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8984 Right_Opnd => Exp));
8986 -- Modular integer case
8988 else pragma Assert (Is_Modular_Integer_Type (Typ));
8990 -- If shift count can be greater than MaxS, we need to wrap
8991 -- the shift in a test that will reduce the result value to
8992 -- zero if this shift count is exceeded.
8996 -- Note: build node for the comparison first, before we
8997 -- reuse the Right_Opnd, so that we have proper parents
8998 -- in place for the Duplicate_Subexpr call.
9002 Left_Opnd => Duplicate_Subexpr (Exp),
9003 Right_Opnd => Make_Integer_Literal (Loc, MaxS));
9006 Make_If_Expression (Loc,
9007 Expressions => New_List (
9009 Make_Integer_Literal (Loc, Uint_0),
9010 Make_Op_Shift_Left (Loc,
9011 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
9012 Right_Opnd => Exp))));
9014 -- If we know shift count cannot be greater than MaxS, then
9015 -- it is safe to just rewrite as a shift with no test.
9019 Make_Op_Shift_Left (Loc,
9020 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
9021 Right_Opnd => Exp));
9025 Analyze_And_Resolve (N, Typ);
9031 -- Fall through if exponentiation must be done using a runtime routine
9033 -- First deal with modular case
9035 if Is_Modular_Integer_Type (Rtyp) then
9037 -- Nonbinary modular case, we call the special exponentiation
9038 -- routine for the nonbinary case, converting the argument to
9039 -- Long_Long_Integer and passing the modulus value. Then the
9040 -- result is converted back to the base type.
9042 if Non_Binary_Modulus (Rtyp) then
9045 Make_Function_Call (Loc,
9047 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
9048 Parameter_Associations => New_List (
9049 Convert_To (RTE (RE_Unsigned), Base),
9050 Make_Integer_Literal (Loc, Modulus (Rtyp)),
9053 -- Binary modular case, in this case, we call one of three routines,
9054 -- either the unsigned integer case, or the unsigned long long
9055 -- integer case, or the unsigned long long long integer case, with a
9056 -- final "and" operation to do the required mod.
9059 if Esize (Rtyp) <= Standard_Integer_Size then
9060 Ent := RTE (RE_Exp_Unsigned);
9061 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
9062 Ent := RTE (RE_Exp_Long_Long_Unsigned);
9064 Ent := RTE (RE_Exp_Long_Long_Long_Unsigned);
9071 Make_Function_Call (Loc,
9072 Name => New_Occurrence_Of (Ent, Loc),
9073 Parameter_Associations => New_List (
9074 Convert_To (Etype (First_Formal (Ent)), Base),
9077 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
9081 -- Common exit point for modular type case
9083 Analyze_And_Resolve (N, Typ);
9086 -- Signed integer cases, using either Integer, Long_Long_Integer or
9087 -- Long_Long_Long_Integer. It is not worth also having routines for
9088 -- Short_[Short_]Integer, since for most machines it would not help,
9089 -- and it would generate more code that might need certification when
9090 -- a certified run time is required.
9092 -- In the integer cases, we have two routines, one for when overflow
9093 -- checks are required, and one when they are not required, since there
9094 -- is a real gain in omitting checks on many machines.
9096 elsif Is_Signed_Integer_Type (Rtyp) then
9097 if Esize (Rtyp) <= Standard_Integer_Size then
9098 Etyp := Standard_Integer;
9101 Rent := RE_Exp_Integer;
9103 Rent := RE_Exn_Integer;
9106 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
9107 Etyp := Standard_Long_Long_Integer;
9110 Rent := RE_Exp_Long_Long_Integer;
9112 Rent := RE_Exn_Long_Long_Integer;
9116 Etyp := Standard_Long_Long_Long_Integer;
9119 Rent := RE_Exp_Long_Long_Long_Integer;
9121 Rent := RE_Exn_Long_Long_Long_Integer;
9125 -- Floating-point cases. We do not need separate routines for the
9126 -- overflow case here, since in the case of floating-point, we generate
9127 -- infinities anyway as a rule (either that or we automatically trap
9128 -- overflow), and if there is an infinity generated and a range check
9129 -- is required, the check will fail anyway.
9131 -- Historical note: we used to convert everything to Long_Long_Float
9132 -- and call a single common routine, but this had the undesirable effect
9133 -- of giving different results for small static exponent values and the
9134 -- same dynamic values.
9137 pragma Assert (Is_Floating_Point_Type (Rtyp));
9139 if Rtyp = Standard_Float then
9140 Etyp := Standard_Float;
9141 Rent := RE_Exn_Float;
9143 elsif Rtyp = Standard_Long_Float then
9144 Etyp := Standard_Long_Float;
9145 Rent := RE_Exn_Long_Float;
9148 Etyp := Standard_Long_Long_Float;
9149 Rent := RE_Exn_Long_Long_Float;
9153 -- Common processing for integer cases and floating-point cases.
9154 -- If we are in the right type, we can call runtime routine directly
9157 and then Rtyp /= Universal_Integer
9158 and then Rtyp /= Universal_Real
9162 Make_Function_Call (Loc,
9163 Name => New_Occurrence_Of (RTE (Rent), Loc),
9164 Parameter_Associations => New_List (Base, Exp))));
9166 -- Otherwise we have to introduce conversions (conversions are also
9167 -- required in the universal cases, since the runtime routine is
9168 -- typed using one of the standard types).
9173 Make_Function_Call (Loc,
9174 Name => New_Occurrence_Of (RTE (Rent), Loc),
9175 Parameter_Associations => New_List (
9176 Convert_To (Etyp, Base),
9180 Analyze_And_Resolve (N, Typ);
9184 when RE_Not_Available =>
9186 end Expand_N_Op_Expon;
9188 --------------------
9189 -- Expand_N_Op_Ge --
9190 --------------------
9192 procedure Expand_N_Op_Ge (N : Node_Id) is
9193 Typ : constant Entity_Id := Etype (N);
9194 Op1 : constant Node_Id := Left_Opnd (N);
9195 Op2 : constant Node_Id := Right_Opnd (N);
9196 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9199 Binary_Op_Validity_Checks (N);
9201 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9202 -- means we no longer have a comparison operation, we are all done.
9204 Expand_Compare_Minimize_Eliminate_Overflow (N);
9206 if Nkind (N) /= N_Op_Ge then
9212 if Is_Array_Type (Typ1) then
9213 Expand_Array_Comparison (N);
9217 -- Deal with boolean operands
9219 if Is_Boolean_Type (Typ1) then
9220 Adjust_Condition (Op1);
9221 Adjust_Condition (Op2);
9222 Set_Etype (N, Standard_Boolean);
9223 Adjust_Result_Type (N, Typ);
9226 Rewrite_Comparison (N);
9228 -- Try to narrow the operation
9230 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Ge then
9231 Narrow_Large_Operation (N);
9234 Optimize_Length_Comparison (N);
9237 --------------------
9238 -- Expand_N_Op_Gt --
9239 --------------------
9241 procedure Expand_N_Op_Gt (N : Node_Id) is
9242 Typ : constant Entity_Id := Etype (N);
9243 Op1 : constant Node_Id := Left_Opnd (N);
9244 Op2 : constant Node_Id := Right_Opnd (N);
9245 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9248 Binary_Op_Validity_Checks (N);
9250 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9251 -- means we no longer have a comparison operation, we are all done.
9253 Expand_Compare_Minimize_Eliminate_Overflow (N);
9255 if Nkind (N) /= N_Op_Gt then
9259 -- Deal with array type operands
9261 if Is_Array_Type (Typ1) then
9262 Expand_Array_Comparison (N);
9266 -- Deal with boolean type operands
9268 if Is_Boolean_Type (Typ1) then
9269 Adjust_Condition (Op1);
9270 Adjust_Condition (Op2);
9271 Set_Etype (N, Standard_Boolean);
9272 Adjust_Result_Type (N, Typ);
9275 Rewrite_Comparison (N);
9277 -- Try to narrow the operation
9279 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Gt then
9280 Narrow_Large_Operation (N);
9283 Optimize_Length_Comparison (N);
9286 --------------------
9287 -- Expand_N_Op_Le --
9288 --------------------
9290 procedure Expand_N_Op_Le (N : Node_Id) is
9291 Typ : constant Entity_Id := Etype (N);
9292 Op1 : constant Node_Id := Left_Opnd (N);
9293 Op2 : constant Node_Id := Right_Opnd (N);
9294 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9297 Binary_Op_Validity_Checks (N);
9299 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9300 -- means we no longer have a comparison operation, we are all done.
9302 Expand_Compare_Minimize_Eliminate_Overflow (N);
9304 if Nkind (N) /= N_Op_Le then
9308 -- Deal with array type operands
9310 if Is_Array_Type (Typ1) then
9311 Expand_Array_Comparison (N);
9315 -- Deal with Boolean type operands
9317 if Is_Boolean_Type (Typ1) then
9318 Adjust_Condition (Op1);
9319 Adjust_Condition (Op2);
9320 Set_Etype (N, Standard_Boolean);
9321 Adjust_Result_Type (N, Typ);
9324 Rewrite_Comparison (N);
9326 -- Try to narrow the operation
9328 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Le then
9329 Narrow_Large_Operation (N);
9332 Optimize_Length_Comparison (N);
9335 --------------------
9336 -- Expand_N_Op_Lt --
9337 --------------------
9339 procedure Expand_N_Op_Lt (N : Node_Id) is
9340 Typ : constant Entity_Id := Etype (N);
9341 Op1 : constant Node_Id := Left_Opnd (N);
9342 Op2 : constant Node_Id := Right_Opnd (N);
9343 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9346 Binary_Op_Validity_Checks (N);
9348 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9349 -- means we no longer have a comparison operation, we are all done.
9351 Expand_Compare_Minimize_Eliminate_Overflow (N);
9353 if Nkind (N) /= N_Op_Lt then
9357 -- Deal with array type operands
9359 if Is_Array_Type (Typ1) then
9360 Expand_Array_Comparison (N);
9364 -- Deal with Boolean type operands
9366 if Is_Boolean_Type (Typ1) then
9367 Adjust_Condition (Op1);
9368 Adjust_Condition (Op2);
9369 Set_Etype (N, Standard_Boolean);
9370 Adjust_Result_Type (N, Typ);
9373 Rewrite_Comparison (N);
9375 -- Try to narrow the operation
9377 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Lt then
9378 Narrow_Large_Operation (N);
9381 Optimize_Length_Comparison (N);
9384 -----------------------
9385 -- Expand_N_Op_Minus --
9386 -----------------------
9388 procedure Expand_N_Op_Minus (N : Node_Id) is
9389 Loc : constant Source_Ptr := Sloc (N);
9390 Typ : constant Entity_Id := Etype (N);
9393 Unary_Op_Validity_Checks (N);
9395 -- Check for MINIMIZED/ELIMINATED overflow mode
9397 if Minimized_Eliminated_Overflow_Check (N) then
9398 Apply_Arithmetic_Overflow_Check (N);
9402 -- Try to narrow the operation
9404 if Typ = Universal_Integer then
9405 Narrow_Large_Operation (N);
9407 if Nkind (N) /= N_Op_Minus then
9412 if not Backend_Overflow_Checks_On_Target
9413 and then Is_Signed_Integer_Type (Typ)
9414 and then Do_Overflow_Check (N)
9416 -- Software overflow checking expands -expr into (0 - expr)
9419 Make_Op_Subtract (Loc,
9420 Left_Opnd => Make_Integer_Literal (Loc, 0),
9421 Right_Opnd => Right_Opnd (N)));
9423 Analyze_And_Resolve (N, Typ);
9426 Expand_Nonbinary_Modular_Op (N);
9427 end Expand_N_Op_Minus;
9429 ---------------------
9430 -- Expand_N_Op_Mod --
9431 ---------------------
9433 procedure Expand_N_Op_Mod (N : Node_Id) is
9434 Loc : constant Source_Ptr := Sloc (N);
9435 Typ : constant Entity_Id := Etype (N);
9436 DDC : constant Boolean := Do_Division_Check (N);
9449 pragma Warnings (Off, Lhi);
9452 Binary_Op_Validity_Checks (N);
9454 -- Check for MINIMIZED/ELIMINATED overflow mode
9456 if Minimized_Eliminated_Overflow_Check (N) then
9457 Apply_Arithmetic_Overflow_Check (N);
9461 -- Try to narrow the operation
9463 if Typ = Universal_Integer then
9464 Narrow_Large_Operation (N);
9466 if Nkind (N) /= N_Op_Mod then
9471 if Is_Integer_Type (Typ) then
9472 Apply_Divide_Checks (N);
9474 -- All done if we don't have a MOD any more, which can happen as a
9475 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9477 if Nkind (N) /= N_Op_Mod then
9482 -- Proceed with expansion of mod operator
9484 Left := Left_Opnd (N);
9485 Right := Right_Opnd (N);
9487 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
9488 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
9490 -- Convert mod to rem if operands are both known to be non-negative, or
9491 -- both known to be non-positive (these are the cases in which rem and
9492 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9493 -- likely that this will improve the quality of code, (the operation now
9494 -- corresponds to the hardware remainder), and it does not seem likely
9495 -- that it could be harmful. It also avoids some cases of the elaborate
9496 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9499 and then ((Llo >= 0 and then Rlo >= 0)
9501 (Lhi <= 0 and then Rhi <= 0))
9504 Make_Op_Rem (Sloc (N),
9505 Left_Opnd => Left_Opnd (N),
9506 Right_Opnd => Right_Opnd (N)));
9508 -- Instead of reanalyzing the node we do the analysis manually. This
9509 -- avoids anomalies when the replacement is done in an instance and
9510 -- is epsilon more efficient.
9512 Set_Entity (N, Standard_Entity (S_Op_Rem));
9514 Set_Do_Division_Check (N, DDC);
9515 Expand_N_Op_Rem (N);
9519 -- Otherwise, normal mod processing
9522 -- Apply optimization x mod 1 = 0. We don't really need that with
9523 -- gcc, but it is useful with other back ends and is certainly
9526 if Is_Integer_Type (Etype (N))
9527 and then Compile_Time_Known_Value (Right)
9528 and then Expr_Value (Right) = Uint_1
9530 -- Call Remove_Side_Effects to ensure that any side effects in
9531 -- the ignored left operand (in particular function calls to
9532 -- user defined functions) are properly executed.
9534 Remove_Side_Effects (Left);
9536 Rewrite (N, Make_Integer_Literal (Loc, 0));
9537 Analyze_And_Resolve (N, Typ);
9541 -- If we still have a mod operator and we are in Modify_Tree_For_C
9542 -- mode, and we have a signed integer type, then here is where we do
9543 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9544 -- for the special handling of the annoying case of largest negative
9545 -- number mod minus one.
9547 if Nkind (N) = N_Op_Mod
9548 and then Is_Signed_Integer_Type (Typ)
9549 and then Modify_Tree_For_C
9551 -- In the general case, we expand A mod B as
9553 -- Tnn : constant typ := A rem B;
9555 -- (if (A >= 0) = (B >= 0) then Tnn
9556 -- elsif Tnn = 0 then 0
9559 -- The comparison can be written simply as A >= 0 if we know that
9560 -- B >= 0 which is a very common case.
9562 -- An important optimization is when B is known at compile time
9563 -- to be 2**K for some constant. In this case we can simply AND
9564 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9565 -- and that works for both the positive and negative cases.
9568 P2 : constant Nat := Power_Of_Two (Right);
9573 Unchecked_Convert_To (Typ,
9576 Unchecked_Convert_To
9577 (Corresponding_Unsigned_Type (Typ), Left),
9579 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
9580 Analyze_And_Resolve (N, Typ);
9585 -- Here for the full rewrite
9588 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
9594 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9595 Right_Opnd => Make_Integer_Literal (Loc, 0));
9597 if not LOK or else Rlo < 0 then
9603 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
9604 Right_Opnd => Make_Integer_Literal (Loc, 0)));
9608 Make_Object_Declaration (Loc,
9609 Defining_Identifier => Tnn,
9610 Constant_Present => True,
9611 Object_Definition => New_Occurrence_Of (Typ, Loc),
9615 Right_Opnd => Right)));
9618 Make_If_Expression (Loc,
9619 Expressions => New_List (
9621 New_Occurrence_Of (Tnn, Loc),
9622 Make_If_Expression (Loc,
9624 Expressions => New_List (
9626 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9627 Right_Opnd => Make_Integer_Literal (Loc, 0)),
9628 Make_Integer_Literal (Loc, 0),
9630 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9632 Duplicate_Subexpr_No_Checks (Right)))))));
9634 Analyze_And_Resolve (N, Typ);
9639 -- Deal with annoying case of largest negative number mod minus one.
9640 -- Gigi may not handle this case correctly, because on some targets,
9641 -- the mod value is computed using a divide instruction which gives
9642 -- an overflow trap for this case.
9644 -- It would be a bit more efficient to figure out which targets
9645 -- this is really needed for, but in practice it is reasonable
9646 -- to do the following special check in all cases, since it means
9647 -- we get a clearer message, and also the overhead is minimal given
9648 -- that division is expensive in any case.
9650 -- In fact the check is quite easy, if the right operand is -1, then
9651 -- the mod value is always 0, and we can just ignore the left operand
9652 -- completely in this case.
9654 -- This only applies if we still have a mod operator. Skip if we
9655 -- have already rewritten this (e.g. in the case of eliminated
9656 -- overflow checks which have driven us into bignum mode).
9658 if Nkind (N) = N_Op_Mod then
9660 -- The operand type may be private (e.g. in the expansion of an
9661 -- intrinsic operation) so we must use the underlying type to get
9662 -- the bounds, and convert the literals explicitly.
9666 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
9668 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
9669 and then ((not LOK) or else (Llo = LLB))
9672 Make_If_Expression (Loc,
9673 Expressions => New_List (
9675 Left_Opnd => Duplicate_Subexpr (Right),
9677 Unchecked_Convert_To (Typ,
9678 Make_Integer_Literal (Loc, -1))),
9679 Unchecked_Convert_To (Typ,
9680 Make_Integer_Literal (Loc, Uint_0)),
9681 Relocate_Node (N))));
9683 Set_Analyzed (Next (Next (First (Expressions (N)))));
9684 Analyze_And_Resolve (N, Typ);
9688 end Expand_N_Op_Mod;
9690 --------------------------
9691 -- Expand_N_Op_Multiply --
9692 --------------------------
9694 procedure Expand_N_Op_Multiply (N : Node_Id) is
9695 Loc : constant Source_Ptr := Sloc (N);
9696 Lop : constant Node_Id := Left_Opnd (N);
9697 Rop : constant Node_Id := Right_Opnd (N);
9699 Lp2 : constant Boolean :=
9700 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
9701 Rp2 : constant Boolean :=
9702 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
9704 Ltyp : constant Entity_Id := Etype (Lop);
9705 Rtyp : constant Entity_Id := Etype (Rop);
9706 Typ : Entity_Id := Etype (N);
9709 Binary_Op_Validity_Checks (N);
9711 -- Check for MINIMIZED/ELIMINATED overflow mode
9713 if Minimized_Eliminated_Overflow_Check (N) then
9714 Apply_Arithmetic_Overflow_Check (N);
9718 -- Special optimizations for integer types
9720 if Is_Integer_Type (Typ) then
9722 -- N * 0 = 0 for integer types
9724 if Compile_Time_Known_Value (Rop)
9725 and then Expr_Value (Rop) = Uint_0
9727 -- Call Remove_Side_Effects to ensure that any side effects in
9728 -- the ignored left operand (in particular function calls to
9729 -- user defined functions) are properly executed.
9731 Remove_Side_Effects (Lop);
9733 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
9734 Analyze_And_Resolve (N, Typ);
9738 -- Similar handling for 0 * N = 0
9740 if Compile_Time_Known_Value (Lop)
9741 and then Expr_Value (Lop) = Uint_0
9743 Remove_Side_Effects (Rop);
9744 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
9745 Analyze_And_Resolve (N, Typ);
9749 -- N * 1 = 1 * N = N for integer types
9751 -- This optimisation is not done if we are going to
9752 -- rewrite the product 1 * 2 ** N to a shift.
9754 if Compile_Time_Known_Value (Rop)
9755 and then Expr_Value (Rop) = Uint_1
9761 elsif Compile_Time_Known_Value (Lop)
9762 and then Expr_Value (Lop) = Uint_1
9770 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9771 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9772 -- operand is an integer, as required for this to work.
9777 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9781 Left_Opnd => Make_Integer_Literal (Loc, 2),
9784 Left_Opnd => Right_Opnd (Lop),
9785 Right_Opnd => Right_Opnd (Rop))));
9786 Analyze_And_Resolve (N, Typ);
9790 -- If the result is modular, perform the reduction of the result
9793 if Is_Modular_Integer_Type (Typ)
9794 and then not Non_Binary_Modulus (Typ)
9799 Make_Op_Shift_Left (Loc,
9802 Convert_To (Standard_Natural, Right_Opnd (Rop))),
9804 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
9808 Make_Op_Shift_Left (Loc,
9811 Convert_To (Standard_Natural, Right_Opnd (Rop))));
9814 Analyze_And_Resolve (N, Typ);
9818 -- Same processing for the operands the other way round
9821 if Is_Modular_Integer_Type (Typ)
9822 and then not Non_Binary_Modulus (Typ)
9827 Make_Op_Shift_Left (Loc,
9830 Convert_To (Standard_Natural, Right_Opnd (Lop))),
9832 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
9836 Make_Op_Shift_Left (Loc,
9839 Convert_To (Standard_Natural, Right_Opnd (Lop))));
9842 Analyze_And_Resolve (N, Typ);
9846 -- Try to narrow the operation
9848 if Typ = Universal_Integer then
9849 Narrow_Large_Operation (N);
9851 if Nkind (N) /= N_Op_Multiply then
9856 -- Do required fixup of universal fixed operation
9858 if Typ = Universal_Fixed then
9859 Fixup_Universal_Fixed_Operation (N);
9863 -- Multiplications with fixed-point results
9865 if Is_Fixed_Point_Type (Typ) then
9867 -- Case of fixed * integer => fixed
9869 if Is_Integer_Type (Rtyp) then
9870 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
9872 -- Case of integer * fixed => fixed
9874 elsif Is_Integer_Type (Ltyp) then
9875 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
9877 -- Case of fixed * fixed => fixed
9880 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
9883 -- Other cases of multiplication of fixed-point operands
9885 elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then
9886 if Is_Integer_Type (Typ) then
9887 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
9889 pragma Assert (Is_Floating_Point_Type (Typ));
9890 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
9893 -- Mixed-mode operations can appear in a non-static universal context,
9894 -- in which case the integer argument must be converted explicitly.
9896 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
9897 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
9898 Analyze_And_Resolve (Rop, Universal_Real);
9900 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
9901 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
9902 Analyze_And_Resolve (Lop, Universal_Real);
9904 -- Non-fixed point cases, check software overflow checking required
9906 elsif Is_Signed_Integer_Type (Etype (N)) then
9907 Apply_Arithmetic_Overflow_Check (N);
9910 -- Overflow checks for floating-point if -gnateF mode active
9912 Check_Float_Op_Overflow (N);
9914 Expand_Nonbinary_Modular_Op (N);
9915 end Expand_N_Op_Multiply;
9917 --------------------
9918 -- Expand_N_Op_Ne --
9919 --------------------
9921 procedure Expand_N_Op_Ne (N : Node_Id) is
9922 Typ : constant Entity_Id := Etype (Left_Opnd (N));
9925 -- Case of elementary type with standard operator. But if unnesting,
9926 -- handle elementary types whose Equivalent_Types are records because
9927 -- there may be padding or undefined fields.
9929 if Is_Elementary_Type (Typ)
9930 and then Sloc (Entity (N)) = Standard_Location
9931 and then not (Ekind (Typ) in E_Class_Wide_Type
9932 | E_Class_Wide_Subtype
9933 | E_Access_Subprogram_Type
9934 | E_Access_Protected_Subprogram_Type
9935 | E_Anonymous_Access_Protected_Subprogram_Type
9937 and then Present (Equivalent_Type (Typ))
9938 and then Is_Record_Type (Equivalent_Type (Typ)))
9940 Binary_Op_Validity_Checks (N);
9942 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9943 -- means we no longer have a /= operation, we are all done.
9945 Expand_Compare_Minimize_Eliminate_Overflow (N);
9947 if Nkind (N) /= N_Op_Ne then
9951 -- Boolean types (requiring handling of non-standard case)
9953 if Is_Boolean_Type (Typ) then
9954 Adjust_Condition (Left_Opnd (N));
9955 Adjust_Condition (Right_Opnd (N));
9956 Set_Etype (N, Standard_Boolean);
9957 Adjust_Result_Type (N, Typ);
9960 Rewrite_Comparison (N);
9962 -- Try to narrow the operation
9964 if Typ = Universal_Integer and then Nkind (N) = N_Op_Ne then
9965 Narrow_Large_Operation (N);
9968 -- For all cases other than elementary types, we rewrite node as the
9969 -- negation of an equality operation, and reanalyze. The equality to be
9970 -- used is defined in the same scope and has the same signature. This
9971 -- signature must be set explicitly since in an instance it may not have
9972 -- the same visibility as in the generic unit. This avoids duplicating
9973 -- or factoring the complex code for record/array equality tests etc.
9975 -- This case is also used for the minimal expansion performed in
9980 Loc : constant Source_Ptr := Sloc (N);
9982 Ne : constant Entity_Id := Entity (N);
9985 Binary_Op_Validity_Checks (N);
9991 Left_Opnd => Left_Opnd (N),
9992 Right_Opnd => Right_Opnd (N)));
9994 -- The level of parentheses is useless in GNATprove mode, and
9995 -- bumping its level here leads to wrong columns being used in
9996 -- check messages, hence skip it in this mode.
9998 if not GNATprove_Mode then
9999 Set_Paren_Count (Right_Opnd (Neg), 1);
10002 if Scope (Ne) /= Standard_Standard then
10003 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
10006 -- For navigation purposes, we want to treat the inequality as an
10007 -- implicit reference to the corresponding equality. Preserve the
10008 -- Comes_From_ source flag to generate proper Xref entries.
10010 Preserve_Comes_From_Source (Neg, N);
10011 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
10013 Analyze_And_Resolve (N, Standard_Boolean);
10017 -- No need for optimization in GNATprove mode, where we would rather see
10018 -- the original source expression.
10020 if not GNATprove_Mode then
10021 Optimize_Length_Comparison (N);
10023 end Expand_N_Op_Ne;
10025 ---------------------
10026 -- Expand_N_Op_Not --
10027 ---------------------
10029 -- If the argument is other than a Boolean array type, there is no special
10030 -- expansion required, except for dealing with validity checks, and non-
10031 -- standard boolean representations.
10033 -- For the packed array case, we call the special routine in Exp_Pakd,
10034 -- except that if the component size is greater than one, we use the
10035 -- standard routine generating a gruesome loop (it is so peculiar to have
10036 -- packed arrays with non-standard Boolean representations anyway, so it
10037 -- does not matter that we do not handle this case efficiently).
10039 -- For the unpacked array case (and for the special packed case where we
10040 -- have non standard Booleans, as discussed above), we generate and insert
10041 -- into the tree the following function definition:
10043 -- function Nnnn (A : arr) is
10046 -- for J in a'range loop
10047 -- B (J) := not A (J);
10052 -- or in the case of Transform_Function_Array:
10054 -- procedure Nnnn (A : arr; RESULT : out arr) is
10056 -- for J in a'range loop
10057 -- RESULT (J) := not A (J);
10061 -- Here arr is the actual subtype of the parameter (and hence always
10062 -- constrained). Then we replace the not with a call to this subprogram.
10064 procedure Expand_N_Op_Not (N : Node_Id) is
10065 Loc : constant Source_Ptr := Sloc (N);
10066 Typ : constant Entity_Id := Etype (Right_Opnd (N));
10075 Func_Name : Entity_Id;
10076 Loop_Statement : Node_Id;
10079 Unary_Op_Validity_Checks (N);
10081 -- For boolean operand, deal with non-standard booleans
10083 if Is_Boolean_Type (Typ) then
10084 Adjust_Condition (Right_Opnd (N));
10085 Set_Etype (N, Standard_Boolean);
10086 Adjust_Result_Type (N, Typ);
10090 -- Only array types need any other processing
10092 if not Is_Array_Type (Typ) then
10096 -- Case of array operand. If bit packed with a component size of 1,
10097 -- handle it in Exp_Pakd if the operand is known to be aligned.
10099 if Is_Bit_Packed_Array (Typ)
10100 and then Component_Size (Typ) = 1
10101 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
10103 Expand_Packed_Not (N);
10107 -- Case of array operand which is not bit-packed. If the context is
10108 -- a safe assignment, call in-place operation, If context is a larger
10109 -- boolean expression in the context of a safe assignment, expansion is
10110 -- done by enclosing operation.
10112 Opnd := Relocate_Node (Right_Opnd (N));
10113 Convert_To_Actual_Subtype (Opnd);
10114 Arr := Etype (Opnd);
10115 Ensure_Defined (Arr, N);
10116 Silly_Boolean_Array_Not_Test (N, Arr);
10118 if Nkind (Parent (N)) = N_Assignment_Statement then
10119 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
10120 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
10123 -- Special case the negation of a binary operation
10125 elsif Nkind (Opnd) in N_Op_And | N_Op_Or | N_Op_Xor
10126 and then Safe_In_Place_Array_Op
10127 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
10129 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
10133 elsif Nkind (Parent (N)) in N_Binary_Op
10134 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
10137 Op1 : constant Node_Id := Left_Opnd (Parent (N));
10138 Op2 : constant Node_Id := Right_Opnd (Parent (N));
10139 Lhs : constant Node_Id := Name (Parent (Parent (N)));
10142 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
10144 -- (not A) op (not B) can be reduced to a single call
10146 if N = Op1 and then Nkind (Op2) = N_Op_Not then
10149 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
10152 -- A xor (not B) can also be special-cased
10154 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
10161 A := Make_Defining_Identifier (Loc, Name_uA);
10163 if Transform_Function_Array then
10164 B := Make_Defining_Identifier (Loc, Name_UP_RESULT);
10166 B := Make_Defining_Identifier (Loc, Name_uB);
10169 J := Make_Defining_Identifier (Loc, Name_uJ);
10172 Make_Indexed_Component (Loc,
10173 Prefix => New_Occurrence_Of (A, Loc),
10174 Expressions => New_List (New_Occurrence_Of (J, Loc)));
10177 Make_Indexed_Component (Loc,
10178 Prefix => New_Occurrence_Of (B, Loc),
10179 Expressions => New_List (New_Occurrence_Of (J, Loc)));
10182 Make_Implicit_Loop_Statement (N,
10183 Identifier => Empty,
10185 Iteration_Scheme =>
10186 Make_Iteration_Scheme (Loc,
10187 Loop_Parameter_Specification =>
10188 Make_Loop_Parameter_Specification (Loc,
10189 Defining_Identifier => J,
10190 Discrete_Subtype_Definition =>
10191 Make_Attribute_Reference (Loc,
10192 Prefix => Make_Identifier (Loc, Chars (A)),
10193 Attribute_Name => Name_Range))),
10195 Statements => New_List (
10196 Make_Assignment_Statement (Loc,
10198 Expression => Make_Op_Not (Loc, A_J))));
10200 Func_Name := Make_Temporary (Loc, 'N');
10201 Set_Is_Inlined (Func_Name);
10203 if Transform_Function_Array then
10205 Make_Subprogram_Body (Loc,
10207 Make_Procedure_Specification (Loc,
10208 Defining_Unit_Name => Func_Name,
10209 Parameter_Specifications => New_List (
10210 Make_Parameter_Specification (Loc,
10211 Defining_Identifier => A,
10212 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
10213 Make_Parameter_Specification (Loc,
10214 Defining_Identifier => B,
10215 Out_Present => True,
10216 Parameter_Type => New_Occurrence_Of (Typ, Loc)))),
10218 Declarations => New_List,
10220 Handled_Statement_Sequence =>
10221 Make_Handled_Sequence_Of_Statements (Loc,
10222 Statements => New_List (Loop_Statement))));
10225 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
10234 Make_Object_Declaration (Loc,
10235 Defining_Identifier => Temp_Id,
10236 Object_Definition => New_Occurrence_Of (Typ, Loc));
10239 -- Proc_Call (Opnd, Temp);
10242 Make_Procedure_Call_Statement (Loc,
10243 Name => New_Occurrence_Of (Func_Name, Loc),
10244 Parameter_Associations =>
10245 New_List (Opnd, New_Occurrence_Of (Temp_Id, Loc)));
10247 Insert_Actions (Parent (N), New_List (Decl, Call));
10248 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
10252 Make_Subprogram_Body (Loc,
10254 Make_Function_Specification (Loc,
10255 Defining_Unit_Name => Func_Name,
10256 Parameter_Specifications => New_List (
10257 Make_Parameter_Specification (Loc,
10258 Defining_Identifier => A,
10259 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
10260 Result_Definition => New_Occurrence_Of (Typ, Loc)),
10262 Declarations => New_List (
10263 Make_Object_Declaration (Loc,
10264 Defining_Identifier => B,
10265 Object_Definition => New_Occurrence_Of (Arr, Loc))),
10267 Handled_Statement_Sequence =>
10268 Make_Handled_Sequence_Of_Statements (Loc,
10269 Statements => New_List (
10271 Make_Simple_Return_Statement (Loc,
10272 Expression => Make_Identifier (Loc, Chars (B)))))));
10275 Make_Function_Call (Loc,
10276 Name => New_Occurrence_Of (Func_Name, Loc),
10277 Parameter_Associations => New_List (Opnd)));
10280 Analyze_And_Resolve (N, Typ);
10281 end Expand_N_Op_Not;
10283 --------------------
10284 -- Expand_N_Op_Or --
10285 --------------------
10287 procedure Expand_N_Op_Or (N : Node_Id) is
10288 Typ : constant Entity_Id := Etype (N);
10291 Binary_Op_Validity_Checks (N);
10293 if Is_Array_Type (Etype (N)) then
10294 Expand_Boolean_Operator (N);
10296 elsif Is_Boolean_Type (Etype (N)) then
10297 Adjust_Condition (Left_Opnd (N));
10298 Adjust_Condition (Right_Opnd (N));
10299 Set_Etype (N, Standard_Boolean);
10300 Adjust_Result_Type (N, Typ);
10302 elsif Is_Intrinsic_Subprogram (Entity (N)) then
10303 Expand_Intrinsic_Call (N, Entity (N));
10306 Expand_Nonbinary_Modular_Op (N);
10307 end Expand_N_Op_Or;
10309 ----------------------
10310 -- Expand_N_Op_Plus --
10311 ----------------------
10313 procedure Expand_N_Op_Plus (N : Node_Id) is
10314 Typ : constant Entity_Id := Etype (N);
10317 Unary_Op_Validity_Checks (N);
10319 -- Check for MINIMIZED/ELIMINATED overflow mode
10321 if Minimized_Eliminated_Overflow_Check (N) then
10322 Apply_Arithmetic_Overflow_Check (N);
10326 -- Try to narrow the operation
10328 if Typ = Universal_Integer then
10329 Narrow_Large_Operation (N);
10331 end Expand_N_Op_Plus;
10333 ---------------------
10334 -- Expand_N_Op_Rem --
10335 ---------------------
10337 procedure Expand_N_Op_Rem (N : Node_Id) is
10338 Loc : constant Source_Ptr := Sloc (N);
10339 Typ : constant Entity_Id := Etype (N);
10350 -- Set if corresponding operand can be negative
10352 pragma Unreferenced (Hi);
10355 Binary_Op_Validity_Checks (N);
10357 -- Check for MINIMIZED/ELIMINATED overflow mode
10359 if Minimized_Eliminated_Overflow_Check (N) then
10360 Apply_Arithmetic_Overflow_Check (N);
10364 -- Try to narrow the operation
10366 if Typ = Universal_Integer then
10367 Narrow_Large_Operation (N);
10369 if Nkind (N) /= N_Op_Rem then
10374 if Is_Integer_Type (Etype (N)) then
10375 Apply_Divide_Checks (N);
10377 -- All done if we don't have a REM any more, which can happen as a
10378 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
10380 if Nkind (N) /= N_Op_Rem then
10385 -- Proceed with expansion of REM
10387 Left := Left_Opnd (N);
10388 Right := Right_Opnd (N);
10390 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
10391 -- but it is useful with other back ends, and is certainly harmless.
10393 if Is_Integer_Type (Etype (N))
10394 and then Compile_Time_Known_Value (Right)
10395 and then Expr_Value (Right) = Uint_1
10397 -- Call Remove_Side_Effects to ensure that any side effects in the
10398 -- ignored left operand (in particular function calls to user defined
10399 -- functions) are properly executed.
10401 Remove_Side_Effects (Left);
10403 Rewrite (N, Make_Integer_Literal (Loc, 0));
10404 Analyze_And_Resolve (N, Typ);
10408 -- Deal with annoying case of largest negative number remainder minus
10409 -- one. Gigi may not handle this case correctly, because on some
10410 -- targets, the mod value is computed using a divide instruction
10411 -- which gives an overflow trap for this case.
10413 -- It would be a bit more efficient to figure out which targets this
10414 -- is really needed for, but in practice it is reasonable to do the
10415 -- following special check in all cases, since it means we get a clearer
10416 -- message, and also the overhead is minimal given that division is
10417 -- expensive in any case.
10419 -- In fact the check is quite easy, if the right operand is -1, then
10420 -- the remainder is always 0, and we can just ignore the left operand
10421 -- completely in this case.
10423 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10424 Lneg := (not OK) or else Lo < 0;
10426 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
10427 Rneg := (not OK) or else Lo < 0;
10429 -- We won't mess with trying to find out if the left operand can really
10430 -- be the largest negative number (that's a pain in the case of private
10431 -- types and this is really marginal). We will just assume that we need
10432 -- the test if the left operand can be negative at all.
10434 if Lneg and Rneg then
10436 Make_If_Expression (Loc,
10437 Expressions => New_List (
10439 Left_Opnd => Duplicate_Subexpr (Right),
10441 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
10443 Unchecked_Convert_To (Typ,
10444 Make_Integer_Literal (Loc, Uint_0)),
10446 Relocate_Node (N))));
10448 Set_Analyzed (Next (Next (First (Expressions (N)))));
10449 Analyze_And_Resolve (N, Typ);
10451 end Expand_N_Op_Rem;
10453 -----------------------------
10454 -- Expand_N_Op_Rotate_Left --
10455 -----------------------------
10457 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
10459 Binary_Op_Validity_Checks (N);
10461 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10462 -- so we rewrite in terms of logical shifts
10464 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10466 -- where Bits is the shift count mod Esize (the mod operation here
10467 -- deals with ludicrous large shift counts, which are apparently OK).
10469 if Modify_Tree_For_C then
10471 Loc : constant Source_Ptr := Sloc (N);
10472 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10473 Typ : constant Entity_Id := Etype (N);
10476 -- Sem_Intr should prevent getting there with a non binary modulus
10478 pragma Assert (not Non_Binary_Modulus (Typ));
10480 Rewrite (Right_Opnd (N),
10482 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10483 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10485 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10490 Make_Op_Shift_Left (Loc,
10491 Left_Opnd => Left_Opnd (N),
10492 Right_Opnd => Right_Opnd (N)),
10495 Make_Op_Shift_Right (Loc,
10496 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10498 Make_Op_Subtract (Loc,
10499 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10501 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10503 Analyze_And_Resolve (N, Typ);
10506 end Expand_N_Op_Rotate_Left;
10508 ------------------------------
10509 -- Expand_N_Op_Rotate_Right --
10510 ------------------------------
10512 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
10514 Binary_Op_Validity_Checks (N);
10516 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10517 -- so we rewrite in terms of logical shifts
10519 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10521 -- where Bits is the shift count mod Esize (the mod operation here
10522 -- deals with ludicrous large shift counts, which are apparently OK).
10524 if Modify_Tree_For_C then
10526 Loc : constant Source_Ptr := Sloc (N);
10527 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10528 Typ : constant Entity_Id := Etype (N);
10531 -- Sem_Intr should prevent getting there with a non binary modulus
10533 pragma Assert (not Non_Binary_Modulus (Typ));
10535 Rewrite (Right_Opnd (N),
10537 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10538 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10540 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10545 Make_Op_Shift_Right (Loc,
10546 Left_Opnd => Left_Opnd (N),
10547 Right_Opnd => Right_Opnd (N)),
10550 Make_Op_Shift_Left (Loc,
10551 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10553 Make_Op_Subtract (Loc,
10554 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10556 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10558 Analyze_And_Resolve (N, Typ);
10561 end Expand_N_Op_Rotate_Right;
10563 ----------------------------
10564 -- Expand_N_Op_Shift_Left --
10565 ----------------------------
10567 -- Note: nothing in this routine depends on left as opposed to right shifts
10568 -- so we share the routine for expanding shift right operations.
10570 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
10572 Binary_Op_Validity_Checks (N);
10574 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10575 -- operand is not greater than the word size (since that would not
10576 -- be defined properly by the corresponding C shift operator).
10578 if Modify_Tree_For_C then
10580 Right : constant Node_Id := Right_Opnd (N);
10581 Loc : constant Source_Ptr := Sloc (Right);
10582 Typ : constant Entity_Id := Etype (N);
10583 Siz : constant Uint := Esize (Typ);
10590 -- Sem_Intr should prevent getting there with a non binary modulus
10592 pragma Assert (not Non_Binary_Modulus (Typ));
10594 if Compile_Time_Known_Value (Right) then
10595 if Expr_Value (Right) >= Siz then
10596 Rewrite (N, Make_Integer_Literal (Loc, 0));
10597 Analyze_And_Resolve (N, Typ);
10600 -- Not compile time known, find range
10603 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10605 -- Nothing to do if known to be OK range, otherwise expand
10607 if not OK or else Hi >= Siz then
10609 -- Prevent recursion on copy of shift node
10611 Orig := Relocate_Node (N);
10612 Set_Analyzed (Orig);
10614 -- Now do the rewrite
10617 Make_If_Expression (Loc,
10618 Expressions => New_List (
10620 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
10621 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
10622 Make_Integer_Literal (Loc, 0),
10624 Analyze_And_Resolve (N, Typ);
10629 end Expand_N_Op_Shift_Left;
10631 -----------------------------
10632 -- Expand_N_Op_Shift_Right --
10633 -----------------------------
10635 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
10637 -- Share shift left circuit
10639 Expand_N_Op_Shift_Left (N);
10640 end Expand_N_Op_Shift_Right;
10642 ----------------------------------------
10643 -- Expand_N_Op_Shift_Right_Arithmetic --
10644 ----------------------------------------
10646 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
10648 Binary_Op_Validity_Checks (N);
10650 -- If we are in Modify_Tree_For_C mode, there is no shift right
10651 -- arithmetic in C, so we rewrite in terms of logical shifts for
10652 -- modular integers, and keep the Shift_Right intrinsic for signed
10653 -- integers: even though doing a shift on a signed integer is not
10654 -- fully guaranteed by the C standard, this is what C compilers
10655 -- implement in practice.
10656 -- Consider also taking advantage of this for modular integers by first
10657 -- performing an unchecked conversion of the modular integer to a signed
10658 -- integer of the same sign, and then convert back.
10660 -- Shift_Right (Num, Bits) or
10662 -- then not (Shift_Right (Mask, bits))
10665 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10667 -- Note: the above works fine for shift counts greater than or equal
10668 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10669 -- generates all 1'bits.
10671 if Modify_Tree_For_C and then Is_Modular_Integer_Type (Etype (N)) then
10673 Loc : constant Source_Ptr := Sloc (N);
10674 Typ : constant Entity_Id := Etype (N);
10675 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
10676 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
10677 Left : constant Node_Id := Left_Opnd (N);
10678 Right : constant Node_Id := Right_Opnd (N);
10682 -- Sem_Intr should prevent getting there with a non binary modulus
10684 pragma Assert (not Non_Binary_Modulus (Typ));
10686 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10687 -- compile time as a single constant.
10689 if Compile_Time_Known_Value (Right) then
10691 Val : constant Uint := Expr_Value (Right);
10694 if Val >= Esize (Typ) then
10695 Maskx := Make_Integer_Literal (Loc, Mask);
10699 Make_Integer_Literal (Loc,
10700 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
10708 Make_Op_Shift_Right (Loc,
10709 Left_Opnd => Make_Integer_Literal (Loc, Mask),
10710 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
10713 -- Now do the rewrite
10718 Make_Op_Shift_Right (Loc,
10720 Right_Opnd => Right),
10722 Make_If_Expression (Loc,
10723 Expressions => New_List (
10725 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
10726 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
10728 Make_Integer_Literal (Loc, 0)))));
10729 Analyze_And_Resolve (N, Typ);
10732 end Expand_N_Op_Shift_Right_Arithmetic;
10734 --------------------------
10735 -- Expand_N_Op_Subtract --
10736 --------------------------
10738 procedure Expand_N_Op_Subtract (N : Node_Id) is
10739 Typ : constant Entity_Id := Etype (N);
10742 Binary_Op_Validity_Checks (N);
10744 -- Check for MINIMIZED/ELIMINATED overflow mode
10746 if Minimized_Eliminated_Overflow_Check (N) then
10747 Apply_Arithmetic_Overflow_Check (N);
10751 -- Try to narrow the operation
10753 if Typ = Universal_Integer then
10754 Narrow_Large_Operation (N);
10756 if Nkind (N) /= N_Op_Subtract then
10761 -- N - 0 = N for integer types
10763 if Is_Integer_Type (Typ)
10764 and then Compile_Time_Known_Value (Right_Opnd (N))
10765 and then Expr_Value (Right_Opnd (N)) = 0
10767 Rewrite (N, Left_Opnd (N));
10771 -- Arithmetic overflow checks for signed integer/fixed point types
10773 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
10774 Apply_Arithmetic_Overflow_Check (N);
10777 -- Overflow checks for floating-point if -gnateF mode active
10779 Check_Float_Op_Overflow (N);
10781 Expand_Nonbinary_Modular_Op (N);
10782 end Expand_N_Op_Subtract;
10784 ---------------------
10785 -- Expand_N_Op_Xor --
10786 ---------------------
10788 procedure Expand_N_Op_Xor (N : Node_Id) is
10789 Typ : constant Entity_Id := Etype (N);
10792 Binary_Op_Validity_Checks (N);
10794 if Is_Array_Type (Etype (N)) then
10795 Expand_Boolean_Operator (N);
10797 elsif Is_Boolean_Type (Etype (N)) then
10798 Adjust_Condition (Left_Opnd (N));
10799 Adjust_Condition (Right_Opnd (N));
10800 Set_Etype (N, Standard_Boolean);
10801 Adjust_Result_Type (N, Typ);
10803 elsif Is_Intrinsic_Subprogram (Entity (N)) then
10804 Expand_Intrinsic_Call (N, Entity (N));
10807 Expand_Nonbinary_Modular_Op (N);
10808 end Expand_N_Op_Xor;
10810 ----------------------
10811 -- Expand_N_Or_Else --
10812 ----------------------
10814 procedure Expand_N_Or_Else (N : Node_Id)
10815 renames Expand_Short_Circuit_Operator;
10817 -----------------------------------
10818 -- Expand_N_Qualified_Expression --
10819 -----------------------------------
10821 procedure Expand_N_Qualified_Expression (N : Node_Id) is
10822 Operand : constant Node_Id := Expression (N);
10823 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
10826 -- Do validity check if validity checking operands
10828 if Validity_Checks_On and Validity_Check_Operands then
10829 Ensure_Valid (Operand);
10832 -- Apply possible constraint check
10834 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
10836 -- Apply possible predicate check
10838 Apply_Predicate_Check (Operand, Target_Type);
10840 if Do_Range_Check (Operand) then
10841 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
10843 end Expand_N_Qualified_Expression;
10845 ------------------------------------
10846 -- Expand_N_Quantified_Expression --
10847 ------------------------------------
10851 -- for all X in range => Cond
10856 -- for X in range loop
10857 -- if not Cond then
10863 -- Similarly, an existentially quantified expression:
10865 -- for some X in range => Cond
10870 -- for X in range loop
10877 -- In both cases, the iteration may be over a container in which case it is
10878 -- given by an iterator specification, not a loop parameter specification.
10880 procedure Expand_N_Quantified_Expression (N : Node_Id) is
10881 Actions : constant List_Id := New_List;
10882 For_All : constant Boolean := All_Present (N);
10883 Iter_Spec : constant Node_Id := Iterator_Specification (N);
10884 Loc : constant Source_Ptr := Sloc (N);
10885 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
10893 -- Ensure that the bound variable is properly frozen. We must do
10894 -- this before expansion because the expression is about to be
10895 -- converted into a loop, and resulting freeze nodes may end up
10896 -- in the wrong place in the tree.
10898 if Present (Iter_Spec) then
10899 Var := Defining_Identifier (Iter_Spec);
10901 Var := Defining_Identifier (Loop_Spec);
10905 P : Node_Id := Parent (N);
10907 while Nkind (P) in N_Subexpr loop
10911 Freeze_Before (P, Etype (Var));
10914 -- Create the declaration of the flag which tracks the status of the
10915 -- quantified expression. Generate:
10917 -- Flag : Boolean := (True | False);
10919 Flag := Make_Temporary (Loc, 'T', N);
10921 Append_To (Actions,
10922 Make_Object_Declaration (Loc,
10923 Defining_Identifier => Flag,
10924 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
10926 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
10928 -- Construct the circuitry which tracks the status of the quantified
10929 -- expression. Generate:
10931 -- if [not] Cond then
10932 -- Flag := (False | True);
10936 Cond := Relocate_Node (Condition (N));
10939 Cond := Make_Op_Not (Loc, Cond);
10942 Stmts := New_List (
10943 Make_Implicit_If_Statement (N,
10945 Then_Statements => New_List (
10946 Make_Assignment_Statement (Loc,
10947 Name => New_Occurrence_Of (Flag, Loc),
10949 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
10950 Make_Exit_Statement (Loc))));
10952 -- Build the loop equivalent of the quantified expression
10954 if Present (Iter_Spec) then
10956 Make_Iteration_Scheme (Loc,
10957 Iterator_Specification => Iter_Spec);
10960 Make_Iteration_Scheme (Loc,
10961 Loop_Parameter_Specification => Loop_Spec);
10964 Append_To (Actions,
10965 Make_Loop_Statement (Loc,
10966 Iteration_Scheme => Scheme,
10967 Statements => Stmts,
10968 End_Label => Empty));
10970 -- Transform the quantified expression
10973 Make_Expression_With_Actions (Loc,
10974 Expression => New_Occurrence_Of (Flag, Loc),
10975 Actions => Actions));
10976 Analyze_And_Resolve (N, Standard_Boolean);
10977 end Expand_N_Quantified_Expression;
10979 ---------------------------------
10980 -- Expand_N_Selected_Component --
10981 ---------------------------------
10983 procedure Expand_N_Selected_Component (N : Node_Id) is
10984 Loc : constant Source_Ptr := Sloc (N);
10985 Par : constant Node_Id := Parent (N);
10986 P : constant Node_Id := Prefix (N);
10987 S : constant Node_Id := Selector_Name (N);
10988 Ptyp : constant Entity_Id := Underlying_Type (Etype (P));
10994 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
10995 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10996 -- unless the context of an assignment can provide size information.
10997 -- Don't we have a general routine that does this???
10999 function Is_Subtype_Declaration return Boolean;
11000 -- The replacement of a discriminant reference by its value is required
11001 -- if this is part of the initialization of an temporary generated by a
11002 -- change of representation. This shows up as the construction of a
11003 -- discriminant constraint for a subtype declared at the same point as
11004 -- the entity in the prefix of the selected component. We recognize this
11005 -- case when the context of the reference is:
11006 -- subtype ST is T(Obj.D);
11007 -- where the entity for Obj comes from source, and ST has the same sloc.
11009 -----------------------
11010 -- In_Left_Hand_Side --
11011 -----------------------
11013 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
11015 return (Nkind (Parent (Comp)) = N_Assignment_Statement
11016 and then Comp = Name (Parent (Comp)))
11017 or else (Present (Parent (Comp))
11018 and then Nkind (Parent (Comp)) in N_Subexpr
11019 and then In_Left_Hand_Side (Parent (Comp)));
11020 end In_Left_Hand_Side;
11022 -----------------------------
11023 -- Is_Subtype_Declaration --
11024 -----------------------------
11026 function Is_Subtype_Declaration return Boolean is
11027 Par : constant Node_Id := Parent (N);
11030 Nkind (Par) = N_Index_Or_Discriminant_Constraint
11031 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
11032 and then Comes_From_Source (Entity (Prefix (N)))
11033 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
11034 end Is_Subtype_Declaration;
11036 -- Start of processing for Expand_N_Selected_Component
11039 -- Deal with discriminant check required
11041 if Do_Discriminant_Check (N) then
11042 if Present (Discriminant_Checking_Func
11043 (Original_Record_Component (Entity (S))))
11045 -- Present the discriminant checking function to the backend, so
11046 -- that it can inline the call to the function.
11049 (Discriminant_Checking_Func
11050 (Original_Record_Component (Entity (S))),
11053 -- Now reset the flag and generate the call
11055 Set_Do_Discriminant_Check (N, False);
11056 Generate_Discriminant_Check (N);
11058 -- In the case of Unchecked_Union, no discriminant checking is
11059 -- actually performed.
11062 Set_Do_Discriminant_Check (N, False);
11066 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11067 -- function, then additional actuals must be passed.
11069 if Is_Build_In_Place_Function_Call (P) then
11070 Make_Build_In_Place_Call_In_Anonymous_Context (P);
11072 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11073 -- containing build-in-place function calls whose returned object covers
11074 -- interface types.
11076 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
11077 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
11080 -- Gigi cannot handle unchecked conversions that are the prefix of a
11081 -- selected component with discriminants. This must be checked during
11082 -- expansion, because during analysis the type of the selector is not
11083 -- known at the point the prefix is analyzed. If the conversion is the
11084 -- target of an assignment, then we cannot force the evaluation.
11086 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
11087 and then Has_Discriminants (Etype (N))
11088 and then not In_Left_Hand_Side (N)
11090 Force_Evaluation (Prefix (N));
11093 -- Remaining processing applies only if selector is a discriminant
11095 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
11097 -- If the selector is a discriminant of a constrained record type,
11098 -- we may be able to rewrite the expression with the actual value
11099 -- of the discriminant, a useful optimization in some cases.
11101 if Is_Record_Type (Ptyp)
11102 and then Has_Discriminants (Ptyp)
11103 and then Is_Constrained (Ptyp)
11105 -- Do this optimization for discrete types only, and not for
11106 -- access types (access discriminants get us into trouble).
11108 if not Is_Discrete_Type (Etype (N)) then
11111 -- Don't do this on the left-hand side of an assignment statement.
11112 -- Normally one would think that references like this would not
11113 -- occur, but they do in generated code, and mean that we really
11114 -- do want to assign the discriminant.
11116 elsif Nkind (Par) = N_Assignment_Statement
11117 and then Name (Par) = N
11121 -- Don't do this optimization for the prefix of an attribute or
11122 -- the name of an object renaming declaration since these are
11123 -- contexts where we do not want the value anyway.
11125 elsif (Nkind (Par) = N_Attribute_Reference
11126 and then Prefix (Par) = N)
11127 or else Is_Renamed_Object (N)
11131 -- Don't do this optimization if we are within the code for a
11132 -- discriminant check, since the whole point of such a check may
11133 -- be to verify the condition on which the code below depends.
11135 elsif Is_In_Discriminant_Check (N) then
11138 -- Green light to see if we can do the optimization. There is
11139 -- still one condition that inhibits the optimization below but
11140 -- now is the time to check the particular discriminant.
11143 -- Loop through discriminants to find the matching discriminant
11144 -- constraint to see if we can copy it.
11146 Disc := First_Discriminant (Ptyp);
11147 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
11148 Discr_Loop : while Present (Dcon) loop
11149 Dval := Node (Dcon);
11151 -- Check if this is the matching discriminant and if the
11152 -- discriminant value is simple enough to make sense to
11153 -- copy. We don't want to copy complex expressions, and
11154 -- indeed to do so can cause trouble (before we put in
11155 -- this guard, a discriminant expression containing an
11156 -- AND THEN was copied, causing problems for coverage
11157 -- analysis tools).
11159 -- However, if the reference is part of the initialization
11160 -- code generated for an object declaration, we must use
11161 -- the discriminant value from the subtype constraint,
11162 -- because the selected component may be a reference to the
11163 -- object being initialized, whose discriminant is not yet
11164 -- set. This only happens in complex cases involving changes
11165 -- of representation.
11167 if Disc = Entity (Selector_Name (N))
11168 and then (Is_Entity_Name (Dval)
11169 or else Compile_Time_Known_Value (Dval)
11170 or else Is_Subtype_Declaration)
11172 -- Here we have the matching discriminant. Check for
11173 -- the case of a discriminant of a component that is
11174 -- constrained by an outer discriminant, which cannot
11175 -- be optimized away.
11177 if Denotes_Discriminant (Dval, Check_Concurrent => True)
11181 -- Do not retrieve value if constraint is not static. It
11182 -- is generally not useful, and the constraint may be a
11183 -- rewritten outer discriminant in which case it is in
11186 elsif Is_Entity_Name (Dval)
11188 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
11189 and then Present (Expression (Parent (Entity (Dval))))
11191 Is_OK_Static_Expression
11192 (Expression (Parent (Entity (Dval))))
11196 -- In the context of a case statement, the expression may
11197 -- have the base type of the discriminant, and we need to
11198 -- preserve the constraint to avoid spurious errors on
11201 elsif Nkind (Parent (N)) = N_Case_Statement
11202 and then Etype (Dval) /= Etype (Disc)
11205 Make_Qualified_Expression (Loc,
11207 New_Occurrence_Of (Etype (Disc), Loc),
11209 New_Copy_Tree (Dval)));
11210 Analyze_And_Resolve (N, Etype (Disc));
11212 -- In case that comes out as a static expression,
11213 -- reset it (a selected component is never static).
11215 Set_Is_Static_Expression (N, False);
11218 -- Otherwise we can just copy the constraint, but the
11219 -- result is certainly not static. In some cases the
11220 -- discriminant constraint has been analyzed in the
11221 -- context of the original subtype indication, but for
11222 -- itypes the constraint might not have been analyzed
11223 -- yet, and this must be done now.
11226 Rewrite (N, New_Copy_Tree (Dval));
11227 Analyze_And_Resolve (N);
11228 Set_Is_Static_Expression (N, False);
11234 Next_Discriminant (Disc);
11235 end loop Discr_Loop;
11237 -- Note: the above loop should always find a matching
11238 -- discriminant, but if it does not, we just missed an
11239 -- optimization due to some glitch (perhaps a previous
11240 -- error), so ignore.
11245 -- The only remaining processing is in the case of a discriminant of
11246 -- a concurrent object, where we rewrite the prefix to denote the
11247 -- corresponding record type. If the type is derived and has renamed
11248 -- discriminants, use corresponding discriminant, which is the one
11249 -- that appears in the corresponding record.
11251 if not Is_Concurrent_Type (Ptyp) then
11255 Disc := Entity (Selector_Name (N));
11257 if Is_Derived_Type (Ptyp)
11258 and then Present (Corresponding_Discriminant (Disc))
11260 Disc := Corresponding_Discriminant (Disc);
11264 Make_Selected_Component (Loc,
11266 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
11267 New_Copy_Tree (P)),
11268 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
11270 Rewrite (N, New_N);
11274 -- Set Atomic_Sync_Required if necessary for atomic component
11276 if Nkind (N) = N_Selected_Component then
11278 E : constant Entity_Id := Entity (Selector_Name (N));
11282 -- If component is atomic, but type is not, setting depends on
11283 -- disable/enable state for the component.
11285 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
11286 Set := not Atomic_Synchronization_Disabled (E);
11288 -- If component is not atomic, but its type is atomic, setting
11289 -- depends on disable/enable state for the type.
11291 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
11292 Set := not Atomic_Synchronization_Disabled (Etype (E));
11294 -- If both component and type are atomic, we disable if either
11295 -- component or its type have sync disabled.
11297 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
11298 Set := (not Atomic_Synchronization_Disabled (E))
11300 (not Atomic_Synchronization_Disabled (Etype (E)));
11306 -- Set flag if required
11309 Activate_Atomic_Synchronization (N);
11313 end Expand_N_Selected_Component;
11315 --------------------
11316 -- Expand_N_Slice --
11317 --------------------
11319 procedure Expand_N_Slice (N : Node_Id) is
11320 Loc : constant Source_Ptr := Sloc (N);
11321 Typ : constant Entity_Id := Etype (N);
11323 function Is_Procedure_Actual (N : Node_Id) return Boolean;
11324 -- Check whether the argument is an actual for a procedure call, in
11325 -- which case the expansion of a bit-packed slice is deferred until the
11326 -- call itself is expanded. The reason this is required is that we might
11327 -- have an IN OUT or OUT parameter, and the copy out is essential, and
11328 -- that copy out would be missed if we created a temporary here in
11329 -- Expand_N_Slice. Note that we don't bother to test specifically for an
11330 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
11331 -- is harmless to defer expansion in the IN case, since the call
11332 -- processing will still generate the appropriate copy in operation,
11333 -- which will take care of the slice.
11335 procedure Make_Temporary_For_Slice;
11336 -- Create a named variable for the value of the slice, in cases where
11337 -- the back end cannot handle it properly, e.g. when packed types or
11338 -- unaligned slices are involved.
11340 -------------------------
11341 -- Is_Procedure_Actual --
11342 -------------------------
11344 function Is_Procedure_Actual (N : Node_Id) return Boolean is
11345 Par : Node_Id := Parent (N);
11349 -- If our parent is a procedure call we can return
11351 if Nkind (Par) = N_Procedure_Call_Statement then
11354 -- If our parent is a type conversion, keep climbing the tree,
11355 -- since a type conversion can be a procedure actual. Also keep
11356 -- climbing if parameter association or a qualified expression,
11357 -- since these are additional cases that do can appear on
11358 -- procedure actuals.
11360 elsif Nkind (Par) in N_Type_Conversion
11361 | N_Parameter_Association
11362 | N_Qualified_Expression
11364 Par := Parent (Par);
11366 -- Any other case is not what we are looking for
11372 end Is_Procedure_Actual;
11374 ------------------------------
11375 -- Make_Temporary_For_Slice --
11376 ------------------------------
11378 procedure Make_Temporary_For_Slice is
11379 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
11384 Make_Object_Declaration (Loc,
11385 Defining_Identifier => Ent,
11386 Object_Definition => New_Occurrence_Of (Typ, Loc));
11388 Set_No_Initialization (Decl);
11390 Insert_Actions (N, New_List (
11392 Make_Assignment_Statement (Loc,
11393 Name => New_Occurrence_Of (Ent, Loc),
11394 Expression => Relocate_Node (N))));
11396 Rewrite (N, New_Occurrence_Of (Ent, Loc));
11397 Analyze_And_Resolve (N, Typ);
11398 end Make_Temporary_For_Slice;
11402 Pref : constant Node_Id := Prefix (N);
11404 -- Start of processing for Expand_N_Slice
11407 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11408 -- function, then additional actuals must be passed.
11410 if Is_Build_In_Place_Function_Call (Pref) then
11411 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
11413 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11414 -- containing build-in-place function calls whose returned object covers
11415 -- interface types.
11417 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
11418 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
11421 -- The remaining case to be handled is packed slices. We can leave
11422 -- packed slices as they are in the following situations:
11424 -- 1. Right or left side of an assignment (we can handle this
11425 -- situation correctly in the assignment statement expansion).
11427 -- 2. Prefix of indexed component (the slide is optimized away in this
11428 -- case, see the start of Expand_N_Slice.)
11430 -- 3. Object renaming declaration, since we want the name of the
11431 -- slice, not the value.
11433 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11434 -- be required, and this is handled in the expansion of call
11437 -- 5. Prefix of an address attribute (this is an error which is caught
11438 -- elsewhere, and the expansion would interfere with generating the
11439 -- error message) or of a size attribute (because 'Size may change
11440 -- when applied to the temporary instead of the slice directly).
11442 if not Is_Packed (Typ) then
11444 -- Apply transformation for actuals of a function call, where
11445 -- Expand_Actuals is not used.
11447 if Nkind (Parent (N)) = N_Function_Call
11448 and then Is_Possibly_Unaligned_Slice (N)
11450 Make_Temporary_For_Slice;
11453 elsif Nkind (Parent (N)) = N_Assignment_Statement
11454 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
11455 and then Parent (N) = Name (Parent (Parent (N))))
11459 elsif Nkind (Parent (N)) = N_Indexed_Component
11460 or else Is_Renamed_Object (N)
11461 or else Is_Procedure_Actual (N)
11465 elsif Nkind (Parent (N)) = N_Attribute_Reference
11466 and then (Attribute_Name (Parent (N)) = Name_Address
11467 or else Attribute_Name (Parent (N)) = Name_Size)
11472 Make_Temporary_For_Slice;
11474 end Expand_N_Slice;
11476 ------------------------------
11477 -- Expand_N_Type_Conversion --
11478 ------------------------------
11480 procedure Expand_N_Type_Conversion (N : Node_Id) is
11481 Loc : constant Source_Ptr := Sloc (N);
11482 Operand : constant Node_Id := Expression (N);
11483 Operand_Acc : Node_Id := Operand;
11484 Target_Type : Entity_Id := Etype (N);
11485 Operand_Type : Entity_Id := Etype (Operand);
11487 procedure Discrete_Range_Check;
11488 -- Handles generation of range check for discrete target value
11490 procedure Handle_Changed_Representation;
11491 -- This is called in the case of record and array type conversions to
11492 -- see if there is a change of representation to be handled. Change of
11493 -- representation is actually handled at the assignment statement level,
11494 -- and what this procedure does is rewrite node N conversion as an
11495 -- assignment to temporary. If there is no change of representation,
11496 -- then the conversion node is unchanged.
11498 procedure Raise_Accessibility_Error;
11499 -- Called when we know that an accessibility check will fail. Rewrites
11500 -- node N to an appropriate raise statement and outputs warning msgs.
11501 -- The Etype of the raise node is set to Target_Type. Note that in this
11502 -- case the rest of the processing should be skipped (i.e. the call to
11503 -- this procedure will be followed by "goto Done").
11505 procedure Real_Range_Check;
11506 -- Handles generation of range check for real target value
11508 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
11509 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11510 -- evaluates to True.
11512 function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
11514 -- Given a target type for a conversion, determine whether the
11515 -- statically deeper accessibility rules apply to it.
11517 --------------------------
11518 -- Discrete_Range_Check --
11519 --------------------------
11521 -- Case of conversions to a discrete type. We let Generate_Range_Check
11522 -- do the heavy lifting, after converting a fixed-point operand to an
11523 -- appropriate integer type.
11525 procedure Discrete_Range_Check is
11529 procedure Generate_Temporary;
11530 -- Generate a temporary to facilitate in the C backend the code
11531 -- generation of the unchecked conversion since the size of the
11532 -- source type may differ from the size of the target type.
11534 ------------------------
11535 -- Generate_Temporary --
11536 ------------------------
11538 procedure Generate_Temporary is
11540 if Esize (Etype (Expr)) < Esize (Etype (Ityp)) then
11542 Exp_Type : constant Entity_Id := Ityp;
11543 Def_Id : constant Entity_Id :=
11544 Make_Temporary (Loc, 'R', Expr);
11549 Set_Is_Internal (Def_Id);
11550 Set_Etype (Def_Id, Exp_Type);
11551 Res := New_Occurrence_Of (Def_Id, Loc);
11554 Make_Object_Declaration (Loc,
11555 Defining_Identifier => Def_Id,
11556 Object_Definition => New_Occurrence_Of
11558 Constant_Present => True,
11559 Expression => Relocate_Node (Expr));
11561 Set_Assignment_OK (E);
11562 Insert_Action (Expr, E);
11564 Set_Assignment_OK (Res, Assignment_OK (Expr));
11566 Rewrite (Expr, Res);
11567 Analyze_And_Resolve (Expr, Exp_Type);
11570 end Generate_Temporary;
11572 -- Start of processing for Discrete_Range_Check
11575 -- Nothing more to do if conversion was rewritten
11577 if Nkind (N) /= N_Type_Conversion then
11581 Expr := Expression (N);
11583 -- Clear the Do_Range_Check flag on Expr
11585 Set_Do_Range_Check (Expr, False);
11587 -- Nothing to do if range checks suppressed
11589 if Range_Checks_Suppressed (Target_Type) then
11593 -- Nothing to do if expression is an entity on which checks have been
11596 if Is_Entity_Name (Expr)
11597 and then Range_Checks_Suppressed (Entity (Expr))
11602 -- Before we do a range check, we have to deal with treating
11603 -- a fixed-point operand as an integer. The way we do this
11604 -- is simply to do an unchecked conversion to an appropriate
11605 -- integer type with the smallest size, so that we can suppress
11608 if Is_Fixed_Point_Type (Etype (Expr)) then
11609 Ityp := Small_Integer_Type_For
11610 (Esize (Base_Type (Etype (Expr))), False);
11612 -- Generate a temporary with the integer type to facilitate in the
11613 -- C backend the code generation for the unchecked conversion.
11615 if Modify_Tree_For_C then
11616 Generate_Temporary;
11619 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
11622 -- Reset overflow flag, since the range check will include
11623 -- dealing with possible overflow, and generate the check.
11625 Set_Do_Overflow_Check (N, False);
11627 Generate_Range_Check (Expr, Target_Type, CE_Range_Check_Failed);
11628 end Discrete_Range_Check;
11630 -----------------------------------
11631 -- Handle_Changed_Representation --
11632 -----------------------------------
11634 procedure Handle_Changed_Representation is
11642 -- Nothing else to do if no change of representation
11644 if Has_Compatible_Representation (Target_Type, Operand_Type) then
11647 -- The real change of representation work is done by the assignment
11648 -- statement processing. So if this type conversion is appearing as
11649 -- the expression of an assignment statement, nothing needs to be
11650 -- done to the conversion.
11652 elsif Nkind (Parent (N)) = N_Assignment_Statement then
11655 -- Otherwise we need to generate a temporary variable, and do the
11656 -- change of representation assignment into that temporary variable.
11657 -- The conversion is then replaced by a reference to this variable.
11662 -- If type is unconstrained we have to add a constraint, copied
11663 -- from the actual value of the left-hand side.
11665 if not Is_Constrained (Target_Type) then
11666 if Has_Discriminants (Operand_Type) then
11668 -- A change of representation can only apply to untagged
11669 -- types. We need to build the constraint that applies to
11670 -- the target type, using the constraints of the operand.
11671 -- The analysis is complicated if there are both inherited
11672 -- discriminants and constrained discriminants.
11673 -- We iterate over the discriminants of the target, and
11674 -- find the discriminant of the same name:
11676 -- a) If there is a corresponding discriminant in the object
11677 -- then the value is a selected component of the operand.
11679 -- b) Otherwise the value of a constrained discriminant is
11680 -- found in the stored constraint of the operand.
11683 Stored : constant Elist_Id :=
11684 Stored_Constraint (Operand_Type);
11688 Disc_O : Entity_Id;
11689 -- Discriminant of the operand type. Its value in the
11690 -- object is captured in a selected component.
11692 Disc_S : Entity_Id;
11693 -- Stored discriminant of the operand. If present, it
11694 -- corresponds to a constrained discriminant of the
11697 Disc_T : Entity_Id;
11698 -- Discriminant of the target type
11701 Disc_T := First_Discriminant (Target_Type);
11702 Disc_O := First_Discriminant (Operand_Type);
11703 Disc_S := First_Stored_Discriminant (Operand_Type);
11705 if Present (Stored) then
11706 Elmt := First_Elmt (Stored);
11708 Elmt := No_Elmt; -- init to avoid warning
11712 while Present (Disc_T) loop
11713 if Present (Disc_O)
11714 and then Chars (Disc_T) = Chars (Disc_O)
11717 Make_Selected_Component (Loc,
11719 Duplicate_Subexpr_Move_Checks (Operand),
11721 Make_Identifier (Loc, Chars (Disc_O))));
11722 Next_Discriminant (Disc_O);
11724 elsif Present (Disc_S) then
11725 Append_To (Cons, New_Copy_Tree (Node (Elmt)));
11729 Next_Discriminant (Disc_T);
11733 elsif Is_Array_Type (Operand_Type) then
11734 N_Ix := First_Index (Target_Type);
11737 for J in 1 .. Number_Dimensions (Operand_Type) loop
11739 -- We convert the bounds explicitly. We use an unchecked
11740 -- conversion because bounds checks are done elsewhere.
11745 Unchecked_Convert_To (Etype (N_Ix),
11746 Make_Attribute_Reference (Loc,
11748 Duplicate_Subexpr_No_Checks
11749 (Operand, Name_Req => True),
11750 Attribute_Name => Name_First,
11751 Expressions => New_List (
11752 Make_Integer_Literal (Loc, J)))),
11755 Unchecked_Convert_To (Etype (N_Ix),
11756 Make_Attribute_Reference (Loc,
11758 Duplicate_Subexpr_No_Checks
11759 (Operand, Name_Req => True),
11760 Attribute_Name => Name_Last,
11761 Expressions => New_List (
11762 Make_Integer_Literal (Loc, J))))));
11769 Odef := New_Occurrence_Of (Target_Type, Loc);
11771 if Present (Cons) then
11773 Make_Subtype_Indication (Loc,
11774 Subtype_Mark => Odef,
11776 Make_Index_Or_Discriminant_Constraint (Loc,
11777 Constraints => Cons));
11780 Temp := Make_Temporary (Loc, 'C');
11782 Make_Object_Declaration (Loc,
11783 Defining_Identifier => Temp,
11784 Object_Definition => Odef);
11786 Set_No_Initialization (Decl, True);
11788 -- Insert required actions. It is essential to suppress checks
11789 -- since we have suppressed default initialization, which means
11790 -- that the variable we create may have no discriminants.
11795 Make_Assignment_Statement (Loc,
11796 Name => New_Occurrence_Of (Temp, Loc),
11797 Expression => Relocate_Node (N))),
11798 Suppress => All_Checks);
11800 Rewrite (N, New_Occurrence_Of (Temp, Loc));
11803 end Handle_Changed_Representation;
11805 -------------------------------
11806 -- Raise_Accessibility_Error --
11807 -------------------------------
11809 procedure Raise_Accessibility_Error is
11811 Error_Msg_Warn := SPARK_Mode /= On;
11813 Make_Raise_Program_Error (Sloc (N),
11814 Reason => PE_Accessibility_Check_Failed));
11815 Set_Etype (N, Target_Type);
11817 Error_Msg_N ("<<accessibility check failure", N);
11818 Error_Msg_NE ("\<<& [", N, Standard_Program_Error);
11819 end Raise_Accessibility_Error;
11821 ----------------------
11822 -- Real_Range_Check --
11823 ----------------------
11825 -- Case of conversions to floating-point or fixed-point. If range checks
11826 -- are enabled and the target type has a range constraint, we convert:
11832 -- Tnn : typ'Base := typ'Base (x);
11833 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11836 -- This is necessary when there is a conversion of integer to float or
11837 -- to fixed-point to ensure that the correct checks are made. It is not
11838 -- necessary for the float-to-float case where it is enough to just set
11839 -- the Do_Range_Check flag on the expression.
11841 procedure Real_Range_Check is
11842 Btyp : constant Entity_Id := Base_Type (Target_Type);
11843 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
11844 Hi : constant Node_Id := Type_High_Bound (Target_Type);
11855 -- Nothing more to do if conversion was rewritten
11857 if Nkind (N) /= N_Type_Conversion then
11861 Expr := Expression (N);
11863 -- Clear the Do_Range_Check flag on Expr
11865 Set_Do_Range_Check (Expr, False);
11867 -- Nothing to do if range checks suppressed, or target has the same
11868 -- range as the base type (or is the base type).
11870 if Range_Checks_Suppressed (Target_Type)
11871 or else (Lo = Type_Low_Bound (Btyp)
11873 Hi = Type_High_Bound (Btyp))
11878 -- Nothing to do if expression is an entity on which checks have been
11881 if Is_Entity_Name (Expr)
11882 and then Range_Checks_Suppressed (Entity (Expr))
11887 -- Nothing to do if expression was rewritten into a float-to-float
11888 -- conversion, since this kind of conversion is handled elsewhere.
11890 if Is_Floating_Point_Type (Etype (Expr))
11891 and then Is_Floating_Point_Type (Target_Type)
11896 -- Nothing to do if bounds are all static and we can tell that the
11897 -- expression is within the bounds of the target. Note that if the
11898 -- operand is of an unconstrained floating-point type, then we do
11899 -- not trust it to be in range (might be infinite)
11902 S_Lo : constant Node_Id := Type_Low_Bound (Etype (Expr));
11903 S_Hi : constant Node_Id := Type_High_Bound (Etype (Expr));
11906 if (not Is_Floating_Point_Type (Etype (Expr))
11907 or else Is_Constrained (Etype (Expr)))
11908 and then Compile_Time_Known_Value (S_Lo)
11909 and then Compile_Time_Known_Value (S_Hi)
11910 and then Compile_Time_Known_Value (Hi)
11911 and then Compile_Time_Known_Value (Lo)
11914 D_Lov : constant Ureal := Expr_Value_R (Lo);
11915 D_Hiv : constant Ureal := Expr_Value_R (Hi);
11920 if Is_Real_Type (Etype (Expr)) then
11921 S_Lov := Expr_Value_R (S_Lo);
11922 S_Hiv := Expr_Value_R (S_Hi);
11924 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
11925 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
11929 and then S_Lov >= D_Lov
11930 and then S_Hiv <= D_Hiv
11938 -- Otherwise rewrite the conversion as described above
11940 Conv := Convert_To (Btyp, Expr);
11942 -- If a conversion is necessary, then copy the specific flags from
11943 -- the original one and also move the Do_Overflow_Check flag since
11944 -- this new conversion is to the base type.
11946 if Nkind (Conv) = N_Type_Conversion then
11947 Set_Conversion_OK (Conv, Conversion_OK (N));
11948 Set_Float_Truncate (Conv, Float_Truncate (N));
11949 Set_Rounded_Result (Conv, Rounded_Result (N));
11951 if Do_Overflow_Check (N) then
11952 Set_Do_Overflow_Check (Conv);
11953 Set_Do_Overflow_Check (N, False);
11957 Tnn := Make_Temporary (Loc, 'T', Conv);
11959 -- For a conversion from Float to Fixed where the bounds of the
11960 -- fixed-point type are static, we can obtain a more accurate
11961 -- fixed-point value by converting the result of the floating-
11962 -- point expression to an appropriate integer type, and then
11963 -- performing an unchecked conversion to the target fixed-point
11964 -- type. The range check can then use the corresponding integer
11965 -- value of the bounds instead of requiring further conversions.
11966 -- This preserves the identity:
11968 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11970 -- which used to fail when Fix_Val was a bound of the type and
11971 -- the 'Small was not a representable number.
11972 -- This transformation requires an integer type large enough to
11973 -- accommodate a fixed-point value.
11975 if Is_Ordinary_Fixed_Point_Type (Target_Type)
11976 and then Is_Floating_Point_Type (Etype (Expr))
11977 and then RM_Size (Btyp) <= System_Max_Integer_Size
11978 and then Nkind (Lo) = N_Real_Literal
11979 and then Nkind (Hi) = N_Real_Literal
11982 Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv);
11983 Int_Typ : constant Entity_Id :=
11984 Small_Integer_Type_For (RM_Size (Btyp), False);
11987 -- Generate a temporary with the integer value. Required in the
11988 -- CCG compiler to ensure that run-time checks reference this
11989 -- integer expression (instead of the resulting fixed-point
11990 -- value because fixed-point values are handled by means of
11991 -- unsigned integer types).
11994 Make_Object_Declaration (Loc,
11995 Defining_Identifier => Expr_Id,
11996 Object_Definition => New_Occurrence_Of (Int_Typ, Loc),
11997 Constant_Present => True,
11999 Convert_To (Int_Typ, Expression (Conv))));
12001 -- Create integer objects for range checking of result.
12004 Unchecked_Convert_To
12005 (Int_Typ, New_Occurrence_Of (Expr_Id, Loc));
12008 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo));
12011 Unchecked_Convert_To
12012 (Int_Typ, New_Occurrence_Of (Expr_Id, Loc));
12015 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi));
12017 -- Rewrite conversion as an integer conversion of the
12018 -- original floating-point expression, followed by an
12019 -- unchecked conversion to the target fixed-point type.
12022 Make_Unchecked_Type_Conversion (Loc,
12023 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
12024 Expression => New_Occurrence_Of (Expr_Id, Loc));
12027 -- All other conversions
12030 Lo_Arg := New_Occurrence_Of (Tnn, Loc);
12032 Make_Attribute_Reference (Loc,
12033 Prefix => New_Occurrence_Of (Target_Type, Loc),
12034 Attribute_Name => Name_First);
12036 Hi_Arg := New_Occurrence_Of (Tnn, Loc);
12038 Make_Attribute_Reference (Loc,
12039 Prefix => New_Occurrence_Of (Target_Type, Loc),
12040 Attribute_Name => Name_Last);
12043 -- Build code for range checking. Note that checks are suppressed
12044 -- here since we don't want a recursive range check popping up.
12046 Insert_Actions (N, New_List (
12047 Make_Object_Declaration (Loc,
12048 Defining_Identifier => Tnn,
12049 Object_Definition => New_Occurrence_Of (Btyp, Loc),
12050 Constant_Present => True,
12051 Expression => Conv),
12053 Make_Raise_Constraint_Error (Loc,
12058 Left_Opnd => Lo_Arg,
12059 Right_Opnd => Lo_Val),
12063 Left_Opnd => Hi_Arg,
12064 Right_Opnd => Hi_Val)),
12065 Reason => CE_Range_Check_Failed)),
12066 Suppress => All_Checks);
12068 Rewrite (Expr, New_Occurrence_Of (Tnn, Loc));
12069 end Real_Range_Check;
12071 -----------------------------
12072 -- Has_Extra_Accessibility --
12073 -----------------------------
12075 -- Returns true for a formal of an anonymous access type or for an Ada
12076 -- 2012-style stand-alone object of an anonymous access type.
12078 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
12080 if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then
12081 return Present (Effective_Extra_Accessibility (Id));
12085 end Has_Extra_Accessibility;
12087 ----------------------------------------
12088 -- Statically_Deeper_Relation_Applies --
12089 ----------------------------------------
12091 function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
12095 -- The case where the target type is an anonymous access type is
12096 -- ignored since they have different semantics and get covered by
12097 -- various runtime checks depending on context.
12099 -- Note, the current implementation of this predicate is incomplete
12100 -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
12103 return Ekind (Targ_Typ) /= E_Anonymous_Access_Type;
12104 end Statically_Deeper_Relation_Applies;
12106 -- Start of processing for Expand_N_Type_Conversion
12109 -- First remove check marks put by the semantic analysis on the type
12110 -- conversion between array types. We need these checks, and they will
12111 -- be generated by this expansion routine, but we do not depend on these
12112 -- flags being set, and since we do intend to expand the checks in the
12113 -- front end, we don't want them on the tree passed to the back end.
12115 if Is_Array_Type (Target_Type) then
12116 if Is_Constrained (Target_Type) then
12117 Set_Do_Length_Check (N, False);
12119 Set_Do_Range_Check (Operand, False);
12123 -- Nothing at all to do if conversion is to the identical type so remove
12124 -- the conversion completely, it is useless, except that it may carry
12125 -- an Assignment_OK attribute, which must be propagated to the operand
12126 -- and the Do_Range_Check flag on the operand must be cleared, if any.
12128 if Operand_Type = Target_Type then
12129 if Assignment_OK (N) then
12130 Set_Assignment_OK (Operand);
12133 Set_Do_Range_Check (Operand, False);
12135 Rewrite (N, Relocate_Node (Operand));
12140 -- Nothing to do if this is the second argument of read. This is a
12141 -- "backwards" conversion that will be handled by the specialized code
12142 -- in attribute processing.
12144 if Nkind (Parent (N)) = N_Attribute_Reference
12145 and then Attribute_Name (Parent (N)) = Name_Read
12146 and then Next (First (Expressions (Parent (N)))) = N
12151 -- Check for case of converting to a type that has an invariant
12152 -- associated with it. This requires an invariant check. We insert
12155 -- invariant_check (typ (expr))
12157 -- in the code, after removing side effects from the expression.
12158 -- This is clearer than replacing the conversion into an expression
12159 -- with actions, because the context may impose additional actions
12160 -- (tag checks, membership tests, etc.) that conflict with this
12161 -- rewriting (used previously).
12163 -- Note: the Comes_From_Source check, and then the resetting of this
12164 -- flag prevents what would otherwise be an infinite recursion.
12166 if Has_Invariants (Target_Type)
12167 and then Present (Invariant_Procedure (Target_Type))
12168 and then Comes_From_Source (N)
12170 Set_Comes_From_Source (N, False);
12171 Remove_Side_Effects (N);
12172 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
12175 -- AI12-0042: For a view conversion to a class-wide type occurring
12176 -- within the immediate scope of T, from a specific type that is
12177 -- a descendant of T (including T itself), an invariant check is
12178 -- performed on the part of the object that is of type T. (We don't
12179 -- need to explicitly check for the operand type being a descendant,
12180 -- just that it's a specific type, because the conversion would be
12181 -- illegal if it's specific and not a descendant -- downward conversion
12182 -- is not allowed).
12184 elsif Is_Class_Wide_Type (Target_Type)
12185 and then not Is_Class_Wide_Type (Etype (Expression (N)))
12186 and then Present (Invariant_Procedure (Root_Type (Target_Type)))
12187 and then Comes_From_Source (N)
12188 and then Within_Scope (Find_Enclosing_Scope (N), Scope (Target_Type))
12190 Remove_Side_Effects (N);
12192 -- Perform the invariant check on a conversion to the class-wide
12193 -- type's root type.
12196 Root_Conv : constant Node_Id :=
12197 Make_Type_Conversion (Loc,
12199 New_Occurrence_Of (Root_Type (Target_Type), Loc),
12200 Expression => Duplicate_Subexpr (Expression (N)));
12202 Set_Etype (Root_Conv, Root_Type (Target_Type));
12204 Insert_Action (N, Make_Invariant_Call (Root_Conv));
12209 -- Here if we may need to expand conversion
12211 -- If the operand of the type conversion is an arithmetic operation on
12212 -- signed integers, and the based type of the signed integer type in
12213 -- question is smaller than Standard.Integer, we promote both of the
12214 -- operands to type Integer.
12216 -- For example, if we have
12218 -- target-type (opnd1 + opnd2)
12220 -- and opnd1 and opnd2 are of type short integer, then we rewrite
12223 -- target-type (integer(opnd1) + integer(opnd2))
12225 -- We do this because we are always allowed to compute in a larger type
12226 -- if we do the right thing with the result, and in this case we are
12227 -- going to do a conversion which will do an appropriate check to make
12228 -- sure that things are in range of the target type in any case. This
12229 -- avoids some unnecessary intermediate overflows.
12231 -- We might consider a similar transformation in the case where the
12232 -- target is a real type or a 64-bit integer type, and the operand
12233 -- is an arithmetic operation using a 32-bit integer type. However,
12234 -- we do not bother with this case, because it could cause significant
12235 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
12236 -- much cheaper, but we don't want different behavior on 32-bit and
12237 -- 64-bit machines. Note that the exclusion of the 64-bit case also
12238 -- handles the configurable run-time cases where 64-bit arithmetic
12239 -- may simply be unavailable.
12241 -- Note: this circuit is partially redundant with respect to the circuit
12242 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
12243 -- the processing here. Also we still need the Checks circuit, since we
12244 -- have to be sure not to generate junk overflow checks in the first
12245 -- place, since it would be tricky to remove them here.
12247 if Integer_Promotion_Possible (N) then
12249 -- All conditions met, go ahead with transformation
12256 Opnd := New_Op_Node (Nkind (Operand), Loc);
12258 R := Convert_To (Standard_Integer, Right_Opnd (Operand));
12259 Set_Right_Opnd (Opnd, R);
12261 if Nkind (Operand) in N_Binary_Op then
12262 L := Convert_To (Standard_Integer, Left_Opnd (Operand));
12263 Set_Left_Opnd (Opnd, L);
12267 Make_Type_Conversion (Loc,
12268 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
12269 Expression => Opnd));
12271 Analyze_And_Resolve (N, Target_Type);
12276 -- Do validity check if validity checking operands
12278 if Validity_Checks_On and Validity_Check_Operands then
12279 Ensure_Valid (Operand);
12282 -- Special case of converting from non-standard boolean type
12284 if Is_Boolean_Type (Operand_Type)
12285 and then (Nonzero_Is_True (Operand_Type))
12287 Adjust_Condition (Operand);
12288 Set_Etype (Operand, Standard_Boolean);
12289 Operand_Type := Standard_Boolean;
12292 -- Case of converting to an access type
12294 if Is_Access_Type (Target_Type) then
12295 -- In terms of accessibility rules, an anonymous access discriminant
12296 -- is not considered separate from its parent object.
12298 if Nkind (Operand) = N_Selected_Component
12299 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
12300 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
12302 Operand_Acc := Original_Node (Prefix (Operand));
12305 -- If this type conversion was internally generated by the front end
12306 -- to displace the pointer to the object to reference an interface
12307 -- type and the original node was an Unrestricted_Access attribute,
12308 -- then skip applying accessibility checks (because, according to the
12309 -- GNAT Reference Manual, this attribute is similar to 'Access except
12310 -- that all accessibility and aliased view checks are omitted).
12312 if not Comes_From_Source (N)
12313 and then Is_Interface (Designated_Type (Target_Type))
12314 and then Nkind (Original_Node (N)) = N_Attribute_Reference
12315 and then Attribute_Name (Original_Node (N)) =
12316 Name_Unrestricted_Access
12320 -- Apply an accessibility check when the conversion operand is an
12321 -- access parameter (or a renaming thereof), unless conversion was
12322 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
12323 -- or for the actual of a class-wide interface parameter. Note that
12324 -- other checks may still need to be applied below (such as tagged
12327 elsif Is_Entity_Name (Operand_Acc)
12328 and then Has_Extra_Accessibility (Entity (Operand_Acc))
12329 and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
12330 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
12331 or else Attribute_Name (Original_Node (N)) = Name_Access)
12333 if not Comes_From_Source (N)
12334 and then Nkind (Parent (N)) in N_Function_Call
12335 | N_Parameter_Association
12336 | N_Procedure_Call_Statement
12337 and then Is_Interface (Designated_Type (Target_Type))
12338 and then Is_Class_Wide_Type (Designated_Type (Target_Type))
12343 Apply_Accessibility_Check
12344 (Operand, Target_Type, Insert_Node => Operand);
12347 -- If the level of the operand type is statically deeper than the
12348 -- level of the target type, then force Program_Error. Note that this
12349 -- can only occur for cases where the attribute is within the body of
12350 -- an instantiation, otherwise the conversion will already have been
12351 -- rejected as illegal.
12353 -- Note: warnings are issued by the analyzer for the instance cases
12355 elsif In_Instance_Body
12356 and then Statically_Deeper_Relation_Applies (Target_Type)
12358 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
12360 Raise_Accessibility_Error;
12363 -- When the operand is a selected access discriminant the check needs
12364 -- to be made against the level of the object denoted by the prefix
12365 -- of the selected name. Force Program_Error for this case as well
12366 -- (this accessibility violation can only happen if within the body
12367 -- of an instantiation).
12369 elsif In_Instance_Body
12370 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
12371 and then Nkind (Operand) = N_Selected_Component
12372 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
12373 and then Static_Accessibility_Level (Operand, Zero_On_Dynamic_Level)
12374 > Type_Access_Level (Target_Type)
12376 Raise_Accessibility_Error;
12381 -- Case of conversions of tagged types and access to tagged types
12383 -- When needed, that is to say when the expression is class-wide, Add
12384 -- runtime a tag check for (strict) downward conversion by using the
12385 -- membership test, generating:
12387 -- [constraint_error when Operand not in Target_Type'Class]
12389 -- or in the access type case
12391 -- [constraint_error
12392 -- when Operand /= null
12393 -- and then Operand.all not in
12394 -- Designated_Type (Target_Type)'Class]
12396 if (Is_Access_Type (Target_Type)
12397 and then Is_Tagged_Type (Designated_Type (Target_Type)))
12398 or else Is_Tagged_Type (Target_Type)
12400 -- Do not do any expansion in the access type case if the parent is a
12401 -- renaming, since this is an error situation which will be caught by
12402 -- Sem_Ch8, and the expansion can interfere with this error check.
12404 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
12408 -- Otherwise, proceed with processing tagged conversion
12410 Tagged_Conversion : declare
12411 Actual_Op_Typ : Entity_Id;
12412 Actual_Targ_Typ : Entity_Id;
12413 Root_Op_Typ : Entity_Id;
12415 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
12416 -- Create a membership check to test whether Operand is a member
12417 -- of Targ_Typ. If the original Target_Type is an access, include
12418 -- a test for null value. The check is inserted at N.
12420 --------------------
12421 -- Make_Tag_Check --
12422 --------------------
12424 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
12429 -- [Constraint_Error
12430 -- when Operand /= null
12431 -- and then Operand.all not in Targ_Typ]
12433 if Is_Access_Type (Target_Type) then
12435 Make_And_Then (Loc,
12438 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
12439 Right_Opnd => Make_Null (Loc)),
12444 Make_Explicit_Dereference (Loc,
12445 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
12446 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
12449 -- [Constraint_Error when Operand not in Targ_Typ]
12454 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
12455 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
12459 Make_Raise_Constraint_Error (Loc,
12461 Reason => CE_Tag_Check_Failed),
12462 Suppress => All_Checks);
12463 end Make_Tag_Check;
12465 -- Start of processing for Tagged_Conversion
12468 -- Handle entities from the limited view
12470 if Is_Access_Type (Operand_Type) then
12472 Available_View (Designated_Type (Operand_Type));
12474 Actual_Op_Typ := Operand_Type;
12477 if Is_Access_Type (Target_Type) then
12479 Available_View (Designated_Type (Target_Type));
12481 Actual_Targ_Typ := Target_Type;
12484 Root_Op_Typ := Root_Type (Actual_Op_Typ);
12486 -- Ada 2005 (AI-251): Handle interface type conversion
12488 if Is_Interface (Actual_Op_Typ)
12490 Is_Interface (Actual_Targ_Typ)
12492 Expand_Interface_Conversion (N);
12496 -- Create a runtime tag check for a downward CW type conversion
12498 if Is_Class_Wide_Type (Actual_Op_Typ)
12499 and then Actual_Op_Typ /= Actual_Targ_Typ
12500 and then Root_Op_Typ /= Actual_Targ_Typ
12501 and then Is_Ancestor
12502 (Root_Op_Typ, Actual_Targ_Typ, Use_Full_View => True)
12503 and then not Tag_Checks_Suppressed (Actual_Targ_Typ)
12508 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
12510 Make_Unchecked_Type_Conversion (Loc,
12511 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
12512 Expression => Relocate_Node (Expression (N)));
12514 Analyze_And_Resolve (N, Target_Type);
12517 end Tagged_Conversion;
12519 -- Case of other access type conversions
12521 elsif Is_Access_Type (Target_Type) then
12522 Apply_Constraint_Check (Operand, Target_Type);
12524 -- Case of conversions from a fixed-point type
12526 -- These conversions require special expansion and processing, found in
12527 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12528 -- since from a semantic point of view, these are simple integer
12529 -- conversions, which do not need further processing except for the
12530 -- generation of range checks, which is performed at the end of this
12533 elsif Is_Fixed_Point_Type (Operand_Type)
12534 and then not Conversion_OK (N)
12536 -- We should never see universal fixed at this case, since the
12537 -- expansion of the constituent divide or multiply should have
12538 -- eliminated the explicit mention of universal fixed.
12540 pragma Assert (Operand_Type /= Universal_Fixed);
12542 -- Check for special case of the conversion to universal real that
12543 -- occurs as a result of the use of a round attribute. In this case,
12544 -- the real type for the conversion is taken from the target type of
12545 -- the Round attribute and the result must be marked as rounded.
12547 if Target_Type = Universal_Real
12548 and then Nkind (Parent (N)) = N_Attribute_Reference
12549 and then Attribute_Name (Parent (N)) = Name_Round
12551 Set_Etype (N, Etype (Parent (N)));
12552 Target_Type := Etype (N);
12553 Set_Rounded_Result (N);
12556 if Is_Fixed_Point_Type (Target_Type) then
12557 Expand_Convert_Fixed_To_Fixed (N);
12558 elsif Is_Integer_Type (Target_Type) then
12559 Expand_Convert_Fixed_To_Integer (N);
12561 pragma Assert (Is_Floating_Point_Type (Target_Type));
12562 Expand_Convert_Fixed_To_Float (N);
12565 -- Case of conversions to a fixed-point type
12567 -- These conversions require special expansion and processing, found in
12568 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12569 -- since from a semantic point of view, these are simple integer
12570 -- conversions, which do not need further processing.
12572 elsif Is_Fixed_Point_Type (Target_Type)
12573 and then not Conversion_OK (N)
12575 if Is_Integer_Type (Operand_Type) then
12576 Expand_Convert_Integer_To_Fixed (N);
12578 pragma Assert (Is_Floating_Point_Type (Operand_Type));
12579 Expand_Convert_Float_To_Fixed (N);
12582 -- Case of array conversions
12584 -- Expansion of array conversions, add required length/range checks but
12585 -- only do this if there is no change of representation. For handling of
12586 -- this case, see Handle_Changed_Representation.
12588 elsif Is_Array_Type (Target_Type) then
12589 if Is_Constrained (Target_Type) then
12590 Apply_Length_Check (Operand, Target_Type);
12592 Apply_Range_Check (Operand, Target_Type);
12595 Handle_Changed_Representation;
12597 -- Case of conversions of discriminated types
12599 -- Add required discriminant checks if target is constrained. Again this
12600 -- change is skipped if we have a change of representation.
12602 elsif Has_Discriminants (Target_Type)
12603 and then Is_Constrained (Target_Type)
12605 Apply_Discriminant_Check (Operand, Target_Type);
12606 Handle_Changed_Representation;
12608 -- Case of all other record conversions. The only processing required
12609 -- is to check for a change of representation requiring the special
12610 -- assignment processing.
12612 elsif Is_Record_Type (Target_Type) then
12614 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12615 -- a derived Unchecked_Union type to an unconstrained type that is
12616 -- not Unchecked_Union if the operand lacks inferable discriminants.
12618 if Is_Derived_Type (Operand_Type)
12619 and then Is_Unchecked_Union (Base_Type (Operand_Type))
12620 and then not Is_Constrained (Target_Type)
12621 and then not Is_Unchecked_Union (Base_Type (Target_Type))
12622 and then not Has_Inferable_Discriminants (Operand)
12624 -- To prevent Gigi from generating illegal code, we generate a
12625 -- Program_Error node, but we give it the target type of the
12626 -- conversion (is this requirement documented somewhere ???)
12629 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
12630 Reason => PE_Unchecked_Union_Restriction);
12633 Set_Etype (PE, Target_Type);
12638 Handle_Changed_Representation;
12641 -- Case of conversions of enumeration types
12643 elsif Is_Enumeration_Type (Target_Type) then
12645 -- Special processing is required if there is a change of
12646 -- representation (from enumeration representation clauses).
12648 if not Has_Compatible_Representation (Target_Type, Operand_Type)
12649 and then not Conversion_OK (N)
12652 -- Convert: x(y) to x'val (ytyp'pos (y))
12655 Make_Attribute_Reference (Loc,
12656 Prefix => New_Occurrence_Of (Target_Type, Loc),
12657 Attribute_Name => Name_Val,
12658 Expressions => New_List (
12659 Make_Attribute_Reference (Loc,
12660 Prefix => New_Occurrence_Of (Operand_Type, Loc),
12661 Attribute_Name => Name_Pos,
12662 Expressions => New_List (Operand)))));
12664 Analyze_And_Resolve (N, Target_Type);
12668 -- At this stage, either the conversion node has been transformed into
12669 -- some other equivalent expression, or left as a conversion that can be
12670 -- handled by Gigi, in the following cases:
12672 -- Conversions with no change of representation or type
12674 -- Numeric conversions involving integer, floating- and fixed-point
12675 -- values. Fixed-point values are allowed only if Conversion_OK is
12676 -- set, i.e. if the fixed-point values are to be treated as integers.
12678 -- No other conversions should be passed to Gigi
12680 -- Check: are these rules stated in sinfo??? if so, why restate here???
12682 -- The only remaining step is to generate a range check if we still have
12683 -- a type conversion at this stage and Do_Range_Check is set. Note that
12684 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12685 -- conversions here, because the float-to-integer case is entirely dealt
12686 -- with by Apply_Float_Conversion_Check.
12688 if Nkind (N) = N_Type_Conversion
12689 and then Do_Range_Check (Expression (N))
12691 -- Float-to-float conversions
12693 if Is_Floating_Point_Type (Target_Type)
12694 and then Is_Floating_Point_Type (Etype (Expression (N)))
12696 -- Reset overflow flag, since the range check will include
12697 -- dealing with possible overflow, and generate the check.
12699 Set_Do_Overflow_Check (N, False);
12701 Generate_Range_Check
12702 (Expression (N), Target_Type, CE_Range_Check_Failed);
12704 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12705 -- conversions when Conversion_OK is set.
12707 elsif Is_Discrete_Type (Target_Type)
12708 and then (Is_Discrete_Type (Etype (Expression (N)))
12709 or else (Is_Fixed_Point_Type (Etype (Expression (N)))
12710 and then Conversion_OK (N)))
12712 -- If Address is either a source type or target type,
12713 -- suppress range check to avoid typing anomalies when
12714 -- it is a visible integer type.
12716 if Is_Descendant_Of_Address (Etype (Expression (N)))
12717 or else Is_Descendant_Of_Address (Target_Type)
12719 Set_Do_Range_Check (Expression (N), False);
12721 Discrete_Range_Check;
12724 -- Conversions to floating- or fixed-point when Conversion_OK is set
12726 elsif Is_Floating_Point_Type (Target_Type)
12727 or else (Is_Fixed_Point_Type (Target_Type)
12728 and then Conversion_OK (N))
12733 pragma Assert (not Do_Range_Check (Expression (N)));
12736 -- Here at end of processing
12739 -- Apply predicate check if required. Note that we can't just call
12740 -- Apply_Predicate_Check here, because the type looks right after
12741 -- the conversion and it would omit the check. The Comes_From_Source
12742 -- guard is necessary to prevent infinite recursions when we generate
12743 -- internal conversions for the purpose of checking predicates.
12745 if Predicate_Enabled (Target_Type)
12746 and then Target_Type /= Operand_Type
12747 and then Comes_From_Source (N)
12750 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
12753 -- Avoid infinite recursion on the subsequent expansion of the
12754 -- copy of the original type conversion. When needed, a range
12755 -- check has already been applied to the expression.
12757 Set_Comes_From_Source (New_Expr, False);
12759 Make_Predicate_Check (Target_Type, New_Expr),
12760 Suppress => Range_Check);
12763 end Expand_N_Type_Conversion;
12765 -----------------------------------
12766 -- Expand_N_Unchecked_Expression --
12767 -----------------------------------
12769 -- Remove the unchecked expression node from the tree. Its job was simply
12770 -- to make sure that its constituent expression was handled with checks
12771 -- off, and now that is done, we can remove it from the tree, and indeed
12772 -- must, since Gigi does not expect to see these nodes.
12774 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
12775 Exp : constant Node_Id := Expression (N);
12777 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
12779 end Expand_N_Unchecked_Expression;
12781 ----------------------------------------
12782 -- Expand_N_Unchecked_Type_Conversion --
12783 ----------------------------------------
12785 -- If this cannot be handled by Gigi and we haven't already made a
12786 -- temporary for it, do it now.
12788 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
12789 Target_Type : constant Entity_Id := Etype (N);
12790 Operand : constant Node_Id := Expression (N);
12791 Operand_Type : constant Entity_Id := Etype (Operand);
12794 -- Nothing at all to do if conversion is to the identical type so remove
12795 -- the conversion completely, it is useless, except that it may carry
12796 -- an Assignment_OK indication which must be propagated to the operand.
12798 if Operand_Type = Target_Type then
12800 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
12802 if Assignment_OK (N) then
12803 Set_Assignment_OK (Operand);
12806 Rewrite (N, Relocate_Node (Operand));
12810 -- Generate an extra temporary for cases unsupported by the C backend
12812 if Modify_Tree_For_C then
12814 Source : constant Node_Id := Unqual_Conv (Expression (N));
12815 Source_Typ : Entity_Id := Get_Full_View (Etype (Source));
12818 if Is_Packed_Array (Source_Typ) then
12819 Source_Typ := Packed_Array_Impl_Type (Source_Typ);
12822 if Nkind (Source) = N_Function_Call
12823 and then (Is_Composite_Type (Etype (Source))
12824 or else Is_Composite_Type (Target_Type))
12826 Force_Evaluation (Source);
12831 -- Nothing to do if conversion is safe
12833 if Safe_Unchecked_Type_Conversion (N) then
12837 -- Otherwise force evaluation unless Assignment_OK flag is set (this
12838 -- flag indicates ??? More comments needed here)
12840 if Assignment_OK (N) then
12843 Force_Evaluation (N);
12845 end Expand_N_Unchecked_Type_Conversion;
12847 ----------------------------
12848 -- Expand_Record_Equality --
12849 ----------------------------
12851 -- For non-variant records, Equality is expanded when needed into:
12853 -- and then Lhs.Discr1 = Rhs.Discr1
12855 -- and then Lhs.Discrn = Rhs.Discrn
12856 -- and then Lhs.Cmp1 = Rhs.Cmp1
12858 -- and then Lhs.Cmpn = Rhs.Cmpn
12860 -- The expression is folded by the back end for adjacent fields. This
12861 -- function is called for tagged record in only one occasion: for imple-
12862 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12863 -- otherwise the primitive "=" is used directly.
12865 function Expand_Record_Equality
12870 Bodies : List_Id) return Node_Id
12872 Loc : constant Source_Ptr := Sloc (Nod);
12877 First_Time : Boolean := True;
12879 function Element_To_Compare (C : Entity_Id) return Entity_Id;
12880 -- Return the next discriminant or component to compare, starting with
12881 -- C, skipping inherited components.
12883 ------------------------
12884 -- Element_To_Compare --
12885 ------------------------
12887 function Element_To_Compare (C : Entity_Id) return Entity_Id is
12893 -- Exit loop when the next element to be compared is found, or
12894 -- there is no more such element.
12896 exit when No (Comp);
12898 exit when Ekind (Comp) in E_Discriminant | E_Component
12901 -- Skip inherited components
12903 -- Note: for a tagged type, we always generate the "=" primitive
12904 -- for the base type (not on the first subtype), so the test for
12905 -- Comp /= Original_Record_Component (Comp) is True for
12906 -- inherited components only.
12908 (Is_Tagged_Type (Typ)
12909 and then Comp /= Original_Record_Component (Comp))
12913 or else Chars (Comp) = Name_uTag
12915 -- Skip interface elements (secondary tags???)
12917 or else Is_Interface (Etype (Comp)));
12919 Next_Entity (Comp);
12923 end Element_To_Compare;
12925 -- Start of processing for Expand_Record_Equality
12928 -- Generates the following code: (assuming that Typ has one Discr and
12929 -- component C2 is also a record)
12931 -- Lhs.Discr1 = Rhs.Discr1
12932 -- and then Lhs.C1 = Rhs.C1
12933 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12935 -- and then Lhs.Cmpn = Rhs.Cmpn
12937 Result := New_Occurrence_Of (Standard_True, Loc);
12938 C := Element_To_Compare (First_Entity (Typ));
12939 while Present (C) loop
12950 New_Lhs := New_Copy_Tree (Lhs);
12951 New_Rhs := New_Copy_Tree (Rhs);
12955 Expand_Composite_Equality (Nod, Etype (C),
12957 Make_Selected_Component (Loc,
12959 Selector_Name => New_Occurrence_Of (C, Loc)),
12961 Make_Selected_Component (Loc,
12963 Selector_Name => New_Occurrence_Of (C, Loc)),
12966 -- If some (sub)component is an unchecked_union, the whole
12967 -- operation will raise program error.
12969 if Nkind (Check) = N_Raise_Program_Error then
12971 Set_Etype (Result, Standard_Boolean);
12977 -- Generate logical "and" for CodePeer to simplify the
12978 -- generated code and analysis.
12980 elsif CodePeer_Mode then
12983 Left_Opnd => Result,
12984 Right_Opnd => Check);
12988 Make_And_Then (Loc,
12989 Left_Opnd => Result,
12990 Right_Opnd => Check);
12995 First_Time := False;
12996 C := Element_To_Compare (Next_Entity (C));
13000 end Expand_Record_Equality;
13002 ---------------------------
13003 -- Expand_Set_Membership --
13004 ---------------------------
13006 procedure Expand_Set_Membership (N : Node_Id) is
13007 Lop : constant Node_Id := Left_Opnd (N);
13011 function Make_Cond (Alt : Node_Id) return Node_Id;
13012 -- If the alternative is a subtype mark, create a simple membership
13013 -- test. Otherwise create an equality test for it.
13019 function Make_Cond (Alt : Node_Id) return Node_Id is
13021 L : constant Node_Id := New_Copy_Tree (Lop);
13022 R : constant Node_Id := Relocate_Node (Alt);
13025 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
13026 or else Nkind (Alt) = N_Range
13029 Make_In (Sloc (Alt),
13034 Make_Op_Eq (Sloc (Alt),
13038 if Is_Record_Or_Limited_Type (Etype (Alt)) then
13040 -- We reset the Entity in order to use the primitive equality
13041 -- of the type, as per RM 4.5.2 (28.1/4).
13043 Set_Entity (Cond, Empty);
13050 -- Start of processing for Expand_Set_Membership
13053 Remove_Side_Effects (Lop);
13055 Alt := First (Alternatives (N));
13056 Res := Make_Cond (Alt);
13059 -- We use left associativity as in the equivalent boolean case. This
13060 -- kind of canonicalization helps the optimizer of the code generator.
13062 while Present (Alt) loop
13064 Make_Or_Else (Sloc (Alt),
13066 Right_Opnd => Make_Cond (Alt));
13071 Analyze_And_Resolve (N, Standard_Boolean);
13072 end Expand_Set_Membership;
13074 -----------------------------------
13075 -- Expand_Short_Circuit_Operator --
13076 -----------------------------------
13078 -- Deal with special expansion if actions are present for the right operand
13079 -- and deal with optimizing case of arguments being True or False. We also
13080 -- deal with the special case of non-standard boolean values.
13082 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
13083 Loc : constant Source_Ptr := Sloc (N);
13084 Typ : constant Entity_Id := Etype (N);
13085 Left : constant Node_Id := Left_Opnd (N);
13086 Right : constant Node_Id := Right_Opnd (N);
13087 LocR : constant Source_Ptr := Sloc (Right);
13090 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
13091 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
13092 -- If Left = Shortcut_Value then Right need not be evaluated
13094 function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
13095 -- For Opnd a boolean expression, return a Boolean expression equivalent
13096 -- to Opnd /= Shortcut_Value.
13098 function Useful (Actions : List_Id) return Boolean;
13099 -- Return True if Actions is not empty and contains useful nodes to
13102 --------------------
13103 -- Make_Test_Expr --
13104 --------------------
13106 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
13108 if Shortcut_Value then
13109 return Make_Op_Not (Sloc (Opnd), Opnd);
13113 end Make_Test_Expr;
13119 function Useful (Actions : List_Id) return Boolean is
13122 if Present (Actions) then
13123 L := First (Actions);
13125 -- For now "useful" means not N_Variable_Reference_Marker.
13126 -- Consider stripping other nodes in the future.
13128 while Present (L) loop
13129 if Nkind (L) /= N_Variable_Reference_Marker then
13142 Op_Var : Entity_Id;
13143 -- Entity for a temporary variable holding the value of the operator,
13144 -- used for expansion in the case where actions are present.
13146 -- Start of processing for Expand_Short_Circuit_Operator
13149 -- Deal with non-standard booleans
13151 if Is_Boolean_Type (Typ) then
13152 Adjust_Condition (Left);
13153 Adjust_Condition (Right);
13154 Set_Etype (N, Standard_Boolean);
13157 -- Check for cases where left argument is known to be True or False
13159 if Compile_Time_Known_Value (Left) then
13161 -- Mark SCO for left condition as compile time known
13163 if Generate_SCO and then Comes_From_Source (Left) then
13164 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
13167 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
13168 -- Any actions associated with Right will be executed unconditionally
13169 -- and can thus be inserted into the tree unconditionally.
13171 if Expr_Value_E (Left) /= Shortcut_Ent then
13172 if Present (Actions (N)) then
13173 Insert_Actions (N, Actions (N));
13176 Rewrite (N, Right);
13178 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
13179 -- In this case we can forget the actions associated with Right,
13180 -- since they will never be executed.
13183 Kill_Dead_Code (Right);
13184 Kill_Dead_Code (Actions (N));
13185 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
13188 Adjust_Result_Type (N, Typ);
13192 -- If Actions are present for the right operand, we have to do some
13193 -- special processing. We can't just let these actions filter back into
13194 -- code preceding the short circuit (which is what would have happened
13195 -- if we had not trapped them in the short-circuit form), since they
13196 -- must only be executed if the right operand of the short circuit is
13197 -- executed and not otherwise.
13199 if Useful (Actions (N)) then
13200 Actlist := Actions (N);
13202 -- The old approach is to expand:
13204 -- left AND THEN right
13208 -- C : Boolean := False;
13216 -- and finally rewrite the operator into a reference to C. Similarly
13217 -- for left OR ELSE right, with negated values. Note that this
13218 -- rewrite causes some difficulties for coverage analysis because
13219 -- of the introduction of the new variable C, which obscures the
13220 -- structure of the test.
13222 -- We use this "old approach" if Minimize_Expression_With_Actions
13225 if Minimize_Expression_With_Actions then
13226 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
13229 Make_Object_Declaration (Loc,
13230 Defining_Identifier => Op_Var,
13231 Object_Definition =>
13232 New_Occurrence_Of (Standard_Boolean, Loc),
13234 New_Occurrence_Of (Shortcut_Ent, Loc)));
13236 Append_To (Actlist,
13237 Make_Implicit_If_Statement (Right,
13238 Condition => Make_Test_Expr (Right),
13239 Then_Statements => New_List (
13240 Make_Assignment_Statement (LocR,
13241 Name => New_Occurrence_Of (Op_Var, LocR),
13244 (Boolean_Literals (not Shortcut_Value), LocR)))));
13247 Make_Implicit_If_Statement (Left,
13248 Condition => Make_Test_Expr (Left),
13249 Then_Statements => Actlist));
13251 Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
13252 Analyze_And_Resolve (N, Standard_Boolean);
13254 -- The new approach (the default) is to use an
13255 -- Expression_With_Actions node for the right operand of the
13256 -- short-circuit form. Note that this solves the traceability
13257 -- problems for coverage analysis.
13261 Make_Expression_With_Actions (LocR,
13262 Expression => Relocate_Node (Right),
13263 Actions => Actlist));
13265 Set_Actions (N, No_List);
13266 Analyze_And_Resolve (Right, Standard_Boolean);
13269 Adjust_Result_Type (N, Typ);
13273 -- No actions present, check for cases of right argument True/False
13275 if Compile_Time_Known_Value (Right) then
13277 -- Mark SCO for left condition as compile time known
13279 if Generate_SCO and then Comes_From_Source (Right) then
13280 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
13283 -- Change (Left and then True), (Left or else False) to Left. Note
13284 -- that we know there are no actions associated with the right
13285 -- operand, since we just checked for this case above.
13287 if Expr_Value_E (Right) /= Shortcut_Ent then
13290 -- Change (Left and then False), (Left or else True) to Right,
13291 -- making sure to preserve any side effects associated with the Left
13295 Remove_Side_Effects (Left);
13296 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
13300 Adjust_Result_Type (N, Typ);
13301 end Expand_Short_Circuit_Operator;
13303 ------------------------------------
13304 -- Fixup_Universal_Fixed_Operation --
13305 -------------------------------------
13307 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
13308 Conv : constant Node_Id := Parent (N);
13311 -- We must have a type conversion immediately above us
13313 pragma Assert (Nkind (Conv) = N_Type_Conversion);
13315 -- Normally the type conversion gives our target type. The exception
13316 -- occurs in the case of the Round attribute, where the conversion
13317 -- will be to universal real, and our real type comes from the Round
13318 -- attribute (as well as an indication that we must round the result)
13320 if Etype (Conv) = Universal_Real
13321 and then Nkind (Parent (Conv)) = N_Attribute_Reference
13322 and then Attribute_Name (Parent (Conv)) = Name_Round
13324 Set_Etype (N, Base_Type (Etype (Parent (Conv))));
13325 Set_Rounded_Result (N);
13327 -- Normal case where type comes from conversion above us
13330 Set_Etype (N, Base_Type (Etype (Conv)));
13332 end Fixup_Universal_Fixed_Operation;
13334 ---------------------------------
13335 -- Has_Inferable_Discriminants --
13336 ---------------------------------
13338 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
13340 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
13341 -- Determines whether the left-most prefix of a selected component is a
13342 -- formal parameter in a subprogram. Assumes N is a selected component.
13344 --------------------------------
13345 -- Prefix_Is_Formal_Parameter --
13346 --------------------------------
13348 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
13349 Sel_Comp : Node_Id;
13352 -- Move to the left-most prefix by climbing up the tree
13355 while Present (Parent (Sel_Comp))
13356 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
13358 Sel_Comp := Parent (Sel_Comp);
13361 return Is_Formal (Entity (Prefix (Sel_Comp)));
13362 end Prefix_Is_Formal_Parameter;
13364 -- Start of processing for Has_Inferable_Discriminants
13367 -- For selected components, the subtype of the selector must be a
13368 -- constrained Unchecked_Union. If the component is subject to a
13369 -- per-object constraint, then the enclosing object must have inferable
13372 if Nkind (N) = N_Selected_Component then
13373 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
13375 -- A small hack. If we have a per-object constrained selected
13376 -- component of a formal parameter, return True since we do not
13377 -- know the actual parameter association yet.
13379 if Prefix_Is_Formal_Parameter (N) then
13382 -- Otherwise, check the enclosing object and the selector
13385 return Has_Inferable_Discriminants (Prefix (N))
13386 and then Has_Inferable_Discriminants (Selector_Name (N));
13389 -- The call to Has_Inferable_Discriminants will determine whether
13390 -- the selector has a constrained Unchecked_Union nominal type.
13393 return Has_Inferable_Discriminants (Selector_Name (N));
13396 -- A qualified expression has inferable discriminants if its subtype
13397 -- mark is a constrained Unchecked_Union subtype.
13399 elsif Nkind (N) = N_Qualified_Expression then
13400 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
13401 and then Is_Constrained (Etype (Subtype_Mark (N)));
13403 -- For all other names, it is sufficient to have a constrained
13404 -- Unchecked_Union nominal subtype.
13407 return Is_Unchecked_Union (Base_Type (Etype (N)))
13408 and then Is_Constrained (Etype (N));
13410 end Has_Inferable_Discriminants;
13412 -------------------------------
13413 -- Insert_Dereference_Action --
13414 -------------------------------
13416 procedure Insert_Dereference_Action (N : Node_Id) is
13417 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
13418 -- Return true if type of P is derived from Checked_Pool;
13420 -----------------------------
13421 -- Is_Checked_Storage_Pool --
13422 -----------------------------
13424 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
13433 while T /= Etype (T) loop
13434 if Is_RTE (T, RE_Checked_Pool) then
13442 end Is_Checked_Storage_Pool;
13446 Context : constant Node_Id := Parent (N);
13447 Ptr_Typ : constant Entity_Id := Etype (N);
13448 Desig_Typ : constant Entity_Id :=
13449 Available_View (Designated_Type (Ptr_Typ));
13450 Loc : constant Source_Ptr := Sloc (N);
13451 Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ);
13457 Size_Bits : Node_Id;
13460 -- Start of processing for Insert_Dereference_Action
13463 pragma Assert (Nkind (Context) = N_Explicit_Dereference);
13465 -- Do not re-expand a dereference which has already been processed by
13468 if Has_Dereference_Action (Context) then
13471 -- Do not perform this type of expansion for internally-generated
13474 elsif not Comes_From_Source (Original_Node (Context)) then
13477 -- A dereference action is only applicable to objects which have been
13478 -- allocated on a checked pool.
13480 elsif not Is_Checked_Storage_Pool (Pool) then
13484 -- Extract the address of the dereferenced object. Generate:
13486 -- Addr : System.Address := <N>'Pool_Address;
13488 Addr := Make_Temporary (Loc, 'P');
13491 Make_Object_Declaration (Loc,
13492 Defining_Identifier => Addr,
13493 Object_Definition =>
13494 New_Occurrence_Of (RTE (RE_Address), Loc),
13496 Make_Attribute_Reference (Loc,
13497 Prefix => Duplicate_Subexpr_Move_Checks (N),
13498 Attribute_Name => Name_Pool_Address)));
13500 -- Calculate the size of the dereferenced object. Generate:
13502 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13505 Make_Explicit_Dereference (Loc,
13506 Prefix => Duplicate_Subexpr_Move_Checks (N));
13507 Set_Has_Dereference_Action (Deref);
13510 Make_Attribute_Reference (Loc,
13512 Attribute_Name => Name_Size);
13514 -- Special case of an unconstrained array: need to add descriptor size
13516 if Is_Array_Type (Desig_Typ)
13517 and then not Is_Constrained (First_Subtype (Desig_Typ))
13522 Make_Attribute_Reference (Loc,
13524 New_Occurrence_Of (First_Subtype (Desig_Typ), Loc),
13525 Attribute_Name => Name_Descriptor_Size),
13526 Right_Opnd => Size_Bits);
13529 Size := Make_Temporary (Loc, 'S');
13531 Make_Object_Declaration (Loc,
13532 Defining_Identifier => Size,
13533 Object_Definition =>
13534 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13536 Make_Op_Divide (Loc,
13537 Left_Opnd => Size_Bits,
13538 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
13540 -- Calculate the alignment of the dereferenced object. Generate:
13541 -- Alig : constant Storage_Count := <N>.all'Alignment;
13544 Make_Explicit_Dereference (Loc,
13545 Prefix => Duplicate_Subexpr_Move_Checks (N));
13546 Set_Has_Dereference_Action (Deref);
13548 Alig := Make_Temporary (Loc, 'A');
13550 Make_Object_Declaration (Loc,
13551 Defining_Identifier => Alig,
13552 Object_Definition =>
13553 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13555 Make_Attribute_Reference (Loc,
13557 Attribute_Name => Name_Alignment)));
13559 -- A dereference of a controlled object requires special processing. The
13560 -- finalization machinery requests additional space from the underlying
13561 -- pool to allocate and hide two pointers. As a result, a checked pool
13562 -- may mark the wrong memory as valid. Since checked pools do not have
13563 -- knowledge of hidden pointers, we have to bring the two pointers back
13564 -- in view in order to restore the original state of the object.
13566 -- The address manipulation is not performed for access types that are
13567 -- subject to pragma No_Heap_Finalization because the two pointers do
13568 -- not exist in the first place.
13570 if No_Heap_Finalization (Ptr_Typ) then
13573 elsif Needs_Finalization (Desig_Typ) then
13575 -- Adjust the address and size of the dereferenced object. Generate:
13576 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13579 Make_Procedure_Call_Statement (Loc,
13581 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
13582 Parameter_Associations => New_List (
13583 New_Occurrence_Of (Addr, Loc),
13584 New_Occurrence_Of (Size, Loc),
13585 New_Occurrence_Of (Alig, Loc)));
13587 -- Class-wide types complicate things because we cannot determine
13588 -- statically whether the actual object is truly controlled. We must
13589 -- generate a runtime check to detect this property. Generate:
13591 -- if Needs_Finalization (<N>.all'Tag) then
13595 if Is_Class_Wide_Type (Desig_Typ) then
13597 Make_Explicit_Dereference (Loc,
13598 Prefix => Duplicate_Subexpr_Move_Checks (N));
13599 Set_Has_Dereference_Action (Deref);
13602 Make_Implicit_If_Statement (N,
13604 Make_Function_Call (Loc,
13606 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
13607 Parameter_Associations => New_List (
13608 Make_Attribute_Reference (Loc,
13610 Attribute_Name => Name_Tag))),
13611 Then_Statements => New_List (Stmt));
13614 Insert_Action (N, Stmt);
13618 -- Dereference (Pool, Addr, Size, Alig);
13621 Make_Procedure_Call_Statement (Loc,
13624 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
13625 Parameter_Associations => New_List (
13626 New_Occurrence_Of (Pool, Loc),
13627 New_Occurrence_Of (Addr, Loc),
13628 New_Occurrence_Of (Size, Loc),
13629 New_Occurrence_Of (Alig, Loc))));
13631 -- Mark the explicit dereference as processed to avoid potential
13632 -- infinite expansion.
13634 Set_Has_Dereference_Action (Context);
13637 when RE_Not_Available =>
13639 end Insert_Dereference_Action;
13641 --------------------------------
13642 -- Integer_Promotion_Possible --
13643 --------------------------------
13645 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
13646 Operand : constant Node_Id := Expression (N);
13647 Operand_Type : constant Entity_Id := Etype (Operand);
13648 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
13651 pragma Assert (Nkind (N) = N_Type_Conversion);
13655 -- We only do the transformation for source constructs. We assume
13656 -- that the expander knows what it is doing when it generates code.
13658 Comes_From_Source (N)
13660 -- If the operand type is Short_Integer or Short_Short_Integer,
13661 -- then we will promote to Integer, which is available on all
13662 -- targets, and is sufficient to ensure no intermediate overflow.
13663 -- Furthermore it is likely to be as efficient or more efficient
13664 -- than using the smaller type for the computation so we do this
13665 -- unconditionally.
13668 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
13670 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
13672 -- Test for interesting operation, which includes addition,
13673 -- division, exponentiation, multiplication, subtraction, absolute
13674 -- value and unary negation. Unary "+" is omitted since it is a
13675 -- no-op and thus can't overflow.
13677 and then Nkind (Operand) in
13678 N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
13679 N_Op_Minus | N_Op_Multiply | N_Op_Subtract;
13680 end Integer_Promotion_Possible;
13682 ------------------------------
13683 -- Make_Array_Comparison_Op --
13684 ------------------------------
13686 -- This is a hand-coded expansion of the following generic function:
13689 -- type elem is (<>);
13690 -- type index is (<>);
13691 -- type a is array (index range <>) of elem;
13693 -- function Gnnn (X : a; Y: a) return boolean is
13694 -- J : index := Y'first;
13697 -- if X'length = 0 then
13700 -- elsif Y'length = 0 then
13704 -- for I in X'range loop
13705 -- if X (I) = Y (J) then
13706 -- if J = Y'last then
13709 -- J := index'succ (J);
13713 -- return X (I) > Y (J);
13717 -- return X'length > Y'length;
13721 -- Note that since we are essentially doing this expansion by hand, we
13722 -- do not need to generate an actual or formal generic part, just the
13723 -- instantiated function itself.
13725 -- Perhaps we could have the actual generic available in the run-time,
13726 -- obtained by rtsfind, and actually expand a real instantiation ???
13728 function Make_Array_Comparison_Op
13730 Nod : Node_Id) return Node_Id
13732 Loc : constant Source_Ptr := Sloc (Nod);
13734 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
13735 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
13736 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
13737 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
13739 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
13741 Loop_Statement : Node_Id;
13742 Loop_Body : Node_Id;
13744 Inner_If : Node_Id;
13745 Final_Expr : Node_Id;
13746 Func_Body : Node_Id;
13747 Func_Name : Entity_Id;
13753 -- if J = Y'last then
13756 -- J := index'succ (J);
13760 Make_Implicit_If_Statement (Nod,
13763 Left_Opnd => New_Occurrence_Of (J, Loc),
13765 Make_Attribute_Reference (Loc,
13766 Prefix => New_Occurrence_Of (Y, Loc),
13767 Attribute_Name => Name_Last)),
13769 Then_Statements => New_List (
13770 Make_Exit_Statement (Loc)),
13774 Make_Assignment_Statement (Loc,
13775 Name => New_Occurrence_Of (J, Loc),
13777 Make_Attribute_Reference (Loc,
13778 Prefix => New_Occurrence_Of (Index, Loc),
13779 Attribute_Name => Name_Succ,
13780 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
13782 -- if X (I) = Y (J) then
13785 -- return X (I) > Y (J);
13789 Make_Implicit_If_Statement (Nod,
13793 Make_Indexed_Component (Loc,
13794 Prefix => New_Occurrence_Of (X, Loc),
13795 Expressions => New_List (New_Occurrence_Of (I, Loc))),
13798 Make_Indexed_Component (Loc,
13799 Prefix => New_Occurrence_Of (Y, Loc),
13800 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
13802 Then_Statements => New_List (Inner_If),
13804 Else_Statements => New_List (
13805 Make_Simple_Return_Statement (Loc,
13809 Make_Indexed_Component (Loc,
13810 Prefix => New_Occurrence_Of (X, Loc),
13811 Expressions => New_List (New_Occurrence_Of (I, Loc))),
13814 Make_Indexed_Component (Loc,
13815 Prefix => New_Occurrence_Of (Y, Loc),
13816 Expressions => New_List (
13817 New_Occurrence_Of (J, Loc)))))));
13819 -- for I in X'range loop
13824 Make_Implicit_Loop_Statement (Nod,
13825 Identifier => Empty,
13827 Iteration_Scheme =>
13828 Make_Iteration_Scheme (Loc,
13829 Loop_Parameter_Specification =>
13830 Make_Loop_Parameter_Specification (Loc,
13831 Defining_Identifier => I,
13832 Discrete_Subtype_Definition =>
13833 Make_Attribute_Reference (Loc,
13834 Prefix => New_Occurrence_Of (X, Loc),
13835 Attribute_Name => Name_Range))),
13837 Statements => New_List (Loop_Body));
13839 -- if X'length = 0 then
13841 -- elsif Y'length = 0 then
13844 -- for ... loop ... end loop;
13845 -- return X'length > Y'length;
13849 Make_Attribute_Reference (Loc,
13850 Prefix => New_Occurrence_Of (X, Loc),
13851 Attribute_Name => Name_Length);
13854 Make_Attribute_Reference (Loc,
13855 Prefix => New_Occurrence_Of (Y, Loc),
13856 Attribute_Name => Name_Length);
13860 Left_Opnd => Length1,
13861 Right_Opnd => Length2);
13864 Make_Implicit_If_Statement (Nod,
13868 Make_Attribute_Reference (Loc,
13869 Prefix => New_Occurrence_Of (X, Loc),
13870 Attribute_Name => Name_Length),
13872 Make_Integer_Literal (Loc, 0)),
13876 Make_Simple_Return_Statement (Loc,
13877 Expression => New_Occurrence_Of (Standard_False, Loc))),
13879 Elsif_Parts => New_List (
13880 Make_Elsif_Part (Loc,
13884 Make_Attribute_Reference (Loc,
13885 Prefix => New_Occurrence_Of (Y, Loc),
13886 Attribute_Name => Name_Length),
13888 Make_Integer_Literal (Loc, 0)),
13892 Make_Simple_Return_Statement (Loc,
13893 Expression => New_Occurrence_Of (Standard_True, Loc))))),
13895 Else_Statements => New_List (
13897 Make_Simple_Return_Statement (Loc,
13898 Expression => Final_Expr)));
13902 Formals := New_List (
13903 Make_Parameter_Specification (Loc,
13904 Defining_Identifier => X,
13905 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
13907 Make_Parameter_Specification (Loc,
13908 Defining_Identifier => Y,
13909 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
13911 -- function Gnnn (...) return boolean is
13912 -- J : index := Y'first;
13917 Func_Name := Make_Temporary (Loc, 'G');
13920 Make_Subprogram_Body (Loc,
13922 Make_Function_Specification (Loc,
13923 Defining_Unit_Name => Func_Name,
13924 Parameter_Specifications => Formals,
13925 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
13927 Declarations => New_List (
13928 Make_Object_Declaration (Loc,
13929 Defining_Identifier => J,
13930 Object_Definition => New_Occurrence_Of (Index, Loc),
13932 Make_Attribute_Reference (Loc,
13933 Prefix => New_Occurrence_Of (Y, Loc),
13934 Attribute_Name => Name_First))),
13936 Handled_Statement_Sequence =>
13937 Make_Handled_Sequence_Of_Statements (Loc,
13938 Statements => New_List (If_Stat)));
13941 end Make_Array_Comparison_Op;
13943 ---------------------------
13944 -- Make_Boolean_Array_Op --
13945 ---------------------------
13947 -- For logical operations on boolean arrays, expand in line the following,
13948 -- replacing 'and' with 'or' or 'xor' where needed:
13950 -- function Annn (A : typ; B: typ) return typ is
13953 -- for J in A'range loop
13954 -- C (J) := A (J) op B (J);
13959 -- or in the case of Transform_Function_Array:
13961 -- procedure Annn (A : typ; B: typ; RESULT: out typ) is
13963 -- for J in A'range loop
13964 -- RESULT (J) := A (J) op B (J);
13968 -- Here typ is the boolean array type
13970 function Make_Boolean_Array_Op
13972 N : Node_Id) return Node_Id
13974 Loc : constant Source_Ptr := Sloc (N);
13976 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
13977 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
13978 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
13988 Func_Name : Entity_Id;
13989 Func_Body : Node_Id;
13990 Loop_Statement : Node_Id;
13993 if Transform_Function_Array then
13994 C := Make_Defining_Identifier (Loc, Name_UP_RESULT);
13996 C := Make_Defining_Identifier (Loc, Name_uC);
14000 Make_Indexed_Component (Loc,
14001 Prefix => New_Occurrence_Of (A, Loc),
14002 Expressions => New_List (New_Occurrence_Of (J, Loc)));
14005 Make_Indexed_Component (Loc,
14006 Prefix => New_Occurrence_Of (B, Loc),
14007 Expressions => New_List (New_Occurrence_Of (J, Loc)));
14010 Make_Indexed_Component (Loc,
14011 Prefix => New_Occurrence_Of (C, Loc),
14012 Expressions => New_List (New_Occurrence_Of (J, Loc)));
14014 if Nkind (N) = N_Op_And then
14018 Right_Opnd => B_J);
14020 elsif Nkind (N) = N_Op_Or then
14024 Right_Opnd => B_J);
14030 Right_Opnd => B_J);
14034 Make_Implicit_Loop_Statement (N,
14035 Identifier => Empty,
14037 Iteration_Scheme =>
14038 Make_Iteration_Scheme (Loc,
14039 Loop_Parameter_Specification =>
14040 Make_Loop_Parameter_Specification (Loc,
14041 Defining_Identifier => J,
14042 Discrete_Subtype_Definition =>
14043 Make_Attribute_Reference (Loc,
14044 Prefix => New_Occurrence_Of (A, Loc),
14045 Attribute_Name => Name_Range))),
14047 Statements => New_List (
14048 Make_Assignment_Statement (Loc,
14050 Expression => Op)));
14052 Formals := New_List (
14053 Make_Parameter_Specification (Loc,
14054 Defining_Identifier => A,
14055 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
14057 Make_Parameter_Specification (Loc,
14058 Defining_Identifier => B,
14059 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
14061 if Transform_Function_Array then
14062 Append_To (Formals,
14063 Make_Parameter_Specification (Loc,
14064 Defining_Identifier => C,
14065 Out_Present => True,
14066 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
14069 Func_Name := Make_Temporary (Loc, 'A');
14070 Set_Is_Inlined (Func_Name);
14072 if Transform_Function_Array then
14074 Make_Subprogram_Body (Loc,
14076 Make_Procedure_Specification (Loc,
14077 Defining_Unit_Name => Func_Name,
14078 Parameter_Specifications => Formals),
14080 Declarations => New_List,
14082 Handled_Statement_Sequence =>
14083 Make_Handled_Sequence_Of_Statements (Loc,
14084 Statements => New_List (Loop_Statement)));
14088 Make_Subprogram_Body (Loc,
14090 Make_Function_Specification (Loc,
14091 Defining_Unit_Name => Func_Name,
14092 Parameter_Specifications => Formals,
14093 Result_Definition => New_Occurrence_Of (Typ, Loc)),
14095 Declarations => New_List (
14096 Make_Object_Declaration (Loc,
14097 Defining_Identifier => C,
14098 Object_Definition => New_Occurrence_Of (Typ, Loc))),
14100 Handled_Statement_Sequence =>
14101 Make_Handled_Sequence_Of_Statements (Loc,
14102 Statements => New_List (
14104 Make_Simple_Return_Statement (Loc,
14105 Expression => New_Occurrence_Of (C, Loc)))));
14109 end Make_Boolean_Array_Op;
14111 -----------------------------------------
14112 -- Minimized_Eliminated_Overflow_Check --
14113 -----------------------------------------
14115 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
14118 Is_Signed_Integer_Type (Etype (N))
14119 and then Overflow_Check_Mode in Minimized_Or_Eliminated;
14120 end Minimized_Eliminated_Overflow_Check;
14122 ----------------------------
14123 -- Narrow_Large_Operation --
14124 ----------------------------
14126 procedure Narrow_Large_Operation (N : Node_Id) is
14127 Kind : constant Node_Kind := Nkind (N);
14128 In_Rng : constant Boolean := Kind = N_In;
14129 Binary : constant Boolean := Kind in N_Binary_Op or else In_Rng;
14130 Compar : constant Boolean := Kind in N_Op_Compare or else In_Rng;
14131 R : constant Node_Id := Right_Opnd (N);
14132 Typ : constant Entity_Id := Etype (R);
14133 Tsiz : constant Uint := RM_Size (Typ);
14135 function Get_Size_For_Range (Lo, Hi : Uint) return Uint;
14136 -- Return the size of a small signed integer type covering Lo .. Hi.
14137 -- The important thing is to return a size lower than that of Typ.
14139 ------------------------
14140 -- Get_Size_For_Range --
14141 ------------------------
14143 function Get_Size_For_Range (Lo, Hi : Uint) return Uint is
14145 function Is_OK_For_Range (Siz : Uint) return Boolean;
14146 -- Return True if a signed integer with given size can cover Lo .. Hi
14148 --------------------------
14149 -- Is_OK_For_Range --
14150 --------------------------
14152 function Is_OK_For_Range (Siz : Uint) return Boolean is
14153 B : constant Uint := Uint_2 ** (Siz - 1);
14156 -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
14158 return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B;
14159 end Is_OK_For_Range;
14162 -- This is (almost always) the size of Integer
14164 if Is_OK_For_Range (Uint_32) then
14167 -- If the size of Typ is 64 then check 63
14169 elsif Tsiz = Uint_64 and then Is_OK_For_Range (Uint_63) then
14172 -- This is (almost always) the size of Long_Long_Integer
14174 elsif Is_OK_For_Range (Uint_64) then
14177 -- If the size of Typ is 128 then check 127
14179 elsif Tsiz = Uint_128 and then Is_OK_For_Range (Uint_127) then
14185 end Get_Size_For_Range;
14199 -- Start of processing for Narrow_Large_Operation
14202 -- First, determine the range of the left operand, if any
14205 L := Left_Opnd (N);
14206 Determine_Range (L, OK, Llo, Lhi, Assume_Valid => True);
14217 -- Second, determine the range of the right operand, which can itself
14218 -- be a range, in which case we take the lower bound of the low bound
14219 -- and the upper bound of the high bound.
14227 (Low_Bound (R), OK, Rlo, Zhi, Assume_Valid => True);
14233 (High_Bound (R), OK, Zlo, Rhi, Assume_Valid => True);
14240 Determine_Range (R, OK, Rlo, Rhi, Assume_Valid => True);
14246 -- Then compute a size suitable for each range
14249 Lsiz := Get_Size_For_Range (Llo, Lhi);
14254 Rsiz := Get_Size_For_Range (Rlo, Rhi);
14256 -- Now compute the size of the narrower type
14259 -- The type must be able to accommodate the operands
14261 Nsiz := UI_Max (Lsiz, Rsiz);
14264 -- The type must be able to accommodate the operand(s) and result.
14266 -- Note that Determine_Range typically does not report the bounds of
14267 -- the value as being larger than those of the base type, which means
14268 -- that it does not report overflow (see also Enable_Overflow_Check).
14270 Determine_Range (N, OK, Nlo, Nhi, Assume_Valid => True);
14275 -- Therefore, if Nsiz is not lower than the size of the original type
14276 -- here, we cannot be sure that the operation does not overflow.
14278 Nsiz := Get_Size_For_Range (Nlo, Nhi);
14279 Nsiz := UI_Max (Nsiz, Lsiz);
14280 Nsiz := UI_Max (Nsiz, Rsiz);
14283 -- If the size is not lower than the size of the original type, then
14284 -- there is no point in changing the type, except in the case where
14285 -- we can remove a conversion to the original type from an operand.
14288 and then not (Binary
14289 and then Nkind (L) = N_Type_Conversion
14290 and then Entity (Subtype_Mark (L)) = Typ)
14291 and then not (Nkind (R) = N_Type_Conversion
14292 and then Entity (Subtype_Mark (R)) = Typ)
14297 -- Now pick the narrower type according to the size. We use the base
14298 -- type instead of the first subtype because operations are done in
14299 -- the base type, so this avoids the need for useless conversions.
14301 if Nsiz <= System_Max_Integer_Size then
14302 Ntyp := Etype (Integer_Type_For (Nsiz, Uns => False));
14307 -- Finally, rewrite the operation in the narrower type
14309 Nop := New_Op_Node (Kind, Sloc (N));
14312 Set_Left_Opnd (Nop, Convert_To (Ntyp, L));
14316 Set_Right_Opnd (Nop,
14317 Make_Range (Sloc (N),
14318 Convert_To (Ntyp, Low_Bound (R)),
14319 Convert_To (Ntyp, High_Bound (R))));
14321 Set_Right_Opnd (Nop, Convert_To (Ntyp, R));
14327 -- Analyze it with the comparison type and checks suppressed since
14328 -- the conversions of the operands cannot overflow.
14330 Analyze_And_Resolve
14331 (N, Etype (Original_Node (N)), Suppress => Overflow_Check);
14334 -- Analyze it with the narrower type and checks suppressed, but only
14335 -- when we are sure that the operation does not overflow, see above.
14337 if Nsiz < Tsiz then
14338 Analyze_And_Resolve (N, Ntyp, Suppress => Overflow_Check);
14340 Analyze_And_Resolve (N, Ntyp);
14343 -- Put back a conversion to the original type
14345 Convert_To_And_Rewrite (Typ, N);
14347 end Narrow_Large_Operation;
14349 --------------------------------
14350 -- Optimize_Length_Comparison --
14351 --------------------------------
14353 procedure Optimize_Length_Comparison (N : Node_Id) is
14354 Loc : constant Source_Ptr := Sloc (N);
14355 Typ : constant Entity_Id := Etype (N);
14360 -- First and Last attribute reference nodes, which end up as left and
14361 -- right operands of the optimized result.
14364 -- True for comparison operand of zero
14366 Maybe_Superflat : Boolean;
14367 -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set
14368 -- to false but the comparison operand can be zero at run time. In this
14369 -- case, we normally cannot do anything because the canonical formula of
14370 -- the length is not valid, but there is one exception: when the operand
14371 -- is itself the length of an array with the same bounds as the array on
14372 -- the LHS, we can entirely optimize away the comparison.
14375 -- Comparison operand, set only if Is_Zero is false
14377 Ent : array (Pos range 1 .. 2) of Entity_Id := (Empty, Empty);
14378 -- Entities whose length is being compared
14380 Index : array (Pos range 1 .. 2) of Node_Id := (Empty, Empty);
14381 -- Integer_Literal nodes for length attribute expressions, or Empty
14382 -- if there is no such expression present.
14384 Op : Node_Kind := Nkind (N);
14385 -- Kind of comparison operator, gets flipped if operands backwards
14387 function Convert_To_Long_Long_Integer (N : Node_Id) return Node_Id;
14388 -- Given a discrete expression, returns a Long_Long_Integer typed
14389 -- expression representing the underlying value of the expression.
14390 -- This is done with an unchecked conversion to Long_Long_Integer.
14391 -- We use unchecked conversion to handle the enumeration type case.
14393 function Is_Entity_Length (N : Node_Id; Num : Pos) return Boolean;
14394 -- Tests if N is a length attribute applied to a simple entity. If so,
14395 -- returns True, and sets Ent to the entity, and Index to the integer
14396 -- literal provided as an attribute expression, or to Empty if none.
14397 -- Num is the index designating the relevant slot in Ent and Index.
14398 -- Also returns True if the expression is a generated type conversion
14399 -- whose expression is of the desired form. This latter case arises
14400 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
14401 -- to check for being in range, which is not needed in this context.
14402 -- Returns False if neither condition holds.
14404 function Is_Optimizable (N : Node_Id) return Boolean;
14405 -- Tests N to see if it is an optimizable comparison value (defined as
14406 -- constant zero or one, or something else where the value is known to
14407 -- be nonnegative and in the 32-bit range and where the corresponding
14408 -- Length value is also known to be 32 bits). If result is true, sets
14409 -- Is_Zero, Maybe_Superflat and Comp accordingly.
14411 procedure Rewrite_For_Equal_Lengths;
14412 -- Rewrite the comparison of two equal lengths into either True or False
14414 ----------------------------------
14415 -- Convert_To_Long_Long_Integer --
14416 ----------------------------------
14418 function Convert_To_Long_Long_Integer (N : Node_Id) return Node_Id is
14420 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
14421 end Convert_To_Long_Long_Integer;
14423 ----------------------
14424 -- Is_Entity_Length --
14425 ----------------------
14427 function Is_Entity_Length (N : Node_Id; Num : Pos) return Boolean is
14429 if Nkind (N) = N_Attribute_Reference
14430 and then Attribute_Name (N) = Name_Length
14431 and then Is_Entity_Name (Prefix (N))
14433 Ent (Num) := Entity (Prefix (N));
14435 if Present (Expressions (N)) then
14436 Index (Num) := First (Expressions (N));
14438 Index (Num) := Empty;
14443 elsif Nkind (N) = N_Type_Conversion
14444 and then not Comes_From_Source (N)
14446 return Is_Entity_Length (Expression (N), Num);
14451 end Is_Entity_Length;
14453 --------------------
14454 -- Is_Optimizable --
14455 --------------------
14457 function Is_Optimizable (N : Node_Id) return Boolean is
14467 if Compile_Time_Known_Value (N) then
14468 Val := Expr_Value (N);
14470 if Val = Uint_0 then
14472 Maybe_Superflat := False;
14476 elsif Val = Uint_1 then
14478 Maybe_Superflat := False;
14484 -- Here we have to make sure of being within a 32-bit range (take the
14485 -- full unsigned range so the length of 32-bit arrays is accepted).
14487 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
14490 or else Lo < Uint_0
14491 or else Hi > Uint_2 ** 32
14496 Maybe_Superflat := (Lo = Uint_0);
14498 -- Tests if N is also a length attribute applied to a simple entity
14500 Dbl := Is_Entity_Length (N, 2);
14502 -- We can deal with the superflat case only if N is also a length
14504 if Maybe_Superflat and then not Dbl then
14508 -- Comparison value was within range, so now we must check the index
14509 -- value to make sure it is also within 32 bits.
14511 for K in Pos range 1 .. 2 loop
14512 Indx := First_Index (Etype (Ent (K)));
14514 if Present (Index (K)) then
14515 for J in 2 .. UI_To_Int (Intval (Index (K))) loop
14520 Ityp := Etype (Indx);
14522 if Esize (Ityp) > 32 then
14532 end Is_Optimizable;
14534 -------------------------------
14535 -- Rewrite_For_Equal_Lengths --
14536 -------------------------------
14538 procedure Rewrite_For_Equal_Lengths is
14547 New_Occurrence_Of (Standard_True, Sloc (N))));
14555 New_Occurrence_Of (Standard_False, Sloc (N))));
14558 raise Program_Error;
14561 Analyze_And_Resolve (N, Typ);
14562 end Rewrite_For_Equal_Lengths;
14564 -- Start of processing for Optimize_Length_Comparison
14567 -- Nothing to do if not a comparison
14569 if Op not in N_Op_Compare then
14573 -- Nothing to do if special -gnatd.P debug flag set.
14575 if Debug_Flag_Dot_PP then
14579 -- Ent'Length op 0/1
14581 if Is_Entity_Length (Left_Opnd (N), 1)
14582 and then Is_Optimizable (Right_Opnd (N))
14586 -- 0/1 op Ent'Length
14588 elsif Is_Entity_Length (Right_Opnd (N), 1)
14589 and then Is_Optimizable (Left_Opnd (N))
14591 -- Flip comparison to opposite sense
14594 when N_Op_Lt => Op := N_Op_Gt;
14595 when N_Op_Le => Op := N_Op_Ge;
14596 when N_Op_Gt => Op := N_Op_Lt;
14597 when N_Op_Ge => Op := N_Op_Le;
14598 when others => null;
14601 -- Else optimization not possible
14607 -- Fall through if we will do the optimization
14609 -- Cases to handle:
14611 -- X'Length = 0 => X'First > X'Last
14612 -- X'Length = 1 => X'First = X'Last
14613 -- X'Length = n => X'First + (n - 1) = X'Last
14615 -- X'Length /= 0 => X'First <= X'Last
14616 -- X'Length /= 1 => X'First /= X'Last
14617 -- X'Length /= n => X'First + (n - 1) /= X'Last
14619 -- X'Length >= 0 => always true, warn
14620 -- X'Length >= 1 => X'First <= X'Last
14621 -- X'Length >= n => X'First + (n - 1) <= X'Last
14623 -- X'Length > 0 => X'First <= X'Last
14624 -- X'Length > 1 => X'First < X'Last
14625 -- X'Length > n => X'First + (n - 1) < X'Last
14627 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
14628 -- X'Length <= 1 => X'First >= X'Last
14629 -- X'Length <= n => X'First + (n - 1) >= X'Last
14631 -- X'Length < 0 => always false (warn)
14632 -- X'Length < 1 => X'First > X'Last
14633 -- X'Length < n => X'First + (n - 1) > X'Last
14635 -- Note: for the cases of n (not constant 0,1), we require that the
14636 -- corresponding index type be integer or shorter (i.e. not 64-bit),
14637 -- and the same for the comparison value. Then we do the comparison
14638 -- using 64-bit arithmetic (actually long long integer), so that we
14639 -- cannot have overflow intefering with the result.
14641 -- First deal with warning cases
14650 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
14651 Analyze_And_Resolve (N, Typ);
14652 Warn_On_Known_Condition (N);
14659 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
14660 Analyze_And_Resolve (N, Typ);
14661 Warn_On_Known_Condition (N);
14665 if Constant_Condition_Warnings
14666 and then Comes_From_Source (Original_Node (N))
14668 Error_Msg_N ("could replace by ""'=""?c?", N);
14678 -- Build the First reference we will use
14681 Make_Attribute_Reference (Loc,
14682 Prefix => New_Occurrence_Of (Ent (1), Loc),
14683 Attribute_Name => Name_First);
14685 if Present (Index (1)) then
14686 Set_Expressions (Left, New_List (New_Copy (Index (1))));
14689 -- Build the Last reference we will use
14692 Make_Attribute_Reference (Loc,
14693 Prefix => New_Occurrence_Of (Ent (1), Loc),
14694 Attribute_Name => Name_Last);
14696 if Present (Index (1)) then
14697 Set_Expressions (Right, New_List (New_Copy (Index (1))));
14700 -- If general value case, then do the addition of (n - 1), and
14701 -- also add the needed conversions to type Long_Long_Integer.
14703 -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into:
14705 -- Y'Last + (X'First - Y'First) op X'Last
14707 -- in the hope that X'First - Y'First can be computed statically.
14709 if Present (Comp) then
14710 if Present (Ent (2)) then
14712 Y_First : constant Node_Id :=
14713 Make_Attribute_Reference (Loc,
14714 Prefix => New_Occurrence_Of (Ent (2), Loc),
14715 Attribute_Name => Name_First);
14716 Y_Last : constant Node_Id :=
14717 Make_Attribute_Reference (Loc,
14718 Prefix => New_Occurrence_Of (Ent (2), Loc),
14719 Attribute_Name => Name_Last);
14720 R : Compare_Result;
14723 if Present (Index (2)) then
14724 Set_Expressions (Y_First, New_List (New_Copy (Index (2))));
14725 Set_Expressions (Y_Last, New_List (New_Copy (Index (2))));
14731 -- If X'First = Y'First, simplify the above formula into a
14732 -- direct comparison of Y'Last and X'Last.
14734 R := Compile_Time_Compare (Left, Y_First, Assume_Valid => True);
14740 R := Compile_Time_Compare
14741 (Right, Y_Last, Assume_Valid => True);
14743 -- If the pairs of attributes are equal, we are done
14746 Rewrite_For_Equal_Lengths;
14750 -- If the base types are different, convert both operands to
14751 -- Long_Long_Integer, else compare them directly.
14753 if Base_Type (Etype (Right)) /= Base_Type (Etype (Y_Last))
14755 Left := Convert_To_Long_Long_Integer (Y_Last);
14761 -- Otherwise, use the above formula as-is
14767 Convert_To_Long_Long_Integer (Y_Last),
14769 Make_Op_Subtract (Loc,
14771 Convert_To_Long_Long_Integer (Left),
14773 Convert_To_Long_Long_Integer (Y_First)));
14777 -- General value case
14782 Left_Opnd => Convert_To_Long_Long_Integer (Left),
14784 Make_Op_Subtract (Loc,
14785 Left_Opnd => Convert_To_Long_Long_Integer (Comp),
14786 Right_Opnd => Make_Integer_Literal (Loc, 1)));
14790 -- We cannot do anything in the superflat case past this point
14792 if Maybe_Superflat then
14796 -- If general operand, convert Last reference to Long_Long_Integer
14798 if Present (Comp) then
14799 Right := Convert_To_Long_Long_Integer (Right);
14802 -- Check for cases to optimize
14804 -- X'Length = 0 => X'First > X'Last
14805 -- X'Length < 1 => X'First > X'Last
14806 -- X'Length < n => X'First + (n - 1) > X'Last
14808 if (Is_Zero and then Op = N_Op_Eq)
14809 or else (not Is_Zero and then Op = N_Op_Lt)
14814 Right_Opnd => Right);
14816 -- X'Length = 1 => X'First = X'Last
14817 -- X'Length = n => X'First + (n - 1) = X'Last
14819 elsif not Is_Zero and then Op = N_Op_Eq then
14823 Right_Opnd => Right);
14825 -- X'Length /= 0 => X'First <= X'Last
14826 -- X'Length > 0 => X'First <= X'Last
14828 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
14832 Right_Opnd => Right);
14834 -- X'Length /= 1 => X'First /= X'Last
14835 -- X'Length /= n => X'First + (n - 1) /= X'Last
14837 elsif not Is_Zero and then Op = N_Op_Ne then
14841 Right_Opnd => Right);
14843 -- X'Length >= 1 => X'First <= X'Last
14844 -- X'Length >= n => X'First + (n - 1) <= X'Last
14846 elsif not Is_Zero and then Op = N_Op_Ge then
14850 Right_Opnd => Right);
14852 -- X'Length > 1 => X'First < X'Last
14853 -- X'Length > n => X'First + (n = 1) < X'Last
14855 elsif not Is_Zero and then Op = N_Op_Gt then
14859 Right_Opnd => Right);
14861 -- X'Length <= 1 => X'First >= X'Last
14862 -- X'Length <= n => X'First + (n - 1) >= X'Last
14864 elsif not Is_Zero and then Op = N_Op_Le then
14868 Right_Opnd => Right);
14870 -- Should not happen at this stage
14873 raise Program_Error;
14876 -- Rewrite and finish up (we can suppress overflow checks, see above)
14878 Rewrite (N, Result);
14879 Analyze_And_Resolve (N, Typ, Suppress => Overflow_Check);
14880 end Optimize_Length_Comparison;
14882 --------------------------------
14883 -- Process_If_Case_Statements --
14884 --------------------------------
14886 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is
14890 Decl := First (Stmts);
14891 while Present (Decl) loop
14892 if Nkind (Decl) = N_Object_Declaration
14893 and then Is_Finalizable_Transient (Decl, N)
14895 Process_Transient_In_Expression (Decl, N, Stmts);
14900 end Process_If_Case_Statements;
14902 -------------------------------------
14903 -- Process_Transient_In_Expression --
14904 -------------------------------------
14906 procedure Process_Transient_In_Expression
14907 (Obj_Decl : Node_Id;
14911 Loc : constant Source_Ptr := Sloc (Obj_Decl);
14912 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
14914 Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
14915 -- The node on which to insert the hook as an action. This is usually
14916 -- the innermost enclosing non-transient construct.
14918 Fin_Call : Node_Id;
14919 Hook_Assign : Node_Id;
14920 Hook_Clear : Node_Id;
14921 Hook_Decl : Node_Id;
14922 Hook_Insert : Node_Id;
14923 Ptr_Decl : Node_Id;
14925 Fin_Context : Node_Id;
14926 -- The node after which to insert the finalization actions of the
14927 -- transient object.
14930 pragma Assert (Nkind (Expr) in N_Case_Expression
14931 | N_Expression_With_Actions
14932 | N_If_Expression);
14934 -- When the context is a Boolean evaluation, all three nodes capture the
14935 -- result of their computation in a local temporary:
14938 -- Trans_Id : Ctrl_Typ := ...;
14939 -- Result : constant Boolean := ... Trans_Id ...;
14940 -- <finalize Trans_Id>
14943 -- As a result, the finalization of any transient objects can safely
14944 -- take place after the result capture.
14946 -- ??? could this be extended to elementary types?
14948 if Is_Boolean_Type (Etype (Expr)) then
14949 Fin_Context := Last (Stmts);
14951 -- Otherwise the immediate context may not be safe enough to carry
14952 -- out transient object finalization due to aliasing and nesting of
14953 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14954 -- enclosing non-transient construct.
14957 Fin_Context := Hook_Context;
14960 -- Mark the transient object as successfully processed to avoid double
14963 Set_Is_Finalized_Transient (Obj_Id);
14965 -- Construct all the pieces necessary to hook and finalize a transient
14968 Build_Transient_Object_Statements
14969 (Obj_Decl => Obj_Decl,
14970 Fin_Call => Fin_Call,
14971 Hook_Assign => Hook_Assign,
14972 Hook_Clear => Hook_Clear,
14973 Hook_Decl => Hook_Decl,
14974 Ptr_Decl => Ptr_Decl,
14975 Finalize_Obj => False);
14977 -- Add the access type which provides a reference to the transient
14978 -- object. Generate:
14980 -- type Ptr_Typ is access all Desig_Typ;
14982 Insert_Action (Hook_Context, Ptr_Decl);
14984 -- Add the temporary which acts as a hook to the transient object.
14987 -- Hook : Ptr_Id := null;
14989 Insert_Action (Hook_Context, Hook_Decl);
14991 -- When the transient object is initialized by an aggregate, the hook
14992 -- must capture the object after the last aggregate assignment takes
14993 -- place. Only then is the object considered initialized. Generate:
14995 -- Hook := Ptr_Typ (Obj_Id);
14997 -- Hook := Obj_Id'Unrestricted_Access;
14999 if Ekind (Obj_Id) in E_Constant | E_Variable
15000 and then Present (Last_Aggregate_Assignment (Obj_Id))
15002 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
15004 -- Otherwise the hook seizes the related object immediately
15007 Hook_Insert := Obj_Decl;
15010 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
15012 -- When the node is part of a return statement, there is no need to
15013 -- insert a finalization call, as the general finalization mechanism
15014 -- (see Build_Finalizer) would take care of the transient object on
15015 -- subprogram exit. Note that it would also be impossible to insert the
15016 -- finalization code after the return statement as this will render it
15019 if Nkind (Fin_Context) = N_Simple_Return_Statement then
15022 -- Finalize the hook after the context has been evaluated. Generate:
15024 -- if Hook /= null then
15025 -- [Deep_]Finalize (Hook.all);
15030 Insert_Action_After (Fin_Context,
15031 Make_Implicit_If_Statement (Obj_Decl,
15035 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
15036 Right_Opnd => Make_Null (Loc)),
15038 Then_Statements => New_List (
15042 end Process_Transient_In_Expression;
15044 ------------------------
15045 -- Rewrite_Comparison --
15046 ------------------------
15048 procedure Rewrite_Comparison (N : Node_Id) is
15049 Typ : constant Entity_Id := Etype (N);
15051 False_Result : Boolean;
15052 True_Result : Boolean;
15055 if Nkind (N) = N_Type_Conversion then
15056 Rewrite_Comparison (Expression (N));
15059 elsif Nkind (N) not in N_Op_Compare then
15063 -- If both operands are static, then the comparison has been already
15064 -- folded in evaluation.
15067 (not Is_Static_Expression (Left_Opnd (N))
15069 not Is_Static_Expression (Right_Opnd (N)));
15071 -- Determine the potential outcome of the comparison assuming that the
15072 -- operands are valid and emit a warning when the comparison evaluates
15073 -- to True or False only in the presence of invalid values.
15075 Warn_On_Constant_Valid_Condition (N);
15077 -- Determine the potential outcome of the comparison assuming that the
15078 -- operands are not valid.
15082 Assume_Valid => False,
15083 True_Result => True_Result,
15084 False_Result => False_Result);
15086 -- The outcome is a decisive False or True, rewrite the operator into a
15087 -- non-static literal.
15089 if False_Result or True_Result then
15092 New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N))));
15094 Analyze_And_Resolve (N, Typ);
15095 Set_Is_Static_Expression (N, False);
15096 Warn_On_Known_Condition (N);
15098 end Rewrite_Comparison;
15100 ----------------------------
15101 -- Safe_In_Place_Array_Op --
15102 ----------------------------
15104 function Safe_In_Place_Array_Op
15107 Op2 : Node_Id) return Boolean
15109 Target : Entity_Id;
15111 function Is_Safe_Operand (Op : Node_Id) return Boolean;
15112 -- Operand is safe if it cannot overlap part of the target of the
15113 -- operation. If the operand and the target are identical, the operand
15114 -- is safe. The operand can be empty in the case of negation.
15116 function Is_Unaliased (N : Node_Id) return Boolean;
15117 -- Check that N is a stand-alone entity
15123 function Is_Unaliased (N : Node_Id) return Boolean is
15127 and then No (Address_Clause (Entity (N)))
15128 and then No (Renamed_Object (Entity (N)));
15131 ---------------------
15132 -- Is_Safe_Operand --
15133 ---------------------
15135 function Is_Safe_Operand (Op : Node_Id) return Boolean is
15140 elsif Is_Entity_Name (Op) then
15141 return Is_Unaliased (Op);
15143 elsif Nkind (Op) in N_Indexed_Component | N_Selected_Component then
15144 return Is_Unaliased (Prefix (Op));
15146 elsif Nkind (Op) = N_Slice then
15148 Is_Unaliased (Prefix (Op))
15149 and then Entity (Prefix (Op)) /= Target;
15151 elsif Nkind (Op) = N_Op_Not then
15152 return Is_Safe_Operand (Right_Opnd (Op));
15157 end Is_Safe_Operand;
15159 -- Start of processing for Safe_In_Place_Array_Op
15162 -- Skip this processing if the component size is different from system
15163 -- storage unit (since at least for NOT this would cause problems).
15165 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
15168 -- Cannot do in place stuff if non-standard Boolean representation
15170 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
15173 elsif not Is_Unaliased (Lhs) then
15177 Target := Entity (Lhs);
15178 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
15180 end Safe_In_Place_Array_Op;
15182 -----------------------
15183 -- Tagged_Membership --
15184 -----------------------
15186 -- There are two different cases to consider depending on whether the right
15187 -- operand is a class-wide type or not. If not we just compare the actual
15188 -- tag of the left expr to the target type tag:
15190 -- Left_Expr.Tag = Right_Type'Tag;
15192 -- If it is a class-wide type we use the RT function CW_Membership which is
15193 -- usually implemented by looking in the ancestor tables contained in the
15194 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
15196 -- In both cases if Left_Expr is an access type, we first check whether it
15199 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
15200 -- function IW_Membership which is usually implemented by looking in the
15201 -- table of abstract interface types plus the ancestor table contained in
15202 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
15204 procedure Tagged_Membership
15206 SCIL_Node : out Node_Id;
15207 Result : out Node_Id)
15209 Left : constant Node_Id := Left_Opnd (N);
15210 Right : constant Node_Id := Right_Opnd (N);
15211 Loc : constant Source_Ptr := Sloc (N);
15213 -- Handle entities from the limited view
15215 Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right));
15217 Full_R_Typ : Entity_Id;
15218 Left_Type : Entity_Id := Available_View (Etype (Left));
15219 Right_Type : Entity_Id := Orig_Right_Type;
15223 SCIL_Node := Empty;
15225 -- In the case where the type is an access type, the test is applied
15226 -- using the designated types (needed in Ada 2012 for implicit anonymous
15227 -- access conversions, for AI05-0149).
15229 if Is_Access_Type (Right_Type) then
15230 Left_Type := Designated_Type (Left_Type);
15231 Right_Type := Designated_Type (Right_Type);
15234 if Is_Class_Wide_Type (Left_Type) then
15235 Left_Type := Root_Type (Left_Type);
15238 if Is_Class_Wide_Type (Right_Type) then
15239 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
15241 Full_R_Typ := Underlying_Type (Right_Type);
15245 Make_Selected_Component (Loc,
15246 Prefix => Relocate_Node (Left),
15248 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
15250 if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then
15252 -- No need to issue a run-time check if we statically know that the
15253 -- result of this membership test is always true. For example,
15254 -- considering the following declarations:
15256 -- type Iface is interface;
15257 -- type T is tagged null record;
15258 -- type DT is new T and Iface with null record;
15263 -- These membership tests are always true:
15266 -- Obj2 in T'Class;
15267 -- Obj2 in Iface'Class;
15269 -- We do not need to handle cases where the membership is illegal.
15272 -- Obj1 in DT'Class; -- Compile time error
15273 -- Obj1 in Iface'Class; -- Compile time error
15275 if not Is_Interface (Left_Type)
15276 and then not Is_Class_Wide_Type (Left_Type)
15277 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
15278 Use_Full_View => True)
15279 or else (Is_Interface (Etype (Right_Type))
15280 and then Interface_Present_In_Ancestor
15282 Iface => Etype (Right_Type))))
15284 Result := New_Occurrence_Of (Standard_True, Loc);
15288 -- Ada 2005 (AI-251): Class-wide applied to interfaces
15290 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
15292 -- Support to: "Iface_CW_Typ in Typ'Class"
15294 or else Is_Interface (Left_Type)
15296 -- Issue error if IW_Membership operation not available in a
15297 -- configurable run-time setting.
15299 if not RTE_Available (RE_IW_Membership) then
15301 ("dynamic membership test on interface types", N);
15307 Make_Function_Call (Loc,
15308 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
15309 Parameter_Associations => New_List (
15310 Make_Attribute_Reference (Loc,
15312 Attribute_Name => Name_Address),
15313 New_Occurrence_Of (
15314 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
15317 -- Ada 95: Normal case
15320 -- Issue error if CW_Membership operation not available in a
15321 -- configurable run-time setting.
15323 if not RTE_Available (RE_CW_Membership) then
15325 ("dynamic membership test on tagged types", N);
15331 Make_Function_Call (Loc,
15332 Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
15333 Parameter_Associations => New_List (
15335 New_Occurrence_Of (
15336 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
15339 -- Generate the SCIL node for this class-wide membership test.
15341 if Generate_SCIL then
15342 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
15343 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
15344 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
15348 -- Right_Type is not a class-wide type
15351 -- No need to check the tag of the object if Right_Typ is abstract
15353 if Is_Abstract_Type (Right_Type) then
15354 Result := New_Occurrence_Of (Standard_False, Loc);
15359 Left_Opnd => Obj_Tag,
15362 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
15366 -- if Left is an access object then generate test of the form:
15367 -- * if Right_Type excludes null: Left /= null and then ...
15368 -- * if Right_Type includes null: Left = null or else ...
15370 if Is_Access_Type (Orig_Right_Type) then
15371 if Can_Never_Be_Null (Orig_Right_Type) then
15372 Result := Make_And_Then (Loc,
15376 Right_Opnd => Make_Null (Loc)),
15377 Right_Opnd => Result);
15380 Result := Make_Or_Else (Loc,
15384 Right_Opnd => Make_Null (Loc)),
15385 Right_Opnd => Result);
15388 end Tagged_Membership;
15390 ------------------------------
15391 -- Unary_Op_Validity_Checks --
15392 ------------------------------
15394 procedure Unary_Op_Validity_Checks (N : Node_Id) is
15396 if Validity_Checks_On and Validity_Check_Operands then
15397 Ensure_Valid (Right_Opnd (N));
15399 end Unary_Op_Validity_Checks;