1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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 Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Einfo.Entities; use Einfo.Entities;
32 with Einfo.Utils; use Einfo.Utils;
33 with Elists; use Elists;
34 with Errout; use Errout;
35 with Exp_Aggr; use Exp_Aggr;
36 with Exp_Atag; use Exp_Atag;
37 with Exp_Ch3; use Exp_Ch3;
38 with Exp_Ch6; use Exp_Ch6;
39 with Exp_Ch7; use Exp_Ch7;
40 with Exp_Ch9; use Exp_Ch9;
41 with Exp_Disp; use Exp_Disp;
42 with Exp_Fixd; use Exp_Fixd;
43 with Exp_Intr; use Exp_Intr;
44 with Exp_Pakd; use Exp_Pakd;
45 with Exp_Tss; use Exp_Tss;
46 with Exp_Util; use Exp_Util;
47 with Freeze; use Freeze;
48 with Inline; use Inline;
50 with Namet; use Namet;
51 with Nlists; use Nlists;
52 with Nmake; use Nmake;
54 with Par_SCO; use Par_SCO;
55 with Restrict; use Restrict;
56 with Rident; use Rident;
57 with Rtsfind; use Rtsfind;
59 with Sem_Aux; use Sem_Aux;
60 with Sem_Cat; use Sem_Cat;
61 with Sem_Ch3; use Sem_Ch3;
62 with Sem_Ch13; use Sem_Ch13;
63 with Sem_Eval; use Sem_Eval;
64 with Sem_Res; use Sem_Res;
65 with Sem_Type; use Sem_Type;
66 with Sem_Util; use Sem_Util;
67 with Sem_Warn; use Sem_Warn;
68 with Sinfo; use Sinfo;
69 with Sinfo.Nodes; use Sinfo.Nodes;
70 with Sinfo.Utils; use Sinfo.Utils;
71 with Snames; use Snames;
72 with Stand; use Stand;
73 with SCIL_LL; use SCIL_LL;
74 with Targparm; use Targparm;
75 with Tbuild; use Tbuild;
76 with Ttypes; use Ttypes;
77 with Uintp; use Uintp;
78 with Urealp; use Urealp;
79 with Validsw; use Validsw;
80 with Warnsw; use Warnsw;
82 package body Exp_Ch4 is
84 Too_Large_Length_For_Array : constant Unat := Uint_256;
85 -- Threshold from which we do not try to create static array temporaries in
86 -- order to eliminate dynamic stack allocations.
88 -----------------------
89 -- Local Subprograms --
90 -----------------------
92 procedure Binary_Op_Validity_Checks (N : Node_Id);
93 pragma Inline (Binary_Op_Validity_Checks);
94 -- Performs validity checks for a binary operator
96 procedure Build_Boolean_Array_Proc_Call
100 -- If a boolean array assignment can be done in place, build call to
101 -- corresponding library procedure.
103 procedure Displace_Allocator_Pointer (N : Node_Id);
104 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
105 -- Expand_Allocator_Expression. Allocating class-wide interface objects
106 -- this routine displaces the pointer to the allocated object to reference
107 -- the component referencing the corresponding secondary dispatch table.
109 procedure Expand_Allocator_Expression (N : Node_Id);
110 -- Subsidiary to Expand_N_Allocator, for the case when the expression
111 -- is a qualified expression.
113 procedure Expand_Array_Comparison (N : Node_Id);
114 -- This routine handles expansion of the comparison operators (N_Op_Lt,
115 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
116 -- code for these operators is similar, differing only in the details of
117 -- the actual comparison call that is made. Special processing (call a
120 function Expand_Array_Equality
125 Typ : Entity_Id) return Node_Id;
126 -- Expand an array equality into a call to a function implementing this
127 -- equality, and a call to it. Loc is the location for the generated nodes.
128 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
129 -- on which to attach bodies of local functions that are created in the
130 -- process. It is the responsibility of the caller to insert those bodies
131 -- at the right place. Nod provides the Sloc value for the generated code.
132 -- Normally the types used for the generated equality routine are taken
133 -- from Lhs and Rhs. However, in some situations of generated code, the
134 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
135 -- the type to be used for the formal parameters.
137 procedure Expand_Boolean_Operator (N : Node_Id);
138 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
139 -- case of array type arguments.
141 procedure Expand_Nonbinary_Modular_Op (N : Node_Id);
142 -- When generating C code, convert nonbinary modular arithmetic operations
143 -- into code that relies on the front-end expansion of operator Mod. No
144 -- expansion is performed if N is not a nonbinary modular operand.
146 procedure Expand_Short_Circuit_Operator (N : Node_Id);
147 -- Common expansion processing for short-circuit boolean operators
149 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
150 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
151 -- where we allow comparison of "out of range" values.
153 function Expand_Composite_Equality
157 Rhs : Node_Id) return Node_Id;
158 -- Local recursive function used to expand equality for nested composite
159 -- types. Used by Expand_Record/Array_Equality. Nod provides the Sloc value
160 -- for generated code. Lhs and Rhs are the left and right sides for the
161 -- comparison, and Typ is the type of the objects to compare.
163 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
164 -- Routine to expand concatenation of a sequence of two or more operands
165 -- (in the list Operands) and replace node Cnode with the result of the
166 -- concatenation. The operands can be of any appropriate type, and can
167 -- include both arrays and singleton elements.
169 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
170 -- N is an N_In membership test mode, with the overflow check mode set to
171 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
172 -- integer type. This is a case where top level processing is required to
173 -- handle overflow checks in subtrees.
175 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
176 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
177 -- fixed. We do not have such a type at runtime, so the purpose of this
178 -- routine is to find the real type by looking up the tree. We also
179 -- determine if the operation must be rounded.
181 procedure Get_First_Index_Bounds (T : Entity_Id; Lo, Hi : out Uint);
182 -- T is an array whose index bounds are all known at compile time. Return
183 -- the value of the low and high bounds of the first index of T.
185 function Get_Size_For_Range (Lo, Hi : Uint) return Uint;
186 -- Return the size of a small signed integer type covering Lo .. Hi, the
187 -- main goal being to return a size lower than that of standard types.
189 procedure Insert_Dereference_Action (N : Node_Id);
190 -- N is an expression whose type is an access. When the type of the
191 -- associated storage pool is derived from Checked_Pool, generate a
192 -- call to the 'Dereference' primitive operation.
194 function Make_Array_Comparison_Op
196 Nod : Node_Id) return Node_Id;
197 -- Comparisons between arrays are expanded in line. This function produces
198 -- the body of the implementation of (a > b), where a and b are one-
199 -- dimensional arrays of some discrete type. The original node is then
200 -- expanded into the appropriate call to this function. Nod provides the
201 -- Sloc value for the generated code.
203 function Make_Boolean_Array_Op
205 N : Node_Id) return Node_Id;
206 -- Boolean operations on boolean arrays are expanded in line. This function
207 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
208 -- b). It is used only the normal case and not the packed case. The type
209 -- involved, Typ, is the Boolean array type, and the logical operations in
210 -- the body are simple boolean operations. Note that Typ is always a
211 -- constrained type (the caller has ensured this by using
212 -- Convert_To_Actual_Subtype if necessary).
214 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
215 -- For signed arithmetic operations when the current overflow mode is
216 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
217 -- as the first thing we do. We then return. We count on the recursive
218 -- apparatus for overflow checks to call us back with an equivalent
219 -- operation that is in CHECKED mode, avoiding a recursive entry into this
220 -- routine, and that is when we will proceed with the expansion of the
221 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
222 -- these optimizations without first making this check, since there may be
223 -- operands further down the tree that are relying on the recursive calls
224 -- triggered by the top level nodes to properly process overflow checking
225 -- and remaining expansion on these nodes. Note that this call back may be
226 -- skipped if the operation is done in Bignum mode but that's fine, since
227 -- the Bignum call takes care of everything.
229 procedure Narrow_Large_Operation (N : Node_Id);
230 -- Try to compute the result of a large operation in a narrower type than
231 -- its nominal type. This is mainly aimed at getting rid of operations done
232 -- in Universal_Integer that can be generated for attributes.
234 procedure Optimize_Length_Comparison (N : Node_Id);
235 -- Given an expression, if it is of the form X'Length op N (or the other
236 -- way round), where N is known at compile time to be 0 or 1, or something
237 -- else where the value is known to be nonnegative and in the 32-bit range,
238 -- and X is a simple entity, and op is a comparison operator, optimizes it
239 -- into a comparison of X'First and X'Last.
241 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
242 -- Inspect and process statement list Stmt of if or case expression N for
243 -- transient objects. If such objects are found, the routine generates code
244 -- to clean them up when the context of the expression is evaluated.
246 procedure Process_Transient_In_Expression
250 -- Subsidiary routine to the expansion of expression_with_actions, if and
251 -- case expressions. Generate all necessary code to finalize a transient
252 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
253 -- denotes the declaration of the transient object, which is usually the
254 -- result of a controlled function call. Expr denotes the expression with
255 -- actions, if expression, or case expression node. Stmts denotes the
256 -- statement list which contains Decl, either at the top level or within a
259 procedure Rewrite_Comparison (N : Node_Id);
260 -- If N is the node for a comparison whose outcome can be determined at
261 -- compile time, then the node N can be rewritten with True or False. If
262 -- the outcome cannot be determined at compile time, the call has no
263 -- effect. If N is a type conversion, then this processing is applied to
264 -- its expression. If N is neither comparison nor a type conversion, the
265 -- call has no effect.
267 procedure Tagged_Membership
269 SCIL_Node : out Node_Id;
270 Result : out Node_Id);
271 -- Construct the expression corresponding to the tagged membership test.
272 -- Deals with a second operand being (or not) a class-wide type.
274 function Safe_In_Place_Array_Op
277 Op2 : Node_Id) return Boolean;
278 -- In the context of an assignment, where the right-hand side is a boolean
279 -- operation on arrays, check whether operation can be performed in place.
281 procedure Unary_Op_Validity_Checks (N : Node_Id);
282 pragma Inline (Unary_Op_Validity_Checks);
283 -- Performs validity checks for a unary operator
285 -------------------------------
286 -- Binary_Op_Validity_Checks --
287 -------------------------------
289 procedure Binary_Op_Validity_Checks (N : Node_Id) is
291 if Validity_Checks_On and Validity_Check_Operands then
292 Ensure_Valid (Left_Opnd (N));
293 Ensure_Valid (Right_Opnd (N));
295 end Binary_Op_Validity_Checks;
297 ------------------------------------
298 -- Build_Boolean_Array_Proc_Call --
299 ------------------------------------
301 procedure Build_Boolean_Array_Proc_Call
306 Loc : constant Source_Ptr := Sloc (N);
307 Kind : constant Node_Kind := Nkind (Expression (N));
308 Target : constant Node_Id :=
309 Make_Attribute_Reference (Loc,
311 Attribute_Name => Name_Address);
313 Arg1 : Node_Id := Op1;
314 Arg2 : Node_Id := Op2;
316 Proc_Name : Entity_Id;
319 if Kind = N_Op_Not then
320 if Nkind (Op1) in N_Binary_Op then
322 -- Use negated version of the binary operators
324 if Nkind (Op1) = N_Op_And then
325 Proc_Name := RTE (RE_Vector_Nand);
327 elsif Nkind (Op1) = N_Op_Or then
328 Proc_Name := RTE (RE_Vector_Nor);
330 else pragma Assert (Nkind (Op1) = N_Op_Xor);
331 Proc_Name := RTE (RE_Vector_Xor);
335 Make_Procedure_Call_Statement (Loc,
336 Name => New_Occurrence_Of (Proc_Name, Loc),
338 Parameter_Associations => New_List (
340 Make_Attribute_Reference (Loc,
341 Prefix => Left_Opnd (Op1),
342 Attribute_Name => Name_Address),
344 Make_Attribute_Reference (Loc,
345 Prefix => Right_Opnd (Op1),
346 Attribute_Name => Name_Address),
348 Make_Attribute_Reference (Loc,
349 Prefix => Left_Opnd (Op1),
350 Attribute_Name => Name_Length)));
353 Proc_Name := RTE (RE_Vector_Not);
356 Make_Procedure_Call_Statement (Loc,
357 Name => New_Occurrence_Of (Proc_Name, Loc),
358 Parameter_Associations => New_List (
361 Make_Attribute_Reference (Loc,
363 Attribute_Name => Name_Address),
365 Make_Attribute_Reference (Loc,
367 Attribute_Name => Name_Length)));
371 -- We use the following equivalences:
373 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
374 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
375 -- (not X) xor (not Y) = X xor Y
376 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
378 if Nkind (Op1) = N_Op_Not then
379 Arg1 := Right_Opnd (Op1);
380 Arg2 := Right_Opnd (Op2);
382 if Kind = N_Op_And then
383 Proc_Name := RTE (RE_Vector_Nor);
384 elsif Kind = N_Op_Or then
385 Proc_Name := RTE (RE_Vector_Nand);
387 Proc_Name := RTE (RE_Vector_Xor);
391 if Kind = N_Op_And then
392 Proc_Name := RTE (RE_Vector_And);
393 elsif Kind = N_Op_Or then
394 Proc_Name := RTE (RE_Vector_Or);
395 elsif Nkind (Op2) = N_Op_Not then
396 Proc_Name := RTE (RE_Vector_Nxor);
397 Arg2 := Right_Opnd (Op2);
399 Proc_Name := RTE (RE_Vector_Xor);
404 Make_Procedure_Call_Statement (Loc,
405 Name => New_Occurrence_Of (Proc_Name, Loc),
406 Parameter_Associations => New_List (
408 Make_Attribute_Reference (Loc,
410 Attribute_Name => Name_Address),
411 Make_Attribute_Reference (Loc,
413 Attribute_Name => Name_Address),
414 Make_Attribute_Reference (Loc,
416 Attribute_Name => Name_Length)));
419 Rewrite (N, Call_Node);
423 when RE_Not_Available =>
425 end Build_Boolean_Array_Proc_Call;
427 -----------------------
429 -----------------------
431 function Build_Eq_Call
435 Rhs : Node_Id) return Node_Id
437 Eq : constant Entity_Id := Get_User_Defined_Equality (Typ);
441 if Is_Abstract_Subprogram (Eq) then
442 return Make_Raise_Program_Error (Loc,
443 Reason => PE_Explicit_Raise);
447 Make_Function_Call (Loc,
448 Name => New_Occurrence_Of (Eq, Loc),
449 Parameter_Associations => New_List (Lhs, Rhs));
453 -- If not found, predefined operation will be used
458 --------------------------------
459 -- Displace_Allocator_Pointer --
460 --------------------------------
462 procedure Displace_Allocator_Pointer (N : Node_Id) is
463 Loc : constant Source_Ptr := Sloc (N);
464 Orig_Node : constant Node_Id := Original_Node (N);
470 -- Do nothing in case of VM targets: the virtual machine will handle
471 -- interfaces directly.
473 if not Tagged_Type_Expansion then
477 pragma Assert (Nkind (N) = N_Identifier
478 and then Nkind (Orig_Node) = N_Allocator);
480 PtrT := Etype (Orig_Node);
481 Dtyp := Available_View (Designated_Type (PtrT));
482 Etyp := Etype (Expression (Orig_Node));
484 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
486 -- If the type of the allocator expression is not an interface type
487 -- we can generate code to reference the record component containing
488 -- the pointer to the secondary dispatch table.
490 if not Is_Interface (Etyp) then
492 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
495 -- 1) Get access to the allocated object
498 Make_Explicit_Dereference (Loc, Relocate_Node (N)));
502 -- 2) Add the conversion to displace the pointer to reference
503 -- the secondary dispatch table.
505 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
506 Analyze_And_Resolve (N, Dtyp);
508 -- 3) The 'access to the secondary dispatch table will be used
509 -- as the value returned by the allocator.
512 Make_Attribute_Reference (Loc,
513 Prefix => Relocate_Node (N),
514 Attribute_Name => Name_Access));
515 Set_Etype (N, Saved_Typ);
519 -- If the type of the allocator expression is an interface type we
520 -- generate a run-time call to displace "this" to reference the
521 -- component containing the pointer to the secondary dispatch table
522 -- or else raise Constraint_Error if the actual object does not
523 -- implement the target interface. This case corresponds to the
524 -- following example:
526 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
528 -- return new Iface_2'Class'(Obj);
533 Unchecked_Convert_To (PtrT,
534 Make_Function_Call (Loc,
535 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
536 Parameter_Associations => New_List (
537 Unchecked_Convert_To (RTE (RE_Address),
543 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
545 Analyze_And_Resolve (N, PtrT);
548 end Displace_Allocator_Pointer;
550 ---------------------------------
551 -- Expand_Allocator_Expression --
552 ---------------------------------
554 procedure Expand_Allocator_Expression (N : Node_Id) is
555 Loc : constant Source_Ptr := Sloc (N);
556 Exp : constant Node_Id := Expression (Expression (N));
557 PtrT : constant Entity_Id := Etype (N);
558 DesigT : constant Entity_Id := Designated_Type (PtrT);
560 procedure Apply_Accessibility_Check
562 Built_In_Place : Boolean := False);
563 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
564 -- type, generate an accessibility check to verify that the level of the
565 -- type of the created object is not deeper than the level of the access
566 -- type. If the type of the qualified expression is class-wide, then
567 -- always generate the check (except in the case where it is known to be
568 -- unnecessary, see comment below). Otherwise, only generate the check
569 -- if the level of the qualified expression type is statically deeper
570 -- than the access type.
572 -- Although the static accessibility will generally have been performed
573 -- as a legality check, it won't have been done in cases where the
574 -- allocator appears in generic body, so a run-time check is needed in
575 -- general. One special case is when the access type is declared in the
576 -- same scope as the class-wide allocator, in which case the check can
577 -- never fail, so it need not be generated.
579 -- As an open issue, there seem to be cases where the static level
580 -- associated with the class-wide object's underlying type is not
581 -- sufficient to perform the proper accessibility check, such as for
582 -- allocators in nested subprograms or accept statements initialized by
583 -- class-wide formals when the actual originates outside at a deeper
584 -- static level. The nested subprogram case might require passing
585 -- accessibility levels along with class-wide parameters, and the task
586 -- case seems to be an actual gap in the language rules that needs to
587 -- be fixed by the ARG. ???
589 -------------------------------
590 -- Apply_Accessibility_Check --
591 -------------------------------
593 procedure Apply_Accessibility_Check
595 Built_In_Place : Boolean := False)
597 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
605 if Ada_Version >= Ada_2005
606 and then Is_Class_Wide_Type (DesigT)
607 and then Tagged_Type_Expansion
608 and then not Scope_Suppress.Suppress (Accessibility_Check)
609 and then not No_Dynamic_Accessibility_Checks_Enabled (Ref)
611 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
613 (Is_Class_Wide_Type (Etype (Exp))
614 and then Scope (PtrT) /= Current_Scope))
616 -- If the allocator was built in place, Ref is already a reference
617 -- to the access object initialized to the result of the allocator
618 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
619 -- Remove_Side_Effects for cases where the build-in-place call may
620 -- still be the prefix of the reference (to avoid generating
621 -- duplicate calls). Otherwise, it is the entity associated with
622 -- the object containing the address of the allocated object.
624 if Built_In_Place then
625 Remove_Side_Effects (Ref);
626 Obj_Ref := New_Copy_Tree (Ref);
628 Obj_Ref := New_Occurrence_Of (Ref, Loc);
631 -- For access to interface types we must generate code to displace
632 -- the pointer to the base of the object since the subsequent code
633 -- references components located in the TSD of the object (which
634 -- is associated with the primary dispatch table --see a-tags.ads)
635 -- and also generates code invoking Free, which requires also a
636 -- reference to the base of the unallocated object.
638 if Is_Interface (DesigT) and then Tagged_Type_Expansion then
640 Unchecked_Convert_To (Etype (Obj_Ref),
641 Make_Function_Call (Loc,
643 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
644 Parameter_Associations => New_List (
645 Unchecked_Convert_To (RTE (RE_Address),
646 New_Copy_Tree (Obj_Ref)))));
649 -- Step 1: Create the object clean up code
653 -- Deallocate the object if the accessibility check fails. This
654 -- is done only on targets or profiles that support deallocation.
658 if RTE_Available (RE_Free) then
659 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
660 Set_Storage_Pool (Free_Stmt, Pool_Id);
662 Append_To (Stmts, Free_Stmt);
664 -- The target or profile cannot deallocate objects
670 -- Finalize the object if applicable. Generate:
672 -- [Deep_]Finalize (Obj_Ref.all);
674 if Needs_Finalization (DesigT)
675 and then not No_Heap_Finalization (PtrT)
680 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
683 -- Guard against a missing [Deep_]Finalize when the designated
684 -- type was not properly frozen.
686 if No (Fin_Call) then
687 Fin_Call := Make_Null_Statement (Loc);
690 -- When the target or profile supports deallocation, wrap the
691 -- finalization call in a block to ensure proper deallocation
692 -- even if finalization fails. Generate:
702 if Present (Free_Stmt) then
704 Make_Block_Statement (Loc,
705 Handled_Statement_Sequence =>
706 Make_Handled_Sequence_Of_Statements (Loc,
707 Statements => New_List (Fin_Call),
709 Exception_Handlers => New_List (
710 Make_Exception_Handler (Loc,
711 Exception_Choices => New_List (
712 Make_Others_Choice (Loc)),
713 Statements => New_List (
714 New_Copy_Tree (Free_Stmt),
715 Make_Raise_Statement (Loc))))));
718 Prepend_To (Stmts, Fin_Call);
721 -- Signal the accessibility failure through a Program_Error
724 Make_Raise_Program_Error (Loc,
725 Reason => PE_Accessibility_Check_Failed));
727 -- Step 2: Create the accessibility comparison
733 Make_Attribute_Reference (Loc,
735 Attribute_Name => Name_Tag);
737 -- For tagged types, determine the accessibility level by looking
738 -- at the type specific data of the dispatch table. Generate:
740 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
742 if Tagged_Type_Expansion then
743 Cond := Build_Get_Access_Level (Loc, Obj_Ref);
745 -- Use a runtime call to determine the accessibility level when
746 -- compiling on virtual machine targets. Generate:
748 -- Get_Access_Level (Ref'Tag)
752 Make_Function_Call (Loc,
754 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
755 Parameter_Associations => New_List (Obj_Ref));
761 Right_Opnd => Accessibility_Level (N, Dynamic_Level));
763 -- Due to the complexity and side effects of the check, utilize an
764 -- if statement instead of the regular Program_Error circuitry.
767 Make_Implicit_If_Statement (N,
769 Then_Statements => Stmts));
771 end Apply_Accessibility_Check;
775 Indic : constant Node_Id := Subtype_Mark (Expression (N));
776 T : constant Entity_Id := Entity (Indic);
778 Aggr_In_Place : Boolean;
780 Tag_Assign : Node_Id;
784 TagT : Entity_Id := Empty;
785 -- Type used as source for tag assignment
787 TagR : Node_Id := Empty;
788 -- Target reference for tag assignment
790 -- Start of processing for Expand_Allocator_Expression
793 -- Handle call to C++ constructor
795 if Is_CPP_Constructor_Call (Exp) then
796 Make_CPP_Constructor_Call_In_Allocator
798 Function_Call => Exp);
803 -- type A is access T1;
804 -- X : A := new T2'(...);
805 -- T1 and T2 can be different subtypes, and we might need to check
806 -- both constraints. First check against the type of the qualified
809 Apply_Constraint_Check (Exp, T, No_Sliding => True);
811 Apply_Predicate_Check (Exp, T);
813 -- Check that any anonymous access discriminants are suitable
814 -- for use in an allocator.
816 -- Note: This check is performed here instead of during analysis so that
817 -- we can check against the fully resolved etype of Exp.
819 if Is_Entity_Name (Exp)
820 and then Has_Anonymous_Access_Discriminant (Etype (Exp))
821 and then Static_Accessibility_Level (Exp, Object_Decl_Level)
822 > Static_Accessibility_Level (N, Object_Decl_Level)
824 -- A dynamic check and a warning are generated when we are within
829 Make_Raise_Program_Error (Loc,
830 Reason => PE_Accessibility_Check_Failed));
832 Error_Msg_Warn := SPARK_Mode /= On;
833 Error_Msg_N ("anonymous access discriminant is too deep for use"
834 & " in allocator<<", N);
835 Error_Msg_N ("\Program_Error [<<", N);
837 -- Otherwise, make the error static
840 Error_Msg_N ("anonymous access discriminant is too deep for use"
841 & " in allocator", N);
845 if Do_Range_Check (Exp) then
846 Generate_Range_Check (Exp, T, CE_Range_Check_Failed);
849 -- A check is also needed in cases where the designated subtype is
850 -- constrained and differs from the subtype given in the qualified
851 -- expression. Note that the check on the qualified expression does
852 -- not allow sliding, but this check does (a relaxation from Ada 83).
854 if Is_Constrained (DesigT)
855 and then not Subtypes_Statically_Match (T, DesigT)
857 Apply_Constraint_Check (Exp, DesigT, No_Sliding => False);
859 Apply_Predicate_Check (Exp, DesigT);
861 if Do_Range_Check (Exp) then
862 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
866 if Nkind (Exp) = N_Raise_Constraint_Error then
867 Rewrite (N, New_Copy (Exp));
872 Aggr_In_Place := Is_Delayed_Aggregate (Exp);
874 -- Case of tagged type or type requiring finalization
876 if Is_Tagged_Type (T) or else Needs_Finalization (T) then
878 -- Ada 2005 (AI-318-02): If the initialization expression is a call
879 -- to a build-in-place function, then access to the allocated object
880 -- must be passed to the function.
882 if Is_Build_In_Place_Function_Call (Exp) then
883 Make_Build_In_Place_Call_In_Allocator (N, Exp);
884 Apply_Accessibility_Check (N, Built_In_Place => True);
887 -- Ada 2005 (AI-318-02): Specialization of the previous case for
888 -- expressions containing a build-in-place function call whose
889 -- returned object covers interface types, and Expr has calls to
890 -- Ada.Tags.Displace to displace the pointer to the returned build-
891 -- in-place object to reference the secondary dispatch table of a
892 -- covered interface type.
894 elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then
895 Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
896 Apply_Accessibility_Check (N, Built_In_Place => True);
900 -- Actions inserted before:
901 -- Temp : constant ptr_T := new T'(Expression);
902 -- Temp._tag = T'tag; -- when not class-wide
903 -- [Deep_]Adjust (Temp.all);
905 -- We analyze by hand the new internal allocator to avoid any
906 -- recursion and inappropriate call to Initialize.
908 -- We don't want to remove side effects when the expression must be
909 -- built in place. In the case of a build-in-place function call,
910 -- that could lead to a duplication of the call, which was already
911 -- substituted for the allocator.
913 if not Aggr_In_Place then
914 Remove_Side_Effects (Exp);
917 Temp := Make_Temporary (Loc, 'P', N);
919 -- For a class wide allocation generate the following code:
921 -- type Equiv_Record is record ... end record;
922 -- implicit subtype CW is <Class_Wide_Subytpe>;
923 -- temp : PtrT := new CW'(CW!(expr));
925 if Is_Class_Wide_Type (T) then
926 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
928 -- Ada 2005 (AI-251): If the expression is a class-wide interface
929 -- object we generate code to move up "this" to reference the
930 -- base of the object before allocating the new object.
932 -- Note that Exp'Address is recursively expanded into a call
933 -- to Base_Address (Exp.Tag)
935 if Is_Class_Wide_Type (Etype (Exp))
936 and then Is_Interface (Etype (Exp))
937 and then Tagged_Type_Expansion
941 Unchecked_Convert_To (Entity (Indic),
942 Make_Explicit_Dereference (Loc,
943 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
944 Make_Attribute_Reference (Loc,
946 Attribute_Name => Name_Address)))));
950 Unchecked_Convert_To (Entity (Indic), Exp));
953 Analyze_And_Resolve (Expression (N), Entity (Indic));
956 -- Processing for allocators returning non-interface types
958 if not Is_Interface (Directly_Designated_Type (PtrT)) then
959 if Aggr_In_Place then
961 Make_Object_Declaration (Loc,
962 Defining_Identifier => Temp,
963 Object_Definition => New_Occurrence_Of (PtrT, Loc),
967 New_Occurrence_Of (Etype (Exp), Loc)));
969 -- Copy the Comes_From_Source flag for the allocator we just
970 -- built, since logically this allocator is a replacement of
971 -- the original allocator node. This is for proper handling of
972 -- restriction No_Implicit_Heap_Allocations.
974 Preserve_Comes_From_Source
975 (Expression (Temp_Decl), N);
977 Set_No_Initialization (Expression (Temp_Decl));
978 Insert_Action (N, Temp_Decl);
980 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
981 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
984 Node := Relocate_Node (N);
988 Make_Object_Declaration (Loc,
989 Defining_Identifier => Temp,
990 Constant_Present => True,
991 Object_Definition => New_Occurrence_Of (PtrT, Loc),
994 Insert_Action (N, Temp_Decl);
995 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
998 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
999 -- interface type. In this case we use the type of the qualified
1000 -- expression to allocate the object.
1004 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
1009 Make_Full_Type_Declaration (Loc,
1010 Defining_Identifier => Def_Id,
1012 Make_Access_To_Object_Definition (Loc,
1013 All_Present => True,
1014 Null_Exclusion_Present => False,
1016 Is_Access_Constant (Etype (N)),
1017 Subtype_Indication =>
1018 New_Occurrence_Of (Etype (Exp), Loc)));
1020 Insert_Action (N, New_Decl);
1022 -- Inherit the allocation-related attributes from the original
1025 Set_Finalization_Master
1026 (Def_Id, Finalization_Master (PtrT));
1028 Set_Associated_Storage_Pool
1029 (Def_Id, Associated_Storage_Pool (PtrT));
1031 -- Declare the object using the previous type declaration
1033 if Aggr_In_Place then
1035 Make_Object_Declaration (Loc,
1036 Defining_Identifier => Temp,
1037 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1039 Make_Allocator (Loc,
1040 New_Occurrence_Of (Etype (Exp), Loc)));
1042 -- Copy the Comes_From_Source flag for the allocator we just
1043 -- built, since logically this allocator is a replacement of
1044 -- the original allocator node. This is for proper handling
1045 -- of restriction No_Implicit_Heap_Allocations.
1047 Set_Comes_From_Source
1048 (Expression (Temp_Decl), Comes_From_Source (N));
1050 Set_No_Initialization (Expression (Temp_Decl));
1051 Insert_Action (N, Temp_Decl);
1053 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1054 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1057 Node := Relocate_Node (N);
1058 Set_Analyzed (Node);
1061 Make_Object_Declaration (Loc,
1062 Defining_Identifier => Temp,
1063 Constant_Present => True,
1064 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1065 Expression => Node);
1067 Insert_Action (N, Temp_Decl);
1068 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1071 -- Generate an additional object containing the address of the
1072 -- returned object. The type of this second object declaration
1073 -- is the correct type required for the common processing that
1074 -- is still performed by this subprogram. The displacement of
1075 -- this pointer to reference the component associated with the
1076 -- interface type will be done at the end of common processing.
1079 Make_Object_Declaration (Loc,
1080 Defining_Identifier => Make_Temporary (Loc, 'P'),
1081 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1083 Unchecked_Convert_To (PtrT,
1084 New_Occurrence_Of (Temp, Loc)));
1086 Insert_Action (N, New_Decl);
1088 Temp_Decl := New_Decl;
1089 Temp := Defining_Identifier (New_Decl);
1093 -- Generate the tag assignment
1095 -- Suppress the tag assignment for VM targets because VM tags are
1096 -- represented implicitly in objects.
1098 if not Tagged_Type_Expansion then
1101 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1102 -- interface objects because in this case the tag does not change.
1104 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1105 pragma Assert (Is_Class_Wide_Type
1106 (Directly_Designated_Type (Etype (N))));
1109 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1112 Make_Explicit_Dereference (Loc,
1113 Prefix => New_Occurrence_Of (Temp, Loc));
1115 elsif Is_Private_Type (T)
1116 and then Is_Tagged_Type (Underlying_Type (T))
1118 TagT := Underlying_Type (T);
1120 Unchecked_Convert_To (Underlying_Type (T),
1121 Make_Explicit_Dereference (Loc,
1122 Prefix => New_Occurrence_Of (Temp, Loc)));
1125 if Present (TagT) then
1127 Full_T : constant Entity_Id := Underlying_Type (TagT);
1131 Make_Assignment_Statement (Loc,
1133 Make_Selected_Component (Loc,
1137 (First_Tag_Component (Full_T), Loc)),
1140 Unchecked_Convert_To (RTE (RE_Tag),
1143 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1146 -- The previous assignment has to be done in any case
1148 Set_Assignment_OK (Name (Tag_Assign));
1149 Insert_Action (N, Tag_Assign);
1152 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1153 -- the object may be inherently limited, in which case there is no
1154 -- Adjust procedure, and the object is built in place. In Ada 95, the
1155 -- object can be limited but not inherently limited if this allocator
1156 -- came from a return statement (we're allocating the result on the
1157 -- secondary stack). In that case, the object will be moved, so we do
1158 -- want to Adjust. However, if it's a nonlimited build-in-place
1159 -- function call, Adjust is not wanted.
1161 -- Needs_Finalization (DesigT) can differ from Needs_Finalization (T)
1162 -- if one of the two types is class-wide, and the other is not.
1164 if Needs_Finalization (DesigT)
1165 and then Needs_Finalization (T)
1166 and then not Aggr_In_Place
1167 and then not Is_Limited_View (T)
1168 and then not Alloc_For_BIP_Return (N)
1169 and then not Is_Build_In_Place_Function_Call (Expression (N))
1171 -- An unchecked conversion is needed in the classwide case because
1172 -- the designated type can be an ancestor of the subtype mark of
1178 Unchecked_Convert_To (T,
1179 Make_Explicit_Dereference (Loc,
1180 Prefix => New_Occurrence_Of (Temp, Loc))),
1183 if Present (Adj_Call) then
1184 Insert_Action (N, Adj_Call);
1188 -- Note: the accessibility check must be inserted after the call to
1189 -- [Deep_]Adjust to ensure proper completion of the assignment.
1191 Apply_Accessibility_Check (Temp);
1193 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1194 Analyze_And_Resolve (N, PtrT);
1196 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1197 -- component containing the secondary dispatch table of the interface
1200 if Is_Interface (Directly_Designated_Type (PtrT)) then
1201 Displace_Allocator_Pointer (N);
1204 -- Always force the generation of a temporary for aggregates when
1205 -- generating C code, to simplify the work in the code generator.
1208 or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate)
1210 Temp := Make_Temporary (Loc, 'P', N);
1212 Make_Object_Declaration (Loc,
1213 Defining_Identifier => Temp,
1214 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1216 Make_Allocator (Loc,
1217 Expression => New_Occurrence_Of (Etype (Exp), Loc)));
1219 -- Copy the Comes_From_Source flag for the allocator we just built,
1220 -- since logically this allocator is a replacement of the original
1221 -- allocator node. This is for proper handling of restriction
1222 -- No_Implicit_Heap_Allocations.
1224 Set_Comes_From_Source
1225 (Expression (Temp_Decl), Comes_From_Source (N));
1227 Set_No_Initialization (Expression (Temp_Decl));
1228 Insert_Action (N, Temp_Decl);
1230 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1231 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1233 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1234 Analyze_And_Resolve (N, PtrT);
1236 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
1237 Install_Null_Excluding_Check (Exp);
1239 elsif Is_Access_Type (DesigT)
1240 and then Nkind (Exp) = N_Allocator
1241 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1243 -- Apply constraint to designated subtype indication
1245 Apply_Constraint_Check
1246 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True);
1248 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1250 -- Propagate constraint_error to enclosing allocator
1252 Rewrite (Exp, New_Copy (Expression (Exp)));
1256 Build_Allocate_Deallocate_Proc (N, True);
1258 -- For an access to unconstrained packed array, GIGI needs to see an
1259 -- expression with a constrained subtype in order to compute the
1260 -- proper size for the allocator.
1262 if Is_Packed_Array (T)
1263 and then not Is_Constrained (T)
1266 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
1267 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1270 Make_Subtype_Declaration (Loc,
1271 Defining_Identifier => ConstrT,
1272 Subtype_Indication =>
1273 Make_Subtype_From_Expr (Internal_Exp, T)));
1274 Freeze_Itype (ConstrT, Exp);
1275 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1279 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1280 -- to a build-in-place function, then access to the allocated object
1281 -- must be passed to the function.
1283 if Is_Build_In_Place_Function_Call (Exp) then
1284 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1289 when RE_Not_Available =>
1291 end Expand_Allocator_Expression;
1293 -----------------------------
1294 -- Expand_Array_Comparison --
1295 -----------------------------
1297 -- Expansion is only required in the case of array types. For the unpacked
1298 -- case, an appropriate runtime routine is called. For packed cases, and
1299 -- also in some other cases where a runtime routine cannot be called, the
1300 -- form of the expansion is:
1302 -- [body for greater_nn; boolean_expression]
1304 -- The body is built by Make_Array_Comparison_Op, and the form of the
1305 -- Boolean expression depends on the operator involved.
1307 procedure Expand_Array_Comparison (N : Node_Id) is
1308 Loc : constant Source_Ptr := Sloc (N);
1309 Op1 : Node_Id := Left_Opnd (N);
1310 Op2 : Node_Id := Right_Opnd (N);
1311 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1312 Ctyp : constant Entity_Id := Component_Type (Typ1);
1315 Func_Body : Node_Id;
1316 Func_Name : Entity_Id;
1320 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1321 -- True for byte addressable target
1323 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1324 -- Returns True if the length of the given operand is known to be less
1325 -- than 4. Returns False if this length is known to be four or greater
1326 -- or is not known at compile time.
1328 ------------------------
1329 -- Length_Less_Than_4 --
1330 ------------------------
1332 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1333 Otyp : constant Entity_Id := Etype (Opnd);
1336 if Ekind (Otyp) = E_String_Literal_Subtype then
1337 return String_Literal_Length (Otyp) < 4;
1339 elsif Compile_Time_Known_Bounds (Otyp) then
1344 Get_First_Index_Bounds (Otyp, Lo, Hi);
1351 end Length_Less_Than_4;
1353 -- Start of processing for Expand_Array_Comparison
1356 -- Deal first with unpacked case, where we can call a runtime routine
1357 -- except that we avoid this for targets for which are not addressable
1360 if not Is_Bit_Packed_Array (Typ1) and then Byte_Addressable then
1361 -- The call we generate is:
1363 -- Compare_Array_xn[_Unaligned]
1364 -- (left'address, right'address, left'length, right'length) <op> 0
1366 -- x = U for unsigned, S for signed
1367 -- n = 8,16,32,64,128 for component size
1368 -- Add _Unaligned if length < 4 and component size is 8.
1369 -- <op> is the standard comparison operator
1371 if Component_Size (Typ1) = 8 then
1372 if Length_Less_Than_4 (Op1)
1374 Length_Less_Than_4 (Op2)
1376 if Is_Unsigned_Type (Ctyp) then
1377 Comp := RE_Compare_Array_U8_Unaligned;
1379 Comp := RE_Compare_Array_S8_Unaligned;
1383 if Is_Unsigned_Type (Ctyp) then
1384 Comp := RE_Compare_Array_U8;
1386 Comp := RE_Compare_Array_S8;
1390 elsif Component_Size (Typ1) = 16 then
1391 if Is_Unsigned_Type (Ctyp) then
1392 Comp := RE_Compare_Array_U16;
1394 Comp := RE_Compare_Array_S16;
1397 elsif Component_Size (Typ1) = 32 then
1398 if Is_Unsigned_Type (Ctyp) then
1399 Comp := RE_Compare_Array_U32;
1401 Comp := RE_Compare_Array_S32;
1404 elsif Component_Size (Typ1) = 64 then
1405 if Is_Unsigned_Type (Ctyp) then
1406 Comp := RE_Compare_Array_U64;
1408 Comp := RE_Compare_Array_S64;
1411 else pragma Assert (Component_Size (Typ1) = 128);
1412 if Is_Unsigned_Type (Ctyp) then
1413 Comp := RE_Compare_Array_U128;
1415 Comp := RE_Compare_Array_S128;
1419 if RTE_Available (Comp) then
1421 -- Expand to a call only if the runtime function is available,
1422 -- otherwise fall back to inline code.
1424 Remove_Side_Effects (Op1, Name_Req => True);
1425 Remove_Side_Effects (Op2, Name_Req => True);
1428 Make_Function_Call (Sloc (Op1),
1429 Name => New_Occurrence_Of (RTE (Comp), Loc),
1431 Parameter_Associations => New_List (
1432 Make_Attribute_Reference (Loc,
1433 Prefix => Relocate_Node (Op1),
1434 Attribute_Name => Name_Address),
1436 Make_Attribute_Reference (Loc,
1437 Prefix => Relocate_Node (Op2),
1438 Attribute_Name => Name_Address),
1440 Make_Attribute_Reference (Loc,
1441 Prefix => Relocate_Node (Op1),
1442 Attribute_Name => Name_Length),
1444 Make_Attribute_Reference (Loc,
1445 Prefix => Relocate_Node (Op2),
1446 Attribute_Name => Name_Length))));
1449 Make_Integer_Literal (Sloc (Op2),
1452 Analyze_And_Resolve (Op1, Standard_Integer);
1453 Analyze_And_Resolve (Op2, Standard_Integer);
1458 -- Cases where we cannot make runtime call
1460 -- For (a <= b) we convert to not (a > b)
1462 if Chars (N) = Name_Op_Le then
1468 Right_Opnd => Op2)));
1469 Analyze_And_Resolve (N, Standard_Boolean);
1472 -- For < the Boolean expression is
1473 -- greater__nn (op2, op1)
1475 elsif Chars (N) = Name_Op_Lt then
1476 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1480 Op1 := Right_Opnd (N);
1481 Op2 := Left_Opnd (N);
1483 -- For (a >= b) we convert to not (a < b)
1485 elsif Chars (N) = Name_Op_Ge then
1491 Right_Opnd => Op2)));
1492 Analyze_And_Resolve (N, Standard_Boolean);
1495 -- For > the Boolean expression is
1496 -- greater__nn (op1, op2)
1499 pragma Assert (Chars (N) = Name_Op_Gt);
1500 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1503 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1505 Make_Function_Call (Loc,
1506 Name => New_Occurrence_Of (Func_Name, Loc),
1507 Parameter_Associations => New_List (Op1, Op2));
1509 Insert_Action (N, Func_Body);
1511 Analyze_And_Resolve (N, Standard_Boolean);
1512 end Expand_Array_Comparison;
1514 ---------------------------
1515 -- Expand_Array_Equality --
1516 ---------------------------
1518 -- Expand an equality function for multi-dimensional arrays. Here is an
1519 -- example of such a function for Nb_Dimension = 2
1521 -- function Enn (A : atyp; B : btyp) return boolean is
1523 -- if (A'length (1) = 0 or else A'length (2) = 0)
1525 -- (B'length (1) = 0 or else B'length (2) = 0)
1527 -- return true; -- RM 4.5.2(22)
1530 -- if A'length (1) /= B'length (1)
1532 -- A'length (2) /= B'length (2)
1534 -- return false; -- RM 4.5.2(23)
1538 -- A1 : Index_T1 := A'first (1);
1539 -- B1 : Index_T1 := B'first (1);
1543 -- A2 : Index_T2 := A'first (2);
1544 -- B2 : Index_T2 := B'first (2);
1547 -- if A (A1, A2) /= B (B1, B2) then
1551 -- exit when A2 = A'last (2);
1552 -- A2 := Index_T2'succ (A2);
1553 -- B2 := Index_T2'succ (B2);
1557 -- exit when A1 = A'last (1);
1558 -- A1 := Index_T1'succ (A1);
1559 -- B1 := Index_T1'succ (B1);
1566 -- Note on the formal types used (atyp and btyp). If either of the arrays
1567 -- is of a private type, we use the underlying type, and do an unchecked
1568 -- conversion of the actual. If either of the arrays has a bound depending
1569 -- on a discriminant, then we use the base type since otherwise we have an
1570 -- escaped discriminant in the function.
1572 -- If both arrays are constrained and have the same bounds, we can generate
1573 -- a loop with an explicit iteration scheme using a 'Range attribute over
1576 function Expand_Array_Equality
1581 Typ : Entity_Id) return Node_Id
1583 Loc : constant Source_Ptr := Sloc (Nod);
1584 Decls : constant List_Id := New_List;
1585 Index_List1 : constant List_Id := New_List;
1586 Index_List2 : constant List_Id := New_List;
1588 First_Idx : Node_Id;
1590 Func_Name : Entity_Id;
1591 Func_Body : Node_Id;
1593 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1594 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1598 -- The parameter types to be used for the formals
1602 -- The LHS and RHS converted to the parameter types
1607 Dim : Pos) return Node_Id;
1608 -- This builds the attribute reference Arr'Nam (Dim)
1610 function Component_Equality (Typ : Entity_Id) return Node_Id;
1611 -- Create one statement to compare corresponding components, designated
1612 -- by a full set of indexes.
1614 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1615 -- Given one of the arguments, computes the appropriate type to be used
1616 -- for that argument in the corresponding function formal
1618 function Handle_One_Dimension
1620 Index : Node_Id) return Node_Id;
1621 -- This procedure returns the following code
1624 -- An : Index_T := A'First (N);
1625 -- Bn : Index_T := B'First (N);
1629 -- exit when An = A'Last (N);
1630 -- An := Index_T'Succ (An)
1631 -- Bn := Index_T'Succ (Bn)
1635 -- If both indexes are constrained and identical, the procedure
1636 -- returns a simpler loop:
1638 -- for An in A'Range (N) loop
1642 -- N is the dimension for which we are generating a loop. Index is the
1643 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1644 -- xxx statement is either the loop or declare for the next dimension
1645 -- or if this is the last dimension the comparison of corresponding
1646 -- components of the arrays.
1648 -- The actual way the code works is to return the comparison of
1649 -- corresponding components for the N+1 call. That's neater.
1651 function Test_Empty_Arrays return Node_Id;
1652 -- This function constructs the test for both arrays being empty
1653 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1655 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1657 function Test_Lengths_Correspond return Node_Id;
1658 -- This function constructs the test for arrays having different lengths
1659 -- in at least one index position, in which case the resulting code is:
1661 -- A'length (1) /= B'length (1)
1663 -- A'length (2) /= B'length (2)
1674 Dim : Pos) return Node_Id
1678 Make_Attribute_Reference (Loc,
1679 Attribute_Name => Nam,
1680 Prefix => New_Occurrence_Of (Arr, Loc),
1681 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
1684 ------------------------
1685 -- Component_Equality --
1686 ------------------------
1688 function Component_Equality (Typ : Entity_Id) return Node_Id is
1693 -- if a(i1...) /= b(j1...) then return false; end if;
1696 Make_Indexed_Component (Loc,
1697 Prefix => Make_Identifier (Loc, Chars (A)),
1698 Expressions => Index_List1);
1701 Make_Indexed_Component (Loc,
1702 Prefix => Make_Identifier (Loc, Chars (B)),
1703 Expressions => Index_List2);
1705 Test := Expand_Composite_Equality (Nod, Component_Type (Typ), L, R);
1707 -- If some (sub)component is an unchecked_union, the whole operation
1708 -- will raise program error.
1710 if Nkind (Test) = N_Raise_Program_Error then
1712 -- This node is going to be inserted at a location where a
1713 -- statement is expected: clear its Etype so analysis will set
1714 -- it to the expected Standard_Void_Type.
1716 Set_Etype (Test, Empty);
1721 Make_Implicit_If_Statement (Nod,
1722 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1723 Then_Statements => New_List (
1724 Make_Simple_Return_Statement (Loc,
1725 Expression => New_Occurrence_Of (Standard_False, Loc))));
1727 end Component_Equality;
1733 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1744 T := Underlying_Type (T);
1746 X := First_Index (T);
1747 while Present (X) loop
1748 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1750 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1763 --------------------------
1764 -- Handle_One_Dimension --
1765 ---------------------------
1767 function Handle_One_Dimension
1769 Index : Node_Id) return Node_Id
1771 Need_Separate_Indexes : constant Boolean :=
1772 Ltyp /= Rtyp or else not Is_Constrained (Ltyp);
1773 -- If the index types are identical, and we are working with
1774 -- constrained types, then we can use the same index for both
1777 An : constant Entity_Id := Make_Temporary (Loc, 'A');
1780 Index_T : Entity_Id;
1785 if N > Number_Dimensions (Ltyp) then
1786 return Component_Equality (Ltyp);
1789 -- Case where we generate a loop
1791 Index_T := Base_Type (Etype (Index));
1793 if Need_Separate_Indexes then
1794 Bn := Make_Temporary (Loc, 'B');
1799 Append (New_Occurrence_Of (An, Loc), Index_List1);
1800 Append (New_Occurrence_Of (Bn, Loc), Index_List2);
1802 Stm_List := New_List (
1803 Handle_One_Dimension (N + 1, Next_Index (Index)));
1805 if Need_Separate_Indexes then
1807 -- Generate guard for loop, followed by increments of indexes
1809 Append_To (Stm_List,
1810 Make_Exit_Statement (Loc,
1813 Left_Opnd => New_Occurrence_Of (An, Loc),
1814 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1816 Append_To (Stm_List,
1817 Make_Assignment_Statement (Loc,
1818 Name => New_Occurrence_Of (An, Loc),
1820 Make_Attribute_Reference (Loc,
1821 Prefix => New_Occurrence_Of (Index_T, Loc),
1822 Attribute_Name => Name_Succ,
1823 Expressions => New_List (
1824 New_Occurrence_Of (An, Loc)))));
1826 Append_To (Stm_List,
1827 Make_Assignment_Statement (Loc,
1828 Name => New_Occurrence_Of (Bn, Loc),
1830 Make_Attribute_Reference (Loc,
1831 Prefix => New_Occurrence_Of (Index_T, Loc),
1832 Attribute_Name => Name_Succ,
1833 Expressions => New_List (
1834 New_Occurrence_Of (Bn, Loc)))));
1837 -- If separate indexes, we need a declare block for An and Bn, and a
1838 -- loop without an iteration scheme.
1840 if Need_Separate_Indexes then
1842 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1845 Make_Block_Statement (Loc,
1846 Declarations => New_List (
1847 Make_Object_Declaration (Loc,
1848 Defining_Identifier => An,
1849 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1850 Expression => Arr_Attr (A, Name_First, N)),
1852 Make_Object_Declaration (Loc,
1853 Defining_Identifier => Bn,
1854 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1855 Expression => Arr_Attr (B, Name_First, N))),
1857 Handled_Statement_Sequence =>
1858 Make_Handled_Sequence_Of_Statements (Loc,
1859 Statements => New_List (Loop_Stm)));
1861 -- If no separate indexes, return loop statement with explicit
1862 -- iteration scheme on its own.
1866 Make_Implicit_Loop_Statement (Nod,
1867 Statements => Stm_List,
1869 Make_Iteration_Scheme (Loc,
1870 Loop_Parameter_Specification =>
1871 Make_Loop_Parameter_Specification (Loc,
1872 Defining_Identifier => An,
1873 Discrete_Subtype_Definition =>
1874 Arr_Attr (A, Name_Range, N))));
1877 end Handle_One_Dimension;
1879 -----------------------
1880 -- Test_Empty_Arrays --
1881 -----------------------
1883 function Test_Empty_Arrays return Node_Id is
1884 Alist : Node_Id := Empty;
1885 Blist : Node_Id := Empty;
1888 for J in 1 .. Number_Dimensions (Ltyp) loop
1889 Evolve_Or_Else (Alist,
1891 Left_Opnd => Arr_Attr (A, Name_Length, J),
1892 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)));
1894 Evolve_Or_Else (Blist,
1896 Left_Opnd => Arr_Attr (B, Name_Length, J),
1897 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)));
1903 Right_Opnd => Blist);
1904 end Test_Empty_Arrays;
1906 -----------------------------
1907 -- Test_Lengths_Correspond --
1908 -----------------------------
1910 function Test_Lengths_Correspond return Node_Id is
1911 Result : Node_Id := Empty;
1914 for J in 1 .. Number_Dimensions (Ltyp) loop
1915 Evolve_Or_Else (Result,
1917 Left_Opnd => Arr_Attr (A, Name_Length, J),
1918 Right_Opnd => Arr_Attr (B, Name_Length, J)));
1922 end Test_Lengths_Correspond;
1924 -- Start of processing for Expand_Array_Equality
1927 Ltyp := Get_Arg_Type (Lhs);
1928 Rtyp := Get_Arg_Type (Rhs);
1930 -- For now, if the argument types are not the same, go to the base type,
1931 -- since the code assumes that the formals have the same type. This is
1932 -- fixable in future ???
1934 if Ltyp /= Rtyp then
1935 Ltyp := Base_Type (Ltyp);
1936 Rtyp := Base_Type (Rtyp);
1937 pragma Assert (Ltyp = Rtyp);
1940 -- If the array type is distinct from the type of the arguments, it
1941 -- is the full view of a private type. Apply an unchecked conversion
1942 -- to ensure that analysis of the code below succeeds.
1945 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
1947 New_Lhs := OK_Convert_To (Ltyp, Lhs);
1953 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
1955 New_Rhs := OK_Convert_To (Rtyp, Rhs);
1960 First_Idx := First_Index (Ltyp);
1962 -- If optimization is enabled and the array boils down to a couple of
1963 -- consecutive elements, generate a simple conjunction of comparisons
1964 -- which should be easier to optimize by the code generator.
1966 if Optimization_Level > 0
1967 and then Ltyp = Rtyp
1968 and then Is_Constrained (Ltyp)
1969 and then Number_Dimensions (Ltyp) = 1
1970 and then Compile_Time_Known_Bounds (Ltyp)
1971 and then Expr_Value (Type_High_Bound (Etype (First_Idx))) =
1972 Expr_Value (Type_Low_Bound (Etype (First_Idx))) + 1
1975 Ctyp : constant Entity_Id := Component_Type (Ltyp);
1976 Low_B : constant Node_Id :=
1977 Type_Low_Bound (Etype (First_Idx));
1978 High_B : constant Node_Id :=
1979 Type_High_Bound (Etype (First_Idx));
1981 TestL, TestH : Node_Id;
1985 Make_Indexed_Component (Loc,
1986 Prefix => New_Copy_Tree (New_Lhs),
1987 Expressions => New_List (New_Copy_Tree (Low_B)));
1990 Make_Indexed_Component (Loc,
1991 Prefix => New_Copy_Tree (New_Rhs),
1992 Expressions => New_List (New_Copy_Tree (Low_B)));
1994 TestL := Expand_Composite_Equality (Nod, Ctyp, L, R);
1997 Make_Indexed_Component (Loc,
1999 Expressions => New_List (New_Copy_Tree (High_B)));
2002 Make_Indexed_Component (Loc,
2004 Expressions => New_List (New_Copy_Tree (High_B)));
2006 TestH := Expand_Composite_Equality (Nod, Ctyp, L, R);
2009 Make_And_Then (Loc, Left_Opnd => TestL, Right_Opnd => TestH);
2013 -- Build list of formals for function
2015 Formals := New_List (
2016 Make_Parameter_Specification (Loc,
2017 Defining_Identifier => A,
2018 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)),
2020 Make_Parameter_Specification (Loc,
2021 Defining_Identifier => B,
2022 Parameter_Type => New_Occurrence_Of (Rtyp, Loc)));
2024 Func_Name := Make_Temporary (Loc, 'E');
2026 -- Build statement sequence for function
2029 Make_Subprogram_Body (Loc,
2031 Make_Function_Specification (Loc,
2032 Defining_Unit_Name => Func_Name,
2033 Parameter_Specifications => Formals,
2034 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
2036 Declarations => Decls,
2038 Handled_Statement_Sequence =>
2039 Make_Handled_Sequence_Of_Statements (Loc,
2040 Statements => New_List (
2042 Make_Implicit_If_Statement (Nod,
2043 Condition => Test_Empty_Arrays,
2044 Then_Statements => New_List (
2045 Make_Simple_Return_Statement (Loc,
2047 New_Occurrence_Of (Standard_True, Loc)))),
2049 Make_Implicit_If_Statement (Nod,
2050 Condition => Test_Lengths_Correspond,
2051 Then_Statements => New_List (
2052 Make_Simple_Return_Statement (Loc,
2053 Expression => New_Occurrence_Of (Standard_False, Loc)))),
2055 Handle_One_Dimension (1, First_Idx),
2057 Make_Simple_Return_Statement (Loc,
2058 Expression => New_Occurrence_Of (Standard_True, Loc)))));
2060 Set_Has_Completion (Func_Name, True);
2061 Set_Is_Inlined (Func_Name);
2063 Append_To (Bodies, Func_Body);
2066 Make_Function_Call (Loc,
2067 Name => New_Occurrence_Of (Func_Name, Loc),
2068 Parameter_Associations => New_List (New_Lhs, New_Rhs));
2069 end Expand_Array_Equality;
2071 -----------------------------
2072 -- Expand_Boolean_Operator --
2073 -----------------------------
2075 -- Note that we first get the actual subtypes of the operands, since we
2076 -- always want to deal with types that have bounds.
2078 procedure Expand_Boolean_Operator (N : Node_Id) is
2079 Typ : constant Entity_Id := Etype (N);
2082 -- Special case of bit packed array where both operands are known to be
2083 -- properly aligned. In this case we use an efficient run time routine
2084 -- to carry out the operation (see System.Bit_Ops).
2086 if Is_Bit_Packed_Array (Typ)
2087 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2088 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2090 Expand_Packed_Boolean_Operator (N);
2094 -- For the normal non-packed case, the general expansion is to build
2095 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2096 -- and then inserting it into the tree. The original operator node is
2097 -- then rewritten as a call to this function. We also use this in the
2098 -- packed case if either operand is a possibly unaligned object.
2101 Loc : constant Source_Ptr := Sloc (N);
2102 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2103 R : Node_Id := Relocate_Node (Right_Opnd (N));
2104 Func_Body : Node_Id;
2105 Func_Name : Entity_Id;
2108 Convert_To_Actual_Subtype (L);
2109 Convert_To_Actual_Subtype (R);
2110 Ensure_Defined (Etype (L), N);
2111 Ensure_Defined (Etype (R), N);
2112 Apply_Length_Check (R, Etype (L));
2114 if Nkind (N) = N_Op_Xor then
2115 R := Duplicate_Subexpr (R);
2116 Silly_Boolean_Array_Xor_Test (N, R, Etype (L));
2119 if Nkind (Parent (N)) = N_Assignment_Statement
2120 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2122 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2124 elsif Nkind (Parent (N)) = N_Op_Not
2125 and then Nkind (N) = N_Op_And
2126 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2127 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2131 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2132 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2133 Insert_Action (N, Func_Body);
2135 -- Now rewrite the expression with a call
2137 if Transform_Function_Array then
2139 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
2148 Make_Object_Declaration (Loc,
2149 Defining_Identifier => Temp_Id,
2150 Object_Definition =>
2151 New_Occurrence_Of (Etype (L), Loc));
2154 -- Proc_Call (L, R, Temp);
2157 Make_Procedure_Call_Statement (Loc,
2158 Name => New_Occurrence_Of (Func_Name, Loc),
2159 Parameter_Associations =>
2162 Make_Type_Conversion
2163 (Loc, New_Occurrence_Of (Etype (L), Loc), R),
2164 New_Occurrence_Of (Temp_Id, Loc)));
2166 Insert_Actions (Parent (N), New_List (Decl, Call));
2167 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
2171 Make_Function_Call (Loc,
2172 Name => New_Occurrence_Of (Func_Name, Loc),
2173 Parameter_Associations =>
2176 Make_Type_Conversion
2177 (Loc, New_Occurrence_Of (Etype (L), Loc), R))));
2180 Analyze_And_Resolve (N, Typ);
2183 end Expand_Boolean_Operator;
2185 ------------------------------------------------
2186 -- Expand_Compare_Minimize_Eliminate_Overflow --
2187 ------------------------------------------------
2189 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2190 Loc : constant Source_Ptr := Sloc (N);
2192 Result_Type : constant Entity_Id := Etype (N);
2193 -- Capture result type (could be a derived boolean type)
2198 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2199 -- Entity for Long_Long_Integer'Base
2202 procedure Set_False;
2203 -- These procedures rewrite N with an occurrence of Standard_True or
2204 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2210 procedure Set_False is
2212 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2213 Warn_On_Known_Condition (N);
2220 procedure Set_True is
2222 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2223 Warn_On_Known_Condition (N);
2226 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2229 -- OK, this is the case we are interested in. First step is to process
2230 -- our operands using the Minimize_Eliminate circuitry which applies
2231 -- this processing to the two operand subtrees.
2233 Minimize_Eliminate_Overflows
2234 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
2235 Minimize_Eliminate_Overflows
2236 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
2238 -- See if the range information decides the result of the comparison.
2239 -- We can only do this if we in fact have full range information (which
2240 -- won't be the case if either operand is bignum at this stage).
2242 if Present (Llo) and then Present (Rlo) then
2243 case N_Op_Compare (Nkind (N)) is
2245 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2247 elsif Llo > Rhi or else Lhi < Rlo then
2254 elsif Lhi < Rlo then
2261 elsif Lhi <= Rlo then
2268 elsif Lhi <= Rlo then
2275 elsif Lhi < Rlo then
2280 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2282 elsif Llo > Rhi or else Lhi < Rlo then
2287 -- All done if we did the rewrite
2289 if Nkind (N) not in N_Op_Compare then
2294 -- Otherwise, time to do the comparison
2297 Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2298 Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2301 -- If the two operands have the same signed integer type we are
2302 -- all set, nothing more to do. This is the case where either
2303 -- both operands were unchanged, or we rewrote both of them to
2304 -- be Long_Long_Integer.
2306 -- Note: Entity for the comparison may be wrong, but it's not worth
2307 -- the effort to change it, since the back end does not use it.
2309 if Is_Signed_Integer_Type (Ltype)
2310 and then Base_Type (Ltype) = Base_Type (Rtype)
2314 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2316 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2318 Left : Node_Id := Left_Opnd (N);
2319 Right : Node_Id := Right_Opnd (N);
2320 -- Bignum references for left and right operands
2323 if not Is_RTE (Ltype, RE_Bignum) then
2324 Left := Convert_To_Bignum (Left);
2325 elsif not Is_RTE (Rtype, RE_Bignum) then
2326 Right := Convert_To_Bignum (Right);
2329 -- We rewrite our node with:
2332 -- Bnn : Result_Type;
2334 -- M : Mark_Id := SS_Mark;
2336 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2344 Blk : constant Node_Id := Make_Bignum_Block (Loc);
2345 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2349 case N_Op_Compare (Nkind (N)) is
2350 when N_Op_Eq => Ent := RE_Big_EQ;
2351 when N_Op_Ge => Ent := RE_Big_GE;
2352 when N_Op_Gt => Ent := RE_Big_GT;
2353 when N_Op_Le => Ent := RE_Big_LE;
2354 when N_Op_Lt => Ent := RE_Big_LT;
2355 when N_Op_Ne => Ent := RE_Big_NE;
2358 -- Insert assignment to Bnn into the bignum block
2361 (First (Statements (Handled_Statement_Sequence (Blk))),
2362 Make_Assignment_Statement (Loc,
2363 Name => New_Occurrence_Of (Bnn, Loc),
2365 Make_Function_Call (Loc,
2367 New_Occurrence_Of (RTE (Ent), Loc),
2368 Parameter_Associations => New_List (Left, Right))));
2370 -- Now do the rewrite with expression actions
2373 Make_Expression_With_Actions (Loc,
2374 Actions => New_List (
2375 Make_Object_Declaration (Loc,
2376 Defining_Identifier => Bnn,
2377 Object_Definition =>
2378 New_Occurrence_Of (Result_Type, Loc)),
2380 Expression => New_Occurrence_Of (Bnn, Loc)));
2381 Analyze_And_Resolve (N, Result_Type);
2385 -- No bignums involved, but types are different, so we must have
2386 -- rewritten one of the operands as a Long_Long_Integer but not
2389 -- If left operand is Long_Long_Integer, convert right operand
2390 -- and we are done (with a comparison of two Long_Long_Integers).
2392 elsif Ltype = LLIB then
2393 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2394 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2397 -- If right operand is Long_Long_Integer, convert left operand
2398 -- and we are done (with a comparison of two Long_Long_Integers).
2400 -- This is the only remaining possibility
2402 else pragma Assert (Rtype = LLIB);
2403 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2404 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2408 end Expand_Compare_Minimize_Eliminate_Overflow;
2410 -------------------------------
2411 -- Expand_Composite_Equality --
2412 -------------------------------
2414 -- This function is only called for comparing internal fields of composite
2415 -- types when these fields are themselves composites. This is a special
2416 -- case because it is not possible to respect normal Ada visibility rules.
2418 function Expand_Composite_Equality
2422 Rhs : Node_Id) return Node_Id
2424 Loc : constant Source_Ptr := Sloc (Nod);
2425 Full_Type : Entity_Id;
2429 if Is_Private_Type (Typ) then
2430 Full_Type := Underlying_Type (Typ);
2435 -- If the private type has no completion the context may be the
2436 -- expansion of a composite equality for a composite type with some
2437 -- still incomplete components. The expression will not be analyzed
2438 -- until the enclosing type is completed, at which point this will be
2439 -- properly expanded, unless there is a bona fide completion error.
2441 if No (Full_Type) then
2442 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2445 Full_Type := Base_Type (Full_Type);
2447 -- When the base type itself is private, use the full view to expand
2448 -- the composite equality.
2450 if Is_Private_Type (Full_Type) then
2451 Full_Type := Underlying_Type (Full_Type);
2454 -- Case of tagged record types
2456 if Is_Tagged_Type (Full_Type) then
2457 Eq_Op := Find_Primitive_Eq (Typ);
2458 pragma Assert (Present (Eq_Op));
2461 Make_Function_Call (Loc,
2462 Name => New_Occurrence_Of (Eq_Op, Loc),
2463 Parameter_Associations =>
2465 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2466 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2468 -- Case of untagged record types
2470 elsif Is_Record_Type (Full_Type) then
2471 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2473 if Present (Eq_Op) then
2474 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2476 -- Inherited equality from parent type. Convert the actuals to
2477 -- match signature of operation.
2480 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2484 Make_Function_Call (Loc,
2485 Name => New_Occurrence_Of (Eq_Op, Loc),
2486 Parameter_Associations => New_List (
2487 OK_Convert_To (T, Lhs),
2488 OK_Convert_To (T, Rhs)));
2492 -- Comparison between Unchecked_Union components
2494 if Is_Unchecked_Union (Full_Type) then
2496 Lhs_Type : Node_Id := Full_Type;
2497 Rhs_Type : Node_Id := Full_Type;
2498 Lhs_Discr_Val : Node_Id;
2499 Rhs_Discr_Val : Node_Id;
2504 if Nkind (Lhs) = N_Selected_Component then
2505 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2510 if Nkind (Rhs) = N_Selected_Component then
2511 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2514 -- Lhs of the composite equality
2516 if Is_Constrained (Lhs_Type) then
2518 -- Since the enclosing record type can never be an
2519 -- Unchecked_Union (this code is executed for records
2520 -- that do not have variants), we may reference its
2523 if Nkind (Lhs) = N_Selected_Component
2524 and then Has_Per_Object_Constraint
2525 (Entity (Selector_Name (Lhs)))
2528 Make_Selected_Component (Loc,
2529 Prefix => Prefix (Lhs),
2532 (Get_Discriminant_Value
2533 (First_Discriminant (Lhs_Type),
2535 Stored_Constraint (Lhs_Type))));
2540 (Get_Discriminant_Value
2541 (First_Discriminant (Lhs_Type),
2543 Stored_Constraint (Lhs_Type)));
2547 -- It is not possible to infer the discriminant since
2548 -- the subtype is not constrained.
2551 Make_Raise_Program_Error (Loc,
2552 Reason => PE_Unchecked_Union_Restriction);
2555 -- Rhs of the composite equality
2557 if Is_Constrained (Rhs_Type) then
2558 if Nkind (Rhs) = N_Selected_Component
2559 and then Has_Per_Object_Constraint
2560 (Entity (Selector_Name (Rhs)))
2563 Make_Selected_Component (Loc,
2564 Prefix => Prefix (Rhs),
2567 (Get_Discriminant_Value
2568 (First_Discriminant (Rhs_Type),
2570 Stored_Constraint (Rhs_Type))));
2575 (Get_Discriminant_Value
2576 (First_Discriminant (Rhs_Type),
2578 Stored_Constraint (Rhs_Type)));
2583 Make_Raise_Program_Error (Loc,
2584 Reason => PE_Unchecked_Union_Restriction);
2587 -- Call the TSS equality function with the inferred
2588 -- discriminant values.
2591 Make_Function_Call (Loc,
2592 Name => New_Occurrence_Of (Eq_Op, Loc),
2593 Parameter_Associations => New_List (
2600 -- All cases other than comparing Unchecked_Union types
2604 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2607 Make_Function_Call (Loc,
2609 New_Occurrence_Of (Eq_Op, Loc),
2610 Parameter_Associations => New_List (
2611 OK_Convert_To (T, Lhs),
2612 OK_Convert_To (T, Rhs)));
2617 -- Equality composes in Ada 2012 for untagged record types. It also
2618 -- composes for bounded strings, because they are part of the
2619 -- predefined environment. We could make it compose for bounded
2620 -- strings by making them tagged, or by making sure all subcomponents
2621 -- are set to the same value, even when not used. Instead, we have
2622 -- this special case in the compiler, because it's more efficient.
2624 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
2626 -- If no TSS has been created for the type, check whether there is
2627 -- a primitive equality declared for it.
2630 Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
2633 -- Use user-defined primitive if it exists, otherwise use
2634 -- predefined equality.
2636 if Present (Op) then
2639 return Make_Op_Eq (Loc, Lhs, Rhs);
2644 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs);
2647 -- Case of non-record types (always use predefined equality)
2650 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2652 end Expand_Composite_Equality;
2654 ------------------------
2655 -- Expand_Concatenate --
2656 ------------------------
2658 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2659 Loc : constant Source_Ptr := Sloc (Cnode);
2661 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2662 -- Result type of concatenation
2664 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2665 -- Component type. Elements of this component type can appear as one
2666 -- of the operands of concatenation as well as arrays.
2668 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2671 Ityp : constant Entity_Id := Base_Type (Istyp);
2672 -- Index type. This is the base type of the index subtype, and is used
2673 -- for all computed bounds (which may be out of range of Istyp in the
2674 -- case of null ranges).
2677 -- This is the type we use to do arithmetic to compute the bounds and
2678 -- lengths of operands. The choice of this type is a little subtle and
2679 -- is discussed in a separate section at the start of the body code.
2681 Result_May_Be_Null : Boolean := True;
2682 -- Reset to False if at least one operand is encountered which is known
2683 -- at compile time to be non-null. Used for handling the special case
2684 -- of setting the high bound to the last operand high bound for a null
2685 -- result, thus ensuring a proper high bound in the super-flat case.
2687 N : constant Nat := List_Length (Opnds);
2688 -- Number of concatenation operands including possibly null operands
2691 -- Number of operands excluding any known to be null, except that the
2692 -- last operand is always retained, in case it provides the bounds for
2695 Opnd : Node_Id := Empty;
2696 -- Current operand being processed in the loop through operands. After
2697 -- this loop is complete, always contains the last operand (which is not
2698 -- the same as Operands (NN), since null operands are skipped).
2700 -- Arrays describing the operands, only the first NN entries of each
2701 -- array are set (NN < N when we exclude known null operands).
2703 Is_Fixed_Length : array (1 .. N) of Boolean;
2704 -- True if length of corresponding operand known at compile time
2706 Operands : array (1 .. N) of Node_Id;
2707 -- Set to the corresponding entry in the Opnds list (but note that null
2708 -- operands are excluded, so not all entries in the list are stored).
2710 Fixed_Length : array (1 .. N) of Unat;
2711 -- Set to length of operand. Entries in this array are set only if the
2712 -- corresponding entry in Is_Fixed_Length is True.
2714 Max_Length : array (1 .. N) of Unat;
2715 -- Set to the maximum length of operand, or Too_Large_Length_For_Array
2716 -- if it is not known. Entries in this array are set only if the
2717 -- corresponding entry in Is_Fixed_Length is False;
2719 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2720 -- Set to lower bound of operand. Either an integer literal in the case
2721 -- where the bound is known at compile time, else actual lower bound.
2722 -- The operand low bound is of type Ityp.
2724 Var_Length : array (1 .. N) of Entity_Id;
2725 -- Set to an entity of type Natural that contains the length of an
2726 -- operand whose length is not known at compile time. Entries in this
2727 -- array are set only if the corresponding entry in Is_Fixed_Length
2728 -- is False. The entity is of type Artyp.
2730 Aggr_Length : array (0 .. N) of Node_Id;
2731 -- The J'th entry is an expression node that represents the total length
2732 -- of operands 1 through J. It is either an integer literal node, or a
2733 -- reference to a constant entity with the right value, so it is fine
2734 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth
2735 -- entry always is set to zero. The length is of type Artyp.
2737 Max_Aggr_Length : Unat := Too_Large_Length_For_Array;
2738 -- Set to the maximum total length, or Too_Large_Length_For_Array at
2739 -- least if it is not known.
2741 Low_Bound : Node_Id := Empty;
2742 -- A tree node representing the low bound of the result (of type Ityp).
2743 -- This is either an integer literal node, or an identifier reference to
2744 -- a constant entity initialized to the appropriate value.
2746 High_Bound : Node_Id := Empty;
2747 -- A tree node representing the high bound of the result (of type Ityp)
2749 Last_Opnd_Low_Bound : Node_Id := Empty;
2750 -- A tree node representing the low bound of the last operand. This
2751 -- need only be set if the result could be null. It is used for the
2752 -- special case of setting the right low bound for a null result.
2753 -- This is of type Ityp.
2755 Last_Opnd_High_Bound : Node_Id := Empty;
2756 -- A tree node representing the high bound of the last operand. This
2757 -- need only be set if the result could be null. It is used for the
2758 -- special case of setting the right high bound for a null result.
2759 -- This is of type Ityp.
2761 Result : Node_Id := Empty;
2762 -- Result of the concatenation (of type Ityp)
2764 Actions : constant List_Id := New_List;
2765 -- Collect actions to be inserted
2767 Known_Non_Null_Operand_Seen : Boolean;
2768 -- Set True during generation of the assignments of operands into
2769 -- result once an operand known to be non-null has been seen.
2771 function Library_Level_Target return Boolean;
2772 -- Return True if the concatenation is within the expression of the
2773 -- declaration of a library-level object.
2775 function Make_Artyp_Literal (Val : Uint) return Node_Id;
2776 -- This function makes an N_Integer_Literal node that is returned in
2777 -- analyzed form with the type set to Artyp. Importantly this literal
2778 -- is not flagged as static, so that if we do computations with it that
2779 -- result in statically detected out of range conditions, we will not
2780 -- generate error messages but instead warning messages.
2782 function To_Artyp (X : Node_Id) return Node_Id;
2783 -- Given a node of type Ityp, returns the corresponding value of type
2784 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2785 -- For enum types, the Pos of the value is returned.
2787 function To_Ityp (X : Node_Id) return Node_Id;
2788 -- The inverse function (uses Val in the case of enumeration types)
2790 --------------------------
2791 -- Library_Level_Target --
2792 --------------------------
2794 function Library_Level_Target return Boolean is
2795 P : Node_Id := Parent (Cnode);
2798 while Present (P) loop
2799 if Nkind (P) = N_Object_Declaration then
2800 return Is_Library_Level_Entity (Defining_Identifier (P));
2802 -- Prevent the search from going too far
2804 elsif Is_Body_Or_Package_Declaration (P) then
2812 end Library_Level_Target;
2814 ------------------------
2815 -- Make_Artyp_Literal --
2816 ------------------------
2818 function Make_Artyp_Literal (Val : Uint) return Node_Id is
2819 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2821 Set_Etype (Result, Artyp);
2822 Set_Analyzed (Result, True);
2823 Set_Is_Static_Expression (Result, False);
2825 end Make_Artyp_Literal;
2831 function To_Artyp (X : Node_Id) return Node_Id is
2833 if Ityp = Base_Type (Artyp) then
2836 elsif Is_Enumeration_Type (Ityp) then
2838 Make_Attribute_Reference (Loc,
2839 Prefix => New_Occurrence_Of (Ityp, Loc),
2840 Attribute_Name => Name_Pos,
2841 Expressions => New_List (X));
2844 return Convert_To (Artyp, X);
2852 function To_Ityp (X : Node_Id) return Node_Id is
2854 if Is_Enumeration_Type (Ityp) then
2856 Make_Attribute_Reference (Loc,
2857 Prefix => New_Occurrence_Of (Ityp, Loc),
2858 Attribute_Name => Name_Val,
2859 Expressions => New_List (X));
2861 -- Case where we will do a type conversion
2864 if Ityp = Base_Type (Artyp) then
2867 return Convert_To (Ityp, X);
2872 -- Local Declarations
2874 Opnd_Typ : Entity_Id;
2875 Slice_Rng : Entity_Id;
2876 Subtyp_Ind : Entity_Id;
2883 -- Start of processing for Expand_Concatenate
2886 -- Choose an appropriate computational type
2888 -- We will be doing calculations of lengths and bounds in this routine
2889 -- and computing one from the other in some cases, e.g. getting the high
2890 -- bound by adding the length-1 to the low bound.
2892 -- We can't just use the index type, or even its base type for this
2893 -- purpose for two reasons. First it might be an enumeration type which
2894 -- is not suitable for computations of any kind, and second it may
2895 -- simply not have enough range. For example if the index type is
2896 -- -128..+127 then lengths can be up to 256, which is out of range of
2899 -- For enumeration types, we can simply use Standard_Integer, this is
2900 -- sufficient since the actual number of enumeration literals cannot
2901 -- possibly exceed the range of integer (remember we will be doing the
2902 -- arithmetic with POS values, not representation values).
2904 if Is_Enumeration_Type (Ityp) then
2905 Artyp := Standard_Integer;
2907 -- For modular types, we use a 32-bit modular type for types whose size
2908 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2909 -- identity type, and for larger unsigned types we use a 64-bit type.
2911 elsif Is_Modular_Integer_Type (Ityp) then
2912 if RM_Size (Ityp) < Standard_Integer_Size then
2913 Artyp := Standard_Unsigned;
2914 elsif RM_Size (Ityp) = Standard_Integer_Size then
2917 Artyp := Standard_Long_Long_Unsigned;
2920 -- Similar treatment for signed types
2923 if RM_Size (Ityp) < Standard_Integer_Size then
2924 Artyp := Standard_Integer;
2925 elsif RM_Size (Ityp) = Standard_Integer_Size then
2928 Artyp := Standard_Long_Long_Integer;
2932 -- Supply dummy entry at start of length array
2934 Aggr_Length (0) := Make_Artyp_Literal (Uint_0);
2936 -- Go through operands setting up the above arrays
2940 Opnd := Remove_Head (Opnds);
2941 Opnd_Typ := Etype (Opnd);
2943 -- The parent got messed up when we put the operands in a list,
2944 -- so now put back the proper parent for the saved operand, that
2945 -- is to say the concatenation node, to make sure that each operand
2946 -- is seen as a subexpression, e.g. if actions must be inserted.
2948 Set_Parent (Opnd, Cnode);
2950 -- Set will be True when we have setup one entry in the array
2954 -- Singleton element (or character literal) case
2956 if Base_Type (Opnd_Typ) = Ctyp then
2958 Operands (NN) := Opnd;
2959 Is_Fixed_Length (NN) := True;
2960 Fixed_Length (NN) := Uint_1;
2961 Result_May_Be_Null := False;
2963 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
2964 -- since we know that the result cannot be null).
2966 Opnd_Low_Bound (NN) :=
2967 Make_Attribute_Reference (Loc,
2968 Prefix => New_Occurrence_Of (Istyp, Loc),
2969 Attribute_Name => Name_First);
2973 -- String literal case (can only occur for strings of course)
2975 elsif Nkind (Opnd) = N_String_Literal then
2976 Len := String_Literal_Length (Opnd_Typ);
2979 Result_May_Be_Null := False;
2982 -- Capture last operand low and high bound if result could be null
2984 if J = N and then Result_May_Be_Null then
2985 Last_Opnd_Low_Bound :=
2986 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
2988 Last_Opnd_High_Bound :=
2989 Make_Op_Subtract (Loc,
2991 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
2992 Right_Opnd => Make_Integer_Literal (Loc, 1));
2995 -- Skip null string literal
2997 if J < N and then Len = 0 then
3002 Operands (NN) := Opnd;
3003 Is_Fixed_Length (NN) := True;
3005 -- Set length and bounds
3007 Fixed_Length (NN) := Len;
3009 Opnd_Low_Bound (NN) :=
3010 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3017 -- Check constrained case with known bounds
3019 if Is_Constrained (Opnd_Typ)
3020 and then Compile_Time_Known_Bounds (Opnd_Typ)
3026 -- Fixed length constrained array type with known at compile
3027 -- time bounds is last case of fixed length operand.
3029 Get_First_Index_Bounds (Opnd_Typ, Lo, Hi);
3030 Len := UI_Max (Hi - Lo + 1, Uint_0);
3033 Result_May_Be_Null := False;
3036 -- Capture last operand bounds if result could be null
3038 if J = N and then Result_May_Be_Null then
3039 Last_Opnd_Low_Bound :=
3040 To_Ityp (Make_Integer_Literal (Loc, Lo));
3042 Last_Opnd_High_Bound :=
3043 To_Ityp (Make_Integer_Literal (Loc, Hi));
3046 -- Exclude null length case unless last operand
3048 if J < N and then Len = 0 then
3053 Operands (NN) := Opnd;
3054 Is_Fixed_Length (NN) := True;
3055 Fixed_Length (NN) := Len;
3057 Opnd_Low_Bound (NN) :=
3058 To_Ityp (Make_Integer_Literal (Loc, Lo));
3063 -- All cases where the length is not known at compile time, or the
3064 -- special case of an operand which is known to be null but has a
3065 -- lower bound other than 1 or is other than a string type.
3070 -- Capture operand bounds
3072 Opnd_Low_Bound (NN) :=
3073 Make_Attribute_Reference (Loc,
3075 Duplicate_Subexpr (Opnd, Name_Req => True),
3076 Attribute_Name => Name_First);
3078 -- Capture last operand bounds if result could be null
3080 if J = N and Result_May_Be_Null then
3081 Last_Opnd_Low_Bound :=
3083 Make_Attribute_Reference (Loc,
3085 Duplicate_Subexpr (Opnd, Name_Req => True),
3086 Attribute_Name => Name_First));
3088 Last_Opnd_High_Bound :=
3090 Make_Attribute_Reference (Loc,
3092 Duplicate_Subexpr (Opnd, Name_Req => True),
3093 Attribute_Name => Name_Last));
3096 -- Capture length of operand in entity
3098 Operands (NN) := Opnd;
3099 Is_Fixed_Length (NN) := False;
3101 Var_Length (NN) := Make_Temporary (Loc, 'L');
3103 -- If the operand is a slice, try to compute an upper bound for
3106 if Nkind (Opnd) = N_Slice
3107 and then Is_Constrained (Etype (Prefix (Opnd)))
3108 and then Compile_Time_Known_Bounds (Etype (Prefix (Opnd)))
3114 Get_First_Index_Bounds (Etype (Prefix (Opnd)), Lo, Hi);
3115 Max_Length (NN) := UI_Max (Hi - Lo + 1, Uint_0);
3119 Max_Length (NN) := Too_Large_Length_For_Array;
3123 Make_Object_Declaration (Loc,
3124 Defining_Identifier => Var_Length (NN),
3125 Constant_Present => True,
3126 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3128 Make_Attribute_Reference (Loc,
3130 Duplicate_Subexpr (Opnd, Name_Req => True),
3131 Attribute_Name => Name_Length)));
3135 -- Set next entry in aggregate length array
3137 -- For first entry, make either integer literal for fixed length
3138 -- or a reference to the saved length for variable length.
3141 if Is_Fixed_Length (1) then
3142 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
3143 Max_Aggr_Length := Fixed_Length (1);
3145 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
3146 Max_Aggr_Length := Max_Length (1);
3149 -- If entry is fixed length and only fixed lengths so far, make
3150 -- appropriate new integer literal adding new length.
3152 elsif Is_Fixed_Length (NN)
3153 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3156 Make_Integer_Literal (Loc,
3157 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3158 Max_Aggr_Length := Intval (Aggr_Length (NN));
3160 -- All other cases, construct an addition node for the length and
3161 -- create an entity initialized to this length.
3164 Ent := Make_Temporary (Loc, 'L');
3166 if Is_Fixed_Length (NN) then
3167 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3168 Max_Aggr_Length := Max_Aggr_Length + Fixed_Length (NN);
3171 Clen := New_Occurrence_Of (Var_Length (NN), Loc);
3172 Max_Aggr_Length := Max_Aggr_Length + Max_Length (NN);
3176 Make_Object_Declaration (Loc,
3177 Defining_Identifier => Ent,
3178 Constant_Present => True,
3179 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3182 Left_Opnd => New_Copy_Tree (Aggr_Length (NN - 1)),
3183 Right_Opnd => Clen)));
3185 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
3192 -- If we have only skipped null operands, return the last operand
3199 -- If we have only one non-null operand, return it and we are done.
3200 -- There is one case in which this cannot be done, and that is when
3201 -- the sole operand is of the element type, in which case it must be
3202 -- converted to an array, and the easiest way of doing that is to go
3203 -- through the normal general circuit.
3205 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
3206 Result := Operands (1);
3210 -- Cases where we have a real concatenation
3212 -- Next step is to find the low bound for the result array that we
3213 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3215 -- If the ultimate ancestor of the index subtype is a constrained array
3216 -- definition, then the lower bound is that of the index subtype as
3217 -- specified by (RM 4.5.3(6)).
3219 -- The right test here is to go to the root type, and then the ultimate
3220 -- ancestor is the first subtype of this root type.
3222 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
3224 Make_Attribute_Reference (Loc,
3226 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
3227 Attribute_Name => Name_First);
3229 -- If the first operand in the list has known length we know that
3230 -- the lower bound of the result is the lower bound of this operand.
3232 elsif Is_Fixed_Length (1) then
3233 Low_Bound := Opnd_Low_Bound (1);
3235 -- OK, we don't know the lower bound, we have to build a horrible
3236 -- if expression node of the form
3238 -- if Cond1'Length /= 0 then
3241 -- if Opnd2'Length /= 0 then
3246 -- The nesting ends either when we hit an operand whose length is known
3247 -- at compile time, or on reaching the last operand, whose low bound we
3248 -- take unconditionally whether or not it is null. It's easiest to do
3249 -- this with a recursive procedure:
3253 function Get_Known_Bound (J : Nat) return Node_Id;
3254 -- Returns the lower bound determined by operands J .. NN
3256 ---------------------
3257 -- Get_Known_Bound --
3258 ---------------------
3260 function Get_Known_Bound (J : Nat) return Node_Id is
3262 if Is_Fixed_Length (J) or else J = NN then
3263 return New_Copy_Tree (Opnd_Low_Bound (J));
3267 Make_If_Expression (Loc,
3268 Expressions => New_List (
3272 New_Occurrence_Of (Var_Length (J), Loc),
3274 Make_Integer_Literal (Loc, 0)),
3276 New_Copy_Tree (Opnd_Low_Bound (J)),
3277 Get_Known_Bound (J + 1)));
3279 end Get_Known_Bound;
3282 Ent := Make_Temporary (Loc, 'L');
3285 Make_Object_Declaration (Loc,
3286 Defining_Identifier => Ent,
3287 Constant_Present => True,
3288 Object_Definition => New_Occurrence_Of (Ityp, Loc),
3289 Expression => Get_Known_Bound (1)));
3291 Low_Bound := New_Occurrence_Of (Ent, Loc);
3295 pragma Assert (Present (Low_Bound));
3297 -- Now we can compute the high bound as Low_Bound + Length - 1
3299 if Compile_Time_Known_Value (Low_Bound)
3300 and then Nkind (Aggr_Length (NN)) = N_Integer_Literal
3305 (Expr_Value (Low_Bound) + Intval (Aggr_Length (NN)) - 1));
3311 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3313 Make_Op_Subtract (Loc,
3314 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3315 Right_Opnd => Make_Artyp_Literal (Uint_1))));
3317 -- Note that calculation of the high bound may cause overflow in some
3318 -- very weird cases, so in the general case we need an overflow check
3319 -- on the high bound. We can avoid this for the common case of string
3320 -- types and other types whose index is Positive, since we chose a
3321 -- wider range for the arithmetic type. If checks are suppressed, we
3322 -- do not set the flag so superfluous warnings may be omitted.
3324 if Istyp /= Standard_Positive
3325 and then not Overflow_Checks_Suppressed (Istyp)
3327 Activate_Overflow_Check (High_Bound);
3331 -- Handle the exceptional case where the result is null, in which case
3332 -- case the bounds come from the last operand (so that we get the proper
3333 -- bounds if the last operand is super-flat).
3335 if Result_May_Be_Null then
3337 Make_If_Expression (Loc,
3338 Expressions => New_List (
3340 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3341 Right_Opnd => Make_Artyp_Literal (Uint_0)),
3342 Last_Opnd_Low_Bound,
3346 Make_If_Expression (Loc,
3347 Expressions => New_List (
3349 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3350 Right_Opnd => Make_Artyp_Literal (Uint_0)),
3351 Last_Opnd_High_Bound,
3355 -- Here is where we insert the saved up actions
3357 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3359 -- If the low bound is known at compile time and not the high bound, but
3360 -- we have computed a sensible upper bound for the length, then adjust
3361 -- the high bound for the subtype of the array. This will change it into
3362 -- a static subtype and thus help the code generator.
3364 if Compile_Time_Known_Value (Low_Bound)
3365 and then not Compile_Time_Known_Value (High_Bound)
3366 and then Max_Aggr_Length < Too_Large_Length_For_Array
3369 Known_High_Bound : constant Node_Id :=
3372 (Expr_Value (Low_Bound) + Max_Aggr_Length - 1));
3375 if not Is_Out_Of_Range (Known_High_Bound, Ityp) then
3376 Slice_Rng := Make_Range (Loc, Low_Bound, High_Bound);
3377 High_Bound := Known_High_Bound;
3388 -- Now we construct an array object with appropriate bounds. We mark
3389 -- the target as internal to prevent useless initialization when
3390 -- Initialize_Scalars is enabled. Also since this is the actual result
3391 -- entity, we make sure we have debug information for the result.
3394 Make_Subtype_Indication (Loc,
3395 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3397 Make_Index_Or_Discriminant_Constraint (Loc,
3398 Constraints => New_List (
3400 Low_Bound => Low_Bound,
3401 High_Bound => High_Bound))));
3403 Ent := Make_Temporary (Loc, 'S');
3404 Set_Is_Internal (Ent);
3405 Set_Debug_Info_Needed (Ent);
3407 -- If we are concatenating strings and the current scope already uses
3408 -- the secondary stack, allocate the resulting string also on the
3409 -- secondary stack to avoid putting too much pressure on the primary
3411 -- Don't do this if -gnatd.h is set, as this will break the wrapping of
3412 -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat.
3414 if Atyp = Standard_String
3415 and then Uses_Sec_Stack (Current_Scope)
3416 and then RTE_Available (RE_SS_Pool)
3417 and then not Debug_Flag_Dot_H
3420 -- subtype Axx is ...;
3421 -- type Ayy is access Axx;
3422 -- Rxx : Ayy := new <subtype> [storage_pool = ss_pool];
3423 -- Sxx : <subtype> renames Rxx.all;
3427 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
3428 Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
3432 Insert_Action (Cnode,
3433 Make_Subtype_Declaration (Loc,
3434 Defining_Identifier => ConstrT,
3435 Subtype_Indication => Subtyp_Ind),
3436 Suppress => All_Checks);
3437 Freeze_Itype (ConstrT, Cnode);
3439 Insert_Action (Cnode,
3440 Make_Full_Type_Declaration (Loc,
3441 Defining_Identifier => Acc_Typ,
3443 Make_Access_To_Object_Definition (Loc,
3444 Subtype_Indication => New_Occurrence_Of (ConstrT, Loc))),
3445 Suppress => All_Checks);
3447 Make_Allocator (Loc,
3448 Expression => New_Occurrence_Of (ConstrT, Loc));
3450 -- Allocate on the secondary stack. This is currently done
3451 -- only for type String, which normally doesn't have default
3452 -- initialization, but we need to Set_No_Initialization in case
3453 -- of Initialize_Scalars or Normalize_Scalars; otherwise, the
3454 -- allocator will get transformed and will not use the secondary
3457 Set_Storage_Pool (Alloc, RTE (RE_SS_Pool));
3458 Set_Procedure_To_Call (Alloc, RTE (RE_SS_Allocate));
3459 Set_No_Initialization (Alloc);
3461 Temp := Make_Temporary (Loc, 'R', Alloc);
3462 Insert_Action (Cnode,
3463 Make_Object_Declaration (Loc,
3464 Defining_Identifier => Temp,
3465 Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
3466 Expression => Alloc),
3467 Suppress => All_Checks);
3469 Insert_Action (Cnode,
3470 Make_Object_Renaming_Declaration (Loc,
3471 Defining_Identifier => Ent,
3472 Subtype_Mark => New_Occurrence_Of (ConstrT, Loc),
3474 Make_Explicit_Dereference (Loc,
3475 Prefix => New_Occurrence_Of (Temp, Loc))),
3476 Suppress => All_Checks);
3479 -- If the bound is statically known to be out of range, we do not
3480 -- want to abort, we want a warning and a runtime constraint error.
3481 -- Note that we have arranged that the result will not be treated as
3482 -- a static constant, so we won't get an illegality during this
3484 -- We also enable checks (in particular range checks) in case the
3485 -- bounds of Subtyp_Ind are out of range.
3487 Insert_Action (Cnode,
3488 Make_Object_Declaration (Loc,
3489 Defining_Identifier => Ent,
3490 Object_Definition => Subtyp_Ind));
3493 -- If the result of the concatenation appears as the initializing
3494 -- expression of an object declaration, we can just rename the
3495 -- result, rather than copying it.
3497 Set_OK_To_Rename (Ent);
3499 -- Catch the static out of range case now
3501 if Raises_Constraint_Error (High_Bound)
3502 or else Is_Out_Of_Range (High_Bound, Ityp)
3504 -- Kill warning generated for the declaration of the static out of
3505 -- range high bound, and instead generate a Constraint_Error with
3506 -- an appropriate specific message.
3508 if Nkind (High_Bound) = N_Integer_Literal then
3509 Kill_Dead_Code (High_Bound);
3510 Rewrite (High_Bound, New_Copy_Tree (Low_Bound));
3513 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3516 Apply_Compile_Time_Constraint_Error
3518 Msg => "concatenation result upper bound out of range??",
3519 Reason => CE_Range_Check_Failed);
3524 -- Now we will generate the assignments to do the actual concatenation
3526 -- There is one case in which we will not do this, namely when all the
3527 -- following conditions are met:
3529 -- The result type is Standard.String
3531 -- There are nine or fewer retained (non-null) operands
3533 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3534 -- and the debug flag gnatd.c is not set.
3536 -- The corresponding System.Concat_n.Str_Concat_n routine is
3537 -- available in the run time.
3539 -- If all these conditions are met then we generate a call to the
3540 -- relevant concatenation routine. The purpose of this is to avoid
3541 -- undesirable code bloat at -O0.
3543 -- If the concatenation is within the declaration of a library-level
3544 -- object, we call the built-in concatenation routines to prevent code
3545 -- bloat, regardless of the optimization level. This is space efficient
3546 -- and prevents linking problems when units are compiled with different
3547 -- optimization levels.
3549 if Atyp = Standard_String
3550 and then NN in 2 .. 9
3551 and then (((Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3552 and then not Debug_Flag_Dot_C)
3553 or else Library_Level_Target)
3556 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3567 if RTE_Available (RR (NN)) then
3569 Opnds : constant List_Id :=
3570 New_List (New_Occurrence_Of (Ent, Loc));
3573 for J in 1 .. NN loop
3574 if Is_List_Member (Operands (J)) then
3575 Remove (Operands (J));
3578 if Base_Type (Etype (Operands (J))) = Ctyp then
3580 Make_Aggregate (Loc,
3581 Component_Associations => New_List (
3582 Make_Component_Association (Loc,
3583 Choices => New_List (
3584 Make_Integer_Literal (Loc, 1)),
3585 Expression => Operands (J)))));
3588 Append_To (Opnds, Operands (J));
3592 Insert_Action (Cnode,
3593 Make_Procedure_Call_Statement (Loc,
3594 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
3595 Parameter_Associations => Opnds));
3597 -- No assignments left to do below
3605 -- Not special case so generate the assignments
3607 Known_Non_Null_Operand_Seen := False;
3609 for J in 1 .. NN loop
3611 Lo : constant Node_Id :=
3613 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3614 Right_Opnd => Aggr_Length (J - 1));
3616 Hi : constant Node_Id :=
3618 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3620 Make_Op_Subtract (Loc,
3621 Left_Opnd => Aggr_Length (J),
3622 Right_Opnd => Make_Artyp_Literal (Uint_1)));
3625 -- Singleton case, simple assignment
3627 if Base_Type (Etype (Operands (J))) = Ctyp then
3628 Known_Non_Null_Operand_Seen := True;
3629 Insert_Action (Cnode,
3630 Make_Assignment_Statement (Loc,
3632 Make_Indexed_Component (Loc,
3633 Prefix => New_Occurrence_Of (Ent, Loc),
3634 Expressions => New_List (To_Ityp (Lo))),
3635 Expression => Operands (J)),
3636 Suppress => All_Checks);
3638 -- Array case, slice assignment, skipped when argument is fixed
3639 -- length and known to be null.
3641 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3644 Make_Assignment_Statement (Loc,
3648 New_Occurrence_Of (Ent, Loc),
3651 Low_Bound => To_Ityp (Lo),
3652 High_Bound => To_Ityp (Hi))),
3653 Expression => Operands (J));
3655 if Is_Fixed_Length (J) then
3656 Known_Non_Null_Operand_Seen := True;
3658 elsif not Known_Non_Null_Operand_Seen then
3660 -- Here if operand length is not statically known and no
3661 -- operand known to be non-null has been processed yet.
3662 -- If operand length is 0, we do not need to perform the
3663 -- assignment, and we must avoid the evaluation of the
3664 -- high bound of the slice, since it may underflow if the
3665 -- low bound is Ityp'First.
3668 Make_Implicit_If_Statement (Cnode,
3672 New_Occurrence_Of (Var_Length (J), Loc),
3673 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3674 Then_Statements => New_List (Assign));
3677 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3683 -- Finally we build the result, which is either a direct reference to
3684 -- the array object or a slice of it.
3686 Result := New_Occurrence_Of (Ent, Loc);
3688 if Present (Slice_Rng) then
3689 Result := Make_Slice (Loc, Result, Slice_Rng);
3693 pragma Assert (Present (Result));
3694 Rewrite (Cnode, Result);
3695 Analyze_And_Resolve (Cnode, Atyp);
3696 end Expand_Concatenate;
3698 ---------------------------------------------------
3699 -- Expand_Membership_Minimize_Eliminate_Overflow --
3700 ---------------------------------------------------
3702 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3703 pragma Assert (Nkind (N) = N_In);
3704 -- Despite the name, this routine applies only to N_In, not to
3705 -- N_Not_In. The latter is always rewritten as not (X in Y).
3707 Result_Type : constant Entity_Id := Etype (N);
3708 -- Capture result type, may be a derived boolean type
3710 Loc : constant Source_Ptr := Sloc (N);
3711 Lop : constant Node_Id := Left_Opnd (N);
3712 Rop : constant Node_Id := Right_Opnd (N);
3714 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3715 -- is thus tempting to capture these values, but due to the rewrites
3716 -- that occur as a result of overflow checking, these values change
3717 -- as we go along, and it is safe just to always use Etype explicitly.
3719 Restype : constant Entity_Id := Etype (N);
3723 -- Bounds in Minimize calls, not used currently
3725 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3726 -- Entity for Long_Long_Integer'Base
3729 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3731 -- If right operand is a subtype name, and the subtype name has no
3732 -- predicate, then we can just replace the right operand with an
3733 -- explicit range T'First .. T'Last, and use the explicit range code.
3735 if Nkind (Rop) /= N_Range
3736 and then No (Predicate_Function (Etype (Rop)))
3739 Rtyp : constant Entity_Id := Etype (Rop);
3744 Make_Attribute_Reference (Loc,
3745 Attribute_Name => Name_First,
3746 Prefix => New_Occurrence_Of (Rtyp, Loc)),
3748 Make_Attribute_Reference (Loc,
3749 Attribute_Name => Name_Last,
3750 Prefix => New_Occurrence_Of (Rtyp, Loc))));
3751 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3755 -- Here for the explicit range case. Note that the bounds of the range
3756 -- have not been processed for minimized or eliminated checks.
3758 if Nkind (Rop) = N_Range then
3759 Minimize_Eliminate_Overflows
3760 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3761 Minimize_Eliminate_Overflows
3762 (High_Bound (Rop), Lo, Hi, Top_Level => False);
3764 -- We have A in B .. C, treated as A >= B and then A <= C
3768 if Is_RTE (Etype (Lop), RE_Bignum)
3769 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3770 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3773 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3774 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3775 L : constant Entity_Id :=
3776 Make_Defining_Identifier (Loc, Name_uL);
3777 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3778 Lbound : constant Node_Id :=
3779 Convert_To_Bignum (Low_Bound (Rop));
3780 Hbound : constant Node_Id :=
3781 Convert_To_Bignum (High_Bound (Rop));
3783 -- Now we rewrite the membership test node to look like
3786 -- Bnn : Result_Type;
3788 -- M : Mark_Id := SS_Mark;
3789 -- L : Bignum := Lopnd;
3791 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3799 -- Insert declaration of L into declarations of bignum block
3802 (Last (Declarations (Blk)),
3803 Make_Object_Declaration (Loc,
3804 Defining_Identifier => L,
3805 Object_Definition =>
3806 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3807 Expression => Lopnd));
3809 -- Insert assignment to Bnn into expressions of bignum block
3812 (First (Statements (Handled_Statement_Sequence (Blk))),
3813 Make_Assignment_Statement (Loc,
3814 Name => New_Occurrence_Of (Bnn, Loc),
3818 Make_Function_Call (Loc,
3820 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3821 Parameter_Associations => New_List (
3822 New_Occurrence_Of (L, Loc),
3826 Make_Function_Call (Loc,
3828 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3829 Parameter_Associations => New_List (
3830 New_Occurrence_Of (L, Loc),
3833 -- Now rewrite the node
3836 Make_Expression_With_Actions (Loc,
3837 Actions => New_List (
3838 Make_Object_Declaration (Loc,
3839 Defining_Identifier => Bnn,
3840 Object_Definition =>
3841 New_Occurrence_Of (Result_Type, Loc)),
3843 Expression => New_Occurrence_Of (Bnn, Loc)));
3844 Analyze_And_Resolve (N, Result_Type);
3848 -- Here if no bignums around
3851 -- Case where types are all the same
3853 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3855 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3859 -- If types are not all the same, it means that we have rewritten
3860 -- at least one of them to be of type Long_Long_Integer, and we
3861 -- will convert the other operands to Long_Long_Integer.
3864 Convert_To_And_Rewrite (LLIB, Lop);
3865 Set_Analyzed (Lop, False);
3866 Analyze_And_Resolve (Lop, LLIB);
3868 -- For the right operand, avoid unnecessary recursion into
3869 -- this routine, we know that overflow is not possible.
3871 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3872 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3873 Set_Analyzed (Rop, False);
3874 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3877 -- Now the three operands are of the same signed integer type,
3878 -- so we can use the normal expansion routine for membership,
3879 -- setting the flag to prevent recursion into this procedure.
3881 Set_No_Minimize_Eliminate (N);
3885 -- Right operand is a subtype name and the subtype has a predicate. We
3886 -- have to make sure the predicate is checked, and for that we need to
3887 -- use the standard N_In circuitry with appropriate types.
3890 pragma Assert (Present (Predicate_Function (Etype (Rop))));
3892 -- If types are "right", just call Expand_N_In preventing recursion
3894 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3895 Set_No_Minimize_Eliminate (N);
3900 elsif Is_RTE (Etype (Lop), RE_Bignum) then
3902 -- For X in T, we want to rewrite our node as
3905 -- Bnn : Result_Type;
3908 -- M : Mark_Id := SS_Mark;
3909 -- Lnn : Long_Long_Integer'Base
3915 -- if not Bignum_In_LLI_Range (Nnn) then
3918 -- Lnn := From_Bignum (Nnn);
3920 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3921 -- and then T'Base (Lnn) in T;
3930 -- A bit gruesome, but there doesn't seem to be a simpler way
3933 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3934 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3935 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
3936 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
3937 T : constant Entity_Id := Etype (Rop);
3938 TB : constant Entity_Id := Base_Type (T);
3942 -- Mark the last membership operation to prevent recursion
3946 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
3947 Right_Opnd => New_Occurrence_Of (T, Loc));
3948 Set_No_Minimize_Eliminate (Nin);
3950 -- Now decorate the block
3953 (Last (Declarations (Blk)),
3954 Make_Object_Declaration (Loc,
3955 Defining_Identifier => Lnn,
3956 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
3959 (Last (Declarations (Blk)),
3960 Make_Object_Declaration (Loc,
3961 Defining_Identifier => Nnn,
3962 Object_Definition =>
3963 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
3966 (First (Statements (Handled_Statement_Sequence (Blk))),
3968 Make_Assignment_Statement (Loc,
3969 Name => New_Occurrence_Of (Nnn, Loc),
3970 Expression => Relocate_Node (Lop)),
3972 Make_Implicit_If_Statement (N,
3976 Make_Function_Call (Loc,
3979 (RTE (RE_Bignum_In_LLI_Range), Loc),
3980 Parameter_Associations => New_List (
3981 New_Occurrence_Of (Nnn, Loc)))),
3983 Then_Statements => New_List (
3984 Make_Assignment_Statement (Loc,
3985 Name => New_Occurrence_Of (Bnn, Loc),
3987 New_Occurrence_Of (Standard_False, Loc))),
3989 Else_Statements => New_List (
3990 Make_Assignment_Statement (Loc,
3991 Name => New_Occurrence_Of (Lnn, Loc),
3993 Make_Function_Call (Loc,
3995 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
3996 Parameter_Associations => New_List (
3997 New_Occurrence_Of (Nnn, Loc)))),
3999 Make_Assignment_Statement (Loc,
4000 Name => New_Occurrence_Of (Bnn, Loc),
4005 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
4010 Make_Attribute_Reference (Loc,
4011 Attribute_Name => Name_First,
4013 New_Occurrence_Of (TB, Loc))),
4017 Make_Attribute_Reference (Loc,
4018 Attribute_Name => Name_Last,
4020 New_Occurrence_Of (TB, Loc))))),
4022 Right_Opnd => Nin))))));
4024 -- Now we can do the rewrite
4027 Make_Expression_With_Actions (Loc,
4028 Actions => New_List (
4029 Make_Object_Declaration (Loc,
4030 Defining_Identifier => Bnn,
4031 Object_Definition =>
4032 New_Occurrence_Of (Result_Type, Loc)),
4034 Expression => New_Occurrence_Of (Bnn, Loc)));
4035 Analyze_And_Resolve (N, Result_Type);
4039 -- Not bignum case, but types don't match (this means we rewrote the
4040 -- left operand to be Long_Long_Integer).
4043 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
4045 -- We rewrite the membership test as (where T is the type with
4046 -- the predicate, i.e. the type of the right operand)
4048 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4049 -- and then T'Base (Lop) in T
4052 T : constant Entity_Id := Etype (Rop);
4053 TB : constant Entity_Id := Base_Type (T);
4057 -- The last membership test is marked to prevent recursion
4061 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
4062 Right_Opnd => New_Occurrence_Of (T, Loc));
4063 Set_No_Minimize_Eliminate (Nin);
4065 -- Now do the rewrite
4076 Make_Attribute_Reference (Loc,
4077 Attribute_Name => Name_First,
4079 New_Occurrence_Of (TB, Loc))),
4082 Make_Attribute_Reference (Loc,
4083 Attribute_Name => Name_Last,
4085 New_Occurrence_Of (TB, Loc))))),
4086 Right_Opnd => Nin));
4087 Set_Analyzed (N, False);
4088 Analyze_And_Resolve (N, Restype);
4092 end Expand_Membership_Minimize_Eliminate_Overflow;
4094 ---------------------------------
4095 -- Expand_Nonbinary_Modular_Op --
4096 ---------------------------------
4098 procedure Expand_Nonbinary_Modular_Op (N : Node_Id) is
4099 Loc : constant Source_Ptr := Sloc (N);
4100 Typ : constant Entity_Id := Etype (N);
4102 procedure Expand_Modular_Addition;
4103 -- Expand the modular addition, handling the special case of adding a
4106 procedure Expand_Modular_Op;
4107 -- Compute the general rule: (lhs OP rhs) mod Modulus
4109 procedure Expand_Modular_Subtraction;
4110 -- Expand the modular addition, handling the special case of subtracting
4113 -----------------------------
4114 -- Expand_Modular_Addition --
4115 -----------------------------
4117 procedure Expand_Modular_Addition is
4119 -- If this is not the addition of a constant then compute it using
4120 -- the general rule: (lhs + rhs) mod Modulus
4122 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4125 -- If this is an addition of a constant, convert it to a subtraction
4126 -- plus a conditional expression since we can compute it faster than
4127 -- computing the modulus.
4129 -- modMinusRhs = Modulus - rhs
4130 -- if lhs < modMinusRhs then lhs + rhs
4131 -- else lhs - modMinusRhs
4135 Mod_Minus_Right : constant Uint :=
4136 Modulus (Typ) - Intval (Right_Opnd (N));
4138 Exprs : constant List_Id := New_List;
4139 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4140 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4141 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4144 -- To prevent spurious visibility issues, convert all
4145 -- operands to Standard.Unsigned.
4147 Set_Left_Opnd (Cond_Expr,
4148 Unchecked_Convert_To (Standard_Unsigned,
4149 New_Copy_Tree (Left_Opnd (N))));
4150 Set_Right_Opnd (Cond_Expr,
4151 Make_Integer_Literal (Loc, Mod_Minus_Right));
4152 Append_To (Exprs, Cond_Expr);
4154 Set_Left_Opnd (Then_Expr,
4155 Unchecked_Convert_To (Standard_Unsigned,
4156 New_Copy_Tree (Left_Opnd (N))));
4157 Set_Right_Opnd (Then_Expr,
4158 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4159 Append_To (Exprs, Then_Expr);
4161 Set_Left_Opnd (Else_Expr,
4162 Unchecked_Convert_To (Standard_Unsigned,
4163 New_Copy_Tree (Left_Opnd (N))));
4164 Set_Right_Opnd (Else_Expr,
4165 Make_Integer_Literal (Loc, Mod_Minus_Right));
4166 Append_To (Exprs, Else_Expr);
4169 Unchecked_Convert_To (Typ,
4170 Make_If_Expression (Loc, Expressions => Exprs)));
4173 end Expand_Modular_Addition;
4175 -----------------------
4176 -- Expand_Modular_Op --
4177 -----------------------
4179 procedure Expand_Modular_Op is
4180 -- We will convert to another type (not a nonbinary-modulus modular
4181 -- type), evaluate the op in that representation, reduce the result,
4182 -- and convert back to the original type. This means that the
4183 -- backend does not have to deal with nonbinary-modulus ops.
4185 Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc);
4186 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc);
4188 Target_Type : Entity_Id;
4190 -- Select a target type that is large enough to avoid spurious
4191 -- intermediate overflow on pre-reduction computation (for
4192 -- correctness) but is no larger than is needed (for performance).
4195 Required_Size : Uint := RM_Size (Etype (N));
4196 Use_Unsigned : Boolean := True;
4200 -- For example, if modulus is 255 then RM_Size will be 8
4201 -- and the range of possible values (before reduction) will
4202 -- be 0 .. 508; that range requires 9 bits.
4203 Required_Size := Required_Size + 1;
4205 when N_Op_Subtract =>
4206 -- For example, if modulus is 255 then RM_Size will be 8
4207 -- and the range of possible values (before reduction) will
4208 -- be -254 .. 254; that range requires 9 bits, signed.
4209 Use_Unsigned := False;
4210 Required_Size := Required_Size + 1;
4212 when N_Op_Multiply =>
4213 -- For example, if modulus is 255 then RM_Size will be 8
4214 -- and the range of possible values (before reduction) will
4215 -- be 0 .. 64,516; that range requires 16 bits.
4216 Required_Size := Required_Size * 2;
4222 if Use_Unsigned then
4223 if Required_Size <= Standard_Short_Short_Integer_Size then
4224 Target_Type := Standard_Short_Short_Unsigned;
4225 elsif Required_Size <= Standard_Short_Integer_Size then
4226 Target_Type := Standard_Short_Unsigned;
4227 elsif Required_Size <= Standard_Integer_Size then
4228 Target_Type := Standard_Unsigned;
4230 pragma Assert (Required_Size <= 64);
4231 Target_Type := Standard_Unsigned_64;
4233 elsif Required_Size <= 8 then
4234 Target_Type := Standard_Integer_8;
4235 elsif Required_Size <= 16 then
4236 Target_Type := Standard_Integer_16;
4237 elsif Required_Size <= 32 then
4238 Target_Type := Standard_Integer_32;
4240 pragma Assert (Required_Size <= 64);
4241 Target_Type := Standard_Integer_64;
4244 pragma Assert (Present (Target_Type));
4247 Set_Left_Opnd (Op_Expr,
4248 Unchecked_Convert_To (Target_Type,
4249 New_Copy_Tree (Left_Opnd (N))));
4250 Set_Right_Opnd (Op_Expr,
4251 Unchecked_Convert_To (Target_Type,
4252 New_Copy_Tree (Right_Opnd (N))));
4254 -- ??? Why do this stuff for some ops and not others?
4255 if Nkind (N) not in N_Op_And | N_Op_Or | N_Op_Xor then
4257 -- Link this node to the tree to analyze it
4259 -- If the parent node is an expression with actions we link it to
4260 -- N since otherwise Force_Evaluation cannot identify if this node
4261 -- comes from the Expression and rejects generating the temporary.
4263 if Nkind (Parent (N)) = N_Expression_With_Actions then
4264 Set_Parent (Op_Expr, N);
4269 Set_Parent (Op_Expr, Parent (N));
4274 -- Force generating a temporary because in the expansion of this
4275 -- expression we may generate code that performs this computation
4278 Force_Evaluation (Op_Expr, Mode => Strict);
4281 Set_Left_Opnd (Mod_Expr, Op_Expr);
4283 Set_Right_Opnd (Mod_Expr,
4284 Make_Integer_Literal (Loc, Modulus (Typ)));
4287 Unchecked_Convert_To (Typ, Mod_Expr));
4288 end Expand_Modular_Op;
4290 --------------------------------
4291 -- Expand_Modular_Subtraction --
4292 --------------------------------
4294 procedure Expand_Modular_Subtraction is
4296 -- If this is not the addition of a constant then compute it using
4297 -- the general rule: (lhs + rhs) mod Modulus
4299 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4302 -- If this is an addition of a constant, convert it to a subtraction
4303 -- plus a conditional expression since we can compute it faster than
4304 -- computing the modulus.
4306 -- modMinusRhs = Modulus - rhs
4307 -- if lhs < rhs then lhs + modMinusRhs
4312 Mod_Minus_Right : constant Uint :=
4313 Modulus (Typ) - Intval (Right_Opnd (N));
4315 Exprs : constant List_Id := New_List;
4316 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4317 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4318 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4321 Set_Left_Opnd (Cond_Expr,
4322 Unchecked_Convert_To (Standard_Unsigned,
4323 New_Copy_Tree (Left_Opnd (N))));
4324 Set_Right_Opnd (Cond_Expr,
4325 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4326 Append_To (Exprs, Cond_Expr);
4328 Set_Left_Opnd (Then_Expr,
4329 Unchecked_Convert_To (Standard_Unsigned,
4330 New_Copy_Tree (Left_Opnd (N))));
4331 Set_Right_Opnd (Then_Expr,
4332 Make_Integer_Literal (Loc, Mod_Minus_Right));
4333 Append_To (Exprs, Then_Expr);
4335 Set_Left_Opnd (Else_Expr,
4336 Unchecked_Convert_To (Standard_Unsigned,
4337 New_Copy_Tree (Left_Opnd (N))));
4338 Set_Right_Opnd (Else_Expr,
4339 Unchecked_Convert_To (Standard_Unsigned,
4340 New_Copy_Tree (Right_Opnd (N))));
4341 Append_To (Exprs, Else_Expr);
4344 Unchecked_Convert_To (Typ,
4345 Make_If_Expression (Loc, Expressions => Exprs)));
4348 end Expand_Modular_Subtraction;
4350 -- Start of processing for Expand_Nonbinary_Modular_Op
4353 -- No action needed if front-end expansion is not required or if we
4354 -- have a binary modular operand.
4356 if not Expand_Nonbinary_Modular_Ops
4357 or else not Non_Binary_Modulus (Typ)
4364 Expand_Modular_Addition;
4366 when N_Op_Subtract =>
4367 Expand_Modular_Subtraction;
4371 -- Expand -expr into (0 - expr)
4374 Make_Op_Subtract (Loc,
4375 Left_Opnd => Make_Integer_Literal (Loc, 0),
4376 Right_Opnd => Right_Opnd (N)));
4377 Analyze_And_Resolve (N, Typ);
4383 Analyze_And_Resolve (N, Typ);
4384 end Expand_Nonbinary_Modular_Op;
4386 ------------------------
4387 -- Expand_N_Allocator --
4388 ------------------------
4390 procedure Expand_N_Allocator (N : Node_Id) is
4391 Etyp : constant Entity_Id := Etype (Expression (N));
4392 Loc : constant Source_Ptr := Sloc (N);
4393 PtrT : constant Entity_Id := Etype (N);
4395 procedure Rewrite_Coextension (N : Node_Id);
4396 -- Static coextensions have the same lifetime as the entity they
4397 -- constrain. Such occurrences can be rewritten as aliased objects
4398 -- and their unrestricted access used instead of the coextension.
4400 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
4401 -- Given a constrained array type E, returns a node representing the
4402 -- code to compute a close approximation of the size in storage elements
4403 -- for the given type; for indexes that are modular types we compute
4404 -- 'Last - First (instead of 'Length) because for large arrays computing
4405 -- 'Last -'First + 1 causes overflow. This is done without using the
4406 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4409 -------------------------
4410 -- Rewrite_Coextension --
4411 -------------------------
4413 procedure Rewrite_Coextension (N : Node_Id) is
4414 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
4415 Temp_Decl : Node_Id;
4419 -- Cnn : aliased Etyp;
4422 Make_Object_Declaration (Loc,
4423 Defining_Identifier => Temp_Id,
4424 Aliased_Present => True,
4425 Object_Definition => New_Occurrence_Of (Etyp, Loc));
4427 if Nkind (Expression (N)) = N_Qualified_Expression then
4428 Set_Expression (Temp_Decl, Expression (Expression (N)));
4431 Insert_Action (N, Temp_Decl);
4433 Make_Attribute_Reference (Loc,
4434 Prefix => New_Occurrence_Of (Temp_Id, Loc),
4435 Attribute_Name => Name_Unrestricted_Access));
4437 Analyze_And_Resolve (N, PtrT);
4438 end Rewrite_Coextension;
4440 ------------------------------
4441 -- Size_In_Storage_Elements --
4442 ------------------------------
4444 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
4445 Idx : Node_Id := First_Index (E);
4447 Res : Node_Id := Empty;
4450 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4451 -- However, the reason for the existence of this function is to
4452 -- construct a test for sizes too large, which means near the 32-bit
4453 -- limit on a 32-bit machine, and precisely the trouble is that we
4454 -- get overflows when sizes are greater than 2**31.
4456 -- So what we end up doing for array types is to use the expression:
4458 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4460 -- which avoids this problem. All this is a bit bogus, but it does
4461 -- mean we catch common cases of trying to allocate arrays that are
4462 -- too large, and which in the absence of a check results in
4463 -- undetected chaos ???
4465 for J in 1 .. Number_Dimensions (E) loop
4467 if not Is_Modular_Integer_Type (Etype (Idx)) then
4469 Make_Attribute_Reference (Loc,
4470 Prefix => New_Occurrence_Of (E, Loc),
4471 Attribute_Name => Name_Length,
4472 Expressions => New_List (Make_Integer_Literal (Loc, J)));
4474 -- For indexes that are modular types we cannot generate code to
4475 -- compute 'Length since for large arrays 'Last -'First + 1 causes
4476 -- overflow; therefore we compute 'Last - 'First (which is not the
4477 -- exact number of components but it is valid for the purpose of
4478 -- this runtime check on 32-bit targets).
4482 Len_Minus_1_Expr : Node_Id;
4488 Make_Attribute_Reference (Loc,
4489 Prefix => New_Occurrence_Of (E, Loc),
4490 Attribute_Name => Name_Last,
4492 New_List (Make_Integer_Literal (Loc, J))),
4493 Make_Attribute_Reference (Loc,
4494 Prefix => New_Occurrence_Of (E, Loc),
4495 Attribute_Name => Name_First,
4497 New_List (Make_Integer_Literal (Loc, J))));
4500 Convert_To (Standard_Unsigned,
4501 Make_Op_Subtract (Loc,
4502 Make_Attribute_Reference (Loc,
4503 Prefix => New_Occurrence_Of (E, Loc),
4504 Attribute_Name => Name_Last,
4506 New_List (Make_Integer_Literal (Loc, J))),
4507 Make_Attribute_Reference (Loc,
4508 Prefix => New_Occurrence_Of (E, Loc),
4509 Attribute_Name => Name_First,
4511 New_List (Make_Integer_Literal (Loc, J)))));
4513 -- Handle superflat arrays, i.e. arrays with such bounds as
4514 -- 4 .. 2, to ensure that the result is correct.
4517 -- (if X'Last > X'First then X'Last - X'First else 0)
4520 Make_If_Expression (Loc,
4521 Expressions => New_List (
4524 Make_Integer_Literal (Loc, Uint_0)));
4532 pragma Assert (Present (Res));
4534 Make_Op_Multiply (Loc,
4543 Make_Op_Multiply (Loc,
4546 Make_Attribute_Reference (Loc,
4547 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4548 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4549 end Size_In_Storage_Elements;
4553 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
4557 Rel_Typ : Entity_Id;
4560 -- Start of processing for Expand_N_Allocator
4563 -- Warn on the presence of an allocator of an anonymous access type when
4564 -- enabled, except when it's an object declaration at library level.
4566 if Warn_On_Anonymous_Allocators
4567 and then Ekind (PtrT) = E_Anonymous_Access_Type
4568 and then not (Is_Library_Level_Entity (PtrT)
4569 and then Nkind (Associated_Node_For_Itype (PtrT)) =
4570 N_Object_Declaration)
4572 Error_Msg_N ("?_a?use of an anonymous access type allocator", N);
4575 -- RM E.2.2(17). We enforce that the expected type of an allocator
4576 -- shall not be a remote access-to-class-wide-limited-private type.
4577 -- We probably shouldn't be doing this legality check during expansion,
4578 -- but this is only an issue for Annex E users, and is unlikely to be a
4579 -- problem in practice.
4581 Validate_Remote_Access_To_Class_Wide_Type (N);
4583 -- Processing for anonymous access-to-controlled types. These access
4584 -- types receive a special finalization master which appears in the
4585 -- declarations of the enclosing semantic unit. This expansion is done
4586 -- now to ensure that any additional types generated by this routine or
4587 -- Expand_Allocator_Expression inherit the proper type attributes.
4589 if (Ekind (PtrT) = E_Anonymous_Access_Type
4590 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4591 and then Needs_Finalization (Dtyp)
4593 -- Detect the allocation of an anonymous controlled object where the
4594 -- type of the context is named. For example:
4596 -- procedure Proc (Ptr : Named_Access_Typ);
4597 -- Proc (new Designated_Typ);
4599 -- Regardless of the anonymous-to-named access type conversion, the
4600 -- lifetime of the object must be associated with the named access
4601 -- type. Use the finalization-related attributes of this type.
4603 if Nkind (Parent (N)) in N_Type_Conversion
4604 | N_Unchecked_Type_Conversion
4605 and then Ekind (Etype (Parent (N))) in E_Access_Subtype
4607 | E_General_Access_Type
4609 Rel_Typ := Etype (Parent (N));
4614 -- Anonymous access-to-controlled types allocate on the global pool.
4615 -- Note that this is a "root type only" attribute.
4617 if No (Associated_Storage_Pool (PtrT)) then
4618 if Present (Rel_Typ) then
4619 Set_Associated_Storage_Pool
4620 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
4622 Set_Associated_Storage_Pool
4623 (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
4627 -- The finalization master must be inserted and analyzed as part of
4628 -- the current semantic unit. Note that the master is updated when
4629 -- analysis changes current units. Note that this is a "root type
4632 if Present (Rel_Typ) then
4633 Set_Finalization_Master
4634 (Root_Type (PtrT), Finalization_Master (Rel_Typ));
4636 Build_Anonymous_Master (Root_Type (PtrT));
4640 -- Set the storage pool and find the appropriate version of Allocate to
4641 -- call. Do not overwrite the storage pool if it is already set, which
4642 -- can happen for build-in-place function returns (see
4643 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4645 if No (Storage_Pool (N)) then
4646 Pool := Associated_Storage_Pool (Root_Type (PtrT));
4648 if Present (Pool) then
4649 Set_Storage_Pool (N, Pool);
4651 if Is_RTE (Pool, RE_RS_Pool) then
4652 Set_Procedure_To_Call (N, RTE (RE_RS_Allocate));
4654 elsif Is_RTE (Pool, RE_SS_Pool) then
4655 Check_Restriction (No_Secondary_Stack, N);
4656 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4658 -- In the case of an allocator for a simple storage pool, locate
4659 -- and save a reference to the pool type's Allocate routine.
4661 elsif Present (Get_Rep_Pragma
4662 (Etype (Pool), Name_Simple_Storage_Pool_Type))
4665 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4666 Alloc_Op : Entity_Id;
4668 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4669 while Present (Alloc_Op) loop
4670 if Scope (Alloc_Op) = Scope (Pool_Type)
4671 and then Present (First_Formal (Alloc_Op))
4672 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4674 Set_Procedure_To_Call (N, Alloc_Op);
4677 Alloc_Op := Homonym (Alloc_Op);
4682 elsif Is_Class_Wide_Type (Etype (Pool)) then
4683 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4686 Set_Procedure_To_Call (N,
4687 Find_Storage_Op (Etype (Pool), Name_Allocate));
4692 -- Under certain circumstances we can replace an allocator by an access
4693 -- to statically allocated storage. The conditions, as noted in AARM
4694 -- 3.10 (10c) are as follows:
4696 -- Size and initial value is known at compile time
4697 -- Access type is access-to-constant
4699 -- The allocator is not part of a constraint on a record component,
4700 -- because in that case the inserted actions are delayed until the
4701 -- record declaration is fully analyzed, which is too late for the
4702 -- analysis of the rewritten allocator.
4704 if Is_Access_Constant (PtrT)
4705 and then Nkind (Expression (N)) = N_Qualified_Expression
4706 and then Compile_Time_Known_Value (Expression (Expression (N)))
4707 and then Size_Known_At_Compile_Time
4708 (Etype (Expression (Expression (N))))
4709 and then not Is_Record_Type (Current_Scope)
4711 -- Here we can do the optimization. For the allocator
4715 -- We insert an object declaration
4717 -- Tnn : aliased x := y;
4719 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4720 -- marked as requiring static allocation.
4722 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4723 Desig := Subtype_Mark (Expression (N));
4725 -- If context is constrained, use constrained subtype directly,
4726 -- so that the constant is not labelled as having a nominally
4727 -- unconstrained subtype.
4729 if Entity (Desig) = Base_Type (Dtyp) then
4730 Desig := New_Occurrence_Of (Dtyp, Loc);
4734 Make_Object_Declaration (Loc,
4735 Defining_Identifier => Temp,
4736 Aliased_Present => True,
4737 Constant_Present => Is_Access_Constant (PtrT),
4738 Object_Definition => Desig,
4739 Expression => Expression (Expression (N))));
4742 Make_Attribute_Reference (Loc,
4743 Prefix => New_Occurrence_Of (Temp, Loc),
4744 Attribute_Name => Name_Unrestricted_Access));
4746 Analyze_And_Resolve (N, PtrT);
4748 -- We set the variable as statically allocated, since we don't want
4749 -- it going on the stack of the current procedure.
4751 Set_Is_Statically_Allocated (Temp);
4755 -- Same if the allocator is an access discriminant for a local object:
4756 -- instead of an allocator we create a local value and constrain the
4757 -- enclosing object with the corresponding access attribute.
4759 if Is_Static_Coextension (N) then
4760 Rewrite_Coextension (N);
4764 -- Check for size too large, we do this because the back end misses
4765 -- proper checks here and can generate rubbish allocation calls when
4766 -- we are near the limit. We only do this for the 32-bit address case
4767 -- since that is from a practical point of view where we see a problem.
4769 if System_Address_Size = 32
4770 and then not Storage_Checks_Suppressed (PtrT)
4771 and then not Storage_Checks_Suppressed (Dtyp)
4772 and then not Storage_Checks_Suppressed (Etyp)
4774 -- The check we want to generate should look like
4776 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4777 -- raise Storage_Error;
4780 -- where 3.5 gigabytes is a constant large enough to accommodate any
4781 -- reasonable request for. But we can't do it this way because at
4782 -- least at the moment we don't compute this attribute right, and
4783 -- can silently give wrong results when the result gets large. Since
4784 -- this is all about large results, that's bad, so instead we only
4785 -- apply the check for constrained arrays, and manually compute the
4786 -- value of the attribute ???
4788 -- The check on No_Initialization is used here to prevent generating
4789 -- this runtime check twice when the allocator is locally replaced by
4790 -- the expander with another one.
4792 if Is_Array_Type (Etyp) and then not No_Initialization (N) then
4795 Ins_Nod : Node_Id := N;
4796 Siz_Typ : Entity_Id := Etyp;
4800 -- For unconstrained array types initialized with a qualified
4801 -- expression we use its type to perform this check
4803 if not Is_Constrained (Etyp)
4804 and then not No_Initialization (N)
4805 and then Nkind (Expression (N)) = N_Qualified_Expression
4807 Expr := Expression (Expression (N));
4808 Siz_Typ := Etype (Expression (Expression (N)));
4810 -- If the qualified expression has been moved to an internal
4811 -- temporary (to remove side effects) then we must insert
4812 -- the runtime check before its declaration to ensure that
4813 -- the check is performed before the execution of the code
4814 -- computing the qualified expression.
4816 if Nkind (Expr) = N_Identifier
4817 and then Is_Internal_Name (Chars (Expr))
4819 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
4821 Ins_Nod := Parent (Entity (Expr));
4827 if Is_Constrained (Siz_Typ)
4828 and then Ekind (Siz_Typ) /= E_String_Literal_Subtype
4830 -- For CCG targets, the largest array may have up to 2**31-1
4831 -- components (i.e. 2 gigabytes if each array component is
4832 -- one byte). This ensures that fat pointer fields do not
4833 -- overflow, since they are 32-bit integer types, and also
4834 -- ensures that 'Length can be computed at run time.
4836 if Modify_Tree_For_C then
4839 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4840 Right_Opnd => Make_Integer_Literal (Loc,
4841 Uint_2 ** 31 - Uint_1));
4843 -- For native targets the largest object is 3.5 gigabytes
4848 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4849 Right_Opnd => Make_Integer_Literal (Loc,
4850 Uint_7 * (Uint_2 ** 29)));
4853 Insert_Action (Ins_Nod,
4854 Make_Raise_Storage_Error (Loc,
4856 Reason => SE_Object_Too_Large));
4858 if Entity (Cond) = Standard_True then
4860 ("object too large: Storage_Error will be raised at "
4868 -- If no storage pool has been specified, or the storage pool
4869 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4870 -- No_Standard_Allocators_After_Elaboration is present, then generate
4871 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4873 if Nkind (N) = N_Allocator
4874 and then (No (Storage_Pool (N))
4875 or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object))
4876 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
4879 Make_Procedure_Call_Statement (Loc,
4881 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc)));
4884 -- Handle case of qualified expression (other than optimization above)
4886 if Nkind (Expression (N)) = N_Qualified_Expression then
4887 Expand_Allocator_Expression (N);
4891 -- If the allocator is for a type which requires initialization, and
4892 -- there is no initial value (i.e. operand is a subtype indication
4893 -- rather than a qualified expression), then we must generate a call to
4894 -- the initialization routine using an expressions action node:
4896 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4898 -- Here ptr_T is the pointer type for the allocator, and T is the
4899 -- subtype of the allocator. A special case arises if the designated
4900 -- type of the access type is a task or contains tasks. In this case
4901 -- the call to Init (Temp.all ...) is replaced by code that ensures
4902 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4903 -- for details). In addition, if the type T is a task type, then the
4904 -- first argument to Init must be converted to the task record type.
4907 T : constant Entity_Id := Etype (Expression (N));
4913 Init_Arg1 : Node_Id;
4914 Init_Call : Node_Id;
4915 Temp_Decl : Node_Id;
4916 Temp_Type : Entity_Id;
4919 -- Apply constraint checks against designated subtype (RM 4.8(10/2))
4920 -- but ignore the expression if the No_Initialization flag is set.
4921 -- Discriminant checks will be generated by the expansion below.
4923 if Is_Array_Type (Dtyp) and then not No_Initialization (N) then
4924 Apply_Constraint_Check (Expression (N), Dtyp, No_Sliding => True);
4926 Apply_Predicate_Check (Expression (N), Dtyp);
4928 if Nkind (Expression (N)) = N_Raise_Constraint_Error then
4929 Rewrite (N, New_Copy (Expression (N)));
4930 Set_Etype (N, PtrT);
4935 if No_Initialization (N) then
4937 -- Even though this might be a simple allocation, create a custom
4938 -- Allocate if the context requires it.
4940 if Present (Finalization_Master (PtrT)) then
4941 Build_Allocate_Deallocate_Proc
4943 Is_Allocate => True);
4946 -- Optimize the default allocation of an array object when pragma
4947 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4948 -- in-place initialization aggregate which may be convert into a fast
4949 -- memset by the backend.
4951 elsif Init_Or_Norm_Scalars
4952 and then Is_Array_Type (T)
4954 -- The array must lack atomic components because they are treated
4955 -- as non-static, and as a result the backend will not initialize
4956 -- the memory in one go.
4958 and then not Has_Atomic_Components (T)
4960 -- The array must not be packed because the invalid values in
4961 -- System.Scalar_Values are multiples of Storage_Unit.
4963 and then not Is_Packed (T)
4965 -- The array must have static non-empty ranges, otherwise the
4966 -- backend cannot initialize the memory in one go.
4968 and then Has_Static_Non_Empty_Array_Bounds (T)
4970 -- The optimization is only relevant for arrays of scalar types
4972 and then Is_Scalar_Type (Component_Type (T))
4974 -- Similar to regular array initialization using a type init proc,
4975 -- predicate checks are not performed because the initialization
4976 -- values are intentionally invalid, and may violate the predicate.
4978 and then not Has_Predicates (Component_Type (T))
4980 -- The component type must have a single initialization value
4982 and then Needs_Simple_Initialization
4983 (Typ => Component_Type (T),
4984 Consider_IS => True)
4987 Temp := Make_Temporary (Loc, 'P');
4990 -- Temp : Ptr_Typ := new ...;
4995 Make_Object_Declaration (Loc,
4996 Defining_Identifier => Temp,
4997 Object_Definition => New_Occurrence_Of (PtrT, Loc),
4998 Expression => Relocate_Node (N)),
4999 Suppress => All_Checks);
5002 -- Temp.all := (others => ...);
5007 Make_Assignment_Statement (Loc,
5009 Make_Explicit_Dereference (Loc,
5010 Prefix => New_Occurrence_Of (Temp, Loc)),
5015 Size => Esize (Component_Type (T)))),
5016 Suppress => All_Checks);
5018 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5019 Analyze_And_Resolve (N, PtrT);
5021 -- Case of no initialization procedure present
5023 elsif not Has_Non_Null_Base_Init_Proc (T) then
5025 -- Case of simple initialization required
5027 if Needs_Simple_Initialization (T) then
5028 Check_Restriction (No_Default_Initialization, N);
5029 Rewrite (Expression (N),
5030 Make_Qualified_Expression (Loc,
5031 Subtype_Mark => New_Occurrence_Of (T, Loc),
5032 Expression => Get_Simple_Init_Val (T, N)));
5034 Analyze_And_Resolve (Expression (Expression (N)), T);
5035 Analyze_And_Resolve (Expression (N), T);
5036 Set_Paren_Count (Expression (Expression (N)), 1);
5037 Expand_N_Allocator (N);
5039 -- No initialization required
5042 Build_Allocate_Deallocate_Proc
5044 Is_Allocate => True);
5047 -- Case of initialization procedure present, must be called
5049 -- NOTE: There is a *huge* amount of code duplication here from
5050 -- Build_Initialization_Call. We should probably refactor???
5053 Check_Restriction (No_Default_Initialization, N);
5055 if not Restriction_Active (No_Default_Initialization) then
5056 Init := Base_Init_Proc (T);
5058 Temp := Make_Temporary (Loc, 'P');
5060 -- Construct argument list for the initialization routine call
5063 Make_Explicit_Dereference (Loc,
5065 New_Occurrence_Of (Temp, Loc));
5067 Set_Assignment_OK (Init_Arg1);
5070 -- The initialization procedure expects a specific type. if the
5071 -- context is access to class wide, indicate that the object
5072 -- being allocated has the right specific type.
5074 if Is_Class_Wide_Type (Dtyp) then
5075 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
5078 -- If designated type is a concurrent type or if it is private
5079 -- type whose definition is a concurrent type, the first
5080 -- argument in the Init routine has to be unchecked conversion
5081 -- to the corresponding record type. If the designated type is
5082 -- a derived type, also convert the argument to its root type.
5084 if Is_Concurrent_Type (T) then
5086 Unchecked_Convert_To (
5087 Corresponding_Record_Type (T), Init_Arg1);
5089 elsif Is_Private_Type (T)
5090 and then Present (Full_View (T))
5091 and then Is_Concurrent_Type (Full_View (T))
5094 Unchecked_Convert_To
5095 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
5097 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
5099 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
5102 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
5103 Set_Etype (Init_Arg1, Ftyp);
5107 Args := New_List (Init_Arg1);
5109 -- For the task case, pass the Master_Id of the access type as
5110 -- the value of the _Master parameter, and _Chain as the value
5111 -- of the _Chain parameter (_Chain will be defined as part of
5112 -- the generated code for the allocator).
5114 -- In Ada 2005, the context may be a function that returns an
5115 -- anonymous access type. In that case the Master_Id has been
5116 -- created when expanding the function declaration.
5118 if Has_Task (T) then
5119 if No (Master_Id (Base_Type (PtrT))) then
5121 -- The designated type was an incomplete type, and the
5122 -- access type did not get expanded. Salvage it now.
5124 if Present (Parent (Base_Type (PtrT))) then
5125 Expand_N_Full_Type_Declaration
5126 (Parent (Base_Type (PtrT)));
5128 -- The only other possibility is an itype. For this
5129 -- case, the master must exist in the context. This is
5130 -- the case when the allocator initializes an access
5131 -- component in an init-proc.
5134 pragma Assert (Is_Itype (PtrT));
5135 Build_Master_Renaming (PtrT, N);
5139 -- If the context of the allocator is a declaration or an
5140 -- assignment, we can generate a meaningful image for it,
5141 -- even though subsequent assignments might remove the
5142 -- connection between task and entity. We build this image
5143 -- when the left-hand side is a simple variable, a simple
5144 -- indexed assignment or a simple selected component.
5146 if Nkind (Parent (N)) = N_Assignment_Statement then
5148 Nam : constant Node_Id := Name (Parent (N));
5151 if Is_Entity_Name (Nam) then
5153 Build_Task_Image_Decls
5156 (Entity (Nam), Sloc (Nam)), T);
5158 elsif Nkind (Nam) in N_Indexed_Component
5159 | N_Selected_Component
5160 and then Is_Entity_Name (Prefix (Nam))
5163 Build_Task_Image_Decls
5164 (Loc, Nam, Etype (Prefix (Nam)));
5166 Decls := Build_Task_Image_Decls (Loc, T, T);
5170 elsif Nkind (Parent (N)) = N_Object_Declaration then
5172 Build_Task_Image_Decls
5173 (Loc, Defining_Identifier (Parent (N)), T);
5176 Decls := Build_Task_Image_Decls (Loc, T, T);
5179 if Restriction_Active (No_Task_Hierarchy) then
5181 (Args, Make_Integer_Literal (Loc, Library_Task_Level));
5185 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
5188 Append_To (Args, Make_Identifier (Loc, Name_uChain));
5190 Decl := Last (Decls);
5192 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
5194 -- Has_Task is false, Decls not used
5200 -- Add discriminants if discriminated type
5203 Dis : Boolean := False;
5204 Typ : Entity_Id := Empty;
5207 if Has_Discriminants (T) then
5211 -- Type may be a private type with no visible discriminants
5212 -- in which case check full view if in scope, or the
5213 -- underlying_full_view if dealing with a type whose full
5214 -- view may be derived from a private type whose own full
5215 -- view has discriminants.
5217 elsif Is_Private_Type (T) then
5218 if Present (Full_View (T))
5219 and then Has_Discriminants (Full_View (T))
5222 Typ := Full_View (T);
5224 elsif Present (Underlying_Full_View (T))
5225 and then Has_Discriminants (Underlying_Full_View (T))
5228 Typ := Underlying_Full_View (T);
5234 -- If the allocated object will be constrained by the
5235 -- default values for discriminants, then build a subtype
5236 -- with those defaults, and change the allocated subtype
5237 -- to that. Note that this happens in fewer cases in Ada
5240 if not Is_Constrained (Typ)
5241 and then Present (Discriminant_Default_Value
5242 (First_Discriminant (Typ)))
5243 and then (Ada_Version < Ada_2005
5245 Object_Type_Has_Constrained_Partial_View
5246 (Typ, Current_Scope))
5248 Typ := Build_Default_Subtype (Typ, N);
5249 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
5252 -- When the designated subtype is unconstrained and
5253 -- the allocator specifies a constrained subtype (or
5254 -- such a subtype has been created, such as above by
5255 -- Build_Default_Subtype), associate that subtype with
5256 -- the dereference of the allocator's access value.
5257 -- This is needed by the back end for cases where
5258 -- the access type has a Designated_Storage_Model,
5259 -- to support allocation of a host object of the right
5260 -- size for passing to the initialization procedure.
5262 if not Is_Constrained (Dtyp)
5263 and then Is_Constrained (Typ)
5266 Init_Deref : constant Node_Id :=
5267 Unqual_Conv (Init_Arg1);
5270 (Nkind (Init_Deref) = N_Explicit_Dereference);
5272 Set_Actual_Designated_Subtype (Init_Deref, Typ);
5276 Discr := First_Elmt (Discriminant_Constraint (Typ));
5277 while Present (Discr) loop
5278 Nod := Node (Discr);
5279 Append (New_Copy_Tree (Node (Discr)), Args);
5281 -- AI-416: when the discriminant constraint is an
5282 -- anonymous access type make sure an accessibility
5283 -- check is inserted if necessary (3.10.2(22.q/2))
5285 if Ada_Version >= Ada_2005
5287 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
5289 No_Dynamic_Accessibility_Checks_Enabled (Nod)
5291 Apply_Accessibility_Check
5292 (Nod, Typ, Insert_Node => Nod);
5300 -- We set the allocator as analyzed so that when we analyze
5301 -- the if expression node, we do not get an unwanted recursive
5302 -- expansion of the allocator expression.
5304 Set_Analyzed (N, True);
5305 Nod := Relocate_Node (N);
5307 -- Here is the transformation:
5308 -- input: new Ctrl_Typ
5309 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5310 -- Ctrl_TypIP (Temp.all, ...);
5311 -- [Deep_]Initialize (Temp.all);
5313 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5314 -- is the subtype of the allocator.
5317 Make_Object_Declaration (Loc,
5318 Defining_Identifier => Temp,
5319 Constant_Present => True,
5320 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
5323 Set_Assignment_OK (Temp_Decl);
5324 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
5326 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
5328 -- If the designated type is a task type or contains tasks,
5329 -- create block to activate created tasks, and insert
5330 -- declaration for Task_Image variable ahead of call.
5332 if Has_Task (T) then
5334 L : constant List_Id := New_List;
5337 Build_Task_Allocate_Block (L, Nod, Args);
5339 Insert_List_Before (First (Declarations (Blk)), Decls);
5340 Insert_Actions (N, L);
5345 Make_Procedure_Call_Statement (Loc,
5346 Name => New_Occurrence_Of (Init, Loc),
5347 Parameter_Associations => Args));
5350 if Needs_Finalization (T) then
5353 -- [Deep_]Initialize (Init_Arg1);
5357 (Obj_Ref => New_Copy_Tree (Init_Arg1),
5360 -- Guard against a missing [Deep_]Initialize when the
5361 -- designated type was not properly frozen.
5363 if Present (Init_Call) then
5364 Insert_Action (N, Init_Call);
5368 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5369 Analyze_And_Resolve (N, PtrT);
5371 -- When designated type has Default_Initial_Condition aspects,
5372 -- make a call to the type's DIC procedure to perform the
5373 -- checks. Theoretically this might also be needed for cases
5374 -- where the type doesn't have an init proc, but those should
5375 -- be very uncommon, and for now we only support the init proc
5379 and then Present (DIC_Procedure (Dtyp))
5380 and then not Has_Null_Body (DIC_Procedure (Dtyp))
5383 Build_DIC_Call (Loc,
5384 Make_Explicit_Dereference (Loc,
5385 Prefix => New_Occurrence_Of (Temp, Loc)),
5392 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5393 -- object that has been rewritten as a reference, we displace "this"
5394 -- to reference properly its secondary dispatch table.
5396 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
5397 Displace_Allocator_Pointer (N);
5401 when RE_Not_Available =>
5403 end Expand_N_Allocator;
5405 -----------------------
5406 -- Expand_N_And_Then --
5407 -----------------------
5409 procedure Expand_N_And_Then (N : Node_Id)
5410 renames Expand_Short_Circuit_Operator;
5412 ------------------------------
5413 -- Expand_N_Case_Expression --
5414 ------------------------------
5416 procedure Expand_N_Case_Expression (N : Node_Id) is
5417 function Is_Copy_Type (Typ : Entity_Id) return Boolean;
5418 -- Return True if we can copy objects of this type when expanding a case
5425 function Is_Copy_Type (Typ : Entity_Id) return Boolean is
5427 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5428 -- large objects, as long as they are constrained and not limited.
5431 Is_Elementary_Type (Underlying_Type (Typ))
5433 (Minimize_Expression_With_Actions
5434 and then Is_Constrained (Underlying_Type (Typ))
5435 and then not Is_Limited_Type (Underlying_Type (Typ)));
5440 Loc : constant Source_Ptr := Sloc (N);
5441 Par : constant Node_Id := Parent (N);
5442 Typ : constant Entity_Id := Etype (N);
5446 Case_Stmt : Node_Id;
5449 Target : Entity_Id := Empty;
5450 Target_Typ : Entity_Id;
5452 In_Predicate : Boolean := False;
5453 -- Flag set when the case expression appears within a predicate
5455 Optimize_Return_Stmt : Boolean := False;
5456 -- Flag set when the case expression can be optimized in the context of
5457 -- a simple return statement.
5459 -- Start of processing for Expand_N_Case_Expression
5462 -- Check for MINIMIZED/ELIMINATED overflow mode
5464 if Minimized_Eliminated_Overflow_Check (N) then
5465 Apply_Arithmetic_Overflow_Check (N);
5469 -- If the case expression is a predicate specification, and the type
5470 -- to which it applies has a static predicate aspect, do not expand,
5471 -- because it will be converted to the proper predicate form later.
5473 if Ekind (Current_Scope) in E_Function | E_Procedure
5474 and then Is_Predicate_Function (Current_Scope)
5476 In_Predicate := True;
5478 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
5484 -- When the type of the case expression is elementary, expand
5486 -- (case X is when A => AX, when B => BX ...)
5501 -- In all other cases expand into
5504 -- type Ptr_Typ is access all Typ;
5505 -- Target : Ptr_Typ;
5508 -- Target := AX'Unrestricted_Access;
5510 -- Target := BX'Unrestricted_Access;
5513 -- in Target.all end;
5515 -- This approach avoids extra copies of potentially large objects. It
5516 -- also allows handling of values of limited or unconstrained types.
5517 -- Note that we do the copy also for constrained, nonlimited types
5518 -- when minimizing expressions with actions (e.g. when generating C
5519 -- code) since it allows us to do the optimization below in more cases.
5521 -- Small optimization: when the case expression appears in the context
5522 -- of a simple return statement, expand into
5533 Make_Case_Statement (Loc,
5534 Expression => Expression (N),
5535 Alternatives => New_List);
5537 -- Preserve the original context for which the case statement is being
5538 -- generated. This is needed by the finalization machinery to prevent
5539 -- the premature finalization of controlled objects found within the
5542 Set_From_Conditional_Expression (Case_Stmt);
5547 if Is_Copy_Type (Typ) then
5550 -- Do not perform the optimization when the return statement is
5551 -- within a predicate function, as this causes spurious errors.
5553 Optimize_Return_Stmt :=
5554 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
5556 -- Otherwise create an access type to handle the general case using
5557 -- 'Unrestricted_Access.
5560 -- type Ptr_Typ is access all Typ;
5563 if Generate_C_Code then
5565 -- We cannot ensure that correct C code will be generated if any
5566 -- temporary is created down the line (to e.g. handle checks or
5567 -- capture values) since we might end up with dangling references
5568 -- to local variables, so better be safe and reject the construct.
5571 ("case expression too complex, use case statement instead", N);
5574 Target_Typ := Make_Temporary (Loc, 'P');
5577 Make_Full_Type_Declaration (Loc,
5578 Defining_Identifier => Target_Typ,
5580 Make_Access_To_Object_Definition (Loc,
5581 All_Present => True,
5582 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5585 -- Create the declaration of the target which captures the value of the
5589 -- Target : [Ptr_]Typ;
5591 if not Optimize_Return_Stmt then
5592 Target := Make_Temporary (Loc, 'T');
5595 Make_Object_Declaration (Loc,
5596 Defining_Identifier => Target,
5597 Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
5598 Set_No_Initialization (Decl);
5600 Append_To (Acts, Decl);
5603 -- Process the alternatives
5605 Alt := First (Alternatives (N));
5606 while Present (Alt) loop
5608 Alt_Expr : Node_Id := Expression (Alt);
5609 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
5614 -- Take the unrestricted access of the expression value for non-
5615 -- scalar types. This approach avoids big copies and covers the
5616 -- limited and unconstrained cases.
5619 -- AX'Unrestricted_Access
5621 if not Is_Copy_Type (Typ) then
5623 Make_Attribute_Reference (Alt_Loc,
5624 Prefix => Relocate_Node (Alt_Expr),
5625 Attribute_Name => Name_Unrestricted_Access);
5629 -- return AX['Unrestricted_Access];
5631 if Optimize_Return_Stmt then
5633 Make_Simple_Return_Statement (Alt_Loc,
5634 Expression => Alt_Expr));
5637 -- Target := AX['Unrestricted_Access];
5640 LHS := New_Occurrence_Of (Target, Loc);
5641 Set_Assignment_OK (LHS);
5644 Make_Assignment_Statement (Alt_Loc,
5646 Expression => Alt_Expr));
5649 -- Propagate declarations inserted in the node by Insert_Actions
5650 -- (for example, temporaries generated to remove side effects).
5651 -- These actions must remain attached to the alternative, given
5652 -- that they are generated by the corresponding expression.
5654 if Present (Actions (Alt)) then
5655 Prepend_List (Actions (Alt), Stmts);
5658 -- Finalize any transient objects on exit from the alternative.
5659 -- This is done only in the return optimization case because
5660 -- otherwise the case expression is converted into an expression
5661 -- with actions which already contains this form of processing.
5663 if Optimize_Return_Stmt then
5664 Process_If_Case_Statements (N, Stmts);
5668 (Alternatives (Case_Stmt),
5669 Make_Case_Statement_Alternative (Sloc (Alt),
5670 Discrete_Choices => Discrete_Choices (Alt),
5671 Statements => Stmts));
5677 -- Rewrite the parent return statement as a case statement
5679 if Optimize_Return_Stmt then
5680 Rewrite (Par, Case_Stmt);
5683 -- Otherwise convert the case expression into an expression with actions
5686 Append_To (Acts, Case_Stmt);
5688 if Is_Copy_Type (Typ) then
5689 Expr := New_Occurrence_Of (Target, Loc);
5693 Make_Explicit_Dereference (Loc,
5694 Prefix => New_Occurrence_Of (Target, Loc));
5700 -- in Target[.all] end;
5703 Make_Expression_With_Actions (Loc,
5707 Analyze_And_Resolve (N, Typ);
5709 end Expand_N_Case_Expression;
5711 -----------------------------------
5712 -- Expand_N_Explicit_Dereference --
5713 -----------------------------------
5715 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
5717 -- Insert explicit dereference call for the checked storage pool case
5719 Insert_Dereference_Action (Prefix (N));
5721 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5722 -- we set the atomic sync flag.
5724 if Is_Atomic (Etype (N))
5725 and then not Atomic_Synchronization_Disabled (Etype (N))
5727 Activate_Atomic_Synchronization (N);
5729 end Expand_N_Explicit_Dereference;
5731 --------------------------------------
5732 -- Expand_N_Expression_With_Actions --
5733 --------------------------------------
5735 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
5736 Acts : constant List_Id := Actions (N);
5738 procedure Force_Boolean_Evaluation (Expr : Node_Id);
5739 -- Force the evaluation of Boolean expression Expr
5741 function Process_Action (Act : Node_Id) return Traverse_Result;
5742 -- Inspect and process a single action of an expression_with_actions for
5743 -- transient objects. If such objects are found, the routine generates
5744 -- code to clean them up when the context of the expression is evaluated
5747 ------------------------------
5748 -- Force_Boolean_Evaluation --
5749 ------------------------------
5751 procedure Force_Boolean_Evaluation (Expr : Node_Id) is
5752 Loc : constant Source_Ptr := Sloc (N);
5753 Flag_Decl : Node_Id;
5754 Flag_Id : Entity_Id;
5757 -- Relocate the expression to the actions list by capturing its value
5758 -- in a Boolean flag. Generate:
5759 -- Flag : constant Boolean := Expr;
5761 Flag_Id := Make_Temporary (Loc, 'F');
5764 Make_Object_Declaration (Loc,
5765 Defining_Identifier => Flag_Id,
5766 Constant_Present => True,
5767 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
5768 Expression => Relocate_Node (Expr));
5770 Append (Flag_Decl, Acts);
5771 Analyze (Flag_Decl);
5773 -- Replace the expression with a reference to the flag
5775 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc));
5776 Analyze (Expression (N));
5777 end Force_Boolean_Evaluation;
5779 --------------------
5780 -- Process_Action --
5781 --------------------
5783 function Process_Action (Act : Node_Id) return Traverse_Result is
5785 if Nkind (Act) = N_Object_Declaration
5786 and then Is_Finalizable_Transient (Act, N)
5788 Process_Transient_In_Expression (Act, N, Acts);
5791 -- Avoid processing temporary function results multiple times when
5792 -- dealing with nested expression_with_actions.
5793 -- Similarly, do not process temporary function results in loops.
5794 -- This is done by Expand_N_Loop_Statement and Build_Finalizer.
5795 -- Note that we used to wrongly return Abandon instead of Skip here:
5796 -- this is wrong since it means that we were ignoring lots of
5797 -- relevant subsequent statements.
5799 elsif Nkind (Act) in N_Expression_With_Actions | N_Loop_Statement then
5806 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5812 -- Start of processing for Expand_N_Expression_With_Actions
5815 -- Do not evaluate the expression when it denotes an entity because the
5816 -- expression_with_actions node will be replaced by the reference.
5818 if Is_Entity_Name (Expression (N)) then
5821 -- Do not evaluate the expression when there are no actions because the
5822 -- expression_with_actions node will be replaced by the expression.
5824 elsif Is_Empty_List (Acts) then
5827 -- Force the evaluation of the expression by capturing its value in a
5828 -- temporary. This ensures that aliases of transient objects do not leak
5829 -- to the expression of the expression_with_actions node:
5832 -- Trans_Id : Ctrl_Typ := ...;
5833 -- Alias : ... := Trans_Id;
5834 -- in ... Alias ... end;
5836 -- In the example above, Trans_Id cannot be finalized at the end of the
5837 -- actions list because this may affect the alias and the final value of
5838 -- the expression_with_actions. Forcing the evaluation encapsulates the
5839 -- reference to the Alias within the actions list:
5842 -- Trans_Id : Ctrl_Typ := ...;
5843 -- Alias : ... := Trans_Id;
5844 -- Val : constant Boolean := ... Alias ...;
5845 -- <finalize Trans_Id>
5848 -- Once this transformation is performed, it is safe to finalize the
5849 -- transient object at the end of the actions list.
5851 -- Note that Force_Evaluation does not remove side effects in operators
5852 -- because it assumes that all operands are evaluated and side effect
5853 -- free. This is not the case when an operand depends implicitly on the
5854 -- transient object through the use of access types.
5856 elsif Is_Boolean_Type (Etype (Expression (N))) then
5857 Force_Boolean_Evaluation (Expression (N));
5859 -- The expression of an expression_with_actions node may not necessarily
5860 -- be Boolean when the node appears in an if expression. In this case do
5861 -- the usual forced evaluation to encapsulate potential aliasing.
5864 Force_Evaluation (Expression (N));
5867 -- Process all transient objects found within the actions of the EWA
5870 Act := First (Acts);
5871 while Present (Act) loop
5872 Process_Single_Action (Act);
5876 -- Deal with case where there are no actions. In this case we simply
5877 -- rewrite the node with its expression since we don't need the actions
5878 -- and the specification of this node does not allow a null action list.
5880 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5881 -- the expanded tree and relying on being able to retrieve the original
5882 -- tree in cases like this. This raises a whole lot of issues of whether
5883 -- we have problems elsewhere, which will be addressed in the future???
5885 if Is_Empty_List (Acts) then
5886 Rewrite (N, Relocate_Node (Expression (N)));
5888 end Expand_N_Expression_With_Actions;
5890 ----------------------------
5891 -- Expand_N_If_Expression --
5892 ----------------------------
5894 -- Deal with limited types and condition actions
5896 procedure Expand_N_If_Expression (N : Node_Id) is
5897 Cond : constant Node_Id := First (Expressions (N));
5898 Loc : constant Source_Ptr := Sloc (N);
5899 Thenx : constant Node_Id := Next (Cond);
5900 Elsex : constant Node_Id := Next (Thenx);
5901 Typ : constant Entity_Id := Etype (N);
5903 Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N);
5904 -- Determine if we are dealing with a special case of a conditional
5905 -- expression used as an actual for an anonymous access type which
5906 -- forces us to transform the if expression into an expression with
5907 -- actions in order to create a temporary to capture the level of the
5908 -- expression in each branch.
5910 function OK_For_Single_Subtype (T1, T2 : Entity_Id) return Boolean;
5911 -- Return true if it is acceptable to use a single subtype for two
5912 -- dependent expressions of subtype T1 and T2 respectively, which are
5913 -- unidimensional arrays whose index bounds are known at compile time.
5915 ---------------------------
5916 -- OK_For_Single_Subtype --
5917 ---------------------------
5919 function OK_For_Single_Subtype (T1, T2 : Entity_Id) return Boolean is
5924 Get_First_Index_Bounds (T1, Lo1, Hi1);
5925 Get_First_Index_Bounds (T2, Lo2, Hi2);
5927 -- Return true if the length of the covering subtype is not too large
5930 UI_Max (Hi1, Hi2) - UI_Min (Lo1, Lo2) < Too_Large_Length_For_Array;
5931 end OK_For_Single_Subtype;
5941 -- Start of processing for Expand_N_If_Expression
5944 -- Deal with non-standard booleans
5946 Adjust_Condition (Cond);
5948 -- Check for MINIMIZED/ELIMINATED overflow mode.
5949 -- Apply_Arithmetic_Overflow_Check will not deal with Then/Else_Actions
5950 -- so skip this step if any actions are present.
5952 if Minimized_Eliminated_Overflow_Check (N)
5953 and then No (Then_Actions (N))
5954 and then No (Else_Actions (N))
5956 Apply_Arithmetic_Overflow_Check (N);
5960 -- Fold at compile time if condition known. We have already folded
5961 -- static if expressions, but it is possible to fold any case in which
5962 -- the condition is known at compile time, even though the result is
5965 -- Note that we don't do the fold of such cases in Sem_Elab because
5966 -- it can cause infinite loops with the expander adding a conditional
5967 -- expression, and Sem_Elab circuitry removing it repeatedly.
5969 if Compile_Time_Known_Value (Cond) then
5971 function Fold_Known_Value (Cond : Node_Id) return Boolean;
5972 -- Fold at compile time. Assumes condition known. Return True if
5973 -- folding occurred, meaning we're done.
5975 ----------------------
5976 -- Fold_Known_Value --
5977 ----------------------
5979 function Fold_Known_Value (Cond : Node_Id) return Boolean is
5981 if Is_True (Expr_Value (Cond)) then
5983 Actions := Then_Actions (N);
5986 Actions := Else_Actions (N);
5991 if Present (Actions) then
5993 -- To minimize the use of Expression_With_Actions, just skip
5994 -- the optimization as it is not critical for correctness.
5996 if Minimize_Expression_With_Actions then
6001 Make_Expression_With_Actions (Loc,
6002 Expression => Relocate_Node (Expr),
6003 Actions => Actions));
6004 Analyze_And_Resolve (N, Typ);
6007 Rewrite (N, Relocate_Node (Expr));
6010 -- Note that the result is never static (legitimate cases of
6011 -- static if expressions were folded in Sem_Eval).
6013 Set_Is_Static_Expression (N, False);
6015 end Fold_Known_Value;
6018 if Fold_Known_Value (Cond) then
6024 -- If the type is limited, and the back end does not handle limited
6025 -- types, then we expand as follows to avoid the possibility of
6026 -- improper copying.
6028 -- type Ptr is access all Typ;
6032 -- Cnn := then-expr'Unrestricted_Access;
6035 -- Cnn := else-expr'Unrestricted_Access;
6038 -- and replace the if expression by a reference to Cnn.all.
6040 -- This special case can be skipped if the back end handles limited
6041 -- types properly and ensures that no incorrect copies are made.
6043 if Is_By_Reference_Type (Typ)
6044 and then not Back_End_Handles_Limited_Types
6046 -- When the "then" or "else" expressions involve controlled function
6047 -- calls, generated temporaries are chained on the corresponding list
6048 -- of actions. These temporaries need to be finalized after the if
6049 -- expression is evaluated.
6051 Process_If_Case_Statements (N, Then_Actions (N));
6052 Process_If_Case_Statements (N, Else_Actions (N));
6055 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N);
6056 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
6060 -- type Ann is access all Typ;
6063 Make_Full_Type_Declaration (Loc,
6064 Defining_Identifier => Ptr_Typ,
6066 Make_Access_To_Object_Definition (Loc,
6067 All_Present => True,
6068 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
6074 Make_Object_Declaration (Loc,
6075 Defining_Identifier => Cnn,
6076 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
6080 -- Cnn := <Thenx>'Unrestricted_Access;
6082 -- Cnn := <Elsex>'Unrestricted_Access;
6086 Make_Implicit_If_Statement (N,
6087 Condition => Relocate_Node (Cond),
6088 Then_Statements => New_List (
6089 Make_Assignment_Statement (Sloc (Thenx),
6090 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
6092 Make_Attribute_Reference (Loc,
6093 Prefix => Relocate_Node (Thenx),
6094 Attribute_Name => Name_Unrestricted_Access))),
6096 Else_Statements => New_List (
6097 Make_Assignment_Statement (Sloc (Elsex),
6098 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
6100 Make_Attribute_Reference (Loc,
6101 Prefix => Relocate_Node (Elsex),
6102 Attribute_Name => Name_Unrestricted_Access))));
6104 -- Preserve the original context for which the if statement is
6105 -- being generated. This is needed by the finalization machinery
6106 -- to prevent the premature finalization of controlled objects
6107 -- found within the if statement.
6109 Set_From_Conditional_Expression (New_If);
6112 Make_Explicit_Dereference (Loc,
6113 Prefix => New_Occurrence_Of (Cnn, Loc));
6116 -- If the result is a unidimensional unconstrained array but the two
6117 -- dependent expressions have constrained subtypes with known bounds,
6118 -- then we expand as follows:
6120 -- subtype Txx is Typ (<static low-bound> .. <static high-bound>);
6124 -- Cnn (<then low-bound .. then high-bound>) := then-expr;
6127 -- Cnn (<else low bound .. else high-bound>) := else-expr;
6130 -- and replace the if expression by a slice of Cnn, provided that Txx
6131 -- is not too large. This will create a static temporary instead of the
6132 -- dynamic one of the next case and thus help the code generator.
6134 -- Note that we need to deal with the case where the else expression is
6135 -- itself such a slice, in order to catch if expressions with more than
6136 -- two dependent expressions in the source code.
6138 -- Also note that this creates variables on branches without an explicit
6139 -- scope, causing troubles with e.g. the LLVM IR, so disable this
6140 -- optimization when Unnest_Subprogram_Mode (enabled for LLVM).
6142 elsif Is_Array_Type (Typ)
6143 and then Number_Dimensions (Typ) = 1
6144 and then not Is_Constrained (Typ)
6145 and then Is_Constrained (Etype (Thenx))
6146 and then Compile_Time_Known_Bounds (Etype (Thenx))
6148 ((Is_Constrained (Etype (Elsex))
6149 and then Compile_Time_Known_Bounds (Etype (Elsex))
6150 and then OK_For_Single_Subtype (Etype (Thenx), Etype (Elsex)))
6152 (Nkind (Elsex) = N_Slice
6153 and then Is_Constrained (Etype (Prefix (Elsex)))
6154 and then Compile_Time_Known_Bounds (Etype (Prefix (Elsex)))
6156 OK_For_Single_Subtype (Etype (Thenx), Etype (Prefix (Elsex)))))
6157 and then not Generate_C_Code
6158 and then not Unnest_Subprogram_Mode
6161 Ityp : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
6163 function Build_New_Bound
6166 Slice_Bnd : Node_Id) return Node_Id;
6167 -- Build a new bound from the bounds of the if expression
6169 function To_Ityp (V : Uint) return Node_Id;
6170 -- Convert V to an index value in Ityp
6172 ---------------------
6173 -- Build_New_Bound --
6174 ---------------------
6176 function Build_New_Bound
6179 Slice_Bnd : Node_Id) return Node_Id is
6182 -- We need to use the special processing for slices only if
6183 -- they do not have compile-time known bounds; if they do, they
6184 -- can be treated like any other expressions.
6186 if Nkind (Elsex) = N_Slice
6187 and then not Compile_Time_Known_Bounds (Etype (Elsex))
6189 if Compile_Time_Known_Value (Slice_Bnd)
6190 and then Expr_Value (Slice_Bnd) = Then_Bnd
6192 return To_Ityp (Then_Bnd);
6195 return Make_If_Expression (Loc,
6196 Expressions => New_List (
6197 Duplicate_Subexpr (Cond),
6199 New_Copy_Tree (Slice_Bnd)));
6202 elsif Then_Bnd = Else_Bnd then
6203 return To_Ityp (Then_Bnd);
6206 return Make_If_Expression (Loc,
6207 Expressions => New_List (
6208 Duplicate_Subexpr (Cond),
6210 To_Ityp (Else_Bnd)));
6212 end Build_New_Bound;
6218 function To_Ityp (V : Uint) return Node_Id is
6219 Result : constant Node_Id := Make_Integer_Literal (Loc, V);
6222 if Is_Enumeration_Type (Ityp) then
6224 Make_Attribute_Reference (Loc,
6225 Prefix => New_Occurrence_Of (Ityp, Loc),
6226 Attribute_Name => Name_Val,
6227 Expressions => New_List (Result));
6234 Slice_Lo, Slice_Hi : Node_Id;
6235 Subtyp_Ind : Node_Id;
6236 Else_Lo, Else_Hi : Uint;
6237 Min_Lo, Max_Hi : Uint;
6238 Then_Lo, Then_Hi : Uint;
6239 Then_List, Else_List : List_Id;
6242 Get_First_Index_Bounds (Etype (Thenx), Then_Lo, Then_Hi);
6244 -- See the rationale in Build_New_Bound
6246 if Nkind (Elsex) = N_Slice
6247 and then not Compile_Time_Known_Bounds (Etype (Elsex))
6249 Slice_Lo := Low_Bound (Discrete_Range (Elsex));
6250 Slice_Hi := High_Bound (Discrete_Range (Elsex));
6251 Get_First_Index_Bounds
6252 (Etype (Prefix (Elsex)), Else_Lo, Else_Hi);
6257 Get_First_Index_Bounds (Etype (Elsex), Else_Lo, Else_Hi);
6260 Min_Lo := UI_Min (Then_Lo, Else_Lo);
6261 Max_Hi := UI_Max (Then_Hi, Else_Hi);
6263 -- Now we construct an array object with appropriate bounds and
6264 -- mark it as internal to prevent useless initialization when
6265 -- Initialize_Scalars is enabled. Also since this is the actual
6266 -- result entity, we make sure we have debug information for it.
6269 Make_Subtype_Indication (Loc,
6270 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
6272 Make_Index_Or_Discriminant_Constraint (Loc,
6273 Constraints => New_List (
6275 Low_Bound => To_Ityp (Min_Lo),
6276 High_Bound => To_Ityp (Max_Hi)))));
6278 Ent := Make_Temporary (Loc, 'C');
6279 Set_Is_Internal (Ent);
6280 Set_Debug_Info_Needed (Ent);
6283 Make_Object_Declaration (Loc,
6284 Defining_Identifier => Ent,
6285 Object_Definition => Subtyp_Ind);
6287 -- If the result of the expression appears as the initializing
6288 -- expression of an object declaration, we can just rename the
6289 -- result, rather than copying it.
6291 Mutate_Ekind (Ent, E_Variable);
6292 Set_OK_To_Rename (Ent);
6294 Then_List := New_List (
6295 Make_Assignment_Statement (Loc,
6298 Prefix => New_Occurrence_Of (Ent, Loc),
6301 Low_Bound => To_Ityp (Then_Lo),
6302 High_Bound => To_Ityp (Then_Hi))),
6303 Expression => Relocate_Node (Thenx)));
6305 Set_Suppress_Assignment_Checks (Last (Then_List));
6307 -- See the rationale in Build_New_Bound
6309 if Nkind (Elsex) = N_Slice
6310 and then not Compile_Time_Known_Bounds (Etype (Elsex))
6312 Else_List := New_List (
6313 Make_Assignment_Statement (Loc,
6316 Prefix => New_Occurrence_Of (Ent, Loc),
6319 Low_Bound => New_Copy_Tree (Slice_Lo),
6320 High_Bound => New_Copy_Tree (Slice_Hi))),
6321 Expression => Relocate_Node (Elsex)));
6324 Else_List := New_List (
6325 Make_Assignment_Statement (Loc,
6328 Prefix => New_Occurrence_Of (Ent, Loc),
6331 Low_Bound => To_Ityp (Else_Lo),
6332 High_Bound => To_Ityp (Else_Hi))),
6333 Expression => Relocate_Node (Elsex)));
6336 Set_Suppress_Assignment_Checks (Last (Else_List));
6339 Make_Implicit_If_Statement (N,
6340 Condition => Duplicate_Subexpr (Cond),
6341 Then_Statements => Then_List,
6342 Else_Statements => Else_List);
6346 Prefix => New_Occurrence_Of (Ent, Loc),
6347 Discrete_Range => Make_Range (Loc,
6348 Low_Bound => Build_New_Bound (Then_Lo, Else_Lo, Slice_Lo),
6349 High_Bound => Build_New_Bound (Then_Hi, Else_Hi, Slice_Hi)));
6352 -- If the result is an unconstrained array and the if expression is in a
6353 -- context other than the initializing expression of the declaration of
6354 -- an object, then we pull out the if expression as follows:
6356 -- Cnn : constant typ := if-expression
6358 -- and then replace the if expression with an occurrence of Cnn. This
6359 -- avoids the need in the back end to create on-the-fly variable length
6360 -- temporaries (which it cannot do!)
6362 -- Note that the test for being in an object declaration avoids doing an
6363 -- unnecessary expansion, and also avoids infinite recursion.
6365 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ)
6366 and then (Nkind (Parent (N)) /= N_Object_Declaration
6367 or else Expression (Parent (N)) /= N)
6370 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
6374 Make_Object_Declaration (Loc,
6375 Defining_Identifier => Cnn,
6376 Constant_Present => True,
6377 Object_Definition => New_Occurrence_Of (Typ, Loc),
6378 Expression => Relocate_Node (N),
6379 Has_Init_Expression => True));
6381 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
6385 -- For other types, we only need to expand if there are other actions
6386 -- associated with either branch or we need to force expansion to deal
6387 -- with if expressions used as an actual of an anonymous access type.
6389 elsif Present (Then_Actions (N))
6390 or else Present (Else_Actions (N))
6391 or else Force_Expand
6394 -- We now wrap the actions into the appropriate expression
6396 if Minimize_Expression_With_Actions
6397 and then (Is_Elementary_Type (Underlying_Type (Typ))
6398 or else Is_Constrained (Underlying_Type (Typ)))
6400 -- If we can't use N_Expression_With_Actions nodes, then we insert
6401 -- the following sequence of actions (using Insert_Actions):
6406 -- Cnn := then-expr;
6412 -- and replace the if expression by a reference to Cnn
6415 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
6419 Make_Object_Declaration (Loc,
6420 Defining_Identifier => Cnn,
6421 Object_Definition => New_Occurrence_Of (Typ, Loc));
6424 Make_Implicit_If_Statement (N,
6425 Condition => Relocate_Node (Cond),
6427 Then_Statements => New_List (
6428 Make_Assignment_Statement (Sloc (Thenx),
6429 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
6430 Expression => Relocate_Node (Thenx))),
6432 Else_Statements => New_List (
6433 Make_Assignment_Statement (Sloc (Elsex),
6434 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
6435 Expression => Relocate_Node (Elsex))));
6437 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
6438 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
6440 New_N := New_Occurrence_Of (Cnn, Loc);
6443 -- Regular path using Expression_With_Actions
6446 if Present (Then_Actions (N)) then
6448 Make_Expression_With_Actions (Sloc (Thenx),
6449 Actions => Then_Actions (N),
6450 Expression => Relocate_Node (Thenx)));
6452 Set_Then_Actions (N, No_List);
6453 Analyze_And_Resolve (Thenx, Typ);
6456 if Present (Else_Actions (N)) then
6458 Make_Expression_With_Actions (Sloc (Elsex),
6459 Actions => Else_Actions (N),
6460 Expression => Relocate_Node (Elsex)));
6462 Set_Else_Actions (N, No_List);
6463 Analyze_And_Resolve (Elsex, Typ);
6466 -- We must force expansion into an expression with actions when
6467 -- an if expression gets used directly as an actual for an
6468 -- anonymous access type.
6470 if Force_Expand then
6472 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C');
6481 Make_Object_Declaration (Loc,
6482 Defining_Identifier => Cnn,
6483 Object_Definition => New_Occurrence_Of (Typ, Loc));
6484 Append_To (Acts, Decl);
6486 Set_No_Initialization (Decl);
6496 Make_Implicit_If_Statement (N,
6497 Condition => Relocate_Node (Cond),
6498 Then_Statements => New_List (
6499 Make_Assignment_Statement (Sloc (Thenx),
6500 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
6501 Expression => Relocate_Node (Thenx))),
6503 Else_Statements => New_List (
6504 Make_Assignment_Statement (Sloc (Elsex),
6505 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
6506 Expression => Relocate_Node (Elsex))));
6507 Append_To (Acts, New_If);
6515 Make_Expression_With_Actions (Loc,
6516 Expression => New_Occurrence_Of (Cnn, Loc),
6518 Analyze_And_Resolve (N, Typ);
6525 -- For the sake of GNATcoverage, generate an intermediate temporary in
6526 -- the case where the if expression is a condition in an outer decision,
6527 -- in order to make sure that no branch is shared between the decisions.
6529 elsif Opt.Suppress_Control_Flow_Optimizations
6530 and then Nkind (Original_Node (Parent (N))) in N_Case_Expression
6534 | N_Goto_When_Statement
6536 | N_Return_When_Statement
6540 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C');
6546 -- Cnn : constant Typ := N;
6550 Make_Object_Declaration (Loc,
6551 Defining_Identifier => Cnn,
6552 Constant_Present => True,
6553 Object_Definition => New_Occurrence_Of (Typ, Loc),
6554 Expression => Relocate_Node (N)));
6557 Make_Expression_With_Actions (Loc,
6558 Expression => New_Occurrence_Of (Cnn, Loc),
6561 Analyze_And_Resolve (N, Typ);
6565 -- If no actions then no expansion needed, gigi will handle it using the
6566 -- same approach as a C conditional expression.
6572 -- Fall through here for either the limited expansion, or the case of
6573 -- inserting actions for nonlimited types. In both these cases, we must
6574 -- move the SLOC of the parent If statement to the newly created one and
6575 -- change it to the SLOC of the expression which, after expansion, will
6576 -- correspond to what is being evaluated.
6578 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
6579 Set_Sloc (New_If, Sloc (Parent (N)));
6580 Set_Sloc (Parent (N), Loc);
6583 -- Move Then_Actions and Else_Actions, if any, to the new if statement
6585 Insert_List_Before (First (Then_Statements (New_If)), Then_Actions (N));
6586 Insert_List_Before (First (Else_Statements (New_If)), Else_Actions (N));
6588 Insert_Action (N, Decl);
6589 Insert_Action (N, New_If);
6591 Analyze_And_Resolve (N, Typ);
6592 end Expand_N_If_Expression;
6598 procedure Expand_N_In (N : Node_Id) is
6599 Loc : constant Source_Ptr := Sloc (N);
6600 Restyp : constant Entity_Id := Etype (N);
6601 Lop : constant Node_Id := Left_Opnd (N);
6602 Rop : constant Node_Id := Right_Opnd (N);
6603 Static : constant Boolean := Is_OK_Static_Expression (N);
6605 procedure Substitute_Valid_Check;
6606 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6607 -- test for the left operand being in range of its subtype.
6609 ----------------------------
6610 -- Substitute_Valid_Check --
6611 ----------------------------
6613 procedure Substitute_Valid_Check is
6614 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
6615 -- Determine whether arbitrary node Nod denotes a source object that
6616 -- may safely act as prefix of attribute 'Valid.
6618 ----------------------------
6619 -- Is_OK_Object_Reference --
6620 ----------------------------
6622 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is
6626 -- Inspect the original operand
6628 Obj_Ref := Original_Node (Nod);
6630 -- The object reference must be a source construct, otherwise the
6631 -- codefix suggestion may refer to nonexistent code from a user
6634 if Comes_From_Source (Obj_Ref) then
6636 if Nkind (Obj_Ref) in
6638 N_Unchecked_Type_Conversion |
6639 N_Qualified_Expression
6641 Obj_Ref := Expression (Obj_Ref);
6647 return Is_Object_Reference (Obj_Ref);
6651 end Is_OK_Object_Reference;
6653 -- Start of processing for Substitute_Valid_Check
6657 Make_Attribute_Reference (Loc,
6658 Prefix => Relocate_Node (Lop),
6659 Attribute_Name => Name_Valid));
6661 Analyze_And_Resolve (N, Restyp);
6663 -- Emit a warning when the left-hand operand of the membership test
6664 -- is a source object, otherwise the use of attribute 'Valid would be
6665 -- illegal. The warning is not given when overflow checking is either
6666 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6667 -- eliminated above.
6669 if Is_OK_Object_Reference (Lop)
6670 and then Overflow_Check_Mode not in Minimized_Or_Eliminated
6673 ("??explicit membership test may be optimized away", N);
6674 Error_Msg_N -- CODEFIX
6675 ("\??use ''Valid attribute instead", N);
6677 end Substitute_Valid_Check;
6684 -- Start of processing for Expand_N_In
6687 -- If set membership case, expand with separate procedure
6689 if Present (Alternatives (N)) then
6690 Expand_Set_Membership (N);
6694 -- Not set membership, proceed with expansion
6696 Ltyp := Etype (Left_Opnd (N));
6697 Rtyp := Etype (Right_Opnd (N));
6699 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6700 -- type, then expand with a separate procedure. Note the use of the
6701 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6703 if Minimized_Eliminated_Overflow_Check (Left_Opnd (N))
6704 and then not No_Minimize_Eliminate (N)
6706 Expand_Membership_Minimize_Eliminate_Overflow (N);
6710 -- Check case of explicit test for an expression in range of its
6711 -- subtype. This is suspicious usage and we replace it with a 'Valid
6712 -- test and give a warning for scalar types.
6714 if Is_Scalar_Type (Ltyp)
6716 -- Only relevant for source comparisons
6718 and then Comes_From_Source (N)
6720 -- In floating-point this is a standard way to check for finite values
6721 -- and using 'Valid would typically be a pessimization.
6723 and then not Is_Floating_Point_Type (Ltyp)
6725 -- Don't give the message unless right operand is a type entity and
6726 -- the type of the left operand matches this type. Note that this
6727 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6728 -- checks have changed the type of the left operand.
6730 and then Nkind (Rop) in N_Has_Entity
6731 and then Ltyp = Entity (Rop)
6733 -- Skip this for predicated types, where such expressions are a
6734 -- reasonable way of testing if something meets the predicate.
6736 and then No (Predicate_Function (Ltyp))
6738 Substitute_Valid_Check;
6742 -- Do validity check on operands
6744 if Validity_Checks_On and Validity_Check_Operands then
6745 Ensure_Valid (Left_Opnd (N));
6746 Validity_Check_Range (Right_Opnd (N));
6749 -- Case of explicit range
6751 if Nkind (Rop) = N_Range then
6753 Lo : constant Node_Id := Low_Bound (Rop);
6754 Hi : constant Node_Id := High_Bound (Rop);
6756 Lo_Orig : constant Node_Id := Original_Node (Lo);
6757 Hi_Orig : constant Node_Id := Original_Node (Hi);
6759 Lcheck : Compare_Result;
6760 Ucheck : Compare_Result;
6762 Warn : constant Boolean :=
6763 Constant_Condition_Warnings
6764 and then Comes_From_Source (N)
6765 and then not In_Instance;
6766 -- This must be true for any of the optimization warnings, we
6767 -- clearly want to give them only for source with the flag on. We
6768 -- also skip these warnings in an instance since it may be the
6769 -- case that different instantiations have different ranges.
6772 -- If test is explicit x'First .. x'Last, replace by valid check
6774 if Is_Scalar_Type (Ltyp)
6776 -- And left operand is X'First where X matches left operand
6777 -- type (this eliminates cases of type mismatch, including
6778 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6779 -- type of the left operand.
6781 and then Nkind (Lo_Orig) = N_Attribute_Reference
6782 and then Attribute_Name (Lo_Orig) = Name_First
6783 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
6784 and then Entity (Prefix (Lo_Orig)) = Ltyp
6786 -- Same tests for right operand
6788 and then Nkind (Hi_Orig) = N_Attribute_Reference
6789 and then Attribute_Name (Hi_Orig) = Name_Last
6790 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
6791 and then Entity (Prefix (Hi_Orig)) = Ltyp
6793 -- Relevant only for source cases
6795 and then Comes_From_Source (N)
6797 Substitute_Valid_Check;
6801 -- If bounds of type are known at compile time, and the end points
6802 -- are known at compile time and identical, this is another case
6803 -- for substituting a valid test. We only do this for discrete
6804 -- types, since it won't arise in practice for float types.
6806 if Comes_From_Source (N)
6807 and then Is_Discrete_Type (Ltyp)
6808 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
6809 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
6810 and then Compile_Time_Known_Value (Lo)
6811 and then Compile_Time_Known_Value (Hi)
6812 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
6813 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
6815 -- Kill warnings in instances, since they may be cases where we
6816 -- have a test in the generic that makes sense with some types
6817 -- and not with other types.
6819 -- Similarly, do not rewrite membership as a validity check if
6820 -- within the predicate function for the type.
6822 -- Finally, if the original bounds are type conversions, even
6823 -- if they have been folded into constants, there are different
6824 -- types involved and 'Valid is not appropriate.
6828 or else (Ekind (Current_Scope) = E_Function
6829 and then Is_Predicate_Function (Current_Scope))
6833 elsif Nkind (Lo_Orig) = N_Type_Conversion
6834 or else Nkind (Hi_Orig) = N_Type_Conversion
6839 Substitute_Valid_Check;
6844 -- If we have an explicit range, do a bit of optimization based on
6845 -- range analysis (we may be able to kill one or both checks).
6847 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
6848 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
6850 -- If either check is known to fail, replace result by False since
6851 -- the other check does not matter. Preserve the static flag for
6852 -- legality checks, because we are constant-folding beyond RM 4.9.
6854 if Lcheck = LT or else Ucheck = GT then
6856 Error_Msg_N ("?c?range test optimized away", N);
6857 Error_Msg_N ("\?c?value is known to be out of range", N);
6860 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6861 Analyze_And_Resolve (N, Restyp);
6862 Set_Is_Static_Expression (N, Static);
6865 -- If both checks are known to succeed, replace result by True,
6866 -- since we know we are in range.
6868 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6870 Error_Msg_N ("?c?range test optimized away", N);
6871 Error_Msg_N ("\?c?value is known to be in range", N);
6874 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6875 Analyze_And_Resolve (N, Restyp);
6876 Set_Is_Static_Expression (N, Static);
6879 -- If lower bound check succeeds and upper bound check is not
6880 -- known to succeed or fail, then replace the range check with
6881 -- a comparison against the upper bound.
6883 elsif Lcheck in Compare_GE then
6887 Right_Opnd => High_Bound (Rop)));
6888 Analyze_And_Resolve (N, Restyp);
6891 -- Inverse of previous case.
6893 elsif Ucheck in Compare_LE then
6897 Right_Opnd => Low_Bound (Rop)));
6898 Analyze_And_Resolve (N, Restyp);
6902 -- We couldn't optimize away the range check, but there is one
6903 -- more issue. If we are checking constant conditionals, then we
6904 -- see if we can determine the outcome assuming everything is
6905 -- valid, and if so give an appropriate warning.
6907 if Warn and then not Assume_No_Invalid_Values then
6908 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
6909 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
6911 -- Result is out of range for valid value
6913 if Lcheck = LT or else Ucheck = GT then
6915 ("?c?value can only be in range if it is invalid", N);
6917 -- Result is in range for valid value
6919 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6921 ("?c?value can only be out of range if it is invalid", N);
6926 -- Try to narrow the operation
6928 if Ltyp = Universal_Integer and then Nkind (N) = N_In then
6929 Narrow_Large_Operation (N);
6932 -- For all other cases of an explicit range, nothing to be done
6936 -- Here right operand is a subtype mark
6940 Typ : Entity_Id := Etype (Rop);
6941 Is_Acc : constant Boolean := Is_Access_Type (Typ);
6942 Check_Null_Exclusion : Boolean;
6943 Cond : Node_Id := Empty;
6945 Obj : Node_Id := Lop;
6946 SCIL_Node : Node_Id;
6949 Remove_Side_Effects (Obj);
6951 -- For tagged type, do tagged membership operation
6953 if Is_Tagged_Type (Typ) then
6955 -- No expansion will be performed for VM targets, as the VM
6956 -- back ends will handle the membership tests directly.
6958 if Tagged_Type_Expansion then
6959 Tagged_Membership (N, SCIL_Node, New_N);
6961 Analyze_And_Resolve (N, Restyp, Suppress => All_Checks);
6963 -- Update decoration of relocated node referenced by the
6966 if Generate_SCIL and then Present (SCIL_Node) then
6967 Set_SCIL_Node (N, SCIL_Node);
6973 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6974 -- This reason we do this is that the bounds may have the wrong
6975 -- type if they come from the original type definition. Also this
6976 -- way we get all the processing above for an explicit range.
6978 -- Don't do this for predicated types, since in this case we
6979 -- want to check the predicate.
6981 elsif Is_Scalar_Type (Typ) then
6982 if No (Predicate_Function (Typ)) then
6986 Make_Attribute_Reference (Loc,
6987 Attribute_Name => Name_First,
6988 Prefix => New_Occurrence_Of (Typ, Loc)),
6991 Make_Attribute_Reference (Loc,
6992 Attribute_Name => Name_Last,
6993 Prefix => New_Occurrence_Of (Typ, Loc))));
6994 Analyze_And_Resolve (N, Restyp);
6999 -- Ada 2005 (AI95-0216 amended by AI12-0162): Program_Error is
7000 -- raised when evaluating an individual membership test if the
7001 -- subtype mark denotes a constrained Unchecked_Union subtype
7002 -- and the expression lacks inferable discriminants.
7004 elsif Is_Unchecked_Union (Base_Type (Typ))
7005 and then Is_Constrained (Typ)
7006 and then not Has_Inferable_Discriminants (Lop)
7009 Make_Expression_With_Actions (Loc,
7011 New_List (Make_Raise_Program_Error (Loc,
7012 Reason => PE_Unchecked_Union_Restriction)),
7014 New_Occurrence_Of (Standard_False, Loc)));
7015 Analyze_And_Resolve (N, Restyp);
7020 -- Here we have a non-scalar type
7024 -- If the null exclusion checks are not compatible, need to
7025 -- perform further checks. In other words, we cannot have
7026 -- Ltyp including null and Typ excluding null. All other cases
7029 Check_Null_Exclusion :=
7030 Can_Never_Be_Null (Typ) and then not Can_Never_Be_Null (Ltyp);
7031 Typ := Designated_Type (Typ);
7034 if not Is_Constrained (Typ) then
7035 Cond := New_Occurrence_Of (Standard_True, Loc);
7037 -- For the constrained array case, we have to check the subscripts
7038 -- for an exact match if the lengths are non-zero (the lengths
7039 -- must match in any case).
7041 elsif Is_Array_Type (Typ) then
7042 Check_Subscripts : declare
7043 function Build_Attribute_Reference
7046 Dim : Nat) return Node_Id;
7047 -- Build attribute reference E'Nam (Dim)
7049 -------------------------------
7050 -- Build_Attribute_Reference --
7051 -------------------------------
7053 function Build_Attribute_Reference
7056 Dim : Nat) return Node_Id
7060 Make_Attribute_Reference (Loc,
7062 Attribute_Name => Nam,
7063 Expressions => New_List (
7064 Make_Integer_Literal (Loc, Dim)));
7065 end Build_Attribute_Reference;
7067 -- Start of processing for Check_Subscripts
7070 for J in 1 .. Number_Dimensions (Typ) loop
7071 Evolve_And_Then (Cond,
7074 Build_Attribute_Reference
7075 (Duplicate_Subexpr_No_Checks (Obj),
7078 Build_Attribute_Reference
7079 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
7081 Evolve_And_Then (Cond,
7084 Build_Attribute_Reference
7085 (Duplicate_Subexpr_No_Checks (Obj),
7088 Build_Attribute_Reference
7089 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
7091 end Check_Subscripts;
7093 -- These are the cases where constraint checks may be required,
7094 -- e.g. records with possible discriminants
7097 -- Expand the test into a series of discriminant comparisons.
7098 -- The expression that is built is the negation of the one that
7099 -- is used for checking discriminant constraints.
7101 Obj := Relocate_Node (Left_Opnd (N));
7103 if Has_Discriminants (Typ) then
7104 Cond := Make_Op_Not (Loc,
7105 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
7107 Cond := New_Occurrence_Of (Standard_True, Loc);
7112 if Check_Null_Exclusion then
7113 Cond := Make_And_Then (Loc,
7117 Right_Opnd => Make_Null (Loc)),
7118 Right_Opnd => Cond);
7120 Cond := Make_Or_Else (Loc,
7124 Right_Opnd => Make_Null (Loc)),
7125 Right_Opnd => Cond);
7130 Analyze_And_Resolve (N, Restyp);
7132 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
7133 -- expression of an anonymous access type. This can involve an
7134 -- accessibility test and a tagged type membership test in the
7135 -- case of tagged designated types.
7137 if Ada_Version >= Ada_2012
7139 and then Ekind (Ltyp) = E_Anonymous_Access_Type
7142 Expr_Entity : Entity_Id := Empty;
7144 Param_Level : Node_Id;
7145 Type_Level : Node_Id;
7148 if Is_Entity_Name (Lop) then
7149 Expr_Entity := Param_Entity (Lop);
7151 if No (Expr_Entity) then
7152 Expr_Entity := Entity (Lop);
7156 -- When restriction No_Dynamic_Accessibility_Checks is in
7157 -- effect, expand the membership test to a static value
7158 -- since we cannot rely on dynamic levels.
7160 if No_Dynamic_Accessibility_Checks_Enabled (Lop) then
7161 if Static_Accessibility_Level
7162 (Lop, Object_Decl_Level)
7163 > Type_Access_Level (Rtyp)
7165 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
7167 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
7169 Analyze_And_Resolve (N, Restyp);
7171 -- If a conversion of the anonymous access value to the
7172 -- tested type would be illegal, then the result is False.
7174 elsif not Valid_Conversion
7175 (Lop, Rtyp, Lop, Report_Errs => False)
7177 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
7178 Analyze_And_Resolve (N, Restyp);
7180 -- Apply an accessibility check if the access object has an
7181 -- associated access level and when the level of the type is
7182 -- less deep than the level of the access parameter. This
7183 -- can only occur for access parameters and stand-alone
7184 -- objects of an anonymous access type.
7187 Param_Level := Accessibility_Level
7188 (Expr_Entity, Dynamic_Level);
7191 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
7193 -- Return True only if the accessibility level of the
7194 -- expression entity is not deeper than the level of
7195 -- the tested access type.
7199 Left_Opnd => Relocate_Node (N),
7200 Right_Opnd => Make_Op_Le (Loc,
7201 Left_Opnd => Param_Level,
7202 Right_Opnd => Type_Level)));
7204 Analyze_And_Resolve (N);
7206 -- If the designated type is tagged, do tagged membership
7209 if Is_Tagged_Type (Typ) then
7211 -- No expansion will be performed for VM targets, as
7212 -- the VM back ends will handle the membership tests
7215 if Tagged_Type_Expansion then
7217 -- Note that we have to pass Original_Node, because
7218 -- the membership test might already have been
7219 -- rewritten by earlier parts of membership test.
7222 (Original_Node (N), SCIL_Node, New_N);
7224 -- Update decoration of relocated node referenced
7225 -- by the SCIL node.
7227 if Generate_SCIL and then Present (SCIL_Node) then
7228 Set_SCIL_Node (New_N, SCIL_Node);
7233 Left_Opnd => Relocate_Node (N),
7234 Right_Opnd => New_N));
7236 Analyze_And_Resolve (N, Restyp);
7245 -- At this point, we have done the processing required for the basic
7246 -- membership test, but not yet dealt with the predicate.
7250 -- If a predicate is present, then we do the predicate test, but we
7251 -- most certainly want to omit this if we are within the predicate
7252 -- function itself, since otherwise we have an infinite recursion.
7253 -- The check should also not be emitted when testing against a range
7254 -- (the check is only done when the right operand is a subtype; see
7255 -- RM12-4.5.2 (28.1/3-30/3)).
7257 Predicate_Check : declare
7258 function In_Range_Check return Boolean;
7259 -- Within an expanded range check that may raise Constraint_Error do
7260 -- not generate a predicate check as well. It is redundant because
7261 -- the context will add an explicit predicate check, and it will
7262 -- raise the wrong exception if it fails.
7264 --------------------
7265 -- In_Range_Check --
7266 --------------------
7268 function In_Range_Check return Boolean is
7272 while Present (P) loop
7273 if Nkind (P) = N_Raise_Constraint_Error then
7276 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call
7277 or else Nkind (P) = N_Procedure_Call_Statement
7278 or else Nkind (P) in N_Declaration
7291 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
7294 -- Start of processing for Predicate_Check
7298 and then Current_Scope /= PFunc
7299 and then Nkind (Rop) /= N_Range
7301 if not In_Range_Check then
7302 -- Indicate via Static_Mem parameter that this predicate
7303 -- evaluation is for a membership test.
7304 R_Op := Make_Predicate_Call (Rtyp, Lop, Static_Mem => True);
7306 R_Op := New_Occurrence_Of (Standard_True, Loc);
7311 Left_Opnd => Relocate_Node (N),
7312 Right_Opnd => R_Op));
7314 -- Analyze new expression, mark left operand as analyzed to
7315 -- avoid infinite recursion adding predicate calls. Similarly,
7316 -- suppress further range checks on the call.
7318 Set_Analyzed (Left_Opnd (N));
7319 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7321 -- All done, skip attempt at compile time determination of result
7325 end Predicate_Check;
7328 --------------------------------
7329 -- Expand_N_Indexed_Component --
7330 --------------------------------
7332 procedure Expand_N_Indexed_Component (N : Node_Id) is
7334 Wild_Reads_May_Have_Bad_Side_Effects : Boolean
7335 renames Validity_Check_Subscripts;
7336 -- This Boolean needs to be True if reading from a bad address can
7337 -- have a bad side effect (e.g., a segmentation fault that is not
7338 -- transformed into a Storage_Error exception, or interactions with
7339 -- memory-mapped I/O) that needs to be prevented. This refers to the
7340 -- act of reading itself, not to any damage that might be caused later
7341 -- by making use of whatever value was read. We assume here that
7342 -- Validity_Check_Subscripts meets this requirement, but introduce
7343 -- this declaration in order to document this assumption.
7345 function Is_Renamed_Variable_Name (N : Node_Id) return Boolean;
7346 -- Returns True if the given name occurs as part of the renaming
7347 -- of a variable. In this case, the indexing operation should be
7348 -- treated as a write, rather than a read, with respect to validity
7349 -- checking. This is because the renamed variable can later be
7352 function Type_Requires_Subscript_Validity_Checks_For_Reads
7353 (Typ : Entity_Id) return Boolean;
7354 -- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing
7355 -- into an array of characters in order to read an element, it is ok
7356 -- if an invalid index value goes undetected. But if it is an array of
7357 -- pointers or an array of tasks, the consequences of such a read are
7358 -- potentially more severe and so we want to detect an invalid index
7359 -- value. This function captures that distinction; this is intended to
7360 -- be consistent with the "but does not by itself lead to erroneous
7361 -- ... execution" rule of RM 13.9.1(11).
7363 ------------------------------
7364 -- Is_Renamed_Variable_Name --
7365 ------------------------------
7367 function Is_Renamed_Variable_Name (N : Node_Id) return Boolean is
7368 Rover : Node_Id := N;
7370 if Is_Variable (N) then
7373 Rover_Parent : constant Node_Id := Parent (Rover);
7375 case Nkind (Rover_Parent) is
7376 when N_Object_Renaming_Declaration =>
7377 return Rover = Name (Rover_Parent);
7379 when N_Indexed_Component
7381 | N_Selected_Component
7383 exit when Rover /= Prefix (Rover_Parent);
7384 Rover := Rover_Parent;
7386 -- No need to check for qualified expressions or type
7387 -- conversions here, mostly because of the Is_Variable
7388 -- test. It is possible to have a view conversion for
7389 -- which Is_Variable yields True and which occurs as
7390 -- part of an object renaming, but only if the type is
7391 -- tagged; in that case this function will not be called.
7400 end Is_Renamed_Variable_Name;
7402 -------------------------------------------------------
7403 -- Type_Requires_Subscript_Validity_Checks_For_Reads --
7404 -------------------------------------------------------
7406 function Type_Requires_Subscript_Validity_Checks_For_Reads
7407 (Typ : Entity_Id) return Boolean
7409 -- a shorter name for recursive calls
7410 function Needs_Check (Typ : Entity_Id) return Boolean renames
7411 Type_Requires_Subscript_Validity_Checks_For_Reads;
7413 if Is_Access_Type (Typ)
7414 or else Is_Tagged_Type (Typ)
7415 or else Is_Concurrent_Type (Typ)
7416 or else (Is_Array_Type (Typ)
7417 and then Needs_Check (Component_Type (Typ)))
7418 or else (Is_Scalar_Type (Typ)
7419 and then Has_Aspect (Typ, Aspect_Default_Value))
7424 if Is_Record_Type (Typ) then
7426 Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
7428 while Present (Comp) loop
7429 if Needs_Check (Etype (Comp)) then
7433 Next_Component_Or_Discriminant (Comp);
7439 end Type_Requires_Subscript_Validity_Checks_For_Reads;
7443 Loc : constant Source_Ptr := Sloc (N);
7444 Typ : constant Entity_Id := Etype (N);
7445 P : constant Node_Id := Prefix (N);
7446 T : constant Entity_Id := Etype (P);
7448 -- Start of processing for Expand_N_Indexed_Component
7451 -- A special optimization, if we have an indexed component that is
7452 -- selecting from a slice, then we can eliminate the slice, since, for
7453 -- example, x (i .. j)(k) is identical to x(k). The only difference is
7454 -- the range check required by the slice. The range check for the slice
7455 -- itself has already been generated. The range check for the
7456 -- subscripting operation is ensured by converting the subject to
7457 -- the subtype of the slice.
7459 -- This optimization not only generates better code, avoiding slice
7460 -- messing especially in the packed case, but more importantly bypasses
7461 -- some problems in handling this peculiar case, for example, the issue
7462 -- of dealing specially with object renamings.
7464 if Nkind (P) = N_Slice
7466 -- This optimization is disabled for CodePeer because it can transform
7467 -- an index-check constraint_error into a range-check constraint_error
7468 -- and CodePeer cares about that distinction.
7470 and then not CodePeer_Mode
7473 Make_Indexed_Component (Loc,
7474 Prefix => Prefix (P),
7475 Expressions => New_List (
7477 (Etype (First_Index (Etype (P))),
7478 First (Expressions (N))))));
7479 Analyze_And_Resolve (N, Typ);
7483 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7484 -- function, then additional actuals must be passed.
7486 if Is_Build_In_Place_Function_Call (P) then
7487 Make_Build_In_Place_Call_In_Anonymous_Context (P);
7489 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
7490 -- containing build-in-place function calls whose returned object covers
7493 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
7494 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
7497 -- Generate index and validity checks
7500 Dims_Checked : Dimension_Set (Dimensions =>
7501 (if Is_Array_Type (T)
7502 then Number_Dimensions (T)
7504 -- Dims_Checked is used to avoid generating two checks (one in
7505 -- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks)
7506 -- for the same index value in cases where the index check eliminates
7507 -- the need for the validity check. The Is_Array_Type test avoids
7508 -- cascading errors.
7511 Generate_Index_Checks (N, Checks_Generated => Dims_Checked);
7513 if Validity_Checks_On
7514 and then (Validity_Check_Subscripts
7515 or else Wild_Reads_May_Have_Bad_Side_Effects
7516 or else Type_Requires_Subscript_Validity_Checks_For_Reads
7518 or else Is_Renamed_Variable_Name (N))
7520 if Validity_Check_Subscripts then
7521 -- If we index into an array with an uninitialized variable
7522 -- and we generate an index check that passes at run time,
7523 -- passing that check does not ensure that the variable is
7524 -- valid (although it does in the common case where the
7525 -- object's subtype matches the index subtype).
7526 -- Consider an uninitialized variable with subtype 1 .. 10
7527 -- used to index into an array with bounds 1 .. 20 when the
7528 -- value of the uninitialized variable happens to be 15.
7529 -- The index check will succeed but the variable is invalid.
7530 -- If Validity_Check_Subscripts is True then we need to
7531 -- ensure validity, so we adjust Dims_Checked accordingly.
7532 Dims_Checked.Elements := (others => False);
7534 elsif Is_Array_Type (T) then
7535 -- We are only adding extra validity checks here to
7536 -- deal with uninitialized variables (but this includes
7537 -- assigning one uninitialized variable to another). Other
7538 -- ways of producing invalid objects imply erroneousness, so
7539 -- the compiler can do whatever it wants for those cases.
7540 -- If an index type has the Default_Value aspect specified,
7541 -- then we don't have to worry about the possibility of an
7542 -- uninitialized variable, so no need for these extra
7546 Idx : Node_Id := First_Index (T);
7548 for No_Check_Needed of Dims_Checked.Elements loop
7549 No_Check_Needed := No_Check_Needed
7550 or else Has_Aspect (Etype (Idx), Aspect_Default_Value);
7556 Apply_Subscript_Validity_Checks
7557 (N, No_Check_Needed => Dims_Checked);
7561 -- If selecting from an array with atomic components, and atomic sync
7562 -- is not suppressed for this array type, set atomic sync flag.
7564 if (Has_Atomic_Components (T)
7565 and then not Atomic_Synchronization_Disabled (T))
7566 or else (Is_Atomic (Typ)
7567 and then not Atomic_Synchronization_Disabled (Typ))
7568 or else (Is_Entity_Name (P)
7569 and then Has_Atomic_Components (Entity (P))
7570 and then not Atomic_Synchronization_Disabled (Entity (P)))
7572 Activate_Atomic_Synchronization (N);
7575 -- All done if the prefix is not a packed array implemented specially
7577 if not (Is_Packed (Etype (Prefix (N)))
7578 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N)))))
7583 -- For packed arrays that are not bit-packed (i.e. the case of an array
7584 -- with one or more index types with a non-contiguous enumeration type),
7585 -- we can always use the normal packed element get circuit.
7587 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
7588 Expand_Packed_Element_Reference (N);
7592 -- For a reference to a component of a bit packed array, we convert it
7593 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
7594 -- want to do this for simple references, and not for:
7596 -- Left side of assignment, or prefix of left side of assignment, or
7597 -- prefix of the prefix, to handle packed arrays of packed arrays,
7598 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
7600 -- Renaming objects in renaming associations
7601 -- This case is handled when a use of the renamed variable occurs
7603 -- Actual parameters for a subprogram call
7604 -- This case is handled in Exp_Ch6.Expand_Actuals
7606 -- The second expression in a 'Read attribute reference
7608 -- The prefix of an address or bit or size attribute reference
7610 -- The following circuit detects these exceptions. Note that we need to
7611 -- deal with implicit dereferences when climbing up the parent chain,
7612 -- with the additional difficulty that the type of parents may have yet
7613 -- to be resolved since prefixes are usually resolved first.
7616 Child : Node_Id := N;
7617 Parnt : Node_Id := Parent (N);
7621 if Nkind (Parnt) = N_Unchecked_Expression then
7624 elsif Nkind (Parnt) = N_Object_Renaming_Declaration then
7627 elsif Nkind (Parnt) in N_Subprogram_Call
7628 or else (Nkind (Parnt) = N_Parameter_Association
7629 and then Nkind (Parent (Parnt)) in N_Subprogram_Call)
7633 elsif Nkind (Parnt) = N_Attribute_Reference
7634 and then Attribute_Name (Parnt) in Name_Address
7637 and then Prefix (Parnt) = Child
7641 elsif Nkind (Parnt) = N_Assignment_Statement
7642 and then Name (Parnt) = Child
7646 -- If the expression is an index of an indexed component, it must
7647 -- be expanded regardless of context.
7649 elsif Nkind (Parnt) = N_Indexed_Component
7650 and then Child /= Prefix (Parnt)
7652 Expand_Packed_Element_Reference (N);
7655 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
7656 and then Name (Parent (Parnt)) = Parnt
7660 elsif Nkind (Parnt) = N_Attribute_Reference
7661 and then Attribute_Name (Parnt) = Name_Read
7662 and then Next (First (Expressions (Parnt))) = Child
7666 elsif Nkind (Parnt) = N_Indexed_Component
7667 and then Prefix (Parnt) = Child
7671 elsif Nkind (Parnt) = N_Selected_Component
7672 and then Prefix (Parnt) = Child
7673 and then not (Present (Etype (Selector_Name (Parnt)))
7675 Is_Access_Type (Etype (Selector_Name (Parnt))))
7679 -- If the parent is a dereference, either implicit or explicit,
7680 -- then the packed reference needs to be expanded.
7683 Expand_Packed_Element_Reference (N);
7687 -- Keep looking up tree for unchecked expression, or if we are the
7688 -- prefix of a possible assignment left side.
7691 Parnt := Parent (Child);
7694 end Expand_N_Indexed_Component;
7696 ---------------------
7697 -- Expand_N_Not_In --
7698 ---------------------
7700 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7701 -- can be done. This avoids needing to duplicate this expansion code.
7703 procedure Expand_N_Not_In (N : Node_Id) is
7704 Loc : constant Source_Ptr := Sloc (N);
7705 Typ : constant Entity_Id := Etype (N);
7706 Cfs : constant Boolean := Comes_From_Source (N);
7713 Left_Opnd => Left_Opnd (N),
7714 Right_Opnd => Right_Opnd (N))));
7716 -- If this is a set membership, preserve list of alternatives
7718 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
7720 -- We want this to appear as coming from source if original does (see
7721 -- transformations in Expand_N_In).
7723 Set_Comes_From_Source (N, Cfs);
7724 Set_Comes_From_Source (Right_Opnd (N), Cfs);
7726 -- Now analyze transformed node
7728 Analyze_And_Resolve (N, Typ);
7729 end Expand_N_Not_In;
7735 -- The only replacement required is for the case of a null of a type that
7736 -- is an access to protected subprogram, or a subtype thereof. We represent
7737 -- such access values as a record, and so we must replace the occurrence of
7738 -- null by the equivalent record (with a null address and a null pointer in
7739 -- it), so that the back end creates the proper value.
7741 procedure Expand_N_Null (N : Node_Id) is
7742 Loc : constant Source_Ptr := Sloc (N);
7743 Typ : constant Entity_Id := Base_Type (Etype (N));
7747 if Is_Access_Protected_Subprogram_Type (Typ) then
7749 Make_Aggregate (Loc,
7750 Expressions => New_List (
7751 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
7755 Analyze_And_Resolve (N, Equivalent_Type (Typ));
7757 -- For subsequent semantic analysis, the node must retain its type.
7758 -- Gigi in any case replaces this type by the corresponding record
7759 -- type before processing the node.
7765 when RE_Not_Available =>
7769 ---------------------
7770 -- Expand_N_Op_Abs --
7771 ---------------------
7773 procedure Expand_N_Op_Abs (N : Node_Id) is
7774 Loc : constant Source_Ptr := Sloc (N);
7775 Expr : constant Node_Id := Right_Opnd (N);
7776 Typ : constant Entity_Id := Etype (N);
7779 Unary_Op_Validity_Checks (N);
7781 -- Check for MINIMIZED/ELIMINATED overflow mode
7783 if Minimized_Eliminated_Overflow_Check (N) then
7784 Apply_Arithmetic_Overflow_Check (N);
7788 -- Try to narrow the operation
7790 if Typ = Universal_Integer then
7791 Narrow_Large_Operation (N);
7793 if Nkind (N) /= N_Op_Abs then
7798 -- Deal with software overflow checking
7800 if Is_Signed_Integer_Type (Typ)
7801 and then Do_Overflow_Check (N)
7803 -- The only case to worry about is when the argument is equal to the
7804 -- largest negative number, so what we do is to insert the check:
7806 -- [constraint_error when Expr = typ'Base'First]
7808 -- with the usual Duplicate_Subexpr use coding for expr
7811 Make_Raise_Constraint_Error (Loc,
7814 Left_Opnd => Duplicate_Subexpr (Expr),
7816 Make_Attribute_Reference (Loc,
7818 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
7819 Attribute_Name => Name_First)),
7820 Reason => CE_Overflow_Check_Failed));
7822 Set_Do_Overflow_Check (N, False);
7824 end Expand_N_Op_Abs;
7826 ---------------------
7827 -- Expand_N_Op_Add --
7828 ---------------------
7830 procedure Expand_N_Op_Add (N : Node_Id) is
7831 Typ : constant Entity_Id := Etype (N);
7834 Binary_Op_Validity_Checks (N);
7836 -- Check for MINIMIZED/ELIMINATED overflow mode
7838 if Minimized_Eliminated_Overflow_Check (N) then
7839 Apply_Arithmetic_Overflow_Check (N);
7843 -- N + 0 = 0 + N = N for integer types
7845 if Is_Integer_Type (Typ) then
7846 if Compile_Time_Known_Value (Right_Opnd (N))
7847 and then Expr_Value (Right_Opnd (N)) = Uint_0
7849 Rewrite (N, Left_Opnd (N));
7852 elsif Compile_Time_Known_Value (Left_Opnd (N))
7853 and then Expr_Value (Left_Opnd (N)) = Uint_0
7855 Rewrite (N, Right_Opnd (N));
7860 -- Try to narrow the operation
7862 if Typ = Universal_Integer then
7863 Narrow_Large_Operation (N);
7865 if Nkind (N) /= N_Op_Add then
7870 -- Arithmetic overflow checks for signed integer/fixed point types
7872 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
7873 Apply_Arithmetic_Overflow_Check (N);
7877 -- Overflow checks for floating-point if -gnateF mode active
7879 Check_Float_Op_Overflow (N);
7881 Expand_Nonbinary_Modular_Op (N);
7882 end Expand_N_Op_Add;
7884 ---------------------
7885 -- Expand_N_Op_And --
7886 ---------------------
7888 procedure Expand_N_Op_And (N : Node_Id) is
7889 Typ : constant Entity_Id := Etype (N);
7892 Binary_Op_Validity_Checks (N);
7894 if Is_Array_Type (Etype (N)) then
7895 Expand_Boolean_Operator (N);
7897 elsif Is_Boolean_Type (Etype (N)) then
7898 Adjust_Condition (Left_Opnd (N));
7899 Adjust_Condition (Right_Opnd (N));
7900 Set_Etype (N, Standard_Boolean);
7901 Adjust_Result_Type (N, Typ);
7903 elsif Is_Intrinsic_Subprogram (Entity (N)) then
7904 Expand_Intrinsic_Call (N, Entity (N));
7907 Expand_Nonbinary_Modular_Op (N);
7908 end Expand_N_Op_And;
7910 ------------------------
7911 -- Expand_N_Op_Concat --
7912 ------------------------
7914 procedure Expand_N_Op_Concat (N : Node_Id) is
7916 -- List of operands to be concatenated
7919 -- Node which is to be replaced by the result of concatenating the nodes
7920 -- in the list Opnds.
7923 -- Ensure validity of both operands
7925 Binary_Op_Validity_Checks (N);
7927 -- If we are the left operand of a concatenation higher up the tree,
7928 -- then do nothing for now, since we want to deal with a series of
7929 -- concatenations as a unit.
7931 if Nkind (Parent (N)) = N_Op_Concat
7932 and then N = Left_Opnd (Parent (N))
7937 -- We get here with a concatenation whose left operand may be a
7938 -- concatenation itself with a consistent type. We need to process
7939 -- these concatenation operands from left to right, which means
7940 -- from the deepest node in the tree to the highest node.
7943 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
7944 Cnode := Left_Opnd (Cnode);
7947 -- Now Cnode is the deepest concatenation, and its parents are the
7948 -- concatenation nodes above, so now we process bottom up, doing the
7951 -- The outer loop runs more than once if more than one concatenation
7952 -- type is involved.
7955 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
7956 Set_Parent (Opnds, N);
7958 -- The inner loop gathers concatenation operands
7960 Inner : while Cnode /= N
7961 and then Base_Type (Etype (Cnode)) =
7962 Base_Type (Etype (Parent (Cnode)))
7964 Cnode := Parent (Cnode);
7965 Append (Right_Opnd (Cnode), Opnds);
7968 -- Note: The following code is a temporary workaround for N731-034
7969 -- and N829-028 and will be kept until the general issue of internal
7970 -- symbol serialization is addressed. The workaround is kept under a
7971 -- debug switch to avoid permiating into the general case.
7973 -- Wrap the node to concatenate into an expression actions node to
7974 -- keep it nicely packaged. This is useful in the case of an assert
7975 -- pragma with a concatenation where we want to be able to delete
7976 -- the concatenation and all its expansion stuff.
7978 if Debug_Flag_Dot_H then
7980 Cnod : constant Node_Id := New_Copy_Tree (Cnode);
7981 Typ : constant Entity_Id := Base_Type (Etype (Cnode));
7984 -- Note: use Rewrite rather than Replace here, so that for
7985 -- example Why_Not_Static can find the original concatenation
7989 Make_Expression_With_Actions (Sloc (Cnode),
7990 Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
7991 Expression => Cnod));
7993 Expand_Concatenate (Cnod, Opnds);
7994 Analyze_And_Resolve (Cnode, Typ);
8000 Expand_Concatenate (Cnode, Opnds);
8003 exit Outer when Cnode = N;
8004 Cnode := Parent (Cnode);
8006 end Expand_N_Op_Concat;
8008 ------------------------
8009 -- Expand_N_Op_Divide --
8010 ------------------------
8012 procedure Expand_N_Op_Divide (N : Node_Id) is
8013 Loc : constant Source_Ptr := Sloc (N);
8014 Lopnd : constant Node_Id := Left_Opnd (N);
8015 Ropnd : constant Node_Id := Right_Opnd (N);
8016 Ltyp : constant Entity_Id := Etype (Lopnd);
8017 Rtyp : constant Entity_Id := Etype (Ropnd);
8018 Typ : Entity_Id := Etype (N);
8019 Rknow : constant Boolean := Is_Integer_Type (Typ)
8021 Compile_Time_Known_Value (Ropnd);
8025 Binary_Op_Validity_Checks (N);
8027 -- Check for MINIMIZED/ELIMINATED overflow mode
8029 if Minimized_Eliminated_Overflow_Check (N) then
8030 Apply_Arithmetic_Overflow_Check (N);
8034 -- Otherwise proceed with expansion of division
8037 Rval := Expr_Value (Ropnd);
8040 -- N / 1 = N for integer types
8042 if Rknow and then Rval = Uint_1 then
8047 -- Try to narrow the operation
8049 if Typ = Universal_Integer then
8050 Narrow_Large_Operation (N);
8052 if Nkind (N) /= N_Op_Divide then
8057 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
8058 -- Is_Power_Of_2_For_Shift is set means that we know that our left
8059 -- operand is an unsigned integer, as required for this to work.
8061 if Nkind (Ropnd) = N_Op_Expon
8062 and then Is_Power_Of_2_For_Shift (Ropnd)
8064 -- We cannot do this transformation in configurable run time mode if we
8065 -- have 64-bit integers and long shifts are not available.
8067 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
8070 Make_Op_Shift_Right (Loc,
8073 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
8074 Analyze_And_Resolve (N, Typ);
8078 -- Do required fixup of universal fixed operation
8080 if Typ = Universal_Fixed then
8081 Fixup_Universal_Fixed_Operation (N);
8085 -- Divisions with fixed-point results
8087 if Is_Fixed_Point_Type (Typ) then
8089 if Is_Integer_Type (Rtyp) then
8090 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
8092 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
8095 -- Deal with divide-by-zero check if back end cannot handle them
8096 -- and the flag is set indicating that we need such a check. Note
8097 -- that we don't need to bother here with the case of mixed-mode
8098 -- (Right operand an integer type), since these will be rewritten
8099 -- with conversions to a divide with a fixed-point right operand.
8101 if Nkind (N) = N_Op_Divide
8102 and then Do_Division_Check (N)
8103 and then not Backend_Divide_Checks_On_Target
8104 and then not Is_Integer_Type (Rtyp)
8106 Set_Do_Division_Check (N, False);
8108 Make_Raise_Constraint_Error (Loc,
8111 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd),
8112 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
8113 Reason => CE_Divide_By_Zero));
8116 -- Other cases of division of fixed-point operands
8118 elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then
8119 if Is_Integer_Type (Typ) then
8120 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
8122 pragma Assert (Is_Floating_Point_Type (Typ));
8123 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
8126 -- Mixed-mode operations can appear in a non-static universal context,
8127 -- in which case the integer argument must be converted explicitly.
8129 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
8131 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
8133 Analyze_And_Resolve (Ropnd, Universal_Real);
8135 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
8137 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
8139 Analyze_And_Resolve (Lopnd, Universal_Real);
8141 -- Non-fixed point cases, do integer zero divide and overflow checks
8143 elsif Is_Integer_Type (Typ) then
8144 Apply_Divide_Checks (N);
8147 -- Overflow checks for floating-point if -gnateF mode active
8149 Check_Float_Op_Overflow (N);
8151 Expand_Nonbinary_Modular_Op (N);
8152 end Expand_N_Op_Divide;
8154 --------------------
8155 -- Expand_N_Op_Eq --
8156 --------------------
8158 procedure Expand_N_Op_Eq (N : Node_Id) is
8159 Loc : constant Source_Ptr := Sloc (N);
8160 Typ : constant Entity_Id := Etype (N);
8161 Lhs : constant Node_Id := Left_Opnd (N);
8162 Rhs : constant Node_Id := Right_Opnd (N);
8163 Bodies : constant List_Id := New_List;
8164 A_Typ : constant Entity_Id := Etype (Lhs);
8166 procedure Build_Equality_Call (Eq : Entity_Id);
8167 -- If a constructed equality exists for the type or for its parent,
8168 -- build and analyze call, adding conversions if the operation is
8171 function Find_Equality (Prims : Elist_Id) return Entity_Id;
8172 -- Find a primitive equality function within primitive operation list
8175 function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean;
8176 -- Determines whether a type has a subcomponent of an unconstrained
8177 -- Unchecked_Union subtype. Typ is a record type.
8179 -------------------------
8180 -- Build_Equality_Call --
8181 -------------------------
8183 procedure Build_Equality_Call (Eq : Entity_Id) is
8184 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
8185 L_Exp : Node_Id := Relocate_Node (Lhs);
8186 R_Exp : Node_Id := Relocate_Node (Rhs);
8189 -- Adjust operands if necessary to comparison type
8191 if Base_Type (Op_Type) /= Base_Type (A_Typ)
8192 and then not Is_Class_Wide_Type (A_Typ)
8194 L_Exp := OK_Convert_To (Op_Type, L_Exp);
8195 R_Exp := OK_Convert_To (Op_Type, R_Exp);
8198 -- If we have an Unchecked_Union, we need to add the inferred
8199 -- discriminant values as actuals in the function call. At this
8200 -- point, the expansion has determined that both operands have
8201 -- inferable discriminants.
8203 if Is_Unchecked_Union (Op_Type) then
8205 Lhs_Type : constant Entity_Id := Etype (L_Exp);
8206 Rhs_Type : constant Entity_Id := Etype (R_Exp);
8208 Lhs_Discr_Vals : Elist_Id;
8209 -- List of inferred discriminant values for left operand.
8211 Rhs_Discr_Vals : Elist_Id;
8212 -- List of inferred discriminant values for right operand.
8217 Lhs_Discr_Vals := New_Elmt_List;
8218 Rhs_Discr_Vals := New_Elmt_List;
8220 -- Per-object constrained selected components require special
8221 -- attention. If the enclosing scope of the component is an
8222 -- Unchecked_Union, we cannot reference its discriminants
8223 -- directly. This is why we use the extra parameters of the
8224 -- equality function of the enclosing Unchecked_Union.
8226 -- type UU_Type (Discr : Integer := 0) is
8229 -- pragma Unchecked_Union (UU_Type);
8231 -- 1. Unchecked_Union enclosing record:
8233 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
8235 -- Comp : UU_Type (Discr);
8237 -- end Enclosing_UU_Type;
8238 -- pragma Unchecked_Union (Enclosing_UU_Type);
8240 -- Obj1 : Enclosing_UU_Type;
8241 -- Obj2 : Enclosing_UU_Type (1);
8243 -- [. . .] Obj1 = Obj2 [. . .]
8247 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
8249 -- A and B are the formal parameters of the equality function
8250 -- of Enclosing_UU_Type. The function always has two extra
8251 -- formals to capture the inferred discriminant values for
8252 -- each discriminant of the type.
8254 -- 2. Non-Unchecked_Union enclosing record:
8257 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
8260 -- Comp : UU_Type (Discr);
8262 -- end Enclosing_Non_UU_Type;
8264 -- Obj1 : Enclosing_Non_UU_Type;
8265 -- Obj2 : Enclosing_Non_UU_Type (1);
8267 -- ... Obj1 = Obj2 ...
8271 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
8272 -- obj1.discr, obj2.discr)) then
8274 -- In this case we can directly reference the discriminants of
8275 -- the enclosing record.
8277 -- Process left operand of equality
8279 if Nkind (Lhs) = N_Selected_Component
8281 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
8283 -- If enclosing record is an Unchecked_Union, use formals
8284 -- corresponding to each discriminant. The name of the
8285 -- formal is that of the discriminant, with added suffix,
8286 -- see Exp_Ch3.Build_Record_Equality for details.
8288 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
8292 (Scope (Entity (Selector_Name (Lhs))));
8293 while Present (Discr) loop
8295 (Make_Identifier (Loc,
8296 Chars => New_External_Name (Chars (Discr), 'A')),
8297 To => Lhs_Discr_Vals);
8298 Next_Discriminant (Discr);
8301 -- If enclosing record is of a non-Unchecked_Union type, it
8302 -- is possible to reference its discriminants directly.
8305 Discr := First_Discriminant (Lhs_Type);
8306 while Present (Discr) loop
8308 (Make_Selected_Component (Loc,
8309 Prefix => Prefix (Lhs),
8312 (Get_Discriminant_Value (Discr,
8314 Stored_Constraint (Lhs_Type)))),
8315 To => Lhs_Discr_Vals);
8316 Next_Discriminant (Discr);
8320 -- Otherwise operand is on object with a constrained type.
8321 -- Infer the discriminant values from the constraint.
8324 Discr := First_Discriminant (Lhs_Type);
8325 while Present (Discr) loop
8328 (Get_Discriminant_Value (Discr,
8330 Stored_Constraint (Lhs_Type))),
8331 To => Lhs_Discr_Vals);
8332 Next_Discriminant (Discr);
8336 -- Similar processing for right operand of equality
8338 if Nkind (Rhs) = N_Selected_Component
8340 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
8342 if Is_Unchecked_Union
8343 (Scope (Entity (Selector_Name (Rhs))))
8347 (Scope (Entity (Selector_Name (Rhs))));
8348 while Present (Discr) loop
8350 (Make_Identifier (Loc,
8351 Chars => New_External_Name (Chars (Discr), 'B')),
8352 To => Rhs_Discr_Vals);
8353 Next_Discriminant (Discr);
8357 Discr := First_Discriminant (Rhs_Type);
8358 while Present (Discr) loop
8360 (Make_Selected_Component (Loc,
8361 Prefix => Prefix (Rhs),
8363 New_Copy (Get_Discriminant_Value
8366 Stored_Constraint (Rhs_Type)))),
8367 To => Rhs_Discr_Vals);
8368 Next_Discriminant (Discr);
8373 Discr := First_Discriminant (Rhs_Type);
8374 while Present (Discr) loop
8376 (New_Copy (Get_Discriminant_Value
8379 Stored_Constraint (Rhs_Type))),
8380 To => Rhs_Discr_Vals);
8381 Next_Discriminant (Discr);
8385 -- Now merge the list of discriminant values so that values
8386 -- of corresponding discriminants are adjacent.
8394 Params := New_List (L_Exp, R_Exp);
8395 L_Elmt := First_Elmt (Lhs_Discr_Vals);
8396 R_Elmt := First_Elmt (Rhs_Discr_Vals);
8397 while Present (L_Elmt) loop
8398 Append_To (Params, Node (L_Elmt));
8399 Append_To (Params, Node (R_Elmt));
8405 Make_Function_Call (Loc,
8406 Name => New_Occurrence_Of (Eq, Loc),
8407 Parameter_Associations => Params));
8411 -- Normal case, not an unchecked union
8415 Make_Function_Call (Loc,
8416 Name => New_Occurrence_Of (Eq, Loc),
8417 Parameter_Associations => New_List (L_Exp, R_Exp)));
8420 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8421 end Build_Equality_Call;
8427 function Find_Equality (Prims : Elist_Id) return Entity_Id is
8428 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id;
8429 -- Find an equality in a possible alias chain starting from primitive
8432 ---------------------------
8433 -- Find_Aliased_Equality --
8434 ---------------------------
8436 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id is
8440 -- Inspect each candidate in the alias chain, checking whether it
8441 -- denotes an equality.
8444 while Present (Candid) loop
8445 if Is_User_Defined_Equality (Candid) then
8449 Candid := Alias (Candid);
8453 end Find_Aliased_Equality;
8457 Eq_Prim : Entity_Id;
8458 Prim_Elmt : Elmt_Id;
8460 -- Start of processing for Find_Equality
8463 -- Assume that the tagged type lacks an equality
8467 -- Inspect the list of primitives looking for a suitable equality
8468 -- within a possible chain of aliases.
8470 Prim_Elmt := First_Elmt (Prims);
8471 while Present (Prim_Elmt) and then No (Eq_Prim) loop
8472 Eq_Prim := Find_Aliased_Equality (Node (Prim_Elmt));
8474 Next_Elmt (Prim_Elmt);
8477 -- A tagged type should always have an equality
8479 pragma Assert (Present (Eq_Prim));
8484 ------------------------------------
8485 -- Has_Unconstrained_UU_Component --
8486 ------------------------------------
8488 function Has_Unconstrained_UU_Component
8489 (Typ : Entity_Id) return Boolean
8491 function Unconstrained_UU_In_Component_Declaration
8492 (N : Node_Id) return Boolean;
8494 function Unconstrained_UU_In_Component_Items
8495 (L : List_Id) return Boolean;
8497 function Unconstrained_UU_In_Component_List
8498 (N : Node_Id) return Boolean;
8500 function Unconstrained_UU_In_Variant_Part
8501 (N : Node_Id) return Boolean;
8502 -- A family of routines that determine whether a particular construct
8503 -- of a record type definition contains a subcomponent of an
8504 -- unchecked union type whose nominal subtype is unconstrained.
8506 -- Individual routines correspond to the production rules of the Ada
8507 -- grammar, as described in the Ada RM (P).
8509 -----------------------------------------------
8510 -- Unconstrained_UU_In_Component_Declaration --
8511 -----------------------------------------------
8513 function Unconstrained_UU_In_Component_Declaration
8514 (N : Node_Id) return Boolean
8516 pragma Assert (Nkind (N) = N_Component_Declaration);
8518 Sindic : constant Node_Id :=
8519 Subtype_Indication (Component_Definition (N));
8521 -- If the component declaration includes a subtype indication
8522 -- it is not an unchecked_union. Otherwise verify that it carries
8523 -- the Unchecked_Union flag and is either a record or a private
8524 -- type. A Record_Subtype declared elsewhere does not qualify,
8525 -- even if its parent type carries the flag.
8527 return Nkind (Sindic) in N_Expanded_Name | N_Identifier
8528 and then Is_Unchecked_Union (Base_Type (Etype (Sindic)))
8529 and then (Ekind (Entity (Sindic)) in
8530 E_Private_Type | E_Record_Type);
8531 end Unconstrained_UU_In_Component_Declaration;
8533 -----------------------------------------
8534 -- Unconstrained_UU_In_Component_Items --
8535 -----------------------------------------
8537 function Unconstrained_UU_In_Component_Items
8538 (L : List_Id) return Boolean
8540 N : Node_Id := First (L);
8542 while Present (N) loop
8543 if Nkind (N) = N_Component_Declaration
8544 and then Unconstrained_UU_In_Component_Declaration (N)
8553 end Unconstrained_UU_In_Component_Items;
8555 ----------------------------------------
8556 -- Unconstrained_UU_In_Component_List --
8557 ----------------------------------------
8559 function Unconstrained_UU_In_Component_List
8560 (N : Node_Id) return Boolean
8562 pragma Assert (Nkind (N) = N_Component_List);
8564 Optional_Variant_Part : Node_Id;
8566 if Unconstrained_UU_In_Component_Items (Component_Items (N)) then
8570 Optional_Variant_Part := Variant_Part (N);
8573 Present (Optional_Variant_Part)
8575 Unconstrained_UU_In_Variant_Part (Optional_Variant_Part);
8576 end Unconstrained_UU_In_Component_List;
8578 --------------------------------------
8579 -- Unconstrained_UU_In_Variant_Part --
8580 --------------------------------------
8582 function Unconstrained_UU_In_Variant_Part
8583 (N : Node_Id) return Boolean
8585 pragma Assert (Nkind (N) = N_Variant_Part);
8587 Variant : Node_Id := First (Variants (N));
8590 if Unconstrained_UU_In_Component_List (Component_List (Variant))
8596 exit when No (Variant);
8600 end Unconstrained_UU_In_Variant_Part;
8602 Typ_Def : constant Node_Id :=
8603 Type_Definition (Declaration_Node (Base_Type (Typ)));
8605 Optional_Component_List : constant Node_Id :=
8606 Component_List (Typ_Def);
8608 -- Start of processing for Has_Unconstrained_UU_Component
8611 return Present (Optional_Component_List)
8613 Unconstrained_UU_In_Component_List (Optional_Component_List);
8614 end Has_Unconstrained_UU_Component;
8620 -- Start of processing for Expand_N_Op_Eq
8623 Binary_Op_Validity_Checks (N);
8625 -- Deal with private types
8627 Typl := Underlying_Type (A_Typ);
8629 -- It may happen in error situations that the underlying type is not
8630 -- set. The error will be detected later, here we just defend the
8637 -- Now get the implementation base type (note that plain Base_Type here
8638 -- might lead us back to the private type, which is not what we want!)
8640 Typl := Implementation_Base_Type (Typl);
8642 -- Equality between variant records results in a call to a routine
8643 -- that has conditional tests of the discriminant value(s), and hence
8644 -- violates the No_Implicit_Conditionals restriction.
8646 if Has_Variant_Part (Typl) then
8651 Check_Restriction (Msg, No_Implicit_Conditionals, N);
8655 ("\comparison of variant records tests discriminants", N);
8661 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8662 -- means we no longer have a comparison operation, we are all done.
8664 if Minimized_Eliminated_Overflow_Check (Left_Opnd (N)) then
8665 Expand_Compare_Minimize_Eliminate_Overflow (N);
8668 if Nkind (N) /= N_Op_Eq then
8672 -- Boolean types (requiring handling of non-standard case)
8674 if Is_Boolean_Type (Typl) then
8675 Adjust_Condition (Left_Opnd (N));
8676 Adjust_Condition (Right_Opnd (N));
8677 Set_Etype (N, Standard_Boolean);
8678 Adjust_Result_Type (N, Typ);
8682 elsif Is_Array_Type (Typl) then
8684 -- If we are doing full validity checking, and it is possible for the
8685 -- array elements to be invalid then expand out array comparisons to
8686 -- make sure that we check the array elements.
8688 if Validity_Check_Operands
8689 and then not Is_Known_Valid (Component_Type (Typl))
8692 Save_Force_Validity_Checks : constant Boolean :=
8693 Force_Validity_Checks;
8695 Force_Validity_Checks := True;
8697 Expand_Array_Equality
8699 Relocate_Node (Lhs),
8700 Relocate_Node (Rhs),
8703 Insert_Actions (N, Bodies);
8704 Analyze_And_Resolve (N, Standard_Boolean);
8705 Force_Validity_Checks := Save_Force_Validity_Checks;
8708 -- Packed case where both operands are known aligned
8710 elsif Is_Bit_Packed_Array (Typl)
8711 and then not Is_Possibly_Unaligned_Object (Lhs)
8712 and then not Is_Possibly_Unaligned_Object (Rhs)
8714 Expand_Packed_Eq (N);
8716 -- Where the component type is elementary we can use a block bit
8717 -- comparison (if supported on the target) exception in the case
8718 -- of floating-point (negative zero issues require element by
8719 -- element comparison), and full access types (where we must be sure
8720 -- to load elements independently) and possibly unaligned arrays.
8722 elsif Is_Elementary_Type (Component_Type (Typl))
8723 and then not Is_Floating_Point_Type (Component_Type (Typl))
8724 and then not Is_Full_Access (Component_Type (Typl))
8725 and then not Is_Possibly_Unaligned_Object (Lhs)
8726 and then not Is_Possibly_Unaligned_Slice (Lhs)
8727 and then not Is_Possibly_Unaligned_Object (Rhs)
8728 and then not Is_Possibly_Unaligned_Slice (Rhs)
8729 and then Support_Composite_Compare_On_Target
8733 -- For composite and floating-point cases, expand equality loop to
8734 -- make sure of using proper comparisons for tagged types, and
8735 -- correctly handling the floating-point case.
8739 Expand_Array_Equality
8741 Relocate_Node (Lhs),
8742 Relocate_Node (Rhs),
8745 Insert_Actions (N, Bodies, Suppress => All_Checks);
8746 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8751 elsif Is_Record_Type (Typl) then
8753 -- For tagged types, use the primitive "="
8755 if Is_Tagged_Type (Typl) then
8757 -- No need to do anything else compiling under restriction
8758 -- No_Dispatching_Calls. During the semantic analysis we
8759 -- already notified such violation.
8761 if Restriction_Active (No_Dispatching_Calls) then
8765 -- If this is an untagged private type completed with a derivation
8766 -- of an untagged private type whose full view is a tagged type,
8767 -- we use the primitive operations of the private type (since it
8768 -- does not have a full view, and also because its equality
8769 -- primitive may have been overridden in its untagged full view).
8771 if Inherits_From_Tagged_Full_View (A_Typ) then
8773 (Find_Equality (Collect_Primitive_Operations (A_Typ)));
8775 -- Find the type's predefined equality or an overriding
8776 -- user-defined equality. The reason for not simply calling
8777 -- Find_Prim_Op here is that there may be a user-defined
8778 -- overloaded equality op that precedes the equality that we
8779 -- want, so we have to explicitly search (e.g., there could be
8780 -- an equality with two different parameter types).
8783 if Is_Class_Wide_Type (Typl) then
8784 Typl := Find_Specific_Type (Typl);
8788 (Find_Equality (Primitive_Operations (Typl)));
8791 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8792 -- predefined equality operator for a type which has a subcomponent
8793 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
8795 elsif Has_Unconstrained_UU_Component (Typl) then
8797 Make_Raise_Program_Error (Loc,
8798 Reason => PE_Unchecked_Union_Restriction));
8800 -- Prevent Gigi from generating incorrect code by rewriting the
8801 -- equality as a standard False. (is this documented somewhere???)
8804 New_Occurrence_Of (Standard_False, Loc));
8806 elsif Is_Unchecked_Union (Typl) then
8808 -- If we can infer the discriminants of the operands, we make a
8809 -- call to the TSS equality function.
8811 if Has_Inferable_Discriminants (Lhs)
8813 Has_Inferable_Discriminants (Rhs)
8816 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8819 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
8820 -- the predefined equality operator for an Unchecked_Union type
8821 -- if either of the operands lack inferable discriminants.
8824 Make_Raise_Program_Error (Loc,
8825 Reason => PE_Unchecked_Union_Restriction));
8827 -- Emit a warning on source equalities only, otherwise the
8828 -- message may appear out of place due to internal use. The
8829 -- warning is unconditional because it is required by the
8832 if Comes_From_Source (N) then
8834 ("Unchecked_Union discriminants cannot be determined??",
8837 ("\Program_Error will be raised for equality operation??",
8841 -- Prevent Gigi from generating incorrect code by rewriting
8842 -- the equality as a standard False (documented where???).
8845 New_Occurrence_Of (Standard_False, Loc));
8848 -- If a type support function is present (for complex cases), use it
8850 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
8852 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8854 -- When comparing two Bounded_Strings, use the primitive equality of
8855 -- the root Super_String type.
8857 elsif Is_Bounded_String (Typl) then
8860 (Collect_Primitive_Operations (Root_Type (Typl))));
8862 -- Otherwise expand the component by component equality. Note that
8863 -- we never use block-bit comparisons for records, because of the
8864 -- problems with gaps. The back end will often be able to recombine
8865 -- the separate comparisons that we generate here.
8868 Remove_Side_Effects (Lhs);
8869 Remove_Side_Effects (Rhs);
8870 Rewrite (N, Expand_Record_Equality (N, Typl, Lhs, Rhs));
8872 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8875 -- If unnesting, handle elementary types whose Equivalent_Types are
8876 -- records because there may be padding or undefined fields.
8878 elsif Unnest_Subprogram_Mode
8879 and then Ekind (Typl) in E_Class_Wide_Type
8880 | E_Class_Wide_Subtype
8881 | E_Access_Subprogram_Type
8882 | E_Access_Protected_Subprogram_Type
8883 | E_Anonymous_Access_Protected_Subprogram_Type
8885 and then Present (Equivalent_Type (Typl))
8886 and then Is_Record_Type (Equivalent_Type (Typl))
8888 Typl := Equivalent_Type (Typl);
8889 Remove_Side_Effects (Lhs);
8890 Remove_Side_Effects (Rhs);
8892 Expand_Record_Equality (N, Typl,
8893 Unchecked_Convert_To (Typl, Lhs),
8894 Unchecked_Convert_To (Typl, Rhs)));
8896 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8899 -- Test if result is known at compile time
8901 Rewrite_Comparison (N);
8903 -- Try to narrow the operation
8905 if Typl = Universal_Integer and then Nkind (N) = N_Op_Eq then
8906 Narrow_Large_Operation (N);
8909 -- Special optimization of length comparison
8911 Optimize_Length_Comparison (N);
8913 -- One more special case: if we have a comparison of X'Result = expr
8914 -- in floating-point, then if not already there, change expr to be
8915 -- f'Machine (expr) to eliminate surprise from extra precision.
8917 if Is_Floating_Point_Type (Typl)
8918 and then Is_Attribute_Result (Original_Node (Lhs))
8920 -- Stick in the Typ'Machine call if not already there
8922 if Nkind (Rhs) /= N_Attribute_Reference
8923 or else Attribute_Name (Rhs) /= Name_Machine
8926 Make_Attribute_Reference (Loc,
8927 Prefix => New_Occurrence_Of (Typl, Loc),
8928 Attribute_Name => Name_Machine,
8929 Expressions => New_List (Relocate_Node (Rhs))));
8930 Analyze_And_Resolve (Rhs, Typl);
8935 -----------------------
8936 -- Expand_N_Op_Expon --
8937 -----------------------
8939 procedure Expand_N_Op_Expon (N : Node_Id) is
8940 Loc : constant Source_Ptr := Sloc (N);
8941 Ovflo : constant Boolean := Do_Overflow_Check (N);
8942 Typ : constant Entity_Id := Etype (N);
8943 Rtyp : constant Entity_Id := Root_Type (Typ);
8947 function Wrap_MA (Exp : Node_Id) return Node_Id;
8948 -- Given an expression Exp, if the root type is Float or Long_Float,
8949 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8950 -- extra precision. This is done to ensure that X**A = X**B when A is
8951 -- a static constant and B is a variable with the same value. For any
8952 -- other type, the node Exp is returned unchanged.
8958 function Wrap_MA (Exp : Node_Id) return Node_Id is
8959 Loc : constant Source_Ptr := Sloc (Exp);
8962 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then
8964 Make_Attribute_Reference (Loc,
8965 Attribute_Name => Name_Machine,
8966 Prefix => New_Occurrence_Of (Bastyp, Loc),
8967 Expressions => New_List (Relocate_Node (Exp)));
8985 -- Start of processing for Expand_N_Op_Expon
8988 Binary_Op_Validity_Checks (N);
8990 -- CodePeer wants to see the unexpanded N_Op_Expon node
8992 if CodePeer_Mode then
8996 -- Relocation of left and right operands must be done after performing
8997 -- the validity checks since the generation of validation checks may
8998 -- remove side effects.
9000 Base := Relocate_Node (Left_Opnd (N));
9001 Bastyp := Etype (Base);
9002 Exp := Relocate_Node (Right_Opnd (N));
9003 Exptyp := Etype (Exp);
9005 -- If either operand is of a private type, then we have the use of an
9006 -- intrinsic operator, and we get rid of the privateness, by using root
9007 -- types of underlying types for the actual operation. Otherwise the
9008 -- private types will cause trouble if we expand multiplications or
9009 -- shifts etc. We also do this transformation if the result type is
9010 -- different from the base type.
9012 if Is_Private_Type (Etype (Base))
9013 or else Is_Private_Type (Typ)
9014 or else Is_Private_Type (Exptyp)
9015 or else Rtyp /= Root_Type (Bastyp)
9018 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
9019 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
9022 Unchecked_Convert_To (Typ,
9024 Left_Opnd => Unchecked_Convert_To (Bt, Base),
9025 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
9026 Analyze_And_Resolve (N, Typ);
9031 -- Check for MINIMIZED/ELIMINATED overflow mode
9033 if Minimized_Eliminated_Overflow_Check (N) then
9034 Apply_Arithmetic_Overflow_Check (N);
9038 -- Test for case of known right argument where we can replace the
9039 -- exponentiation by an equivalent expression using multiplication.
9041 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
9042 -- configurable run-time mode, we may not have the exponentiation
9043 -- routine available, and we don't want the legality of the program
9044 -- to depend on how clever the compiler is in knowing values.
9046 if CRT_Safe_Compile_Time_Known_Value (Exp) then
9047 Expv := Expr_Value (Exp);
9049 -- We only fold small non-negative exponents. You might think we
9050 -- could fold small negative exponents for the real case, but we
9051 -- can't because we are required to raise Constraint_Error for
9052 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
9053 -- See ACVC test C4A012B, and it is not worth generating the test.
9055 -- For small negative exponents, we return the reciprocal of
9056 -- the folding of the exponentiation for the opposite (positive)
9057 -- exponent, as required by Ada RM 4.5.6(11/3).
9059 if abs Expv <= 4 then
9061 -- X ** 0 = 1 (or 1.0)
9065 -- Call Remove_Side_Effects to ensure that any side effects
9066 -- in the ignored left operand (in particular function calls
9067 -- to user defined functions) are properly executed.
9069 Remove_Side_Effects (Base);
9071 if Ekind (Typ) in Integer_Kind then
9072 Xnode := Make_Integer_Literal (Loc, Intval => 1);
9074 Xnode := Make_Real_Literal (Loc, Ureal_1);
9087 Make_Op_Multiply (Loc,
9088 Left_Opnd => Duplicate_Subexpr (Base),
9089 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
9091 -- X ** 3 = X * X * X
9096 Make_Op_Multiply (Loc,
9098 Make_Op_Multiply (Loc,
9099 Left_Opnd => Duplicate_Subexpr (Base),
9100 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
9101 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
9106 -- En : constant base'type := base * base;
9111 Temp := Make_Temporary (Loc, 'E', Base);
9114 Make_Expression_With_Actions (Loc,
9115 Actions => New_List (
9116 Make_Object_Declaration (Loc,
9117 Defining_Identifier => Temp,
9118 Constant_Present => True,
9119 Object_Definition => New_Occurrence_Of (Typ, Loc),
9122 Make_Op_Multiply (Loc,
9124 Duplicate_Subexpr (Base),
9126 Duplicate_Subexpr_No_Checks (Base))))),
9130 Make_Op_Multiply (Loc,
9131 Left_Opnd => New_Occurrence_Of (Temp, Loc),
9132 Right_Opnd => New_Occurrence_Of (Temp, Loc))));
9134 -- X ** N = 1.0 / X ** (-N)
9139 (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4);
9142 Make_Op_Divide (Loc,
9144 Make_Float_Literal (Loc,
9146 Significand => Uint_1,
9147 Exponent => Uint_0),
9150 Left_Opnd => Duplicate_Subexpr (Base),
9152 Make_Integer_Literal (Loc,
9157 Analyze_And_Resolve (N, Typ);
9162 -- Deal with optimizing 2 ** expression to shift where possible
9164 -- Note: we used to check that Exptyp was an unsigned type. But that is
9165 -- an unnecessary check, since if Exp is negative, we have a run-time
9166 -- error that is either caught (so we get the right result) or we have
9167 -- suppressed the check, in which case the code is erroneous anyway.
9169 if Is_Integer_Type (Rtyp)
9171 -- The base value must be "safe compile-time known", and exactly 2
9173 and then Nkind (Base) = N_Integer_Literal
9174 and then CRT_Safe_Compile_Time_Known_Value (Base)
9175 and then Expr_Value (Base) = Uint_2
9177 -- We only handle cases where the right type is a integer
9179 and then Is_Integer_Type (Root_Type (Exptyp))
9180 and then Esize (Root_Type (Exptyp)) <= Standard_Integer_Size
9182 -- This transformation is not applicable for a modular type with a
9183 -- nonbinary modulus because we do not handle modular reduction in
9184 -- a correct manner if we attempt this transformation in this case.
9186 and then not Non_Binary_Modulus (Typ)
9188 -- Handle the cases where our parent is a division or multiplication
9189 -- specially. In these cases we can convert to using a shift at the
9190 -- parent level if we are not doing overflow checking, since it is
9191 -- too tricky to combine the overflow check at the parent level.
9194 and then Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply
9197 P : constant Node_Id := Parent (N);
9198 L : constant Node_Id := Left_Opnd (P);
9199 R : constant Node_Id := Right_Opnd (P);
9202 if (Nkind (P) = N_Op_Multiply
9204 ((Is_Integer_Type (Etype (L)) and then R = N)
9206 (Is_Integer_Type (Etype (R)) and then L = N))
9207 and then not Do_Overflow_Check (P))
9210 (Nkind (P) = N_Op_Divide
9211 and then Is_Integer_Type (Etype (L))
9212 and then Is_Unsigned_Type (Etype (L))
9214 and then not Do_Overflow_Check (P))
9216 Set_Is_Power_Of_2_For_Shift (N);
9221 -- Here we just have 2 ** N on its own, so we can convert this to a
9222 -- shift node. We are prepared to deal with overflow here, and we
9223 -- also have to handle proper modular reduction for binary modular.
9232 -- Maximum shift count with no overflow
9235 -- Set True if we must test the shift count
9238 -- Node for test against TestS
9241 -- Compute maximum shift based on the underlying size. For a
9242 -- modular type this is one less than the size.
9244 if Is_Modular_Integer_Type (Typ) then
9246 -- For modular integer types, this is the size of the value
9247 -- being shifted minus one. Any larger values will cause
9248 -- modular reduction to a result of zero. Note that we do
9249 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
9250 -- of 6, since 2**7 should be reduced to zero).
9252 MaxS := RM_Size (Rtyp) - 1;
9254 -- For signed integer types, we use the size of the value
9255 -- being shifted minus 2. Larger values cause overflow.
9258 MaxS := Esize (Rtyp) - 2;
9261 -- Determine range to see if it can be larger than MaxS
9263 Determine_Range (Exp, OK, Lo, Hi, Assume_Valid => True);
9264 TestS := (not OK) or else Hi > MaxS;
9266 -- Signed integer case
9268 if Is_Signed_Integer_Type (Typ) then
9270 -- Generate overflow check if overflow is active. Note that
9271 -- we can simply ignore the possibility of overflow if the
9272 -- flag is not set (means that overflow cannot happen or
9273 -- that overflow checks are suppressed).
9275 if Ovflo and TestS then
9277 Make_Raise_Constraint_Error (Loc,
9280 Left_Opnd => Duplicate_Subexpr (Exp),
9281 Right_Opnd => Make_Integer_Literal (Loc, MaxS)),
9282 Reason => CE_Overflow_Check_Failed));
9285 -- Now rewrite node as Shift_Left (1, right-operand)
9288 Make_Op_Shift_Left (Loc,
9289 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
9290 Right_Opnd => Exp));
9292 -- Modular integer case
9294 else pragma Assert (Is_Modular_Integer_Type (Typ));
9296 -- If shift count can be greater than MaxS, we need to wrap
9297 -- the shift in a test that will reduce the result value to
9298 -- zero if this shift count is exceeded.
9302 -- Note: build node for the comparison first, before we
9303 -- reuse the Right_Opnd, so that we have proper parents
9304 -- in place for the Duplicate_Subexpr call.
9308 Left_Opnd => Duplicate_Subexpr (Exp),
9309 Right_Opnd => Make_Integer_Literal (Loc, MaxS));
9312 Make_If_Expression (Loc,
9313 Expressions => New_List (
9315 Make_Integer_Literal (Loc, Uint_0),
9316 Make_Op_Shift_Left (Loc,
9317 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
9318 Right_Opnd => Exp))));
9320 -- If we know shift count cannot be greater than MaxS, then
9321 -- it is safe to just rewrite as a shift with no test.
9325 Make_Op_Shift_Left (Loc,
9326 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
9327 Right_Opnd => Exp));
9331 Analyze_And_Resolve (N, Typ);
9337 -- Fall through if exponentiation must be done using a runtime routine
9339 -- First deal with modular case
9341 if Is_Modular_Integer_Type (Rtyp) then
9343 -- Nonbinary modular case, we call the special exponentiation
9344 -- routine for the nonbinary case, converting the argument to
9345 -- Long_Long_Integer and passing the modulus value. Then the
9346 -- result is converted back to the base type.
9348 if Non_Binary_Modulus (Rtyp) then
9351 Make_Function_Call (Loc,
9353 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
9354 Parameter_Associations => New_List (
9355 Convert_To (RTE (RE_Unsigned), Base),
9356 Make_Integer_Literal (Loc, Modulus (Rtyp)),
9359 -- Binary modular case, in this case, we call one of three routines,
9360 -- either the unsigned integer case, or the unsigned long long
9361 -- integer case, or the unsigned long long long integer case, with a
9362 -- final "and" operation to do the required mod.
9365 if Esize (Rtyp) <= Standard_Integer_Size then
9366 Ent := RTE (RE_Exp_Unsigned);
9367 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
9368 Ent := RTE (RE_Exp_Long_Long_Unsigned);
9370 Ent := RTE (RE_Exp_Long_Long_Long_Unsigned);
9377 Make_Function_Call (Loc,
9378 Name => New_Occurrence_Of (Ent, Loc),
9379 Parameter_Associations => New_List (
9380 Convert_To (Etype (First_Formal (Ent)), Base),
9383 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
9387 -- Common exit point for modular type case
9389 Analyze_And_Resolve (N, Typ);
9392 -- Signed integer cases, using either Integer, Long_Long_Integer or
9393 -- Long_Long_Long_Integer. It is not worth also having routines for
9394 -- Short_[Short_]Integer, since for most machines it would not help,
9395 -- and it would generate more code that might need certification when
9396 -- a certified run time is required.
9398 -- In the integer cases, we have two routines, one for when overflow
9399 -- checks are required, and one when they are not required, since there
9400 -- is a real gain in omitting checks on many machines.
9402 elsif Is_Signed_Integer_Type (Rtyp) then
9403 if Esize (Rtyp) <= Standard_Integer_Size then
9404 Etyp := Standard_Integer;
9407 Rent := RE_Exp_Integer;
9409 Rent := RE_Exn_Integer;
9412 elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
9413 Etyp := Standard_Long_Long_Integer;
9416 Rent := RE_Exp_Long_Long_Integer;
9418 Rent := RE_Exn_Long_Long_Integer;
9422 Etyp := Standard_Long_Long_Long_Integer;
9425 Rent := RE_Exp_Long_Long_Long_Integer;
9427 Rent := RE_Exn_Long_Long_Long_Integer;
9431 -- Floating-point cases. We do not need separate routines for the
9432 -- overflow case here, since in the case of floating-point, we generate
9433 -- infinities anyway as a rule (either that or we automatically trap
9434 -- overflow), and if there is an infinity generated and a range check
9435 -- is required, the check will fail anyway.
9438 pragma Assert (Is_Floating_Point_Type (Rtyp));
9440 -- Short_Float and Float are the same type for GNAT
9442 if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
9443 Etyp := Standard_Float;
9444 Rent := RE_Exn_Float;
9446 elsif Rtyp = Standard_Long_Float then
9447 Etyp := Standard_Long_Float;
9448 Rent := RE_Exn_Long_Float;
9451 Etyp := Standard_Long_Long_Float;
9452 Rent := RE_Exn_Long_Long_Float;
9456 -- Common processing for integer cases and floating-point cases.
9457 -- If we are in the right type, we can call runtime routine directly
9460 and then not Is_Universal_Numeric_Type (Rtyp)
9464 Make_Function_Call (Loc,
9465 Name => New_Occurrence_Of (RTE (Rent), Loc),
9466 Parameter_Associations => New_List (Base, Exp))));
9468 -- Otherwise we have to introduce conversions (conversions are also
9469 -- required in the universal cases, since the runtime routine is
9470 -- typed using one of the standard types).
9475 Make_Function_Call (Loc,
9476 Name => New_Occurrence_Of (RTE (Rent), Loc),
9477 Parameter_Associations => New_List (
9478 Convert_To (Etyp, Base),
9482 Analyze_And_Resolve (N, Typ);
9486 when RE_Not_Available =>
9488 end Expand_N_Op_Expon;
9490 --------------------
9491 -- Expand_N_Op_Ge --
9492 --------------------
9494 procedure Expand_N_Op_Ge (N : Node_Id) is
9495 Typ : constant Entity_Id := Etype (N);
9496 Op1 : constant Node_Id := Left_Opnd (N);
9497 Op2 : constant Node_Id := Right_Opnd (N);
9498 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9501 Binary_Op_Validity_Checks (N);
9503 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9504 -- means we no longer have a comparison operation, we are all done.
9506 if Minimized_Eliminated_Overflow_Check (Op1) then
9507 Expand_Compare_Minimize_Eliminate_Overflow (N);
9510 if Nkind (N) /= N_Op_Ge then
9516 if Is_Array_Type (Typ1) then
9517 Expand_Array_Comparison (N);
9521 -- Deal with boolean operands
9523 if Is_Boolean_Type (Typ1) then
9524 Adjust_Condition (Op1);
9525 Adjust_Condition (Op2);
9526 Set_Etype (N, Standard_Boolean);
9527 Adjust_Result_Type (N, Typ);
9530 Rewrite_Comparison (N);
9532 -- Try to narrow the operation
9534 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Ge then
9535 Narrow_Large_Operation (N);
9538 Optimize_Length_Comparison (N);
9541 --------------------
9542 -- Expand_N_Op_Gt --
9543 --------------------
9545 procedure Expand_N_Op_Gt (N : Node_Id) is
9546 Typ : constant Entity_Id := Etype (N);
9547 Op1 : constant Node_Id := Left_Opnd (N);
9548 Op2 : constant Node_Id := Right_Opnd (N);
9549 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9552 Binary_Op_Validity_Checks (N);
9554 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9555 -- means we no longer have a comparison operation, we are all done.
9557 if Minimized_Eliminated_Overflow_Check (Op1) then
9558 Expand_Compare_Minimize_Eliminate_Overflow (N);
9561 if Nkind (N) /= N_Op_Gt then
9565 -- Deal with array type operands
9567 if Is_Array_Type (Typ1) then
9568 Expand_Array_Comparison (N);
9572 -- Deal with boolean type operands
9574 if Is_Boolean_Type (Typ1) then
9575 Adjust_Condition (Op1);
9576 Adjust_Condition (Op2);
9577 Set_Etype (N, Standard_Boolean);
9578 Adjust_Result_Type (N, Typ);
9581 Rewrite_Comparison (N);
9583 -- Try to narrow the operation
9585 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Gt then
9586 Narrow_Large_Operation (N);
9589 Optimize_Length_Comparison (N);
9592 --------------------
9593 -- Expand_N_Op_Le --
9594 --------------------
9596 procedure Expand_N_Op_Le (N : Node_Id) is
9597 Typ : constant Entity_Id := Etype (N);
9598 Op1 : constant Node_Id := Left_Opnd (N);
9599 Op2 : constant Node_Id := Right_Opnd (N);
9600 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9603 Binary_Op_Validity_Checks (N);
9605 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9606 -- means we no longer have a comparison operation, we are all done.
9608 if Minimized_Eliminated_Overflow_Check (Op1) then
9609 Expand_Compare_Minimize_Eliminate_Overflow (N);
9612 if Nkind (N) /= N_Op_Le then
9616 -- Deal with array type operands
9618 if Is_Array_Type (Typ1) then
9619 Expand_Array_Comparison (N);
9623 -- Deal with Boolean type operands
9625 if Is_Boolean_Type (Typ1) then
9626 Adjust_Condition (Op1);
9627 Adjust_Condition (Op2);
9628 Set_Etype (N, Standard_Boolean);
9629 Adjust_Result_Type (N, Typ);
9632 Rewrite_Comparison (N);
9634 -- Try to narrow the operation
9636 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Le then
9637 Narrow_Large_Operation (N);
9640 Optimize_Length_Comparison (N);
9643 --------------------
9644 -- Expand_N_Op_Lt --
9645 --------------------
9647 procedure Expand_N_Op_Lt (N : Node_Id) is
9648 Typ : constant Entity_Id := Etype (N);
9649 Op1 : constant Node_Id := Left_Opnd (N);
9650 Op2 : constant Node_Id := Right_Opnd (N);
9651 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9654 Binary_Op_Validity_Checks (N);
9656 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9657 -- means we no longer have a comparison operation, we are all done.
9659 if Minimized_Eliminated_Overflow_Check (Op1) then
9660 Expand_Compare_Minimize_Eliminate_Overflow (N);
9663 if Nkind (N) /= N_Op_Lt then
9667 -- Deal with array type operands
9669 if Is_Array_Type (Typ1) then
9670 Expand_Array_Comparison (N);
9674 -- Deal with Boolean type operands
9676 if Is_Boolean_Type (Typ1) then
9677 Adjust_Condition (Op1);
9678 Adjust_Condition (Op2);
9679 Set_Etype (N, Standard_Boolean);
9680 Adjust_Result_Type (N, Typ);
9683 Rewrite_Comparison (N);
9685 -- Try to narrow the operation
9687 if Typ1 = Universal_Integer and then Nkind (N) = N_Op_Lt then
9688 Narrow_Large_Operation (N);
9691 Optimize_Length_Comparison (N);
9694 -----------------------
9695 -- Expand_N_Op_Minus --
9696 -----------------------
9698 procedure Expand_N_Op_Minus (N : Node_Id) is
9699 Loc : constant Source_Ptr := Sloc (N);
9700 Typ : constant Entity_Id := Etype (N);
9703 Unary_Op_Validity_Checks (N);
9705 -- Check for MINIMIZED/ELIMINATED overflow mode
9707 if Minimized_Eliminated_Overflow_Check (N) then
9708 Apply_Arithmetic_Overflow_Check (N);
9712 -- Try to narrow the operation
9714 if Typ = Universal_Integer then
9715 Narrow_Large_Operation (N);
9717 if Nkind (N) /= N_Op_Minus then
9722 if not Backend_Overflow_Checks_On_Target
9723 and then Is_Signed_Integer_Type (Typ)
9724 and then Do_Overflow_Check (N)
9726 -- Software overflow checking expands -expr into (0 - expr)
9729 Make_Op_Subtract (Loc,
9730 Left_Opnd => Make_Integer_Literal (Loc, 0),
9731 Right_Opnd => Right_Opnd (N)));
9733 Analyze_And_Resolve (N, Typ);
9736 Expand_Nonbinary_Modular_Op (N);
9737 end Expand_N_Op_Minus;
9739 ---------------------
9740 -- Expand_N_Op_Mod --
9741 ---------------------
9743 procedure Expand_N_Op_Mod (N : Node_Id) is
9744 Loc : constant Source_Ptr := Sloc (N);
9745 Typ : constant Entity_Id := Etype (N);
9746 DDC : constant Boolean := Do_Division_Check (N);
9759 pragma Warnings (Off, Lhi);
9762 Binary_Op_Validity_Checks (N);
9764 -- Check for MINIMIZED/ELIMINATED overflow mode
9766 if Minimized_Eliminated_Overflow_Check (N) then
9767 Apply_Arithmetic_Overflow_Check (N);
9771 -- Try to narrow the operation
9773 if Typ = Universal_Integer then
9774 Narrow_Large_Operation (N);
9776 if Nkind (N) /= N_Op_Mod then
9781 if Is_Integer_Type (Typ) then
9782 Apply_Divide_Checks (N);
9784 -- All done if we don't have a MOD any more, which can happen as a
9785 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9787 if Nkind (N) /= N_Op_Mod then
9792 -- Proceed with expansion of mod operator
9794 Left := Left_Opnd (N);
9795 Right := Right_Opnd (N);
9797 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
9798 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
9800 -- Convert mod to rem if operands are both known to be non-negative, or
9801 -- both known to be non-positive (these are the cases in which rem and
9802 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9803 -- likely that this will improve the quality of code, (the operation now
9804 -- corresponds to the hardware remainder), and it does not seem likely
9805 -- that it could be harmful. It also avoids some cases of the elaborate
9806 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9809 and then ((Llo >= 0 and then Rlo >= 0)
9811 (Lhi <= 0 and then Rhi <= 0))
9814 Make_Op_Rem (Sloc (N),
9815 Left_Opnd => Left_Opnd (N),
9816 Right_Opnd => Right_Opnd (N)));
9818 -- Instead of reanalyzing the node we do the analysis manually. This
9819 -- avoids anomalies when the replacement is done in an instance and
9820 -- is epsilon more efficient.
9822 Set_Entity (N, Standard_Entity (S_Op_Rem));
9824 Set_Do_Division_Check (N, DDC);
9825 Expand_N_Op_Rem (N);
9829 -- Otherwise, normal mod processing
9832 -- Apply optimization x mod 1 = 0. We don't really need that with
9833 -- gcc, but it is useful with other back ends and is certainly
9836 if Is_Integer_Type (Etype (N))
9837 and then Compile_Time_Known_Value (Right)
9838 and then Expr_Value (Right) = Uint_1
9840 -- Call Remove_Side_Effects to ensure that any side effects in
9841 -- the ignored left operand (in particular function calls to
9842 -- user defined functions) are properly executed.
9844 Remove_Side_Effects (Left);
9846 Rewrite (N, Make_Integer_Literal (Loc, 0));
9847 Analyze_And_Resolve (N, Typ);
9851 -- If we still have a mod operator and we are in Modify_Tree_For_C
9852 -- mode, and we have a signed integer type, then here is where we do
9853 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9854 -- for the special handling of the annoying case of largest negative
9855 -- number mod minus one.
9857 if Nkind (N) = N_Op_Mod
9858 and then Is_Signed_Integer_Type (Typ)
9859 and then Modify_Tree_For_C
9861 -- In the general case, we expand A mod B as
9863 -- Tnn : constant typ := A rem B;
9865 -- (if (A >= 0) = (B >= 0) then Tnn
9866 -- elsif Tnn = 0 then 0
9869 -- The comparison can be written simply as A >= 0 if we know that
9870 -- B >= 0 which is a very common case.
9872 -- An important optimization is when B is known at compile time
9873 -- to be 2**K for some constant. In this case we can simply AND
9874 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9875 -- and that works for both the positive and negative cases.
9878 P2 : constant Nat := Power_Of_Two (Right);
9883 Unchecked_Convert_To (Typ,
9886 Unchecked_Convert_To
9887 (Corresponding_Unsigned_Type (Typ), Left),
9889 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
9890 Analyze_And_Resolve (N, Typ);
9895 -- Here for the full rewrite
9898 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
9904 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9905 Right_Opnd => Make_Integer_Literal (Loc, 0));
9907 if not LOK or else Rlo < 0 then
9913 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
9914 Right_Opnd => Make_Integer_Literal (Loc, 0)));
9918 Make_Object_Declaration (Loc,
9919 Defining_Identifier => Tnn,
9920 Constant_Present => True,
9921 Object_Definition => New_Occurrence_Of (Typ, Loc),
9925 Right_Opnd => Right)));
9928 Make_If_Expression (Loc,
9929 Expressions => New_List (
9931 New_Occurrence_Of (Tnn, Loc),
9932 Make_If_Expression (Loc,
9934 Expressions => New_List (
9936 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9937 Right_Opnd => Make_Integer_Literal (Loc, 0)),
9938 Make_Integer_Literal (Loc, 0),
9940 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9942 Duplicate_Subexpr_No_Checks (Right)))))));
9944 Analyze_And_Resolve (N, Typ);
9949 -- Deal with annoying case of largest negative number mod minus one.
9950 -- Gigi may not handle this case correctly, because on some targets,
9951 -- the mod value is computed using a divide instruction which gives
9952 -- an overflow trap for this case.
9954 -- It would be a bit more efficient to figure out which targets
9955 -- this is really needed for, but in practice it is reasonable
9956 -- to do the following special check in all cases, since it means
9957 -- we get a clearer message, and also the overhead is minimal given
9958 -- that division is expensive in any case.
9960 -- In fact the check is quite easy, if the right operand is -1, then
9961 -- the mod value is always 0, and we can just ignore the left operand
9962 -- completely in this case.
9964 -- This only applies if we still have a mod operator. Skip if we
9965 -- have already rewritten this (e.g. in the case of eliminated
9966 -- overflow checks which have driven us into bignum mode).
9968 if Nkind (N) = N_Op_Mod then
9970 -- The operand type may be private (e.g. in the expansion of an
9971 -- intrinsic operation) so we must use the underlying type to get
9972 -- the bounds, and convert the literals explicitly.
9976 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
9978 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
9979 and then ((not LOK) or else (Llo = LLB))
9980 and then not CodePeer_Mode
9983 Make_If_Expression (Loc,
9984 Expressions => New_List (
9986 Left_Opnd => Duplicate_Subexpr (Right),
9988 Unchecked_Convert_To (Typ,
9989 Make_Integer_Literal (Loc, -1))),
9990 Unchecked_Convert_To (Typ,
9991 Make_Integer_Literal (Loc, Uint_0)),
9992 Relocate_Node (N))));
9994 Set_Analyzed (Next (Next (First (Expressions (N)))));
9995 Analyze_And_Resolve (N, Typ);
9999 end Expand_N_Op_Mod;
10001 --------------------------
10002 -- Expand_N_Op_Multiply --
10003 --------------------------
10005 procedure Expand_N_Op_Multiply (N : Node_Id) is
10006 Loc : constant Source_Ptr := Sloc (N);
10007 Lop : constant Node_Id := Left_Opnd (N);
10008 Rop : constant Node_Id := Right_Opnd (N);
10010 Lp2 : constant Boolean :=
10011 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
10012 Rp2 : constant Boolean :=
10013 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
10015 Ltyp : constant Entity_Id := Etype (Lop);
10016 Rtyp : constant Entity_Id := Etype (Rop);
10017 Typ : Entity_Id := Etype (N);
10020 Binary_Op_Validity_Checks (N);
10022 -- Check for MINIMIZED/ELIMINATED overflow mode
10024 if Minimized_Eliminated_Overflow_Check (N) then
10025 Apply_Arithmetic_Overflow_Check (N);
10029 -- Special optimizations for integer types
10031 if Is_Integer_Type (Typ) then
10033 -- N * 0 = 0 for integer types
10035 if Compile_Time_Known_Value (Rop)
10036 and then Expr_Value (Rop) = Uint_0
10038 -- Call Remove_Side_Effects to ensure that any side effects in
10039 -- the ignored left operand (in particular function calls to
10040 -- user defined functions) are properly executed.
10042 Remove_Side_Effects (Lop);
10044 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
10045 Analyze_And_Resolve (N, Typ);
10049 -- Similar handling for 0 * N = 0
10051 if Compile_Time_Known_Value (Lop)
10052 and then Expr_Value (Lop) = Uint_0
10054 Remove_Side_Effects (Rop);
10055 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
10056 Analyze_And_Resolve (N, Typ);
10060 -- N * 1 = 1 * N = N for integer types
10062 -- This optimisation is not done if we are going to
10063 -- rewrite the product 1 * 2 ** N to a shift.
10065 if Compile_Time_Known_Value (Rop)
10066 and then Expr_Value (Rop) = Uint_1
10072 elsif Compile_Time_Known_Value (Lop)
10073 and then Expr_Value (Lop) = Uint_1
10081 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
10082 -- Is_Power_Of_2_For_Shift is set means that we know that our left
10083 -- operand is an integer, as required for this to work.
10088 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
10091 Make_Op_Expon (Loc,
10092 Left_Opnd => Make_Integer_Literal (Loc, 2),
10095 Left_Opnd => Right_Opnd (Lop),
10096 Right_Opnd => Right_Opnd (Rop))));
10097 Analyze_And_Resolve (N, Typ);
10101 -- If the result is modular, perform the reduction of the result
10104 if Is_Modular_Integer_Type (Typ)
10105 and then not Non_Binary_Modulus (Typ)
10110 Make_Op_Shift_Left (Loc,
10113 Convert_To (Standard_Natural, Right_Opnd (Rop))),
10115 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
10119 Make_Op_Shift_Left (Loc,
10122 Convert_To (Standard_Natural, Right_Opnd (Rop))));
10125 Analyze_And_Resolve (N, Typ);
10129 -- Same processing for the operands the other way round
10132 if Is_Modular_Integer_Type (Typ)
10133 and then not Non_Binary_Modulus (Typ)
10138 Make_Op_Shift_Left (Loc,
10141 Convert_To (Standard_Natural, Right_Opnd (Lop))),
10143 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
10147 Make_Op_Shift_Left (Loc,
10150 Convert_To (Standard_Natural, Right_Opnd (Lop))));
10153 Analyze_And_Resolve (N, Typ);
10157 -- Try to narrow the operation
10159 if Typ = Universal_Integer then
10160 Narrow_Large_Operation (N);
10162 if Nkind (N) /= N_Op_Multiply then
10167 -- Do required fixup of universal fixed operation
10169 if Typ = Universal_Fixed then
10170 Fixup_Universal_Fixed_Operation (N);
10174 -- Multiplications with fixed-point results
10176 if Is_Fixed_Point_Type (Typ) then
10178 -- Case of fixed * integer => fixed
10180 if Is_Integer_Type (Rtyp) then
10181 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
10183 -- Case of integer * fixed => fixed
10185 elsif Is_Integer_Type (Ltyp) then
10186 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
10188 -- Case of fixed * fixed => fixed
10191 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
10194 -- Other cases of multiplication of fixed-point operands
10196 elsif Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp) then
10197 if Is_Integer_Type (Typ) then
10198 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
10200 pragma Assert (Is_Floating_Point_Type (Typ));
10201 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
10204 -- Mixed-mode operations can appear in a non-static universal context,
10205 -- in which case the integer argument must be converted explicitly.
10207 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
10208 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
10209 Analyze_And_Resolve (Rop, Universal_Real);
10211 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
10212 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
10213 Analyze_And_Resolve (Lop, Universal_Real);
10215 -- Non-fixed point cases, check software overflow checking required
10217 elsif Is_Signed_Integer_Type (Etype (N)) then
10218 Apply_Arithmetic_Overflow_Check (N);
10221 -- Overflow checks for floating-point if -gnateF mode active
10223 Check_Float_Op_Overflow (N);
10225 Expand_Nonbinary_Modular_Op (N);
10226 end Expand_N_Op_Multiply;
10228 --------------------
10229 -- Expand_N_Op_Ne --
10230 --------------------
10232 procedure Expand_N_Op_Ne (N : Node_Id) is
10233 Typ : constant Entity_Id := Etype (Left_Opnd (N));
10236 -- Case of elementary type with standard operator. But if unnesting,
10237 -- handle elementary types whose Equivalent_Types are records because
10238 -- there may be padding or undefined fields.
10240 if Is_Elementary_Type (Typ)
10241 and then Sloc (Entity (N)) = Standard_Location
10242 and then not (Ekind (Typ) in E_Class_Wide_Type
10243 | E_Class_Wide_Subtype
10244 | E_Access_Subprogram_Type
10245 | E_Access_Protected_Subprogram_Type
10246 | E_Anonymous_Access_Protected_Subprogram_Type
10248 and then Present (Equivalent_Type (Typ))
10249 and then Is_Record_Type (Equivalent_Type (Typ)))
10251 Binary_Op_Validity_Checks (N);
10253 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
10254 -- means we no longer have a /= operation, we are all done.
10256 if Minimized_Eliminated_Overflow_Check (Left_Opnd (N)) then
10257 Expand_Compare_Minimize_Eliminate_Overflow (N);
10260 if Nkind (N) /= N_Op_Ne then
10264 -- Boolean types (requiring handling of non-standard case)
10266 if Is_Boolean_Type (Typ) then
10267 Adjust_Condition (Left_Opnd (N));
10268 Adjust_Condition (Right_Opnd (N));
10269 Set_Etype (N, Standard_Boolean);
10270 Adjust_Result_Type (N, Typ);
10273 Rewrite_Comparison (N);
10275 -- Try to narrow the operation
10277 if Typ = Universal_Integer and then Nkind (N) = N_Op_Ne then
10278 Narrow_Large_Operation (N);
10281 -- For all cases other than elementary types, we rewrite node as the
10282 -- negation of an equality operation, and reanalyze. The equality to be
10283 -- used is defined in the same scope and has the same signature. This
10284 -- signature must be set explicitly since in an instance it may not have
10285 -- the same visibility as in the generic unit. This avoids duplicating
10286 -- or factoring the complex code for record/array equality tests etc.
10288 -- This case is also used for the minimal expansion performed in
10293 Loc : constant Source_Ptr := Sloc (N);
10295 Ne : constant Entity_Id := Entity (N);
10298 Binary_Op_Validity_Checks (N);
10304 Left_Opnd => Left_Opnd (N),
10305 Right_Opnd => Right_Opnd (N)));
10307 -- The level of parentheses is useless in GNATprove mode, and
10308 -- bumping its level here leads to wrong columns being used in
10309 -- check messages, hence skip it in this mode.
10311 if not GNATprove_Mode then
10312 Set_Paren_Count (Right_Opnd (Neg), 1);
10315 if Scope (Ne) /= Standard_Standard then
10316 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
10319 -- For navigation purposes, we want to treat the inequality as an
10320 -- implicit reference to the corresponding equality. Preserve the
10321 -- Comes_From_ source flag to generate proper Xref entries.
10323 Preserve_Comes_From_Source (Neg, N);
10324 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
10326 Analyze_And_Resolve (N, Standard_Boolean);
10330 -- No need for optimization in GNATprove mode, where we would rather see
10331 -- the original source expression.
10333 if not GNATprove_Mode then
10334 Optimize_Length_Comparison (N);
10336 end Expand_N_Op_Ne;
10338 ---------------------
10339 -- Expand_N_Op_Not --
10340 ---------------------
10342 -- If the argument is other than a Boolean array type, there is no special
10343 -- expansion required, except for dealing with validity checks, and non-
10344 -- standard boolean representations.
10346 -- For the packed array case, we call the special routine in Exp_Pakd,
10347 -- except that if the component size is greater than one, we use the
10348 -- standard routine generating a gruesome loop (it is so peculiar to have
10349 -- packed arrays with non-standard Boolean representations anyway, so it
10350 -- does not matter that we do not handle this case efficiently).
10352 -- For the unpacked array case (and for the special packed case where we
10353 -- have non standard Booleans, as discussed above), we generate and insert
10354 -- into the tree the following function definition:
10356 -- function Nnnn (A : arr) is
10359 -- for J in a'range loop
10360 -- B (J) := not A (J);
10365 -- or in the case of Transform_Function_Array:
10367 -- procedure Nnnn (A : arr; RESULT : out arr) is
10369 -- for J in a'range loop
10370 -- RESULT (J) := not A (J);
10374 -- Here arr is the actual subtype of the parameter (and hence always
10375 -- constrained). Then we replace the not with a call to this subprogram.
10377 procedure Expand_N_Op_Not (N : Node_Id) is
10378 Loc : constant Source_Ptr := Sloc (N);
10379 Typ : constant Entity_Id := Etype (Right_Opnd (N));
10388 Func_Name : Entity_Id;
10389 Loop_Statement : Node_Id;
10392 Unary_Op_Validity_Checks (N);
10394 -- For boolean operand, deal with non-standard booleans
10396 if Is_Boolean_Type (Typ) then
10397 Adjust_Condition (Right_Opnd (N));
10398 Set_Etype (N, Standard_Boolean);
10399 Adjust_Result_Type (N, Typ);
10403 -- Only array types need any other processing
10405 if not Is_Array_Type (Typ) then
10409 -- Case of array operand. If bit packed with a component size of 1,
10410 -- handle it in Exp_Pakd if the operand is known to be aligned.
10412 if Is_Bit_Packed_Array (Typ)
10413 and then Component_Size (Typ) = 1
10414 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
10416 Expand_Packed_Not (N);
10420 -- Case of array operand which is not bit-packed. If the context is
10421 -- a safe assignment, call in-place operation, If context is a larger
10422 -- boolean expression in the context of a safe assignment, expansion is
10423 -- done by enclosing operation.
10425 Opnd := Relocate_Node (Right_Opnd (N));
10426 Convert_To_Actual_Subtype (Opnd);
10427 Arr := Etype (Opnd);
10428 Ensure_Defined (Arr, N);
10429 Silly_Boolean_Array_Not_Test (N, Arr);
10431 if Nkind (Parent (N)) = N_Assignment_Statement then
10432 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
10433 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
10436 -- Special case the negation of a binary operation
10438 elsif Nkind (Opnd) in N_Op_And | N_Op_Or | N_Op_Xor
10439 and then Safe_In_Place_Array_Op
10440 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
10442 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
10446 elsif Nkind (Parent (N)) in N_Binary_Op
10447 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
10450 Op1 : constant Node_Id := Left_Opnd (Parent (N));
10451 Op2 : constant Node_Id := Right_Opnd (Parent (N));
10452 Lhs : constant Node_Id := Name (Parent (Parent (N)));
10455 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
10457 -- (not A) op (not B) can be reduced to a single call
10459 if N = Op1 and then Nkind (Op2) = N_Op_Not then
10462 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
10465 -- A xor (not B) can also be special-cased
10467 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
10474 A := Make_Defining_Identifier (Loc, Name_uA);
10476 if Transform_Function_Array then
10477 B := Make_Defining_Identifier (Loc, Name_UP_RESULT);
10479 B := Make_Defining_Identifier (Loc, Name_uB);
10482 J := Make_Defining_Identifier (Loc, Name_uJ);
10485 Make_Indexed_Component (Loc,
10486 Prefix => New_Occurrence_Of (A, Loc),
10487 Expressions => New_List (New_Occurrence_Of (J, Loc)));
10490 Make_Indexed_Component (Loc,
10491 Prefix => New_Occurrence_Of (B, Loc),
10492 Expressions => New_List (New_Occurrence_Of (J, Loc)));
10495 Make_Implicit_Loop_Statement (N,
10496 Identifier => Empty,
10498 Iteration_Scheme =>
10499 Make_Iteration_Scheme (Loc,
10500 Loop_Parameter_Specification =>
10501 Make_Loop_Parameter_Specification (Loc,
10502 Defining_Identifier => J,
10503 Discrete_Subtype_Definition =>
10504 Make_Attribute_Reference (Loc,
10505 Prefix => Make_Identifier (Loc, Chars (A)),
10506 Attribute_Name => Name_Range))),
10508 Statements => New_List (
10509 Make_Assignment_Statement (Loc,
10511 Expression => Make_Op_Not (Loc, A_J))));
10513 Func_Name := Make_Temporary (Loc, 'N');
10514 Set_Is_Inlined (Func_Name);
10516 if Transform_Function_Array then
10518 Make_Subprogram_Body (Loc,
10520 Make_Procedure_Specification (Loc,
10521 Defining_Unit_Name => Func_Name,
10522 Parameter_Specifications => New_List (
10523 Make_Parameter_Specification (Loc,
10524 Defining_Identifier => A,
10525 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
10526 Make_Parameter_Specification (Loc,
10527 Defining_Identifier => B,
10528 Out_Present => True,
10529 Parameter_Type => New_Occurrence_Of (Typ, Loc)))),
10531 Declarations => New_List,
10533 Handled_Statement_Sequence =>
10534 Make_Handled_Sequence_Of_Statements (Loc,
10535 Statements => New_List (Loop_Statement))));
10538 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
10547 Make_Object_Declaration (Loc,
10548 Defining_Identifier => Temp_Id,
10549 Object_Definition => New_Occurrence_Of (Typ, Loc));
10552 -- Proc_Call (Opnd, Temp);
10555 Make_Procedure_Call_Statement (Loc,
10556 Name => New_Occurrence_Of (Func_Name, Loc),
10557 Parameter_Associations =>
10558 New_List (Opnd, New_Occurrence_Of (Temp_Id, Loc)));
10560 Insert_Actions (Parent (N), New_List (Decl, Call));
10561 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
10565 Make_Subprogram_Body (Loc,
10567 Make_Function_Specification (Loc,
10568 Defining_Unit_Name => Func_Name,
10569 Parameter_Specifications => New_List (
10570 Make_Parameter_Specification (Loc,
10571 Defining_Identifier => A,
10572 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
10573 Result_Definition => New_Occurrence_Of (Typ, Loc)),
10575 Declarations => New_List (
10576 Make_Object_Declaration (Loc,
10577 Defining_Identifier => B,
10578 Object_Definition => New_Occurrence_Of (Arr, Loc))),
10580 Handled_Statement_Sequence =>
10581 Make_Handled_Sequence_Of_Statements (Loc,
10582 Statements => New_List (
10584 Make_Simple_Return_Statement (Loc,
10585 Expression => Make_Identifier (Loc, Chars (B)))))));
10588 Make_Function_Call (Loc,
10589 Name => New_Occurrence_Of (Func_Name, Loc),
10590 Parameter_Associations => New_List (Opnd)));
10593 Analyze_And_Resolve (N, Typ);
10594 end Expand_N_Op_Not;
10596 --------------------
10597 -- Expand_N_Op_Or --
10598 --------------------
10600 procedure Expand_N_Op_Or (N : Node_Id) is
10601 Typ : constant Entity_Id := Etype (N);
10604 Binary_Op_Validity_Checks (N);
10606 if Is_Array_Type (Etype (N)) then
10607 Expand_Boolean_Operator (N);
10609 elsif Is_Boolean_Type (Etype (N)) then
10610 Adjust_Condition (Left_Opnd (N));
10611 Adjust_Condition (Right_Opnd (N));
10612 Set_Etype (N, Standard_Boolean);
10613 Adjust_Result_Type (N, Typ);
10615 elsif Is_Intrinsic_Subprogram (Entity (N)) then
10616 Expand_Intrinsic_Call (N, Entity (N));
10619 Expand_Nonbinary_Modular_Op (N);
10620 end Expand_N_Op_Or;
10622 ----------------------
10623 -- Expand_N_Op_Plus --
10624 ----------------------
10626 procedure Expand_N_Op_Plus (N : Node_Id) is
10627 Typ : constant Entity_Id := Etype (N);
10630 Unary_Op_Validity_Checks (N);
10632 -- Check for MINIMIZED/ELIMINATED overflow mode
10634 if Minimized_Eliminated_Overflow_Check (N) then
10635 Apply_Arithmetic_Overflow_Check (N);
10639 -- Try to narrow the operation
10641 if Typ = Universal_Integer then
10642 Narrow_Large_Operation (N);
10644 end Expand_N_Op_Plus;
10646 ---------------------
10647 -- Expand_N_Op_Rem --
10648 ---------------------
10650 procedure Expand_N_Op_Rem (N : Node_Id) is
10651 Loc : constant Source_Ptr := Sloc (N);
10652 Typ : constant Entity_Id := Etype (N);
10663 -- Set if corresponding operand can be negative
10666 Binary_Op_Validity_Checks (N);
10668 -- Check for MINIMIZED/ELIMINATED overflow mode
10670 if Minimized_Eliminated_Overflow_Check (N) then
10671 Apply_Arithmetic_Overflow_Check (N);
10675 -- Try to narrow the operation
10677 if Typ = Universal_Integer then
10678 Narrow_Large_Operation (N);
10680 if Nkind (N) /= N_Op_Rem then
10685 if Is_Integer_Type (Etype (N)) then
10686 Apply_Divide_Checks (N);
10688 -- All done if we don't have a REM any more, which can happen as a
10689 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
10691 if Nkind (N) /= N_Op_Rem then
10696 -- Proceed with expansion of REM
10698 Left := Left_Opnd (N);
10699 Right := Right_Opnd (N);
10701 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
10702 -- but it is useful with other back ends, and is certainly harmless.
10704 if Is_Integer_Type (Etype (N))
10705 and then Compile_Time_Known_Value (Right)
10706 and then Expr_Value (Right) = Uint_1
10708 -- Call Remove_Side_Effects to ensure that any side effects in the
10709 -- ignored left operand (in particular function calls to user defined
10710 -- functions) are properly executed.
10712 Remove_Side_Effects (Left);
10714 Rewrite (N, Make_Integer_Literal (Loc, 0));
10715 Analyze_And_Resolve (N, Typ);
10719 -- Deal with annoying case of largest negative number remainder minus
10720 -- one. Gigi may not handle this case correctly, because on some
10721 -- targets, the mod value is computed using a divide instruction
10722 -- which gives an overflow trap for this case.
10724 -- It would be a bit more efficient to figure out which targets this
10725 -- is really needed for, but in practice it is reasonable to do the
10726 -- following special check in all cases, since it means we get a clearer
10727 -- message, and also the overhead is minimal given that division is
10728 -- expensive in any case.
10730 -- In fact the check is quite easy, if the right operand is -1, then
10731 -- the remainder is always 0, and we can just ignore the left operand
10732 -- completely in this case.
10734 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10735 Lneg := (not OK) or else Lo < 0;
10737 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
10738 Rneg := (not OK) or else Lo < 0;
10740 -- We won't mess with trying to find out if the left operand can really
10741 -- be the largest negative number (that's a pain in the case of private
10742 -- types and this is really marginal). We will just assume that we need
10743 -- the test if the left operand can be negative at all.
10746 and then not CodePeer_Mode
10749 Make_If_Expression (Loc,
10750 Expressions => New_List (
10752 Left_Opnd => Duplicate_Subexpr (Right),
10754 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
10756 Unchecked_Convert_To (Typ,
10757 Make_Integer_Literal (Loc, Uint_0)),
10759 Relocate_Node (N))));
10761 Set_Analyzed (Next (Next (First (Expressions (N)))));
10762 Analyze_And_Resolve (N, Typ);
10764 end Expand_N_Op_Rem;
10766 -----------------------------
10767 -- Expand_N_Op_Rotate_Left --
10768 -----------------------------
10770 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
10772 Binary_Op_Validity_Checks (N);
10774 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10775 -- so we rewrite in terms of logical shifts
10777 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10779 -- where Bits is the shift count mod Esize (the mod operation here
10780 -- deals with ludicrous large shift counts, which are apparently OK).
10782 if Modify_Tree_For_C then
10784 Loc : constant Source_Ptr := Sloc (N);
10785 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10786 Typ : constant Entity_Id := Etype (N);
10789 -- Sem_Intr should prevent getting there with a non binary modulus
10791 pragma Assert (not Non_Binary_Modulus (Typ));
10793 Rewrite (Right_Opnd (N),
10795 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10796 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10798 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10803 Make_Op_Shift_Left (Loc,
10804 Left_Opnd => Left_Opnd (N),
10805 Right_Opnd => Right_Opnd (N)),
10808 Make_Op_Shift_Right (Loc,
10809 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10811 Make_Op_Subtract (Loc,
10812 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10814 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10816 Analyze_And_Resolve (N, Typ);
10819 end Expand_N_Op_Rotate_Left;
10821 ------------------------------
10822 -- Expand_N_Op_Rotate_Right --
10823 ------------------------------
10825 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
10827 Binary_Op_Validity_Checks (N);
10829 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10830 -- so we rewrite in terms of logical shifts
10832 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10834 -- where Bits is the shift count mod Esize (the mod operation here
10835 -- deals with ludicrous large shift counts, which are apparently OK).
10837 if Modify_Tree_For_C then
10839 Loc : constant Source_Ptr := Sloc (N);
10840 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10841 Typ : constant Entity_Id := Etype (N);
10844 -- Sem_Intr should prevent getting there with a non binary modulus
10846 pragma Assert (not Non_Binary_Modulus (Typ));
10848 Rewrite (Right_Opnd (N),
10850 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10851 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10853 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10858 Make_Op_Shift_Right (Loc,
10859 Left_Opnd => Left_Opnd (N),
10860 Right_Opnd => Right_Opnd (N)),
10863 Make_Op_Shift_Left (Loc,
10864 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10866 Make_Op_Subtract (Loc,
10867 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10869 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10871 Analyze_And_Resolve (N, Typ);
10874 end Expand_N_Op_Rotate_Right;
10876 ----------------------------
10877 -- Expand_N_Op_Shift_Left --
10878 ----------------------------
10880 -- Note: nothing in this routine depends on left as opposed to right shifts
10881 -- so we share the routine for expanding shift right operations.
10883 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
10885 Binary_Op_Validity_Checks (N);
10887 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10888 -- operand is not greater than the word size (since that would not
10889 -- be defined properly by the corresponding C shift operator).
10891 if Modify_Tree_For_C then
10893 Right : constant Node_Id := Right_Opnd (N);
10894 Loc : constant Source_Ptr := Sloc (Right);
10895 Typ : constant Entity_Id := Etype (N);
10896 Siz : constant Uint := Esize (Typ);
10903 -- Sem_Intr should prevent getting there with a non binary modulus
10905 pragma Assert (not Non_Binary_Modulus (Typ));
10907 if Compile_Time_Known_Value (Right) then
10908 if Expr_Value (Right) >= Siz then
10909 Rewrite (N, Make_Integer_Literal (Loc, 0));
10910 Analyze_And_Resolve (N, Typ);
10913 -- Not compile time known, find range
10916 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10918 -- Nothing to do if known to be OK range, otherwise expand
10920 if not OK or else Hi >= Siz then
10922 -- Prevent recursion on copy of shift node
10924 Orig := Relocate_Node (N);
10925 Set_Analyzed (Orig);
10927 -- Now do the rewrite
10930 Make_If_Expression (Loc,
10931 Expressions => New_List (
10933 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
10934 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
10935 Make_Integer_Literal (Loc, 0),
10937 Analyze_And_Resolve (N, Typ);
10942 end Expand_N_Op_Shift_Left;
10944 -----------------------------
10945 -- Expand_N_Op_Shift_Right --
10946 -----------------------------
10948 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
10950 -- Share shift left circuit
10952 Expand_N_Op_Shift_Left (N);
10953 end Expand_N_Op_Shift_Right;
10955 ----------------------------------------
10956 -- Expand_N_Op_Shift_Right_Arithmetic --
10957 ----------------------------------------
10959 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
10961 Binary_Op_Validity_Checks (N);
10963 -- If we are in Modify_Tree_For_C mode, there is no shift right
10964 -- arithmetic in C, so we rewrite in terms of logical shifts for
10965 -- modular integers, and keep the Shift_Right intrinsic for signed
10966 -- integers: even though doing a shift on a signed integer is not
10967 -- fully guaranteed by the C standard, this is what C compilers
10968 -- implement in practice.
10969 -- Consider also taking advantage of this for modular integers by first
10970 -- performing an unchecked conversion of the modular integer to a signed
10971 -- integer of the same sign, and then convert back.
10973 -- Shift_Right (Num, Bits) or
10975 -- then not (Shift_Right (Mask, bits))
10978 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10980 -- Note: the above works fine for shift counts greater than or equal
10981 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10982 -- generates all 1'bits.
10984 if Modify_Tree_For_C and then Is_Modular_Integer_Type (Etype (N)) then
10986 Loc : constant Source_Ptr := Sloc (N);
10987 Typ : constant Entity_Id := Etype (N);
10988 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
10989 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
10990 Left : constant Node_Id := Left_Opnd (N);
10991 Right : constant Node_Id := Right_Opnd (N);
10995 -- Sem_Intr should prevent getting there with a non binary modulus
10997 pragma Assert (not Non_Binary_Modulus (Typ));
10999 -- Here if not (Shift_Right (Mask, bits)) can be computed at
11000 -- compile time as a single constant.
11002 if Compile_Time_Known_Value (Right) then
11004 Val : constant Uint := Expr_Value (Right);
11007 if Val >= Esize (Typ) then
11008 Maskx := Make_Integer_Literal (Loc, Mask);
11012 Make_Integer_Literal (Loc,
11013 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
11021 Make_Op_Shift_Right (Loc,
11022 Left_Opnd => Make_Integer_Literal (Loc, Mask),
11023 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
11026 -- Now do the rewrite
11031 Make_Op_Shift_Right (Loc,
11033 Right_Opnd => Right),
11035 Make_If_Expression (Loc,
11036 Expressions => New_List (
11038 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
11039 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
11041 Make_Integer_Literal (Loc, 0)))));
11042 Analyze_And_Resolve (N, Typ);
11045 end Expand_N_Op_Shift_Right_Arithmetic;
11047 --------------------------
11048 -- Expand_N_Op_Subtract --
11049 --------------------------
11051 procedure Expand_N_Op_Subtract (N : Node_Id) is
11052 Typ : constant Entity_Id := Etype (N);
11055 Binary_Op_Validity_Checks (N);
11057 -- Check for MINIMIZED/ELIMINATED overflow mode
11059 if Minimized_Eliminated_Overflow_Check (N) then
11060 Apply_Arithmetic_Overflow_Check (N);
11064 -- Try to narrow the operation
11066 if Typ = Universal_Integer then
11067 Narrow_Large_Operation (N);
11069 if Nkind (N) /= N_Op_Subtract then
11074 -- N - 0 = N for integer types
11076 if Is_Integer_Type (Typ)
11077 and then Compile_Time_Known_Value (Right_Opnd (N))
11078 and then Expr_Value (Right_Opnd (N)) = 0
11080 Rewrite (N, Left_Opnd (N));
11084 -- Arithmetic overflow checks for signed integer/fixed point types
11086 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
11087 Apply_Arithmetic_Overflow_Check (N);
11090 -- Overflow checks for floating-point if -gnateF mode active
11092 Check_Float_Op_Overflow (N);
11094 Expand_Nonbinary_Modular_Op (N);
11095 end Expand_N_Op_Subtract;
11097 ---------------------
11098 -- Expand_N_Op_Xor --
11099 ---------------------
11101 procedure Expand_N_Op_Xor (N : Node_Id) is
11102 Typ : constant Entity_Id := Etype (N);
11105 Binary_Op_Validity_Checks (N);
11107 if Is_Array_Type (Etype (N)) then
11108 Expand_Boolean_Operator (N);
11110 elsif Is_Boolean_Type (Etype (N)) then
11111 Adjust_Condition (Left_Opnd (N));
11112 Adjust_Condition (Right_Opnd (N));
11113 Set_Etype (N, Standard_Boolean);
11114 Adjust_Result_Type (N, Typ);
11116 elsif Is_Intrinsic_Subprogram (Entity (N)) then
11117 Expand_Intrinsic_Call (N, Entity (N));
11120 Expand_Nonbinary_Modular_Op (N);
11121 end Expand_N_Op_Xor;
11123 ----------------------
11124 -- Expand_N_Or_Else --
11125 ----------------------
11127 procedure Expand_N_Or_Else (N : Node_Id)
11128 renames Expand_Short_Circuit_Operator;
11130 -----------------------------------
11131 -- Expand_N_Qualified_Expression --
11132 -----------------------------------
11134 procedure Expand_N_Qualified_Expression (N : Node_Id) is
11135 Operand : constant Node_Id := Expression (N);
11136 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
11139 -- Do validity check if validity checking operands
11141 if Validity_Checks_On and Validity_Check_Operands then
11142 Ensure_Valid (Operand);
11145 Freeze_Before (Operand, Target_Type);
11147 -- Apply possible constraint check
11149 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
11151 -- Apply possible predicate check
11153 Apply_Predicate_Check (Operand, Target_Type);
11155 if Do_Range_Check (Operand) then
11156 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
11158 end Expand_N_Qualified_Expression;
11160 ------------------------------------
11161 -- Expand_N_Quantified_Expression --
11162 ------------------------------------
11166 -- for all X in range => Cond
11171 -- for X in range loop
11172 -- if not Cond then
11178 -- Similarly, an existentially quantified expression:
11180 -- for some X in range => Cond
11185 -- for X in range loop
11192 -- In both cases, the iteration may be over a container in which case it is
11193 -- given by an iterator specification, not a loop parameter specification.
11195 procedure Expand_N_Quantified_Expression (N : Node_Id) is
11196 Actions : constant List_Id := New_List;
11197 For_All : constant Boolean := All_Present (N);
11198 Iter_Spec : constant Node_Id := Iterator_Specification (N);
11199 Loc : constant Source_Ptr := Sloc (N);
11200 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
11208 -- Ensure that the bound variable as well as the type of Name of the
11209 -- Iter_Spec if present are properly frozen. We must do this before
11210 -- expansion because the expression is about to be converted into a
11211 -- loop, and resulting freeze nodes may end up in the wrong place in the
11214 if Present (Iter_Spec) then
11215 Var := Defining_Identifier (Iter_Spec);
11217 Var := Defining_Identifier (Loop_Spec);
11221 P : Node_Id := Parent (N);
11223 while Nkind (P) in N_Subexpr loop
11227 if Present (Iter_Spec) then
11228 Freeze_Before (P, Etype (Name (Iter_Spec)));
11231 Freeze_Before (P, Etype (Var));
11234 -- Create the declaration of the flag which tracks the status of the
11235 -- quantified expression. Generate:
11237 -- Flag : Boolean := (True | False);
11239 Flag := Make_Temporary (Loc, 'T', N);
11241 Append_To (Actions,
11242 Make_Object_Declaration (Loc,
11243 Defining_Identifier => Flag,
11244 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
11246 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
11248 -- Construct the circuitry which tracks the status of the quantified
11249 -- expression. Generate:
11251 -- if [not] Cond then
11252 -- Flag := (False | True);
11256 Cond := Relocate_Node (Condition (N));
11259 Cond := Make_Op_Not (Loc, Cond);
11262 Stmts := New_List (
11263 Make_Implicit_If_Statement (N,
11265 Then_Statements => New_List (
11266 Make_Assignment_Statement (Loc,
11267 Name => New_Occurrence_Of (Flag, Loc),
11269 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
11270 Make_Exit_Statement (Loc))));
11272 -- Build the loop equivalent of the quantified expression
11274 if Present (Iter_Spec) then
11276 Make_Iteration_Scheme (Loc,
11277 Iterator_Specification => Iter_Spec);
11280 Make_Iteration_Scheme (Loc,
11281 Loop_Parameter_Specification => Loop_Spec);
11284 Append_To (Actions,
11285 Make_Loop_Statement (Loc,
11286 Iteration_Scheme => Scheme,
11287 Statements => Stmts,
11288 End_Label => Empty));
11290 -- Transform the quantified expression
11293 Make_Expression_With_Actions (Loc,
11294 Expression => New_Occurrence_Of (Flag, Loc),
11295 Actions => Actions));
11296 Analyze_And_Resolve (N, Standard_Boolean);
11297 end Expand_N_Quantified_Expression;
11299 ---------------------------------
11300 -- Expand_N_Selected_Component --
11301 ---------------------------------
11303 procedure Expand_N_Selected_Component (N : Node_Id) is
11304 Loc : constant Source_Ptr := Sloc (N);
11305 Par : constant Node_Id := Parent (N);
11306 P : constant Node_Id := Prefix (N);
11307 S : constant Node_Id := Selector_Name (N);
11308 Ptyp : constant Entity_Id := Underlying_Type (Etype (P));
11314 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
11315 -- Gigi needs a temporary for prefixes that depend on a discriminant,
11316 -- unless the context of an assignment can provide size information.
11317 -- Don't we have a general routine that does this???
11319 function Is_Subtype_Declaration return Boolean;
11320 -- The replacement of a discriminant reference by its value is required
11321 -- if this is part of the initialization of an temporary generated by a
11322 -- change of representation. This shows up as the construction of a
11323 -- discriminant constraint for a subtype declared at the same point as
11324 -- the entity in the prefix of the selected component. We recognize this
11325 -- case when the context of the reference is:
11326 -- subtype ST is T(Obj.D);
11327 -- where the entity for Obj comes from source, and ST has the same sloc.
11329 -----------------------
11330 -- In_Left_Hand_Side --
11331 -----------------------
11333 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
11335 return (Nkind (Parent (Comp)) = N_Assignment_Statement
11336 and then Comp = Name (Parent (Comp)))
11337 or else (Present (Parent (Comp))
11338 and then Nkind (Parent (Comp)) in N_Subexpr
11339 and then In_Left_Hand_Side (Parent (Comp)));
11340 end In_Left_Hand_Side;
11342 -----------------------------
11343 -- Is_Subtype_Declaration --
11344 -----------------------------
11346 function Is_Subtype_Declaration return Boolean is
11347 Par : constant Node_Id := Parent (N);
11350 Nkind (Par) = N_Index_Or_Discriminant_Constraint
11351 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
11352 and then Comes_From_Source (Entity (Prefix (N)))
11353 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
11354 end Is_Subtype_Declaration;
11356 -- Start of processing for Expand_N_Selected_Component
11359 -- Deal with discriminant check required
11361 if Do_Discriminant_Check (N) then
11362 if Present (Discriminant_Checking_Func
11363 (Original_Record_Component (Entity (S))))
11365 -- Present the discriminant checking function to the backend, so
11366 -- that it can inline the call to the function.
11369 (Discriminant_Checking_Func
11370 (Original_Record_Component (Entity (S))),
11373 -- Now reset the flag and generate the call
11375 Set_Do_Discriminant_Check (N, False);
11376 Generate_Discriminant_Check (N);
11378 -- In the case of Unchecked_Union, no discriminant checking is
11379 -- actually performed.
11382 if (not Is_Unchecked_Union
11383 (Implementation_Base_Type (Etype (Prefix (N)))))
11384 and then not Is_Predefined_Unit (Get_Source_Unit (N))
11387 ("sorry - unable to generate discriminant check for" &
11388 " reference to variant component &",
11389 Selector_Name (N));
11392 Set_Do_Discriminant_Check (N, False);
11396 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11397 -- function, then additional actuals must be passed.
11399 if Is_Build_In_Place_Function_Call (P) then
11400 Make_Build_In_Place_Call_In_Anonymous_Context (P);
11402 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11403 -- containing build-in-place function calls whose returned object covers
11404 -- interface types.
11406 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
11407 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
11410 -- Gigi cannot handle unchecked conversions that are the prefix of a
11411 -- selected component with discriminants. This must be checked during
11412 -- expansion, because during analysis the type of the selector is not
11413 -- known at the point the prefix is analyzed. If the conversion is the
11414 -- target of an assignment, then we cannot force the evaluation.
11416 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
11417 and then Has_Discriminants (Etype (N))
11418 and then not In_Left_Hand_Side (N)
11420 Force_Evaluation (Prefix (N));
11423 -- Remaining processing applies only if selector is a discriminant
11425 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
11427 -- If the selector is a discriminant of a constrained record type,
11428 -- we may be able to rewrite the expression with the actual value
11429 -- of the discriminant, a useful optimization in some cases.
11431 if Is_Record_Type (Ptyp)
11432 and then Has_Discriminants (Ptyp)
11433 and then Is_Constrained (Ptyp)
11435 -- Do this optimization for discrete types only, and not for
11436 -- access types (access discriminants get us into trouble).
11438 if not Is_Discrete_Type (Etype (N)) then
11441 -- Don't do this on the left-hand side of an assignment statement.
11442 -- Normally one would think that references like this would not
11443 -- occur, but they do in generated code, and mean that we really
11444 -- do want to assign the discriminant.
11446 elsif Nkind (Par) = N_Assignment_Statement
11447 and then Name (Par) = N
11451 -- Don't do this optimization for the prefix of an attribute or
11452 -- the name of an object renaming declaration since these are
11453 -- contexts where we do not want the value anyway.
11455 elsif (Nkind (Par) = N_Attribute_Reference
11456 and then Prefix (Par) = N)
11457 or else Is_Renamed_Object (N)
11461 -- Don't do this optimization if we are within the code for a
11462 -- discriminant check, since the whole point of such a check may
11463 -- be to verify the condition on which the code below depends.
11465 elsif Is_In_Discriminant_Check (N) then
11468 -- Green light to see if we can do the optimization. There is
11469 -- still one condition that inhibits the optimization below but
11470 -- now is the time to check the particular discriminant.
11473 -- Loop through discriminants to find the matching discriminant
11474 -- constraint to see if we can copy it.
11476 Disc := First_Discriminant (Ptyp);
11477 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
11478 Discr_Loop : while Present (Dcon) loop
11479 Dval := Node (Dcon);
11481 -- Check if this is the matching discriminant and if the
11482 -- discriminant value is simple enough to make sense to
11483 -- copy. We don't want to copy complex expressions, and
11484 -- indeed to do so can cause trouble (before we put in
11485 -- this guard, a discriminant expression containing an
11486 -- AND THEN was copied, causing problems for coverage
11487 -- analysis tools).
11489 -- However, if the reference is part of the initialization
11490 -- code generated for an object declaration, we must use
11491 -- the discriminant value from the subtype constraint,
11492 -- because the selected component may be a reference to the
11493 -- object being initialized, whose discriminant is not yet
11494 -- set. This only happens in complex cases involving changes
11495 -- of representation.
11497 if Disc = Entity (Selector_Name (N))
11498 and then (Is_Entity_Name (Dval)
11499 or else Compile_Time_Known_Value (Dval)
11500 or else Is_Subtype_Declaration)
11502 -- Here we have the matching discriminant. Check for
11503 -- the case of a discriminant of a component that is
11504 -- constrained by an outer discriminant, which cannot
11505 -- be optimized away.
11507 if Denotes_Discriminant (Dval, Check_Concurrent => True)
11511 -- Do not retrieve value if constraint is not static. It
11512 -- is generally not useful, and the constraint may be a
11513 -- rewritten outer discriminant in which case it is in
11516 elsif Is_Entity_Name (Dval)
11518 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
11519 and then Present (Expression (Parent (Entity (Dval))))
11521 Is_OK_Static_Expression
11522 (Expression (Parent (Entity (Dval))))
11526 -- In the context of a case statement, the expression may
11527 -- have the base type of the discriminant, and we need to
11528 -- preserve the constraint to avoid spurious errors on
11531 elsif Nkind (Parent (N)) = N_Case_Statement
11532 and then Etype (Dval) /= Etype (Disc)
11535 Make_Qualified_Expression (Loc,
11537 New_Occurrence_Of (Etype (Disc), Loc),
11539 New_Copy_Tree (Dval)));
11540 Analyze_And_Resolve (N, Etype (Disc));
11542 -- In case that comes out as a static expression,
11543 -- reset it (a selected component is never static).
11545 Set_Is_Static_Expression (N, False);
11548 -- Otherwise we can just copy the constraint, but the
11549 -- result is certainly not static. In some cases the
11550 -- discriminant constraint has been analyzed in the
11551 -- context of the original subtype indication, but for
11552 -- itypes the constraint might not have been analyzed
11553 -- yet, and this must be done now.
11556 Rewrite (N, New_Copy_Tree (Dval));
11557 Analyze_And_Resolve (N);
11558 Set_Is_Static_Expression (N, False);
11564 Next_Discriminant (Disc);
11565 end loop Discr_Loop;
11567 -- Note: the above loop should always find a matching
11568 -- discriminant, but if it does not, we just missed an
11569 -- optimization due to some glitch (perhaps a previous
11570 -- error), so ignore.
11575 -- The only remaining processing is in the case of a discriminant of
11576 -- a concurrent object, where we rewrite the prefix to denote the
11577 -- corresponding record type. If the type is derived and has renamed
11578 -- discriminants, use corresponding discriminant, which is the one
11579 -- that appears in the corresponding record.
11581 if not Is_Concurrent_Type (Ptyp) then
11585 Disc := Entity (Selector_Name (N));
11587 if Is_Derived_Type (Ptyp)
11588 and then Present (Corresponding_Discriminant (Disc))
11590 Disc := Corresponding_Discriminant (Disc);
11594 Make_Selected_Component (Loc,
11596 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
11597 New_Copy_Tree (P)),
11598 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
11600 Rewrite (N, New_N);
11604 -- Set Atomic_Sync_Required if necessary for atomic component
11606 if Nkind (N) = N_Selected_Component then
11608 E : constant Entity_Id := Entity (Selector_Name (N));
11612 -- If component is atomic, but type is not, setting depends on
11613 -- disable/enable state for the component.
11615 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
11616 Set := not Atomic_Synchronization_Disabled (E);
11618 -- If component is not atomic, but its type is atomic, setting
11619 -- depends on disable/enable state for the type.
11621 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
11622 Set := not Atomic_Synchronization_Disabled (Etype (E));
11624 -- If both component and type are atomic, we disable if either
11625 -- component or its type have sync disabled.
11627 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
11628 Set := (not Atomic_Synchronization_Disabled (E))
11630 (not Atomic_Synchronization_Disabled (Etype (E)));
11636 -- Set flag if required
11639 Activate_Atomic_Synchronization (N);
11643 end Expand_N_Selected_Component;
11645 --------------------
11646 -- Expand_N_Slice --
11647 --------------------
11649 procedure Expand_N_Slice (N : Node_Id) is
11650 Loc : constant Source_Ptr := Sloc (N);
11651 Typ : constant Entity_Id := Etype (N);
11653 function Is_Procedure_Actual (N : Node_Id) return Boolean;
11654 -- Check whether the argument is an actual for a procedure call, in
11655 -- which case the expansion of a bit-packed slice is deferred until the
11656 -- call itself is expanded. The reason this is required is that we might
11657 -- have an IN OUT or OUT parameter, and the copy out is essential, and
11658 -- that copy out would be missed if we created a temporary here in
11659 -- Expand_N_Slice. Note that we don't bother to test specifically for an
11660 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
11661 -- is harmless to defer expansion in the IN case, since the call
11662 -- processing will still generate the appropriate copy in operation,
11663 -- which will take care of the slice.
11665 procedure Make_Temporary_For_Slice;
11666 -- Create a named variable for the value of the slice, in cases where
11667 -- the back end cannot handle it properly, e.g. when packed types or
11668 -- unaligned slices are involved.
11670 -------------------------
11671 -- Is_Procedure_Actual --
11672 -------------------------
11674 function Is_Procedure_Actual (N : Node_Id) return Boolean is
11675 Par : Node_Id := Parent (N);
11679 -- If our parent is a procedure call we can return
11681 if Nkind (Par) = N_Procedure_Call_Statement then
11684 -- If our parent is a type conversion, keep climbing the tree,
11685 -- since a type conversion can be a procedure actual. Also keep
11686 -- climbing if parameter association or a qualified expression,
11687 -- since these are additional cases that do can appear on
11688 -- procedure actuals.
11690 elsif Nkind (Par) in N_Type_Conversion
11691 | N_Parameter_Association
11692 | N_Qualified_Expression
11694 Par := Parent (Par);
11696 -- Any other case is not what we are looking for
11702 end Is_Procedure_Actual;
11704 ------------------------------
11705 -- Make_Temporary_For_Slice --
11706 ------------------------------
11708 procedure Make_Temporary_For_Slice is
11709 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
11714 Make_Object_Declaration (Loc,
11715 Defining_Identifier => Ent,
11716 Object_Definition => New_Occurrence_Of (Typ, Loc));
11718 Set_No_Initialization (Decl);
11720 Insert_Actions (N, New_List (
11722 Make_Assignment_Statement (Loc,
11723 Name => New_Occurrence_Of (Ent, Loc),
11724 Expression => Relocate_Node (N))));
11726 Rewrite (N, New_Occurrence_Of (Ent, Loc));
11727 Analyze_And_Resolve (N, Typ);
11728 end Make_Temporary_For_Slice;
11732 Pref : constant Node_Id := Prefix (N);
11734 -- Start of processing for Expand_N_Slice
11737 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11738 -- function, then additional actuals must be passed.
11740 if Is_Build_In_Place_Function_Call (Pref) then
11741 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
11743 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11744 -- containing build-in-place function calls whose returned object covers
11745 -- interface types.
11747 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
11748 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
11751 -- The remaining case to be handled is packed slices. We can leave
11752 -- packed slices as they are in the following situations:
11754 -- 1. Right or left side of an assignment (we can handle this
11755 -- situation correctly in the assignment statement expansion).
11757 -- 2. Prefix of indexed component (the slide is optimized away in this
11758 -- case, see the start of Expand_N_Indexed_Component.)
11760 -- 3. Object renaming declaration, since we want the name of the
11761 -- slice, not the value.
11763 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11764 -- be required, and this is handled in the expansion of call
11767 -- 5. Prefix of an address attribute (this is an error which is caught
11768 -- elsewhere, and the expansion would interfere with generating the
11769 -- error message) or of a size attribute (because 'Size may change
11770 -- when applied to the temporary instead of the slice directly).
11772 if not Is_Packed (Typ) then
11774 -- Apply transformation for actuals of a function call, where
11775 -- Expand_Actuals is not used.
11777 if Nkind (Parent (N)) = N_Function_Call
11778 and then Is_Possibly_Unaligned_Slice (N)
11780 Make_Temporary_For_Slice;
11783 elsif Nkind (Parent (N)) = N_Assignment_Statement
11784 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
11785 and then Parent (N) = Name (Parent (Parent (N))))
11789 elsif Nkind (Parent (N)) = N_Indexed_Component
11790 or else Is_Renamed_Object (N)
11791 or else Is_Procedure_Actual (N)
11795 elsif Nkind (Parent (N)) = N_Attribute_Reference
11796 and then (Attribute_Name (Parent (N)) = Name_Address
11797 or else Attribute_Name (Parent (N)) = Name_Size)
11802 Make_Temporary_For_Slice;
11804 end Expand_N_Slice;
11806 ------------------------------
11807 -- Expand_N_Type_Conversion --
11808 ------------------------------
11810 procedure Expand_N_Type_Conversion (N : Node_Id) is
11811 Loc : constant Source_Ptr := Sloc (N);
11812 Operand : constant Node_Id := Expression (N);
11813 Operand_Acc : Node_Id := Operand;
11814 Target_Type : Entity_Id := Etype (N);
11815 Operand_Type : Entity_Id := Etype (Operand);
11817 procedure Discrete_Range_Check;
11818 -- Handles generation of range check for discrete target value
11820 procedure Handle_Changed_Representation;
11821 -- This is called in the case of record and array type conversions to
11822 -- see if there is a change of representation to be handled. Change of
11823 -- representation is actually handled at the assignment statement level,
11824 -- and what this procedure does is rewrite node N conversion as an
11825 -- assignment to temporary. If there is no change of representation,
11826 -- then the conversion node is unchanged.
11828 procedure Raise_Accessibility_Error;
11829 -- Called when we know that an accessibility check will fail. Rewrites
11830 -- node N to an appropriate raise statement and outputs warning msgs.
11831 -- The Etype of the raise node is set to Target_Type. Note that in this
11832 -- case the rest of the processing should be skipped (i.e. the call to
11833 -- this procedure will be followed by "goto Done").
11835 procedure Real_Range_Check;
11836 -- Handles generation of range check for real target value
11838 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
11839 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11840 -- evaluates to True.
11842 function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
11844 -- Given a target type for a conversion, determine whether the
11845 -- statically deeper accessibility rules apply to it.
11847 --------------------------
11848 -- Discrete_Range_Check --
11849 --------------------------
11851 -- Case of conversions to a discrete type. We let Generate_Range_Check
11852 -- do the heavy lifting, after converting a fixed-point operand to an
11853 -- appropriate integer type.
11855 procedure Discrete_Range_Check is
11859 procedure Generate_Temporary;
11860 -- Generate a temporary to facilitate in the C backend the code
11861 -- generation of the unchecked conversion since the size of the
11862 -- source type may differ from the size of the target type.
11864 ------------------------
11865 -- Generate_Temporary --
11866 ------------------------
11868 procedure Generate_Temporary is
11870 if Esize (Etype (Expr)) < Esize (Etype (Ityp)) then
11872 Exp_Type : constant Entity_Id := Ityp;
11873 Def_Id : constant Entity_Id :=
11874 Make_Temporary (Loc, 'R', Expr);
11879 Set_Is_Internal (Def_Id);
11880 Set_Etype (Def_Id, Exp_Type);
11881 Res := New_Occurrence_Of (Def_Id, Loc);
11884 Make_Object_Declaration (Loc,
11885 Defining_Identifier => Def_Id,
11886 Object_Definition => New_Occurrence_Of
11888 Constant_Present => True,
11889 Expression => Relocate_Node (Expr));
11891 Set_Assignment_OK (E);
11892 Insert_Action (Expr, E);
11894 Set_Assignment_OK (Res, Assignment_OK (Expr));
11896 Rewrite (Expr, Res);
11897 Analyze_And_Resolve (Expr, Exp_Type);
11900 end Generate_Temporary;
11902 -- Start of processing for Discrete_Range_Check
11905 -- Nothing more to do if conversion was rewritten
11907 if Nkind (N) /= N_Type_Conversion then
11911 Expr := Expression (N);
11913 -- Clear the Do_Range_Check flag on Expr
11915 Set_Do_Range_Check (Expr, False);
11917 -- Nothing to do if range checks suppressed
11919 if Range_Checks_Suppressed (Target_Type) then
11923 -- Nothing to do if expression is an entity on which checks have been
11926 if Is_Entity_Name (Expr)
11927 and then Range_Checks_Suppressed (Entity (Expr))
11932 -- Before we do a range check, we have to deal with treating
11933 -- a fixed-point operand as an integer. The way we do this
11934 -- is simply to do an unchecked conversion to an appropriate
11935 -- integer type with the smallest size, so that we can suppress
11938 if Is_Fixed_Point_Type (Etype (Expr)) then
11939 Ityp := Small_Integer_Type_For
11940 (Esize (Base_Type (Etype (Expr))), False);
11942 -- Generate a temporary with the integer type to facilitate in the
11943 -- C backend the code generation for the unchecked conversion.
11945 if Modify_Tree_For_C then
11946 Generate_Temporary;
11949 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
11952 -- Reset overflow flag, since the range check will include
11953 -- dealing with possible overflow, and generate the check.
11955 Set_Do_Overflow_Check (N, False);
11957 Generate_Range_Check (Expr, Target_Type, CE_Range_Check_Failed);
11958 end Discrete_Range_Check;
11960 -----------------------------------
11961 -- Handle_Changed_Representation --
11962 -----------------------------------
11964 procedure Handle_Changed_Representation is
11972 -- Nothing else to do if no change of representation
11974 if Has_Compatible_Representation (Target_Type, Operand_Type) then
11977 -- The real change of representation work is done by the assignment
11978 -- statement processing. So if this type conversion is appearing as
11979 -- the expression of an assignment statement, nothing needs to be
11980 -- done to the conversion.
11982 elsif Nkind (Parent (N)) = N_Assignment_Statement then
11985 -- Otherwise we need to generate a temporary variable, and do the
11986 -- change of representation assignment into that temporary variable.
11987 -- The conversion is then replaced by a reference to this variable.
11992 -- If type is unconstrained we have to add a constraint, copied
11993 -- from the actual value of the left-hand side.
11995 if not Is_Constrained (Target_Type) then
11996 if Has_Discriminants (Operand_Type) then
11998 -- A change of representation can only apply to untagged
11999 -- types. We need to build the constraint that applies to
12000 -- the target type, using the constraints of the operand.
12001 -- The analysis is complicated if there are both inherited
12002 -- discriminants and constrained discriminants.
12003 -- We iterate over the discriminants of the target, and
12004 -- find the discriminant of the same name:
12006 -- a) If there is a corresponding discriminant in the object
12007 -- then the value is a selected component of the operand.
12009 -- b) Otherwise the value of a constrained discriminant is
12010 -- found in the stored constraint of the operand.
12013 Stored : constant Elist_Id :=
12014 Stored_Constraint (Operand_Type);
12015 -- Stored constraints of the operand. If present, they
12016 -- correspond to the discriminants of the parent type.
12018 Disc_O : Entity_Id;
12019 -- Discriminant of the operand type. Its value in the
12020 -- object is captured in a selected component.
12022 Disc_T : Entity_Id;
12023 -- Discriminant of the target type
12028 Disc_O := First_Discriminant (Operand_Type);
12029 Disc_T := First_Discriminant (Target_Type);
12030 Elmt := (if Present (Stored)
12031 then First_Elmt (Stored)
12035 while Present (Disc_T) loop
12036 if Present (Disc_O)
12037 and then Chars (Disc_T) = Chars (Disc_O)
12040 Make_Selected_Component (Loc,
12042 Duplicate_Subexpr_Move_Checks (Operand),
12044 Make_Identifier (Loc, Chars (Disc_O))));
12045 Next_Discriminant (Disc_O);
12047 elsif Present (Elmt) then
12048 Append_To (Cons, New_Copy_Tree (Node (Elmt)));
12051 if Present (Elmt) then
12055 Next_Discriminant (Disc_T);
12059 elsif Is_Array_Type (Operand_Type) then
12060 N_Ix := First_Index (Target_Type);
12063 for J in 1 .. Number_Dimensions (Operand_Type) loop
12065 -- We convert the bounds explicitly. We use an unchecked
12066 -- conversion because bounds checks are done elsewhere.
12071 Unchecked_Convert_To (Etype (N_Ix),
12072 Make_Attribute_Reference (Loc,
12074 Duplicate_Subexpr_No_Checks
12075 (Operand, Name_Req => True),
12076 Attribute_Name => Name_First,
12077 Expressions => New_List (
12078 Make_Integer_Literal (Loc, J)))),
12081 Unchecked_Convert_To (Etype (N_Ix),
12082 Make_Attribute_Reference (Loc,
12084 Duplicate_Subexpr_No_Checks
12085 (Operand, Name_Req => True),
12086 Attribute_Name => Name_Last,
12087 Expressions => New_List (
12088 Make_Integer_Literal (Loc, J))))));
12095 Odef := New_Occurrence_Of (Target_Type, Loc);
12097 if Present (Cons) then
12099 Make_Subtype_Indication (Loc,
12100 Subtype_Mark => Odef,
12102 Make_Index_Or_Discriminant_Constraint (Loc,
12103 Constraints => Cons));
12106 Temp := Make_Temporary (Loc, 'C');
12108 Make_Object_Declaration (Loc,
12109 Defining_Identifier => Temp,
12110 Object_Definition => Odef);
12112 Set_No_Initialization (Decl, True);
12114 -- Insert required actions. It is essential to suppress checks
12115 -- since we have suppressed default initialization, which means
12116 -- that the variable we create may have no discriminants.
12121 Make_Assignment_Statement (Loc,
12122 Name => New_Occurrence_Of (Temp, Loc),
12123 Expression => Relocate_Node (N))),
12124 Suppress => All_Checks);
12126 Rewrite (N, New_Occurrence_Of (Temp, Loc));
12129 end Handle_Changed_Representation;
12131 -------------------------------
12132 -- Raise_Accessibility_Error --
12133 -------------------------------
12135 procedure Raise_Accessibility_Error is
12137 Error_Msg_Warn := SPARK_Mode /= On;
12139 Make_Raise_Program_Error (Sloc (N),
12140 Reason => PE_Accessibility_Check_Failed));
12141 Set_Etype (N, Target_Type);
12143 Error_Msg_N ("accessibility check failure<<", N);
12144 Error_Msg_N ("\Program_Error [<<", N);
12145 end Raise_Accessibility_Error;
12147 ----------------------
12148 -- Real_Range_Check --
12149 ----------------------
12151 -- Case of conversions to floating-point or fixed-point. If range checks
12152 -- are enabled and the target type has a range constraint, we convert:
12158 -- Tnn : typ'Base := typ'Base (x);
12159 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
12162 -- This is necessary when there is a conversion of integer to float or
12163 -- to fixed-point to ensure that the correct checks are made. It is not
12164 -- necessary for the float-to-float case where it is enough to just set
12165 -- the Do_Range_Check flag on the expression.
12167 procedure Real_Range_Check is
12168 Btyp : constant Entity_Id := Base_Type (Target_Type);
12169 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
12170 Hi : constant Node_Id := Type_High_Bound (Target_Type);
12181 -- Nothing more to do if conversion was rewritten
12183 if Nkind (N) /= N_Type_Conversion then
12187 Expr := Expression (N);
12189 -- Clear the Do_Range_Check flag on Expr
12191 Set_Do_Range_Check (Expr, False);
12193 -- Nothing to do if range checks suppressed, or target has the same
12194 -- range as the base type (or is the base type).
12196 if Range_Checks_Suppressed (Target_Type)
12197 or else (Lo = Type_Low_Bound (Btyp)
12199 Hi = Type_High_Bound (Btyp))
12204 -- Nothing to do if expression is an entity on which checks have been
12207 if Is_Entity_Name (Expr)
12208 and then Range_Checks_Suppressed (Entity (Expr))
12213 -- Nothing to do if expression was rewritten into a float-to-float
12214 -- conversion, since this kind of conversion is handled elsewhere.
12216 if Is_Floating_Point_Type (Etype (Expr))
12217 and then Is_Floating_Point_Type (Target_Type)
12222 -- Nothing to do if bounds are all static and we can tell that the
12223 -- expression is within the bounds of the target. Note that if the
12224 -- operand is of an unconstrained floating-point type, then we do
12225 -- not trust it to be in range (might be infinite)
12228 S_Lo : constant Node_Id := Type_Low_Bound (Etype (Expr));
12229 S_Hi : constant Node_Id := Type_High_Bound (Etype (Expr));
12232 if (not Is_Floating_Point_Type (Etype (Expr))
12233 or else Is_Constrained (Etype (Expr)))
12234 and then Compile_Time_Known_Value (S_Lo)
12235 and then Compile_Time_Known_Value (S_Hi)
12236 and then Compile_Time_Known_Value (Hi)
12237 and then Compile_Time_Known_Value (Lo)
12240 D_Lov : constant Ureal := Expr_Value_R (Lo);
12241 D_Hiv : constant Ureal := Expr_Value_R (Hi);
12246 if Is_Real_Type (Etype (Expr)) then
12247 S_Lov := Expr_Value_R (S_Lo);
12248 S_Hiv := Expr_Value_R (S_Hi);
12250 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
12251 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
12255 and then S_Lov >= D_Lov
12256 and then S_Hiv <= D_Hiv
12264 -- Otherwise rewrite the conversion as described above
12266 Conv := Convert_To (Btyp, Expr);
12268 -- If a conversion is necessary, then copy the specific flags from
12269 -- the original one and also move the Do_Overflow_Check flag since
12270 -- this new conversion is to the base type.
12272 if Nkind (Conv) = N_Type_Conversion then
12273 Set_Conversion_OK (Conv, Conversion_OK (N));
12274 Set_Float_Truncate (Conv, Float_Truncate (N));
12275 Set_Rounded_Result (Conv, Rounded_Result (N));
12277 if Do_Overflow_Check (N) then
12278 Set_Do_Overflow_Check (Conv);
12279 Set_Do_Overflow_Check (N, False);
12283 Tnn := Make_Temporary (Loc, 'T', Conv);
12285 -- For a conversion from Float to Fixed where the bounds of the
12286 -- fixed-point type are static, we can obtain a more accurate
12287 -- fixed-point value by converting the result of the floating-
12288 -- point expression to an appropriate integer type, and then
12289 -- performing an unchecked conversion to the target fixed-point
12290 -- type. The range check can then use the corresponding integer
12291 -- value of the bounds instead of requiring further conversions.
12292 -- This preserves the identity:
12294 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
12296 -- which used to fail when Fix_Val was a bound of the type and
12297 -- the 'Small was not a representable number.
12298 -- This transformation requires an integer type large enough to
12299 -- accommodate a fixed-point value.
12301 if Is_Ordinary_Fixed_Point_Type (Target_Type)
12302 and then Is_Floating_Point_Type (Etype (Expr))
12303 and then RM_Size (Btyp) <= System_Max_Integer_Size
12304 and then Nkind (Lo) = N_Real_Literal
12305 and then Nkind (Hi) = N_Real_Literal
12308 Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv);
12309 Int_Typ : constant Entity_Id :=
12310 Small_Integer_Type_For (RM_Size (Btyp), False);
12313 -- Generate a temporary with the integer value. Required in the
12314 -- CCG compiler to ensure that run-time checks reference this
12315 -- integer expression (instead of the resulting fixed-point
12316 -- value because fixed-point values are handled by means of
12317 -- unsigned integer types).
12320 Make_Object_Declaration (Loc,
12321 Defining_Identifier => Expr_Id,
12322 Object_Definition => New_Occurrence_Of (Int_Typ, Loc),
12323 Constant_Present => True,
12325 Convert_To (Int_Typ, Expression (Conv))));
12327 -- Create integer objects for range checking of result.
12330 Unchecked_Convert_To
12331 (Int_Typ, New_Occurrence_Of (Expr_Id, Loc));
12334 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo));
12337 Unchecked_Convert_To
12338 (Int_Typ, New_Occurrence_Of (Expr_Id, Loc));
12341 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi));
12343 -- Rewrite conversion as an integer conversion of the
12344 -- original floating-point expression, followed by an
12345 -- unchecked conversion to the target fixed-point type.
12348 Unchecked_Convert_To
12349 (Target_Type, New_Occurrence_Of (Expr_Id, Loc));
12352 -- All other conversions
12355 Lo_Arg := New_Occurrence_Of (Tnn, Loc);
12357 Make_Attribute_Reference (Loc,
12358 Prefix => New_Occurrence_Of (Target_Type, Loc),
12359 Attribute_Name => Name_First);
12361 Hi_Arg := New_Occurrence_Of (Tnn, Loc);
12363 Make_Attribute_Reference (Loc,
12364 Prefix => New_Occurrence_Of (Target_Type, Loc),
12365 Attribute_Name => Name_Last);
12368 -- Build code for range checking. Note that checks are suppressed
12369 -- here since we don't want a recursive range check popping up.
12371 Insert_Actions (N, New_List (
12372 Make_Object_Declaration (Loc,
12373 Defining_Identifier => Tnn,
12374 Object_Definition => New_Occurrence_Of (Btyp, Loc),
12375 Constant_Present => True,
12376 Expression => Conv),
12378 Make_Raise_Constraint_Error (Loc,
12383 Left_Opnd => Lo_Arg,
12384 Right_Opnd => Lo_Val),
12388 Left_Opnd => Hi_Arg,
12389 Right_Opnd => Hi_Val)),
12390 Reason => CE_Range_Check_Failed)),
12391 Suppress => All_Checks);
12393 Rewrite (Expr, New_Occurrence_Of (Tnn, Loc));
12394 end Real_Range_Check;
12396 -----------------------------
12397 -- Has_Extra_Accessibility --
12398 -----------------------------
12400 -- Returns true for a formal of an anonymous access type or for an Ada
12401 -- 2012-style stand-alone object of an anonymous access type.
12403 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
12405 if Is_Formal (Id) or else Ekind (Id) in E_Constant | E_Variable then
12406 return Present (Effective_Extra_Accessibility (Id));
12410 end Has_Extra_Accessibility;
12412 ----------------------------------------
12413 -- Statically_Deeper_Relation_Applies --
12414 ----------------------------------------
12416 function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
12420 -- The case where the target type is an anonymous access type is
12421 -- ignored since they have different semantics and get covered by
12422 -- various runtime checks depending on context.
12424 -- Note, the current implementation of this predicate is incomplete
12425 -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
12428 return Ekind (Targ_Typ) /= E_Anonymous_Access_Type;
12429 end Statically_Deeper_Relation_Applies;
12431 -- Start of processing for Expand_N_Type_Conversion
12434 -- First remove check marks put by the semantic analysis on the type
12435 -- conversion between array types. We need these checks, and they will
12436 -- be generated by this expansion routine, but we do not depend on these
12437 -- flags being set, and since we do intend to expand the checks in the
12438 -- front end, we don't want them on the tree passed to the back end.
12440 if Is_Array_Type (Target_Type) then
12441 if Is_Constrained (Target_Type) then
12442 Set_Do_Length_Check (N, False);
12444 Set_Do_Range_Check (Operand, False);
12448 -- Nothing at all to do if conversion is to the identical type so remove
12449 -- the conversion completely, it is useless, except that it may carry
12450 -- an Assignment_OK attribute, which must be propagated to the operand
12451 -- and the Do_Range_Check flag on the operand must be cleared, if any.
12453 if Operand_Type = Target_Type then
12454 if Assignment_OK (N) then
12455 Set_Assignment_OK (Operand);
12458 Set_Do_Range_Check (Operand, False);
12460 Rewrite (N, Relocate_Node (Operand));
12465 -- Nothing to do if this is the second argument of read. This is a
12466 -- "backwards" conversion that will be handled by the specialized code
12467 -- in attribute processing.
12469 if Nkind (Parent (N)) = N_Attribute_Reference
12470 and then Attribute_Name (Parent (N)) = Name_Read
12471 and then Next (First (Expressions (Parent (N)))) = N
12476 -- Check for case of converting to a type that has an invariant
12477 -- associated with it. This requires an invariant check. We insert
12480 -- invariant_check (typ (expr))
12482 -- in the code, after removing side effects from the expression.
12483 -- This is clearer than replacing the conversion into an expression
12484 -- with actions, because the context may impose additional actions
12485 -- (tag checks, membership tests, etc.) that conflict with this
12486 -- rewriting (used previously).
12488 -- Note: the Comes_From_Source check, and then the resetting of this
12489 -- flag prevents what would otherwise be an infinite recursion.
12491 if Has_Invariants (Target_Type)
12492 and then Present (Invariant_Procedure (Target_Type))
12493 and then Comes_From_Source (N)
12495 Set_Comes_From_Source (N, False);
12496 Remove_Side_Effects (N);
12497 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
12500 -- AI12-0042: For a view conversion to a class-wide type occurring
12501 -- within the immediate scope of T, from a specific type that is
12502 -- a descendant of T (including T itself), an invariant check is
12503 -- performed on the part of the object that is of type T. (We don't
12504 -- need to explicitly check for the operand type being a descendant,
12505 -- just that it's a specific type, because the conversion would be
12506 -- illegal if it's specific and not a descendant -- downward conversion
12507 -- is not allowed).
12509 elsif Is_Class_Wide_Type (Target_Type)
12510 and then not Is_Class_Wide_Type (Etype (Expression (N)))
12511 and then Present (Invariant_Procedure (Root_Type (Target_Type)))
12512 and then Comes_From_Source (N)
12513 and then Within_Scope (Find_Enclosing_Scope (N), Scope (Target_Type))
12515 Remove_Side_Effects (N);
12517 -- Perform the invariant check on a conversion to the class-wide
12518 -- type's root type.
12521 Root_Conv : constant Node_Id :=
12522 Make_Type_Conversion (Loc,
12524 New_Occurrence_Of (Root_Type (Target_Type), Loc),
12525 Expression => Duplicate_Subexpr (Expression (N)));
12527 Set_Etype (Root_Conv, Root_Type (Target_Type));
12529 Insert_Action (N, Make_Invariant_Call (Root_Conv));
12534 -- Here if we may need to expand conversion
12536 -- If the operand of the type conversion is an arithmetic operation on
12537 -- signed integers, and the based type of the signed integer type in
12538 -- question is smaller than Standard.Integer, we promote both of the
12539 -- operands to type Integer.
12541 -- For example, if we have
12543 -- target-type (opnd1 + opnd2)
12545 -- and opnd1 and opnd2 are of type short integer, then we rewrite
12548 -- target-type (integer(opnd1) + integer(opnd2))
12550 -- We do this because we are always allowed to compute in a larger type
12551 -- if we do the right thing with the result, and in this case we are
12552 -- going to do a conversion which will do an appropriate check to make
12553 -- sure that things are in range of the target type in any case. This
12554 -- avoids some unnecessary intermediate overflows.
12556 -- We might consider a similar transformation in the case where the
12557 -- target is a real type or a 64-bit integer type, and the operand
12558 -- is an arithmetic operation using a 32-bit integer type. However,
12559 -- we do not bother with this case, because it could cause significant
12560 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
12561 -- much cheaper, but we don't want different behavior on 32-bit and
12562 -- 64-bit machines. Note that the exclusion of the 64-bit case also
12563 -- handles the configurable run-time cases where 64-bit arithmetic
12564 -- may simply be unavailable.
12566 -- Note: this circuit is partially redundant with respect to the circuit
12567 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
12568 -- the processing here. Also we still need the Checks circuit, since we
12569 -- have to be sure not to generate junk overflow checks in the first
12570 -- place, since it would be tricky to remove them here.
12572 if Integer_Promotion_Possible (N) then
12574 -- All conditions met, go ahead with transformation
12581 Opnd := New_Op_Node (Nkind (Operand), Loc);
12583 R := Convert_To (Standard_Integer, Right_Opnd (Operand));
12584 Set_Right_Opnd (Opnd, R);
12586 if Nkind (Operand) in N_Binary_Op then
12587 L := Convert_To (Standard_Integer, Left_Opnd (Operand));
12588 Set_Left_Opnd (Opnd, L);
12592 Make_Type_Conversion (Loc,
12593 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
12594 Expression => Opnd));
12596 Analyze_And_Resolve (N, Target_Type);
12601 -- If the conversion is from Universal_Integer and requires an overflow
12602 -- check, try to do an intermediate conversion to a narrower type first
12603 -- without overflow check, in order to avoid doing the overflow check
12604 -- in Universal_Integer, which can be a very large type.
12606 if Operand_Type = Universal_Integer and then Do_Overflow_Check (N) then
12608 Lo, Hi, Siz : Uint;
12613 Determine_Range (Operand, OK, Lo, Hi, Assume_Valid => True);
12616 Siz := Get_Size_For_Range (Lo, Hi);
12618 -- We use the base type instead of the first subtype because
12619 -- overflow checks are done in the base type, so this avoids
12620 -- the need for useless conversions.
12622 if Siz < System_Max_Integer_Size then
12623 Typ := Etype (Integer_Type_For (Siz, Uns => False));
12625 Convert_To_And_Rewrite (Typ, Operand);
12626 Analyze_And_Resolve
12627 (Operand, Typ, Suppress => Overflow_Check);
12629 Analyze_And_Resolve (N, Target_Type);
12636 -- Do validity check if validity checking operands
12638 if Validity_Checks_On and Validity_Check_Operands then
12639 Ensure_Valid (Operand);
12642 -- Special case of converting from non-standard boolean type
12644 if Is_Boolean_Type (Operand_Type)
12645 and then (Nonzero_Is_True (Operand_Type))
12647 Adjust_Condition (Operand);
12648 Set_Etype (Operand, Standard_Boolean);
12649 Operand_Type := Standard_Boolean;
12652 -- Case of converting to an access type
12654 if Is_Access_Type (Target_Type) then
12655 -- In terms of accessibility rules, an anonymous access discriminant
12656 -- is not considered separate from its parent object.
12658 if Nkind (Operand) = N_Selected_Component
12659 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
12660 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
12662 Operand_Acc := Original_Node (Prefix (Operand));
12665 -- If this type conversion was internally generated by the front end
12666 -- to displace the pointer to the object to reference an interface
12667 -- type and the original node was an Unrestricted_Access attribute,
12668 -- then skip applying accessibility checks (because, according to the
12669 -- GNAT Reference Manual, this attribute is similar to 'Access except
12670 -- that all accessibility and aliased view checks are omitted).
12672 if not Comes_From_Source (N)
12673 and then Is_Interface (Designated_Type (Target_Type))
12674 and then Nkind (Original_Node (N)) = N_Attribute_Reference
12675 and then Attribute_Name (Original_Node (N)) =
12676 Name_Unrestricted_Access
12680 -- Apply an accessibility check when the conversion operand is an
12681 -- access parameter (or a renaming thereof), unless conversion was
12682 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
12683 -- or for the actual of a class-wide interface parameter. Note that
12684 -- other checks may still need to be applied below (such as tagged
12687 elsif Is_Entity_Name (Operand_Acc)
12688 and then Has_Extra_Accessibility (Entity (Operand_Acc))
12689 and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
12690 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
12691 or else Attribute_Name (Original_Node (N)) = Name_Access)
12692 and then not No_Dynamic_Accessibility_Checks_Enabled (N)
12694 if not Comes_From_Source (N)
12695 and then Nkind (Parent (N)) in N_Function_Call
12696 | N_Parameter_Association
12697 | N_Procedure_Call_Statement
12698 and then Is_Interface (Designated_Type (Target_Type))
12699 and then Is_Class_Wide_Type (Designated_Type (Target_Type))
12704 Apply_Accessibility_Check
12705 (Operand, Target_Type, Insert_Node => Operand);
12708 -- If the level of the operand type is statically deeper than the
12709 -- level of the target type, then force Program_Error. Note that this
12710 -- can only occur for cases where the attribute is within the body of
12711 -- an instantiation, otherwise the conversion will already have been
12712 -- rejected as illegal.
12714 -- Note: warnings are issued by the analyzer for the instance cases,
12715 -- and, since we are late in expansion, a check is performed to
12716 -- verify that neither the target type nor the operand type are
12717 -- internally generated - as this can lead to spurious errors when,
12718 -- for example, the operand type is a result of BIP expansion.
12720 elsif In_Instance_Body
12721 and then Statically_Deeper_Relation_Applies (Target_Type)
12722 and then not Is_Internal (Target_Type)
12723 and then not Is_Internal (Operand_Type)
12725 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
12727 Raise_Accessibility_Error;
12730 -- When the operand is a selected access discriminant the check needs
12731 -- to be made against the level of the object denoted by the prefix
12732 -- of the selected name. Force Program_Error for this case as well
12733 -- (this accessibility violation can only happen if within the body
12734 -- of an instantiation).
12736 elsif In_Instance_Body
12737 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
12738 and then Nkind (Operand) = N_Selected_Component
12739 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
12740 and then Static_Accessibility_Level (Operand, Zero_On_Dynamic_Level)
12741 > Type_Access_Level (Target_Type)
12743 Raise_Accessibility_Error;
12748 -- Case of conversions of tagged types and access to tagged types
12750 -- When needed, that is to say when the expression is class-wide, Add
12751 -- runtime a tag check for (strict) downward conversion by using the
12752 -- membership test, generating:
12754 -- [constraint_error when Operand not in Target_Type'Class]
12756 -- or in the access type case
12758 -- [constraint_error
12759 -- when Operand /= null
12760 -- and then Operand.all not in
12761 -- Designated_Type (Target_Type)'Class]
12763 if (Is_Access_Type (Target_Type)
12764 and then Is_Tagged_Type (Designated_Type (Target_Type)))
12765 or else Is_Tagged_Type (Target_Type)
12767 -- Do not do any expansion in the access type case if the parent is a
12768 -- renaming, since this is an error situation which will be caught by
12769 -- Sem_Ch8, and the expansion can interfere with this error check.
12771 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
12775 -- Otherwise, proceed with processing tagged conversion
12777 Tagged_Conversion : declare
12778 Actual_Op_Typ : Entity_Id;
12779 Actual_Targ_Typ : Entity_Id;
12780 Root_Op_Typ : Entity_Id;
12782 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
12783 -- Create a membership check to test whether Operand is a member
12784 -- of Targ_Typ. If the original Target_Type is an access, include
12785 -- a test for null value. The check is inserted at N.
12787 --------------------
12788 -- Make_Tag_Check --
12789 --------------------
12791 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
12796 -- [Constraint_Error
12797 -- when Operand /= null
12798 -- and then Operand.all not in Targ_Typ]
12800 if Is_Access_Type (Target_Type) then
12802 Make_And_Then (Loc,
12805 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
12806 Right_Opnd => Make_Null (Loc)),
12811 Make_Explicit_Dereference (Loc,
12812 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
12813 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
12816 -- [Constraint_Error when Operand not in Targ_Typ]
12821 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
12822 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
12826 Make_Raise_Constraint_Error (Loc,
12828 Reason => CE_Tag_Check_Failed),
12829 Suppress => All_Checks);
12830 end Make_Tag_Check;
12832 -- Start of processing for Tagged_Conversion
12835 -- Handle entities from the limited view
12837 if Is_Access_Type (Operand_Type) then
12839 Available_View (Designated_Type (Operand_Type));
12841 Actual_Op_Typ := Operand_Type;
12844 if Is_Access_Type (Target_Type) then
12846 Available_View (Designated_Type (Target_Type));
12848 Actual_Targ_Typ := Target_Type;
12851 Root_Op_Typ := Root_Type (Actual_Op_Typ);
12853 -- Ada 2005 (AI-251): Handle interface type conversion
12855 if Is_Interface (Actual_Op_Typ)
12857 Is_Interface (Actual_Targ_Typ)
12859 Expand_Interface_Conversion (N);
12863 -- Create a runtime tag check for a downward CW type conversion
12865 if Is_Class_Wide_Type (Actual_Op_Typ)
12866 and then Actual_Op_Typ /= Actual_Targ_Typ
12867 and then Root_Op_Typ /= Actual_Targ_Typ
12868 and then Is_Ancestor
12869 (Root_Op_Typ, Actual_Targ_Typ, Use_Full_View => True)
12870 and then not Tag_Checks_Suppressed (Actual_Targ_Typ)
12875 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
12876 Conv := Unchecked_Convert_To (Target_Type, Expression (N));
12878 Analyze_And_Resolve (N, Target_Type);
12881 end Tagged_Conversion;
12883 -- Case of other access type conversions
12885 elsif Is_Access_Type (Target_Type) then
12886 Apply_Constraint_Check (Operand, Target_Type);
12888 -- Case of conversions from a fixed-point type
12890 -- These conversions require special expansion and processing, found in
12891 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12892 -- since from a semantic point of view, these are simple integer
12893 -- conversions, which do not need further processing except for the
12894 -- generation of range checks, which is performed at the end of this
12897 elsif Is_Fixed_Point_Type (Operand_Type)
12898 and then not Conversion_OK (N)
12900 -- We should never see universal fixed at this case, since the
12901 -- expansion of the constituent divide or multiply should have
12902 -- eliminated the explicit mention of universal fixed.
12904 pragma Assert (Operand_Type /= Universal_Fixed);
12906 -- Check for special case of the conversion to universal real that
12907 -- occurs as a result of the use of a round attribute. In this case,
12908 -- the real type for the conversion is taken from the target type of
12909 -- the Round attribute and the result must be marked as rounded.
12911 if Target_Type = Universal_Real
12912 and then Nkind (Parent (N)) = N_Attribute_Reference
12913 and then Attribute_Name (Parent (N)) = Name_Round
12915 Set_Etype (N, Etype (Parent (N)));
12916 Target_Type := Etype (N);
12917 Set_Rounded_Result (N);
12920 if Is_Fixed_Point_Type (Target_Type) then
12921 Expand_Convert_Fixed_To_Fixed (N);
12922 elsif Is_Integer_Type (Target_Type) then
12923 Expand_Convert_Fixed_To_Integer (N);
12925 pragma Assert (Is_Floating_Point_Type (Target_Type));
12926 Expand_Convert_Fixed_To_Float (N);
12929 -- Case of conversions to a fixed-point type
12931 -- These conversions require special expansion and processing, found in
12932 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12933 -- since from a semantic point of view, these are simple integer
12934 -- conversions, which do not need further processing.
12936 elsif Is_Fixed_Point_Type (Target_Type)
12937 and then not Conversion_OK (N)
12939 if Is_Integer_Type (Operand_Type) then
12940 Expand_Convert_Integer_To_Fixed (N);
12942 pragma Assert (Is_Floating_Point_Type (Operand_Type));
12943 Expand_Convert_Float_To_Fixed (N);
12946 -- Case of array conversions
12948 -- Expansion of array conversions, add required length/range checks but
12949 -- only do this if there is no change of representation. For handling of
12950 -- this case, see Handle_Changed_Representation.
12952 elsif Is_Array_Type (Target_Type) then
12953 if Is_Constrained (Target_Type) then
12954 Apply_Length_Check (Operand, Target_Type);
12956 -- If the object has an unconstrained array subtype with fixed
12957 -- lower bound, then sliding to that bound may be needed.
12959 if Is_Fixed_Lower_Bound_Array_Subtype (Target_Type) then
12960 Expand_Sliding_Conversion (Operand, Target_Type);
12963 Apply_Range_Check (Operand, Target_Type);
12966 Handle_Changed_Representation;
12968 -- Case of conversions of discriminated types
12970 -- Add required discriminant checks if target is constrained. Again this
12971 -- change is skipped if we have a change of representation.
12973 elsif Has_Discriminants (Target_Type)
12974 and then Is_Constrained (Target_Type)
12976 Apply_Discriminant_Check (Operand, Target_Type);
12977 Handle_Changed_Representation;
12979 -- Case of all other record conversions. The only processing required
12980 -- is to check for a change of representation requiring the special
12981 -- assignment processing.
12983 elsif Is_Record_Type (Target_Type) then
12985 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12986 -- a derived Unchecked_Union type to an unconstrained type that is
12987 -- not Unchecked_Union if the operand lacks inferable discriminants.
12989 if Is_Derived_Type (Operand_Type)
12990 and then Is_Unchecked_Union (Base_Type (Operand_Type))
12991 and then not Is_Constrained (Target_Type)
12992 and then not Is_Unchecked_Union (Base_Type (Target_Type))
12993 and then not Has_Inferable_Discriminants (Operand)
12995 -- To prevent Gigi from generating illegal code, we generate a
12996 -- Program_Error node, but we give it the target type of the
12997 -- conversion (is this requirement documented somewhere ???)
13000 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
13001 Reason => PE_Unchecked_Union_Restriction);
13004 Set_Etype (PE, Target_Type);
13009 Handle_Changed_Representation;
13012 -- Case of conversions of enumeration types
13014 elsif Is_Enumeration_Type (Target_Type) then
13016 -- Special processing is required if there is a change of
13017 -- representation (from enumeration representation clauses).
13019 if not Has_Compatible_Representation (Target_Type, Operand_Type)
13020 and then not Conversion_OK (N)
13022 if Optimization_Level > 0
13023 and then Is_Boolean_Type (Target_Type)
13025 -- Convert x(y) to (if y then x'(True) else x'(False)).
13026 -- Use literals, instead of indexing x'val, to enable
13027 -- further optimizations in the middle-end.
13030 Make_If_Expression (Loc,
13031 Expressions => New_List (
13033 Convert_To (Target_Type,
13034 New_Occurrence_Of (Standard_True, Loc)),
13035 Convert_To (Target_Type,
13036 New_Occurrence_Of (Standard_False, Loc)))));
13039 -- Convert: x(y) to x'val (ytyp'pos (y))
13042 Make_Attribute_Reference (Loc,
13043 Prefix => New_Occurrence_Of (Target_Type, Loc),
13044 Attribute_Name => Name_Val,
13045 Expressions => New_List (
13046 Make_Attribute_Reference (Loc,
13047 Prefix => New_Occurrence_Of (Operand_Type, Loc),
13048 Attribute_Name => Name_Pos,
13049 Expressions => New_List (Operand)))));
13052 Analyze_And_Resolve (N, Target_Type);
13056 -- At this stage, either the conversion node has been transformed into
13057 -- some other equivalent expression, or left as a conversion that can be
13058 -- handled by Gigi.
13060 -- The only remaining step is to generate a range check if we still have
13061 -- a type conversion at this stage and Do_Range_Check is set. Note that
13062 -- we need to deal with at most 8 out of the 9 possible cases of numeric
13063 -- conversions here, because the float-to-integer case is entirely dealt
13064 -- with by Apply_Float_Conversion_Check.
13066 if Nkind (N) = N_Type_Conversion
13067 and then Do_Range_Check (Expression (N))
13069 -- Float-to-float conversions
13071 if Is_Floating_Point_Type (Target_Type)
13072 and then Is_Floating_Point_Type (Etype (Expression (N)))
13074 -- Reset overflow flag, since the range check will include
13075 -- dealing with possible overflow, and generate the check.
13077 Set_Do_Overflow_Check (N, False);
13079 Generate_Range_Check
13080 (Expression (N), Target_Type, CE_Range_Check_Failed);
13082 -- Discrete-to-discrete conversions or fixed-point-to-discrete
13083 -- conversions when Conversion_OK is set.
13085 elsif Is_Discrete_Type (Target_Type)
13086 and then (Is_Discrete_Type (Etype (Expression (N)))
13087 or else (Is_Fixed_Point_Type (Etype (Expression (N)))
13088 and then Conversion_OK (N)))
13090 -- If Address is either a source type or target type,
13091 -- suppress range check to avoid typing anomalies when
13092 -- it is a visible integer type.
13094 if Is_Descendant_Of_Address (Etype (Expression (N)))
13095 or else Is_Descendant_Of_Address (Target_Type)
13097 Set_Do_Range_Check (Expression (N), False);
13099 Discrete_Range_Check;
13102 -- Conversions to floating- or fixed-point when Conversion_OK is set
13104 elsif Is_Floating_Point_Type (Target_Type)
13105 or else (Is_Fixed_Point_Type (Target_Type)
13106 and then Conversion_OK (N))
13111 pragma Assert (not Do_Range_Check (Expression (N)));
13114 -- Here at end of processing
13117 -- Apply predicate check if required. Note that we can't just call
13118 -- Apply_Predicate_Check here, because the type looks right after
13119 -- the conversion and it would omit the check. The Comes_From_Source
13120 -- guard is necessary to prevent infinite recursions when we generate
13121 -- internal conversions for the purpose of checking predicates.
13123 -- A view conversion of a tagged object is an object and can appear
13124 -- in an assignment context, in which case no predicate check applies
13125 -- to the now-dead value.
13127 if Nkind (Parent (N)) = N_Assignment_Statement
13128 and then N = Name (Parent (N))
13132 elsif Predicate_Enabled (Target_Type)
13133 and then Target_Type /= Operand_Type
13134 and then Comes_From_Source (N)
13137 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
13140 -- Avoid infinite recursion on the subsequent expansion of the
13141 -- copy of the original type conversion. When needed, a range
13142 -- check has already been applied to the expression.
13144 Set_Comes_From_Source (New_Expr, False);
13146 Make_Predicate_Check (Target_Type, New_Expr),
13147 Suppress => Range_Check);
13150 end Expand_N_Type_Conversion;
13152 -----------------------------------
13153 -- Expand_N_Unchecked_Expression --
13154 -----------------------------------
13156 -- Remove the unchecked expression node from the tree. Its job was simply
13157 -- to make sure that its constituent expression was handled with checks
13158 -- off, and now that is done, we can remove it from the tree, and indeed
13159 -- must, since Gigi does not expect to see these nodes.
13161 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
13162 Exp : constant Node_Id := Expression (N);
13164 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
13166 end Expand_N_Unchecked_Expression;
13168 ----------------------------------------
13169 -- Expand_N_Unchecked_Type_Conversion --
13170 ----------------------------------------
13172 -- If this cannot be handled by Gigi and we haven't already made a
13173 -- temporary for it, do it now.
13175 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
13176 Target_Type : constant Entity_Id := Etype (N);
13177 Operand : constant Node_Id := Expression (N);
13178 Operand_Type : constant Entity_Id := Etype (Operand);
13181 -- Nothing at all to do if conversion is to the identical type so remove
13182 -- the conversion completely, it is useless, except that it may carry
13183 -- an Assignment_OK indication which must be propagated to the operand.
13185 if Operand_Type = Target_Type then
13186 Expand_N_Unchecked_Expression (N);
13190 -- Generate an extra temporary for cases unsupported by the C backend
13192 if Modify_Tree_For_C then
13194 Source : constant Node_Id := Unqual_Conv (Expression (N));
13195 Source_Typ : Entity_Id := Get_Full_View (Etype (Source));
13198 if Is_Packed_Array (Source_Typ) then
13199 Source_Typ := Packed_Array_Impl_Type (Source_Typ);
13202 if Nkind (Source) = N_Function_Call
13203 and then (Is_Composite_Type (Etype (Source))
13204 or else Is_Composite_Type (Target_Type))
13206 Force_Evaluation (Source);
13211 -- Nothing to do if conversion is safe
13213 if Safe_Unchecked_Type_Conversion (N) then
13217 if Assignment_OK (N) then
13220 Force_Evaluation (N);
13222 end Expand_N_Unchecked_Type_Conversion;
13224 ----------------------------
13225 -- Expand_Record_Equality --
13226 ----------------------------
13228 -- For non-variant records, Equality is expanded when needed into:
13230 -- and then Lhs.Discr1 = Rhs.Discr1
13232 -- and then Lhs.Discrn = Rhs.Discrn
13233 -- and then Lhs.Cmp1 = Rhs.Cmp1
13235 -- and then Lhs.Cmpn = Rhs.Cmpn
13237 -- The expression is folded by the back end for adjacent fields. This
13238 -- function is called for tagged record in only one occasion: for imple-
13239 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
13240 -- otherwise the primitive "=" is used directly.
13242 function Expand_Record_Equality
13246 Rhs : Node_Id) return Node_Id
13248 Loc : constant Source_Ptr := Sloc (Nod);
13253 First_Time : Boolean := True;
13255 function Element_To_Compare (C : Entity_Id) return Entity_Id;
13256 -- Return the next discriminant or component to compare, starting with
13257 -- C, skipping inherited components.
13259 ------------------------
13260 -- Element_To_Compare --
13261 ------------------------
13263 function Element_To_Compare (C : Entity_Id) return Entity_Id is
13264 Comp : Entity_Id := C;
13267 while Present (Comp) loop
13268 -- Skip inherited components
13270 -- Note: for a tagged type, we always generate the "=" primitive
13271 -- for the base type (not on the first subtype), so the test for
13272 -- Comp /= Original_Record_Component (Comp) is True for inherited
13273 -- components only.
13275 if (Is_Tagged_Type (Typ)
13276 and then Comp /= Original_Record_Component (Comp))
13280 or else Chars (Comp) = Name_uTag
13282 -- Skip interface elements (secondary tags???)
13284 or else Is_Interface (Etype (Comp))
13286 Next_Component_Or_Discriminant (Comp);
13293 end Element_To_Compare;
13295 -- Start of processing for Expand_Record_Equality
13298 -- Generates the following code: (assuming that Typ has one Discr and
13299 -- component C2 is also a record)
13301 -- Lhs.Discr1 = Rhs.Discr1
13302 -- and then Lhs.C1 = Rhs.C1
13303 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
13305 -- and then Lhs.Cmpn = Rhs.Cmpn
13307 Result := New_Occurrence_Of (Standard_True, Loc);
13308 C := Element_To_Compare (First_Component_Or_Discriminant (Typ));
13309 while Present (C) loop
13320 New_Lhs := New_Copy_Tree (Lhs);
13321 New_Rhs := New_Copy_Tree (Rhs);
13325 Expand_Composite_Equality (Nod, Etype (C),
13327 Make_Selected_Component (Loc,
13329 Selector_Name => New_Occurrence_Of (C, Loc)),
13331 Make_Selected_Component (Loc,
13333 Selector_Name => New_Occurrence_Of (C, Loc)));
13335 -- If some (sub)component is an unchecked_union, the whole
13336 -- operation will raise program error.
13338 if Nkind (Check) = N_Raise_Program_Error then
13340 Set_Etype (Result, Standard_Boolean);
13346 -- Generate logical "and" for CodePeer to simplify the
13347 -- generated code and analysis.
13349 elsif CodePeer_Mode then
13352 Left_Opnd => Result,
13353 Right_Opnd => Check);
13357 Make_And_Then (Loc,
13358 Left_Opnd => Result,
13359 Right_Opnd => Check);
13364 First_Time := False;
13365 C := Element_To_Compare (Next_Component_Or_Discriminant (C));
13369 end Expand_Record_Equality;
13371 ---------------------------
13372 -- Expand_Set_Membership --
13373 ---------------------------
13375 procedure Expand_Set_Membership (N : Node_Id) is
13376 Lop : constant Node_Id := Left_Opnd (N);
13380 function Make_Cond (Alt : Node_Id) return Node_Id;
13381 -- If the alternative is a subtype mark, create a simple membership
13382 -- test. Otherwise create an equality test for it.
13388 function Make_Cond (Alt : Node_Id) return Node_Id is
13390 L : constant Node_Id := New_Copy_Tree (Lop);
13391 R : constant Node_Id := Relocate_Node (Alt);
13394 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
13395 or else Nkind (Alt) = N_Range
13397 Cond := Make_In (Sloc (Alt), Left_Opnd => L, Right_Opnd => R);
13400 Cond := Make_Op_Eq (Sloc (Alt), Left_Opnd => L, Right_Opnd => R);
13401 Resolve_Membership_Equality (Cond, Etype (Alt));
13407 -- Start of processing for Expand_Set_Membership
13410 Remove_Side_Effects (Lop);
13412 Alt := First (Alternatives (N));
13413 Res := Make_Cond (Alt);
13416 -- We use left associativity as in the equivalent boolean case. This
13417 -- kind of canonicalization helps the optimizer of the code generator.
13419 while Present (Alt) loop
13421 Make_Or_Else (Sloc (Alt),
13423 Right_Opnd => Make_Cond (Alt));
13428 Analyze_And_Resolve (N, Standard_Boolean);
13429 end Expand_Set_Membership;
13431 -----------------------------------
13432 -- Expand_Short_Circuit_Operator --
13433 -----------------------------------
13435 -- Deal with special expansion if actions are present for the right operand
13436 -- and deal with optimizing case of arguments being True or False. We also
13437 -- deal with the special case of non-standard boolean values.
13439 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
13440 Loc : constant Source_Ptr := Sloc (N);
13441 Typ : constant Entity_Id := Etype (N);
13442 Left : constant Node_Id := Left_Opnd (N);
13443 Right : constant Node_Id := Right_Opnd (N);
13444 LocR : constant Source_Ptr := Sloc (Right);
13447 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
13448 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
13449 -- If Left = Shortcut_Value then Right need not be evaluated
13451 function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
13452 -- For Opnd a boolean expression, return a Boolean expression equivalent
13453 -- to Opnd /= Shortcut_Value.
13455 function Useful (Actions : List_Id) return Boolean;
13456 -- Return True if Actions is not empty and contains useful nodes to
13459 --------------------
13460 -- Make_Test_Expr --
13461 --------------------
13463 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
13465 if Shortcut_Value then
13466 return Make_Op_Not (Sloc (Opnd), Opnd);
13470 end Make_Test_Expr;
13476 function Useful (Actions : List_Id) return Boolean is
13479 if Present (Actions) then
13480 L := First (Actions);
13482 -- For now "useful" means not N_Variable_Reference_Marker.
13483 -- Consider stripping other nodes in the future.
13485 while Present (L) loop
13486 if Nkind (L) /= N_Variable_Reference_Marker then
13499 Op_Var : Entity_Id;
13500 -- Entity for a temporary variable holding the value of the operator,
13501 -- used for expansion in the case where actions are present.
13503 -- Start of processing for Expand_Short_Circuit_Operator
13506 -- Deal with non-standard booleans
13508 if Is_Boolean_Type (Typ) then
13509 Adjust_Condition (Left);
13510 Adjust_Condition (Right);
13511 Set_Etype (N, Standard_Boolean);
13514 -- Check for cases where left argument is known to be True or False
13516 if Compile_Time_Known_Value (Left) then
13518 -- Mark SCO for left condition as compile time known
13520 if Generate_SCO and then Comes_From_Source (Left) then
13521 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
13524 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
13525 -- Any actions associated with Right will be executed unconditionally
13526 -- and can thus be inserted into the tree unconditionally.
13528 if Expr_Value_E (Left) /= Shortcut_Ent then
13529 if Present (Actions (N)) then
13530 Insert_Actions (N, Actions (N));
13533 Rewrite (N, Right);
13535 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
13536 -- In this case we can forget the actions associated with Right,
13537 -- since they will never be executed.
13540 Kill_Dead_Code (Right);
13541 Kill_Dead_Code (Actions (N));
13542 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
13545 Adjust_Result_Type (N, Typ);
13549 -- If Actions are present for the right operand, we have to do some
13550 -- special processing. We can't just let these actions filter back into
13551 -- code preceding the short circuit (which is what would have happened
13552 -- if we had not trapped them in the short-circuit form), since they
13553 -- must only be executed if the right operand of the short circuit is
13554 -- executed and not otherwise.
13556 if Useful (Actions (N)) then
13557 Actlist := Actions (N);
13559 -- The old approach is to expand:
13561 -- left AND THEN right
13565 -- C : Boolean := False;
13573 -- and finally rewrite the operator into a reference to C. Similarly
13574 -- for left OR ELSE right, with negated values. Note that this
13575 -- rewrite causes some difficulties for coverage analysis because
13576 -- of the introduction of the new variable C, which obscures the
13577 -- structure of the test.
13579 -- We use this "old approach" if Minimize_Expression_With_Actions
13582 if Minimize_Expression_With_Actions then
13583 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
13586 Make_Object_Declaration (Loc,
13587 Defining_Identifier => Op_Var,
13588 Object_Definition =>
13589 New_Occurrence_Of (Standard_Boolean, Loc),
13591 New_Occurrence_Of (Shortcut_Ent, Loc)));
13593 Append_To (Actlist,
13594 Make_Implicit_If_Statement (Right,
13595 Condition => Make_Test_Expr (Right),
13596 Then_Statements => New_List (
13597 Make_Assignment_Statement (LocR,
13598 Name => New_Occurrence_Of (Op_Var, LocR),
13601 (Boolean_Literals (not Shortcut_Value), LocR)))));
13604 Make_Implicit_If_Statement (Left,
13605 Condition => Make_Test_Expr (Left),
13606 Then_Statements => Actlist));
13608 Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
13609 Analyze_And_Resolve (N, Standard_Boolean);
13611 -- The new approach (the default) is to use an
13612 -- Expression_With_Actions node for the right operand of the
13613 -- short-circuit form. Note that this solves the traceability
13614 -- problems for coverage analysis.
13618 Make_Expression_With_Actions (LocR,
13619 Expression => Relocate_Node (Right),
13620 Actions => Actlist));
13622 Set_Actions (N, No_List);
13623 Analyze_And_Resolve (Right, Standard_Boolean);
13626 Adjust_Result_Type (N, Typ);
13630 -- No actions present, check for cases of right argument True/False
13632 if Compile_Time_Known_Value (Right) then
13634 -- Mark SCO for left condition as compile time known
13636 if Generate_SCO and then Comes_From_Source (Right) then
13637 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
13640 -- Change (Left and then True), (Left or else False) to Left. Note
13641 -- that we know there are no actions associated with the right
13642 -- operand, since we just checked for this case above.
13644 if Expr_Value_E (Right) /= Shortcut_Ent then
13647 -- Change (Left and then False), (Left or else True) to Right,
13648 -- making sure to preserve any side effects associated with the Left
13652 Remove_Side_Effects (Left);
13653 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
13657 Adjust_Result_Type (N, Typ);
13658 end Expand_Short_Circuit_Operator;
13660 ------------------------------------
13661 -- Fixup_Universal_Fixed_Operation --
13662 -------------------------------------
13664 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
13665 Conv : constant Node_Id := Parent (N);
13668 -- We must have a type conversion immediately above us
13670 pragma Assert (Nkind (Conv) = N_Type_Conversion);
13672 -- Normally the type conversion gives our target type. The exception
13673 -- occurs in the case of the Round attribute, where the conversion
13674 -- will be to universal real, and our real type comes from the Round
13675 -- attribute (as well as an indication that we must round the result)
13677 if Etype (Conv) = Universal_Real
13678 and then Nkind (Parent (Conv)) = N_Attribute_Reference
13679 and then Attribute_Name (Parent (Conv)) = Name_Round
13681 Set_Etype (N, Base_Type (Etype (Parent (Conv))));
13682 Set_Rounded_Result (N);
13684 -- Normal case where type comes from conversion above us
13687 Set_Etype (N, Base_Type (Etype (Conv)));
13689 end Fixup_Universal_Fixed_Operation;
13691 ----------------------------
13692 -- Get_First_Index_Bounds --
13693 ----------------------------
13695 procedure Get_First_Index_Bounds (T : Entity_Id; Lo, Hi : out Uint) is
13699 pragma Assert (Is_Array_Type (T));
13701 -- This follows Sem_Eval.Compile_Time_Known_Bounds
13703 if Ekind (T) = E_String_Literal_Subtype then
13704 Lo := Expr_Value (String_Literal_Low_Bound (T));
13705 Hi := Lo + String_Literal_Length (T) - 1;
13708 Typ := Underlying_Type (Etype (First_Index (T)));
13710 Lo := Expr_Value (Type_Low_Bound (Typ));
13711 Hi := Expr_Value (Type_High_Bound (Typ));
13713 end Get_First_Index_Bounds;
13715 ------------------------
13716 -- Get_Size_For_Range --
13717 ------------------------
13719 function Get_Size_For_Range (Lo, Hi : Uint) return Uint is
13721 function Is_OK_For_Range (Siz : Uint) return Boolean;
13722 -- Return True if a signed integer with given size can cover Lo .. Hi
13724 --------------------------
13725 -- Is_OK_For_Range --
13726 --------------------------
13728 function Is_OK_For_Range (Siz : Uint) return Boolean is
13729 B : constant Uint := Uint_2 ** (Siz - 1);
13732 -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
13734 return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B;
13735 end Is_OK_For_Range;
13738 -- This is (almost always) the size of Integer
13740 if Is_OK_For_Range (Uint_32) then
13745 elsif Is_OK_For_Range (Uint_63) then
13748 -- This is (almost always) the size of Long_Long_Integer
13750 elsif Is_OK_For_Range (Uint_64) then
13755 elsif Is_OK_For_Range (Uint_127) then
13761 end Get_Size_For_Range;
13763 -------------------------------
13764 -- Insert_Dereference_Action --
13765 -------------------------------
13767 procedure Insert_Dereference_Action (N : Node_Id) is
13768 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
13769 -- Return true if type of P is derived from Checked_Pool;
13771 -----------------------------
13772 -- Is_Checked_Storage_Pool --
13773 -----------------------------
13775 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
13784 while T /= Etype (T) loop
13785 if Is_RTE (T, RE_Checked_Pool) then
13793 end Is_Checked_Storage_Pool;
13797 Context : constant Node_Id := Parent (N);
13798 Ptr_Typ : constant Entity_Id := Etype (N);
13799 Desig_Typ : constant Entity_Id :=
13800 Available_View (Designated_Type (Ptr_Typ));
13801 Loc : constant Source_Ptr := Sloc (N);
13802 Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ);
13808 Size_Bits : Node_Id;
13811 -- Start of processing for Insert_Dereference_Action
13814 pragma Assert (Nkind (Context) = N_Explicit_Dereference);
13816 -- Do not re-expand a dereference which has already been processed by
13819 if Has_Dereference_Action (Context) then
13822 -- Do not perform this type of expansion for internally-generated
13825 elsif not Comes_From_Source (Original_Node (Context)) then
13828 -- A dereference action is only applicable to objects which have been
13829 -- allocated on a checked pool.
13831 elsif not Is_Checked_Storage_Pool (Pool) then
13835 -- Extract the address of the dereferenced object. Generate:
13837 -- Addr : System.Address := <N>'Pool_Address;
13839 Addr := Make_Temporary (Loc, 'P');
13842 Make_Object_Declaration (Loc,
13843 Defining_Identifier => Addr,
13844 Object_Definition =>
13845 New_Occurrence_Of (RTE (RE_Address), Loc),
13847 Make_Attribute_Reference (Loc,
13848 Prefix => Duplicate_Subexpr_Move_Checks (N),
13849 Attribute_Name => Name_Pool_Address)));
13851 -- Calculate the size of the dereferenced object. Generate:
13853 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13856 Make_Explicit_Dereference (Loc,
13857 Prefix => Duplicate_Subexpr_Move_Checks (N));
13858 Set_Has_Dereference_Action (Deref);
13861 Make_Attribute_Reference (Loc,
13863 Attribute_Name => Name_Size);
13865 -- Special case of an unconstrained array: need to add descriptor size
13867 if Is_Array_Type (Desig_Typ)
13868 and then not Is_Constrained (First_Subtype (Desig_Typ))
13873 Make_Attribute_Reference (Loc,
13875 New_Occurrence_Of (First_Subtype (Desig_Typ), Loc),
13876 Attribute_Name => Name_Descriptor_Size),
13877 Right_Opnd => Size_Bits);
13880 Size := Make_Temporary (Loc, 'S');
13882 Make_Object_Declaration (Loc,
13883 Defining_Identifier => Size,
13884 Object_Definition =>
13885 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13887 Make_Op_Divide (Loc,
13888 Left_Opnd => Size_Bits,
13889 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
13891 -- Calculate the alignment of the dereferenced object. Generate:
13892 -- Alig : constant Storage_Count := <N>.all'Alignment;
13895 Make_Explicit_Dereference (Loc,
13896 Prefix => Duplicate_Subexpr_Move_Checks (N));
13897 Set_Has_Dereference_Action (Deref);
13899 Alig := Make_Temporary (Loc, 'A');
13901 Make_Object_Declaration (Loc,
13902 Defining_Identifier => Alig,
13903 Object_Definition =>
13904 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13906 Make_Attribute_Reference (Loc,
13908 Attribute_Name => Name_Alignment)));
13910 -- A dereference of a controlled object requires special processing. The
13911 -- finalization machinery requests additional space from the underlying
13912 -- pool to allocate and hide two pointers. As a result, a checked pool
13913 -- may mark the wrong memory as valid. Since checked pools do not have
13914 -- knowledge of hidden pointers, we have to bring the two pointers back
13915 -- in view in order to restore the original state of the object.
13917 -- The address manipulation is not performed for access types that are
13918 -- subject to pragma No_Heap_Finalization because the two pointers do
13919 -- not exist in the first place.
13921 if No_Heap_Finalization (Ptr_Typ) then
13924 elsif Needs_Finalization (Desig_Typ) then
13926 -- Adjust the address and size of the dereferenced object. Generate:
13927 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13930 Make_Procedure_Call_Statement (Loc,
13932 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
13933 Parameter_Associations => New_List (
13934 New_Occurrence_Of (Addr, Loc),
13935 New_Occurrence_Of (Size, Loc),
13936 New_Occurrence_Of (Alig, Loc)));
13938 -- Class-wide types complicate things because we cannot determine
13939 -- statically whether the actual object is truly controlled. We must
13940 -- generate a runtime check to detect this property. Generate:
13942 -- if Needs_Finalization (<N>.all'Tag) then
13946 if Is_Class_Wide_Type (Desig_Typ) then
13948 Make_Explicit_Dereference (Loc,
13949 Prefix => Duplicate_Subexpr_Move_Checks (N));
13950 Set_Has_Dereference_Action (Deref);
13953 Make_Implicit_If_Statement (N,
13955 Make_Function_Call (Loc,
13957 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
13958 Parameter_Associations => New_List (
13959 Make_Attribute_Reference (Loc,
13961 Attribute_Name => Name_Tag))),
13962 Then_Statements => New_List (Stmt));
13965 Insert_Action (N, Stmt);
13969 -- Dereference (Pool, Addr, Size, Alig);
13972 Make_Procedure_Call_Statement (Loc,
13975 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
13976 Parameter_Associations => New_List (
13977 New_Occurrence_Of (Pool, Loc),
13978 New_Occurrence_Of (Addr, Loc),
13979 New_Occurrence_Of (Size, Loc),
13980 New_Occurrence_Of (Alig, Loc))));
13982 -- Mark the explicit dereference as processed to avoid potential
13983 -- infinite expansion.
13985 Set_Has_Dereference_Action (Context);
13988 when RE_Not_Available =>
13990 end Insert_Dereference_Action;
13992 --------------------------------
13993 -- Integer_Promotion_Possible --
13994 --------------------------------
13996 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
13997 Operand : constant Node_Id := Expression (N);
13998 Operand_Type : constant Entity_Id := Etype (Operand);
13999 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
14002 pragma Assert (Nkind (N) = N_Type_Conversion);
14006 -- We only do the transformation for source constructs. We assume
14007 -- that the expander knows what it is doing when it generates code.
14009 Comes_From_Source (N)
14011 -- If the operand type is Short_Integer or Short_Short_Integer,
14012 -- then we will promote to Integer, which is available on all
14013 -- targets, and is sufficient to ensure no intermediate overflow.
14014 -- Furthermore it is likely to be as efficient or more efficient
14015 -- than using the smaller type for the computation so we do this
14016 -- unconditionally.
14019 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
14021 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
14023 -- Test for interesting operation, which includes addition,
14024 -- division, exponentiation, multiplication, subtraction, absolute
14025 -- value and unary negation. Unary "+" is omitted since it is a
14026 -- no-op and thus can't overflow.
14028 and then Nkind (Operand) in
14029 N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
14030 N_Op_Minus | N_Op_Multiply | N_Op_Subtract;
14031 end Integer_Promotion_Possible;
14033 ------------------------------
14034 -- Make_Array_Comparison_Op --
14035 ------------------------------
14037 -- This is a hand-coded expansion of the following generic function:
14040 -- type elem is (<>);
14041 -- type index is (<>);
14042 -- type a is array (index range <>) of elem;
14044 -- function Gnnn (X : a; Y: a) return boolean is
14045 -- J : index := Y'first;
14048 -- if X'length = 0 then
14051 -- elsif Y'length = 0 then
14055 -- for I in X'range loop
14056 -- if X (I) = Y (J) then
14057 -- if J = Y'last then
14060 -- J := index'succ (J);
14064 -- return X (I) > Y (J);
14068 -- return X'length > Y'length;
14072 -- Note that since we are essentially doing this expansion by hand, we
14073 -- do not need to generate an actual or formal generic part, just the
14074 -- instantiated function itself.
14076 function Make_Array_Comparison_Op
14078 Nod : Node_Id) return Node_Id
14080 Loc : constant Source_Ptr := Sloc (Nod);
14082 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
14083 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
14084 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
14085 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
14087 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
14089 Loop_Statement : Node_Id;
14090 Loop_Body : Node_Id;
14092 Inner_If : Node_Id;
14093 Final_Expr : Node_Id;
14094 Func_Body : Node_Id;
14095 Func_Name : Entity_Id;
14101 -- if J = Y'last then
14104 -- J := index'succ (J);
14108 Make_Implicit_If_Statement (Nod,
14111 Left_Opnd => New_Occurrence_Of (J, Loc),
14113 Make_Attribute_Reference (Loc,
14114 Prefix => New_Occurrence_Of (Y, Loc),
14115 Attribute_Name => Name_Last)),
14117 Then_Statements => New_List (
14118 Make_Exit_Statement (Loc)),
14122 Make_Assignment_Statement (Loc,
14123 Name => New_Occurrence_Of (J, Loc),
14125 Make_Attribute_Reference (Loc,
14126 Prefix => New_Occurrence_Of (Index, Loc),
14127 Attribute_Name => Name_Succ,
14128 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
14130 -- if X (I) = Y (J) then
14133 -- return X (I) > Y (J);
14137 Make_Implicit_If_Statement (Nod,
14141 Make_Indexed_Component (Loc,
14142 Prefix => New_Occurrence_Of (X, Loc),
14143 Expressions => New_List (New_Occurrence_Of (I, Loc))),
14146 Make_Indexed_Component (Loc,
14147 Prefix => New_Occurrence_Of (Y, Loc),
14148 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
14150 Then_Statements => New_List (Inner_If),
14152 Else_Statements => New_List (
14153 Make_Simple_Return_Statement (Loc,
14157 Make_Indexed_Component (Loc,
14158 Prefix => New_Occurrence_Of (X, Loc),
14159 Expressions => New_List (New_Occurrence_Of (I, Loc))),
14162 Make_Indexed_Component (Loc,
14163 Prefix => New_Occurrence_Of (Y, Loc),
14164 Expressions => New_List (
14165 New_Occurrence_Of (J, Loc)))))));
14167 -- for I in X'range loop
14172 Make_Implicit_Loop_Statement (Nod,
14173 Identifier => Empty,
14175 Iteration_Scheme =>
14176 Make_Iteration_Scheme (Loc,
14177 Loop_Parameter_Specification =>
14178 Make_Loop_Parameter_Specification (Loc,
14179 Defining_Identifier => I,
14180 Discrete_Subtype_Definition =>
14181 Make_Attribute_Reference (Loc,
14182 Prefix => New_Occurrence_Of (X, Loc),
14183 Attribute_Name => Name_Range))),
14185 Statements => New_List (Loop_Body));
14187 -- if X'length = 0 then
14189 -- elsif Y'length = 0 then
14192 -- for ... loop ... end loop;
14193 -- return X'length > Y'length;
14197 Make_Attribute_Reference (Loc,
14198 Prefix => New_Occurrence_Of (X, Loc),
14199 Attribute_Name => Name_Length);
14202 Make_Attribute_Reference (Loc,
14203 Prefix => New_Occurrence_Of (Y, Loc),
14204 Attribute_Name => Name_Length);
14208 Left_Opnd => Length1,
14209 Right_Opnd => Length2);
14212 Make_Implicit_If_Statement (Nod,
14216 Make_Attribute_Reference (Loc,
14217 Prefix => New_Occurrence_Of (X, Loc),
14218 Attribute_Name => Name_Length),
14220 Make_Integer_Literal (Loc, 0)),
14224 Make_Simple_Return_Statement (Loc,
14225 Expression => New_Occurrence_Of (Standard_False, Loc))),
14227 Elsif_Parts => New_List (
14228 Make_Elsif_Part (Loc,
14232 Make_Attribute_Reference (Loc,
14233 Prefix => New_Occurrence_Of (Y, Loc),
14234 Attribute_Name => Name_Length),
14236 Make_Integer_Literal (Loc, 0)),
14240 Make_Simple_Return_Statement (Loc,
14241 Expression => New_Occurrence_Of (Standard_True, Loc))))),
14243 Else_Statements => New_List (
14245 Make_Simple_Return_Statement (Loc,
14246 Expression => Final_Expr)));
14250 Formals := New_List (
14251 Make_Parameter_Specification (Loc,
14252 Defining_Identifier => X,
14253 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
14255 Make_Parameter_Specification (Loc,
14256 Defining_Identifier => Y,
14257 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
14259 -- function Gnnn (...) return boolean is
14260 -- J : index := Y'first;
14265 Func_Name := Make_Temporary (Loc, 'G');
14268 Make_Subprogram_Body (Loc,
14270 Make_Function_Specification (Loc,
14271 Defining_Unit_Name => Func_Name,
14272 Parameter_Specifications => Formals,
14273 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
14275 Declarations => New_List (
14276 Make_Object_Declaration (Loc,
14277 Defining_Identifier => J,
14278 Object_Definition => New_Occurrence_Of (Index, Loc),
14280 Make_Attribute_Reference (Loc,
14281 Prefix => New_Occurrence_Of (Y, Loc),
14282 Attribute_Name => Name_First))),
14284 Handled_Statement_Sequence =>
14285 Make_Handled_Sequence_Of_Statements (Loc,
14286 Statements => New_List (If_Stat)));
14289 end Make_Array_Comparison_Op;
14291 ---------------------------
14292 -- Make_Boolean_Array_Op --
14293 ---------------------------
14295 -- For logical operations on boolean arrays, expand in line the following,
14296 -- replacing 'and' with 'or' or 'xor' where needed:
14298 -- function Annn (A : typ; B: typ) return typ is
14301 -- for J in A'range loop
14302 -- C (J) := A (J) op B (J);
14307 -- or in the case of Transform_Function_Array:
14309 -- procedure Annn (A : typ; B: typ; RESULT: out typ) is
14311 -- for J in A'range loop
14312 -- RESULT (J) := A (J) op B (J);
14316 -- Here typ is the boolean array type
14318 function Make_Boolean_Array_Op
14320 N : Node_Id) return Node_Id
14322 Loc : constant Source_Ptr := Sloc (N);
14324 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
14325 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
14326 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
14336 Func_Name : Entity_Id;
14337 Func_Body : Node_Id;
14338 Loop_Statement : Node_Id;
14341 if Transform_Function_Array then
14342 C := Make_Defining_Identifier (Loc, Name_UP_RESULT);
14344 C := Make_Defining_Identifier (Loc, Name_uC);
14348 Make_Indexed_Component (Loc,
14349 Prefix => New_Occurrence_Of (A, Loc),
14350 Expressions => New_List (New_Occurrence_Of (J, Loc)));
14353 Make_Indexed_Component (Loc,
14354 Prefix => New_Occurrence_Of (B, Loc),
14355 Expressions => New_List (New_Occurrence_Of (J, Loc)));
14358 Make_Indexed_Component (Loc,
14359 Prefix => New_Occurrence_Of (C, Loc),
14360 Expressions => New_List (New_Occurrence_Of (J, Loc)));
14362 if Nkind (N) = N_Op_And then
14366 Right_Opnd => B_J);
14368 elsif Nkind (N) = N_Op_Or then
14372 Right_Opnd => B_J);
14378 Right_Opnd => B_J);
14382 Make_Implicit_Loop_Statement (N,
14383 Identifier => Empty,
14385 Iteration_Scheme =>
14386 Make_Iteration_Scheme (Loc,
14387 Loop_Parameter_Specification =>
14388 Make_Loop_Parameter_Specification (Loc,
14389 Defining_Identifier => J,
14390 Discrete_Subtype_Definition =>
14391 Make_Attribute_Reference (Loc,
14392 Prefix => New_Occurrence_Of (A, Loc),
14393 Attribute_Name => Name_Range))),
14395 Statements => New_List (
14396 Make_Assignment_Statement (Loc,
14398 Expression => Op)));
14400 Formals := New_List (
14401 Make_Parameter_Specification (Loc,
14402 Defining_Identifier => A,
14403 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
14405 Make_Parameter_Specification (Loc,
14406 Defining_Identifier => B,
14407 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
14409 if Transform_Function_Array then
14410 Append_To (Formals,
14411 Make_Parameter_Specification (Loc,
14412 Defining_Identifier => C,
14413 Out_Present => True,
14414 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
14417 Func_Name := Make_Temporary (Loc, 'A');
14418 Set_Is_Inlined (Func_Name);
14420 if Transform_Function_Array then
14422 Make_Subprogram_Body (Loc,
14424 Make_Procedure_Specification (Loc,
14425 Defining_Unit_Name => Func_Name,
14426 Parameter_Specifications => Formals),
14428 Declarations => New_List,
14430 Handled_Statement_Sequence =>
14431 Make_Handled_Sequence_Of_Statements (Loc,
14432 Statements => New_List (Loop_Statement)));
14436 Make_Subprogram_Body (Loc,
14438 Make_Function_Specification (Loc,
14439 Defining_Unit_Name => Func_Name,
14440 Parameter_Specifications => Formals,
14441 Result_Definition => New_Occurrence_Of (Typ, Loc)),
14443 Declarations => New_List (
14444 Make_Object_Declaration (Loc,
14445 Defining_Identifier => C,
14446 Object_Definition => New_Occurrence_Of (Typ, Loc))),
14448 Handled_Statement_Sequence =>
14449 Make_Handled_Sequence_Of_Statements (Loc,
14450 Statements => New_List (
14452 Make_Simple_Return_Statement (Loc,
14453 Expression => New_Occurrence_Of (C, Loc)))));
14457 end Make_Boolean_Array_Op;
14459 -----------------------------------------
14460 -- Minimized_Eliminated_Overflow_Check --
14461 -----------------------------------------
14463 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
14465 -- The MINIMIZED mode operates in Long_Long_Integer so we cannot use it
14466 -- if the type of the expression is already larger.
14469 Is_Signed_Integer_Type (Etype (N))
14470 and then Overflow_Check_Mode in Minimized_Or_Eliminated
14471 and then not (Overflow_Check_Mode = Minimized
14473 Esize (Etype (N)) > Standard_Long_Long_Integer_Size);
14474 end Minimized_Eliminated_Overflow_Check;
14476 ----------------------------
14477 -- Narrow_Large_Operation --
14478 ----------------------------
14480 procedure Narrow_Large_Operation (N : Node_Id) is
14481 Kind : constant Node_Kind := Nkind (N);
14482 Otyp : constant Entity_Id := Etype (N);
14483 In_Rng : constant Boolean := Kind = N_In;
14484 Binary : constant Boolean := Kind in N_Binary_Op or else In_Rng;
14485 Compar : constant Boolean := Kind in N_Op_Compare or else In_Rng;
14486 R : constant Node_Id := Right_Opnd (N);
14487 Typ : constant Entity_Id := Etype (R);
14488 Tsiz : constant Uint := RM_Size (Typ);
14502 -- Start of processing for Narrow_Large_Operation
14505 -- First, determine the range of the left operand, if any
14508 L := Left_Opnd (N);
14509 Determine_Range (L, OK, Llo, Lhi, Assume_Valid => True);
14520 -- Second, determine the range of the right operand, which can itself
14521 -- be a range, in which case we take the lower bound of the low bound
14522 -- and the upper bound of the high bound.
14530 (Low_Bound (R), OK, Rlo, Zhi, Assume_Valid => True);
14536 (High_Bound (R), OK, Zlo, Rhi, Assume_Valid => True);
14543 Determine_Range (R, OK, Rlo, Rhi, Assume_Valid => True);
14549 -- Then compute a size suitable for each range
14552 Lsiz := Get_Size_For_Range (Llo, Lhi);
14557 Rsiz := Get_Size_For_Range (Rlo, Rhi);
14559 -- Now compute the size of the narrower type
14562 -- The type must be able to accommodate the operands
14564 Nsiz := UI_Max (Lsiz, Rsiz);
14567 -- The type must be able to accommodate the operand(s) and result.
14569 -- Note that Determine_Range typically does not report the bounds of
14570 -- the value as being larger than those of the base type, which means
14571 -- that it does not report overflow (see also Enable_Overflow_Check).
14573 Determine_Range (N, OK, Nlo, Nhi, Assume_Valid => True);
14578 -- Therefore, if Nsiz is not lower than the size of the original type
14579 -- here, we cannot be sure that the operation does not overflow.
14581 Nsiz := Get_Size_For_Range (Nlo, Nhi);
14582 Nsiz := UI_Max (Nsiz, Lsiz);
14583 Nsiz := UI_Max (Nsiz, Rsiz);
14586 -- If the size is not lower than the size of the original type, then
14587 -- there is no point in changing the type, except in the case where
14588 -- we can remove a conversion to the original type from an operand.
14591 and then not (Binary
14592 and then Nkind (L) = N_Type_Conversion
14593 and then Entity (Subtype_Mark (L)) = Typ)
14594 and then not (Nkind (R) = N_Type_Conversion
14595 and then Entity (Subtype_Mark (R)) = Typ)
14600 -- Now pick the narrower type according to the size. We use the base
14601 -- type instead of the first subtype because operations are done in
14602 -- the base type, so this avoids the need for useless conversions.
14604 if Nsiz <= System_Max_Integer_Size then
14605 Ntyp := Etype (Integer_Type_For (Nsiz, Uns => False));
14610 -- Finally, rewrite the operation in the narrower type, but make sure
14611 -- not to perform name resolution for the operator again.
14613 Nop := New_Op_Node (Kind, Sloc (N));
14614 if Nkind (N) in N_Has_Entity then
14615 Set_Entity (Nop, Entity (N));
14619 Set_Left_Opnd (Nop, Convert_To (Ntyp, L));
14623 Set_Right_Opnd (Nop,
14624 Make_Range (Sloc (N),
14625 Convert_To (Ntyp, Low_Bound (R)),
14626 Convert_To (Ntyp, High_Bound (R))));
14628 Set_Right_Opnd (Nop, Convert_To (Ntyp, R));
14634 -- Analyze it with the comparison type and checks suppressed since
14635 -- the conversions of the operands cannot overflow.
14637 Analyze_And_Resolve (N, Otyp, Suppress => Overflow_Check);
14640 -- Analyze it with the narrower type and checks suppressed, but only
14641 -- when we are sure that the operation does not overflow, see above.
14643 if Nsiz < Tsiz then
14644 Analyze_And_Resolve (N, Ntyp, Suppress => Overflow_Check);
14646 Analyze_And_Resolve (N, Ntyp);
14649 -- Put back a conversion to the original type
14651 Convert_To_And_Rewrite (Typ, N);
14653 end Narrow_Large_Operation;
14655 --------------------------------
14656 -- Optimize_Length_Comparison --
14657 --------------------------------
14659 procedure Optimize_Length_Comparison (N : Node_Id) is
14660 Loc : constant Source_Ptr := Sloc (N);
14661 Typ : constant Entity_Id := Etype (N);
14666 -- First and Last attribute reference nodes, which end up as left and
14667 -- right operands of the optimized result.
14670 -- True for comparison operand of zero
14672 Maybe_Superflat : Boolean;
14673 -- True if we may be in the dynamic superflat case, i.e. Is_Zero is set
14674 -- to false but the comparison operand can be zero at run time. In this
14675 -- case, we normally cannot do anything because the canonical formula of
14676 -- the length is not valid, but there is one exception: when the operand
14677 -- is itself the length of an array with the same bounds as the array on
14678 -- the LHS, we can entirely optimize away the comparison.
14681 -- Comparison operand, set only if Is_Zero is false
14683 Ent : array (Pos range 1 .. 2) of Entity_Id := (Empty, Empty);
14684 -- Entities whose length is being compared
14686 Index : array (Pos range 1 .. 2) of Node_Id := (Empty, Empty);
14687 -- Integer_Literal nodes for length attribute expressions, or Empty
14688 -- if there is no such expression present.
14690 Op : Node_Kind := Nkind (N);
14691 -- Kind of comparison operator, gets flipped if operands backwards
14693 function Convert_To_Long_Long_Integer (N : Node_Id) return Node_Id;
14694 -- Given a discrete expression, returns a Long_Long_Integer typed
14695 -- expression representing the underlying value of the expression.
14696 -- This is done with an unchecked conversion to Long_Long_Integer.
14697 -- We use unchecked conversion to handle the enumeration type case.
14699 function Is_Entity_Length (N : Node_Id; Num : Pos) return Boolean;
14700 -- Tests if N is a length attribute applied to a simple entity. If so,
14701 -- returns True, and sets Ent to the entity, and Index to the integer
14702 -- literal provided as an attribute expression, or to Empty if none.
14703 -- Num is the index designating the relevant slot in Ent and Index.
14704 -- Also returns True if the expression is a generated type conversion
14705 -- whose expression is of the desired form. This latter case arises
14706 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
14707 -- to check for being in range, which is not needed in this context.
14708 -- Returns False if neither condition holds.
14710 function Is_Optimizable (N : Node_Id) return Boolean;
14711 -- Tests N to see if it is an optimizable comparison value (defined as
14712 -- constant zero or one, or something else where the value is known to
14713 -- be nonnegative and in the 32-bit range and where the corresponding
14714 -- Length value is also known to be 32 bits). If result is true, sets
14715 -- Is_Zero, Maybe_Superflat and Comp accordingly.
14717 procedure Rewrite_For_Equal_Lengths;
14718 -- Rewrite the comparison of two equal lengths into either True or False
14720 ----------------------------------
14721 -- Convert_To_Long_Long_Integer --
14722 ----------------------------------
14724 function Convert_To_Long_Long_Integer (N : Node_Id) return Node_Id is
14726 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
14727 end Convert_To_Long_Long_Integer;
14729 ----------------------
14730 -- Is_Entity_Length --
14731 ----------------------
14733 function Is_Entity_Length (N : Node_Id; Num : Pos) return Boolean is
14735 if Nkind (N) = N_Attribute_Reference
14736 and then Attribute_Name (N) = Name_Length
14737 and then Is_Entity_Name (Prefix (N))
14739 Ent (Num) := Entity (Prefix (N));
14741 if Present (Expressions (N)) then
14742 Index (Num) := First (Expressions (N));
14744 Index (Num) := Empty;
14749 elsif Nkind (N) = N_Type_Conversion
14750 and then not Comes_From_Source (N)
14752 return Is_Entity_Length (Expression (N), Num);
14757 end Is_Entity_Length;
14759 --------------------
14760 -- Is_Optimizable --
14761 --------------------
14763 function Is_Optimizable (N : Node_Id) return Boolean is
14773 if Compile_Time_Known_Value (N) then
14774 Val := Expr_Value (N);
14776 if Val = Uint_0 then
14778 Maybe_Superflat := False;
14782 elsif Val = Uint_1 then
14784 Maybe_Superflat := False;
14790 -- Here we have to make sure of being within a 32-bit range (take the
14791 -- full unsigned range so the length of 32-bit arrays is accepted).
14793 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
14796 or else Lo < Uint_0
14797 or else Hi > Uint_2 ** 32
14802 Maybe_Superflat := (Lo = Uint_0);
14804 -- Tests if N is also a length attribute applied to a simple entity
14806 Dbl := Is_Entity_Length (N, 2);
14808 -- We can deal with the superflat case only if N is also a length
14810 if Maybe_Superflat and then not Dbl then
14814 -- Comparison value was within range, so now we must check the index
14815 -- value to make sure it is also within 32 bits.
14817 for K in Pos range 1 .. 2 loop
14818 Indx := First_Index (Etype (Ent (K)));
14820 if Present (Index (K)) then
14821 for J in 2 .. UI_To_Int (Intval (Index (K))) loop
14826 Ityp := Etype (Indx);
14828 if Esize (Ityp) > 32 then
14838 end Is_Optimizable;
14840 -------------------------------
14841 -- Rewrite_For_Equal_Lengths --
14842 -------------------------------
14844 procedure Rewrite_For_Equal_Lengths is
14853 New_Occurrence_Of (Standard_True, Sloc (N))));
14861 New_Occurrence_Of (Standard_False, Sloc (N))));
14864 raise Program_Error;
14867 Analyze_And_Resolve (N, Typ);
14868 end Rewrite_For_Equal_Lengths;
14870 -- Start of processing for Optimize_Length_Comparison
14873 -- Nothing to do if not a comparison
14875 if Op not in N_Op_Compare then
14879 -- Nothing to do if special -gnatd.P debug flag set.
14881 if Debug_Flag_Dot_PP then
14885 -- Ent'Length op 0/1
14887 if Is_Entity_Length (Left_Opnd (N), 1)
14888 and then Is_Optimizable (Right_Opnd (N))
14892 -- 0/1 op Ent'Length
14894 elsif Is_Entity_Length (Right_Opnd (N), 1)
14895 and then Is_Optimizable (Left_Opnd (N))
14897 -- Flip comparison to opposite sense
14900 when N_Op_Lt => Op := N_Op_Gt;
14901 when N_Op_Le => Op := N_Op_Ge;
14902 when N_Op_Gt => Op := N_Op_Lt;
14903 when N_Op_Ge => Op := N_Op_Le;
14904 when others => null;
14907 -- Else optimization not possible
14913 -- Fall through if we will do the optimization
14915 -- Cases to handle:
14917 -- X'Length = 0 => X'First > X'Last
14918 -- X'Length = 1 => X'First = X'Last
14919 -- X'Length = n => X'First + (n - 1) = X'Last
14921 -- X'Length /= 0 => X'First <= X'Last
14922 -- X'Length /= 1 => X'First /= X'Last
14923 -- X'Length /= n => X'First + (n - 1) /= X'Last
14925 -- X'Length >= 0 => always true, warn
14926 -- X'Length >= 1 => X'First <= X'Last
14927 -- X'Length >= n => X'First + (n - 1) <= X'Last
14929 -- X'Length > 0 => X'First <= X'Last
14930 -- X'Length > 1 => X'First < X'Last
14931 -- X'Length > n => X'First + (n - 1) < X'Last
14933 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
14934 -- X'Length <= 1 => X'First >= X'Last
14935 -- X'Length <= n => X'First + (n - 1) >= X'Last
14937 -- X'Length < 0 => always false (warn)
14938 -- X'Length < 1 => X'First > X'Last
14939 -- X'Length < n => X'First + (n - 1) > X'Last
14941 -- Note: for the cases of n (not constant 0,1), we require that the
14942 -- corresponding index type be integer or shorter (i.e. not 64-bit),
14943 -- and the same for the comparison value. Then we do the comparison
14944 -- using 64-bit arithmetic (actually long long integer), so that we
14945 -- cannot have overflow intefering with the result.
14947 -- First deal with warning cases
14956 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
14957 Analyze_And_Resolve (N, Typ);
14958 Warn_On_Known_Condition (N);
14965 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
14966 Analyze_And_Resolve (N, Typ);
14967 Warn_On_Known_Condition (N);
14971 if Constant_Condition_Warnings
14972 and then Comes_From_Source (Original_Node (N))
14974 Error_Msg_N ("could replace by ""'=""?c?", N);
14984 -- Build the First reference we will use
14987 Make_Attribute_Reference (Loc,
14988 Prefix => New_Occurrence_Of (Ent (1), Loc),
14989 Attribute_Name => Name_First);
14991 if Present (Index (1)) then
14992 Set_Expressions (Left, New_List (New_Copy (Index (1))));
14995 -- Build the Last reference we will use
14998 Make_Attribute_Reference (Loc,
14999 Prefix => New_Occurrence_Of (Ent (1), Loc),
15000 Attribute_Name => Name_Last);
15002 if Present (Index (1)) then
15003 Set_Expressions (Right, New_List (New_Copy (Index (1))));
15006 -- If general value case, then do the addition of (n - 1), and
15007 -- also add the needed conversions to type Long_Long_Integer.
15009 -- If n = Y'Length, we rewrite X'First + (n - 1) op X'Last into:
15011 -- Y'Last + (X'First - Y'First) op X'Last
15013 -- in the hope that X'First - Y'First can be computed statically.
15015 if Present (Comp) then
15016 if Present (Ent (2)) then
15018 Y_First : constant Node_Id :=
15019 Make_Attribute_Reference (Loc,
15020 Prefix => New_Occurrence_Of (Ent (2), Loc),
15021 Attribute_Name => Name_First);
15022 Y_Last : constant Node_Id :=
15023 Make_Attribute_Reference (Loc,
15024 Prefix => New_Occurrence_Of (Ent (2), Loc),
15025 Attribute_Name => Name_Last);
15026 R : Compare_Result;
15029 if Present (Index (2)) then
15030 Set_Expressions (Y_First, New_List (New_Copy (Index (2))));
15031 Set_Expressions (Y_Last, New_List (New_Copy (Index (2))));
15037 -- If X'First = Y'First, simplify the above formula into a
15038 -- direct comparison of Y'Last and X'Last.
15040 R := Compile_Time_Compare (Left, Y_First, Assume_Valid => True);
15046 R := Compile_Time_Compare
15047 (Right, Y_Last, Assume_Valid => True);
15049 -- If the pairs of attributes are equal, we are done
15052 Rewrite_For_Equal_Lengths;
15056 -- If the base types are different, convert both operands to
15057 -- Long_Long_Integer, else compare them directly.
15059 if Base_Type (Etype (Right)) /= Base_Type (Etype (Y_Last))
15061 Left := Convert_To_Long_Long_Integer (Y_Last);
15067 -- Otherwise, use the above formula as-is
15073 Convert_To_Long_Long_Integer (Y_Last),
15075 Make_Op_Subtract (Loc,
15077 Convert_To_Long_Long_Integer (Left),
15079 Convert_To_Long_Long_Integer (Y_First)));
15083 -- General value case
15088 Left_Opnd => Convert_To_Long_Long_Integer (Left),
15090 Make_Op_Subtract (Loc,
15091 Left_Opnd => Convert_To_Long_Long_Integer (Comp),
15092 Right_Opnd => Make_Integer_Literal (Loc, 1)));
15096 -- We cannot do anything in the superflat case past this point
15098 if Maybe_Superflat then
15102 -- If general operand, convert Last reference to Long_Long_Integer
15104 if Present (Comp) then
15105 Right := Convert_To_Long_Long_Integer (Right);
15108 -- Check for cases to optimize
15110 -- X'Length = 0 => X'First > X'Last
15111 -- X'Length < 1 => X'First > X'Last
15112 -- X'Length < n => X'First + (n - 1) > X'Last
15114 if (Is_Zero and then Op = N_Op_Eq)
15115 or else (not Is_Zero and then Op = N_Op_Lt)
15120 Right_Opnd => Right);
15122 -- X'Length = 1 => X'First = X'Last
15123 -- X'Length = n => X'First + (n - 1) = X'Last
15125 elsif not Is_Zero and then Op = N_Op_Eq then
15129 Right_Opnd => Right);
15131 -- X'Length /= 0 => X'First <= X'Last
15132 -- X'Length > 0 => X'First <= X'Last
15134 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
15138 Right_Opnd => Right);
15140 -- X'Length /= 1 => X'First /= X'Last
15141 -- X'Length /= n => X'First + (n - 1) /= X'Last
15143 elsif not Is_Zero and then Op = N_Op_Ne then
15147 Right_Opnd => Right);
15149 -- X'Length >= 1 => X'First <= X'Last
15150 -- X'Length >= n => X'First + (n - 1) <= X'Last
15152 elsif not Is_Zero and then Op = N_Op_Ge then
15156 Right_Opnd => Right);
15158 -- X'Length > 1 => X'First < X'Last
15159 -- X'Length > n => X'First + (n = 1) < X'Last
15161 elsif not Is_Zero and then Op = N_Op_Gt then
15165 Right_Opnd => Right);
15167 -- X'Length <= 1 => X'First >= X'Last
15168 -- X'Length <= n => X'First + (n - 1) >= X'Last
15170 elsif not Is_Zero and then Op = N_Op_Le then
15174 Right_Opnd => Right);
15176 -- Should not happen at this stage
15179 raise Program_Error;
15182 -- Rewrite and finish up (we can suppress overflow checks, see above)
15184 Rewrite (N, Result);
15185 Analyze_And_Resolve (N, Typ, Suppress => Overflow_Check);
15186 end Optimize_Length_Comparison;
15188 --------------------------------
15189 -- Process_If_Case_Statements --
15190 --------------------------------
15192 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is
15196 Decl := First (Stmts);
15197 while Present (Decl) loop
15198 if Nkind (Decl) = N_Object_Declaration
15199 and then Is_Finalizable_Transient (Decl, N)
15201 Process_Transient_In_Expression (Decl, N, Stmts);
15206 end Process_If_Case_Statements;
15208 -------------------------------------
15209 -- Process_Transient_In_Expression --
15210 -------------------------------------
15212 procedure Process_Transient_In_Expression
15213 (Obj_Decl : Node_Id;
15217 Loc : constant Source_Ptr := Sloc (Obj_Decl);
15218 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
15220 Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
15221 -- The node on which to insert the hook as an action. This is usually
15222 -- the innermost enclosing non-transient construct.
15224 Fin_Call : Node_Id;
15225 Hook_Assign : Node_Id;
15226 Hook_Clear : Node_Id;
15227 Hook_Decl : Node_Id;
15228 Hook_Insert : Node_Id;
15229 Ptr_Decl : Node_Id;
15231 Fin_Context : Node_Id;
15232 -- The node after which to insert the finalization actions of the
15233 -- transient object.
15236 pragma Assert (Nkind (Expr) in N_Case_Expression
15237 | N_Expression_With_Actions
15238 | N_If_Expression);
15240 -- When the context is a Boolean evaluation, all three nodes capture the
15241 -- result of their computation in a local temporary:
15244 -- Trans_Id : Ctrl_Typ := ...;
15245 -- Result : constant Boolean := ... Trans_Id ...;
15246 -- <finalize Trans_Id>
15249 -- As a result, the finalization of any transient objects can safely
15250 -- take place after the result capture.
15252 -- ??? could this be extended to elementary types?
15254 if Is_Boolean_Type (Etype (Expr)) then
15255 Fin_Context := Last (Stmts);
15257 -- Otherwise the immediate context may not be safe enough to carry
15258 -- out transient object finalization due to aliasing and nesting of
15259 -- constructs. Insert calls to [Deep_]Finalize after the innermost
15260 -- enclosing non-transient construct.
15263 Fin_Context := Hook_Context;
15266 -- Mark the transient object as successfully processed to avoid double
15269 Set_Is_Finalized_Transient (Obj_Id);
15271 -- Construct all the pieces necessary to hook and finalize a transient
15274 Build_Transient_Object_Statements
15275 (Obj_Decl => Obj_Decl,
15276 Fin_Call => Fin_Call,
15277 Hook_Assign => Hook_Assign,
15278 Hook_Clear => Hook_Clear,
15279 Hook_Decl => Hook_Decl,
15280 Ptr_Decl => Ptr_Decl,
15281 Finalize_Obj => False);
15283 -- Add the access type which provides a reference to the transient
15284 -- object. Generate:
15286 -- type Ptr_Typ is access all Desig_Typ;
15288 Insert_Action (Hook_Context, Ptr_Decl);
15290 -- Add the temporary which acts as a hook to the transient object.
15293 -- Hook : Ptr_Id := null;
15295 Insert_Action (Hook_Context, Hook_Decl);
15297 -- When the transient object is initialized by an aggregate, the hook
15298 -- must capture the object after the last aggregate assignment takes
15299 -- place. Only then is the object considered initialized. Generate:
15301 -- Hook := Ptr_Typ (Obj_Id);
15303 -- Hook := Obj_Id'Unrestricted_Access;
15305 if Ekind (Obj_Id) in E_Constant | E_Variable
15306 and then Present (Last_Aggregate_Assignment (Obj_Id))
15308 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
15310 -- Otherwise the hook seizes the related object immediately
15313 Hook_Insert := Obj_Decl;
15316 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
15318 -- When the node is part of a return statement, there is no need to
15319 -- insert a finalization call, as the general finalization mechanism
15320 -- (see Build_Finalizer) would take care of the transient object on
15321 -- subprogram exit. Note that it would also be impossible to insert the
15322 -- finalization code after the return statement as this will render it
15325 if Nkind (Fin_Context) = N_Simple_Return_Statement then
15328 -- Finalize the hook after the context has been evaluated. Generate:
15330 -- if Hook /= null then
15331 -- [Deep_]Finalize (Hook.all);
15335 -- Note that the value returned by Find_Hook_Context may be an operator
15336 -- node, which is not a list member. We must locate the proper node in
15337 -- in the tree after which to insert the finalization code.
15340 while not Is_List_Member (Fin_Context) loop
15341 Fin_Context := Parent (Fin_Context);
15344 pragma Assert (Present (Fin_Context));
15346 Insert_Action_After (Fin_Context,
15347 Make_Implicit_If_Statement (Obj_Decl,
15351 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
15352 Right_Opnd => Make_Null (Loc)),
15354 Then_Statements => New_List (
15358 end Process_Transient_In_Expression;
15360 ------------------------
15361 -- Rewrite_Comparison --
15362 ------------------------
15364 procedure Rewrite_Comparison (N : Node_Id) is
15365 Typ : constant Entity_Id := Etype (N);
15367 False_Result : Boolean;
15368 True_Result : Boolean;
15371 if Nkind (N) = N_Type_Conversion then
15372 Rewrite_Comparison (Expression (N));
15375 elsif Nkind (N) not in N_Op_Compare then
15379 -- If both operands are static, then the comparison has been already
15380 -- folded in evaluation.
15383 (not Is_Static_Expression (Left_Opnd (N))
15385 not Is_Static_Expression (Right_Opnd (N)));
15387 -- Determine the potential outcome of the comparison assuming that the
15388 -- operands are valid and emit a warning when the comparison evaluates
15389 -- to True or False only in the presence of invalid values.
15391 Warn_On_Constant_Valid_Condition (N);
15393 -- Determine the potential outcome of the comparison assuming that the
15394 -- operands are not valid.
15398 Assume_Valid => False,
15399 True_Result => True_Result,
15400 False_Result => False_Result);
15402 -- The outcome is a decisive False or True, rewrite the operator into a
15403 -- non-static literal.
15405 if False_Result or True_Result then
15408 New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N))));
15410 Analyze_And_Resolve (N, Typ);
15411 Set_Is_Static_Expression (N, False);
15412 Warn_On_Known_Condition (N);
15414 end Rewrite_Comparison;
15416 ----------------------------
15417 -- Safe_In_Place_Array_Op --
15418 ----------------------------
15420 function Safe_In_Place_Array_Op
15423 Op2 : Node_Id) return Boolean
15425 Target : Entity_Id;
15427 function Is_Safe_Operand (Op : Node_Id) return Boolean;
15428 -- Operand is safe if it cannot overlap part of the target of the
15429 -- operation. If the operand and the target are identical, the operand
15430 -- is safe. The operand can be empty in the case of negation.
15432 function Is_Unaliased (N : Node_Id) return Boolean;
15433 -- Check that N is a stand-alone entity
15439 function Is_Unaliased (N : Node_Id) return Boolean is
15443 and then No (Address_Clause (Entity (N)))
15444 and then No (Renamed_Object (Entity (N)));
15447 ---------------------
15448 -- Is_Safe_Operand --
15449 ---------------------
15451 function Is_Safe_Operand (Op : Node_Id) return Boolean is
15456 elsif Is_Entity_Name (Op) then
15457 return Is_Unaliased (Op);
15459 elsif Nkind (Op) in N_Indexed_Component | N_Selected_Component then
15460 return Is_Unaliased (Prefix (Op));
15462 elsif Nkind (Op) = N_Slice then
15464 Is_Unaliased (Prefix (Op))
15465 and then Entity (Prefix (Op)) /= Target;
15467 elsif Nkind (Op) = N_Op_Not then
15468 return Is_Safe_Operand (Right_Opnd (Op));
15473 end Is_Safe_Operand;
15475 -- Start of processing for Safe_In_Place_Array_Op
15478 -- Skip this processing if the component size is different from system
15479 -- storage unit (since at least for NOT this would cause problems).
15481 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
15484 -- Cannot do in place stuff if non-standard Boolean representation
15486 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
15489 elsif not Is_Unaliased (Lhs) then
15493 Target := Entity (Lhs);
15494 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
15496 end Safe_In_Place_Array_Op;
15498 -----------------------
15499 -- Tagged_Membership --
15500 -----------------------
15502 -- There are two different cases to consider depending on whether the right
15503 -- operand is a class-wide type or not. If not we just compare the actual
15504 -- tag of the left expr to the target type tag:
15506 -- Left_Expr.Tag = Right_Type'Tag;
15508 -- If it is a class-wide type we use the RT function CW_Membership which is
15509 -- usually implemented by looking in the ancestor tables contained in the
15510 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
15512 -- In both cases if Left_Expr is an access type, we first check whether it
15515 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
15516 -- function IW_Membership which is usually implemented by looking in the
15517 -- table of abstract interface types plus the ancestor table contained in
15518 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
15520 procedure Tagged_Membership
15522 SCIL_Node : out Node_Id;
15523 Result : out Node_Id)
15525 Left : constant Node_Id := Left_Opnd (N);
15526 Right : constant Node_Id := Right_Opnd (N);
15527 Loc : constant Source_Ptr := Sloc (N);
15529 -- Handle entities from the limited view
15531 Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right));
15533 Full_R_Typ : Entity_Id;
15534 Left_Type : Entity_Id := Available_View (Etype (Left));
15535 Right_Type : Entity_Id := Orig_Right_Type;
15539 SCIL_Node := Empty;
15541 -- We have to examine the corresponding record type when dealing with
15542 -- protected types instead of the original, unexpanded, type.
15544 if Ekind (Right_Type) = E_Protected_Type then
15545 Right_Type := Corresponding_Record_Type (Right_Type);
15548 if Ekind (Left_Type) = E_Protected_Type then
15549 Left_Type := Corresponding_Record_Type (Left_Type);
15552 -- In the case where the type is an access type, the test is applied
15553 -- using the designated types (needed in Ada 2012 for implicit anonymous
15554 -- access conversions, for AI05-0149).
15556 if Is_Access_Type (Right_Type) then
15557 Left_Type := Designated_Type (Left_Type);
15558 Right_Type := Designated_Type (Right_Type);
15561 if Is_Class_Wide_Type (Left_Type) then
15562 Left_Type := Root_Type (Left_Type);
15565 if Is_Class_Wide_Type (Right_Type) then
15566 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
15568 Full_R_Typ := Underlying_Type (Right_Type);
15572 Make_Selected_Component (Loc,
15573 Prefix => Relocate_Node (Left),
15575 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
15577 if Is_Class_Wide_Type (Right_Type) then
15579 -- No need to issue a run-time check if we statically know that the
15580 -- result of this membership test is always true. For example,
15581 -- considering the following declarations:
15583 -- type Iface is interface;
15584 -- type T is tagged null record;
15585 -- type DT is new T and Iface with null record;
15590 -- These membership tests are always true:
15593 -- Obj2 in T'Class;
15594 -- Obj2 in Iface'Class;
15596 -- We do not need to handle cases where the membership is illegal.
15599 -- Obj1 in DT'Class; -- Compile time error
15600 -- Obj1 in Iface'Class; -- Compile time error
15602 if not Is_Interface (Left_Type)
15603 and then not Is_Class_Wide_Type (Left_Type)
15604 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
15605 Use_Full_View => True)
15606 or else (Is_Interface (Etype (Right_Type))
15607 and then Interface_Present_In_Ancestor
15609 Iface => Etype (Right_Type))))
15611 Result := New_Occurrence_Of (Standard_True, Loc);
15615 -- Ada 2005 (AI-251): Class-wide applied to interfaces
15617 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
15619 -- Support to: "Iface_CW_Typ in Typ'Class"
15621 or else Is_Interface (Left_Type)
15623 -- Issue error if IW_Membership operation not available in a
15624 -- configurable run-time setting.
15626 if not RTE_Available (RE_IW_Membership) then
15628 ("dynamic membership test on interface types", N);
15634 Make_Function_Call (Loc,
15635 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
15636 Parameter_Associations => New_List (
15637 Make_Attribute_Reference (Loc,
15639 Attribute_Name => Name_Address),
15640 New_Occurrence_Of (
15641 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
15644 -- Ada 95: Normal case
15647 -- Issue error if CW_Membership operation not available in a
15648 -- configurable run-time setting.
15650 if not RTE_Available (RE_CW_Membership) then
15652 ("dynamic membership test on tagged types", N);
15658 Make_Function_Call (Loc,
15659 Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc),
15660 Parameter_Associations => New_List (
15662 New_Occurrence_Of (
15663 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
15666 -- Generate the SCIL node for this class-wide membership test.
15668 if Generate_SCIL then
15669 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
15670 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
15671 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
15675 -- Right_Type is not a class-wide type
15678 -- No need to check the tag of the object if Right_Typ is abstract
15680 if Is_Abstract_Type (Right_Type) then
15681 Result := New_Occurrence_Of (Standard_False, Loc);
15686 Left_Opnd => Obj_Tag,
15689 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
15693 -- if Left is an access object then generate test of the form:
15694 -- * if Right_Type excludes null: Left /= null and then ...
15695 -- * if Right_Type includes null: Left = null or else ...
15697 if Is_Access_Type (Orig_Right_Type) then
15698 if Can_Never_Be_Null (Orig_Right_Type) then
15699 Result := Make_And_Then (Loc,
15703 Right_Opnd => Make_Null (Loc)),
15704 Right_Opnd => Result);
15707 Result := Make_Or_Else (Loc,
15711 Right_Opnd => Make_Null (Loc)),
15712 Right_Opnd => Result);
15715 end Tagged_Membership;
15717 ------------------------------
15718 -- Unary_Op_Validity_Checks --
15719 ------------------------------
15721 procedure Unary_Op_Validity_Checks (N : Node_Id) is
15723 if Validity_Checks_On and Validity_Check_Operands then
15724 Ensure_Valid (Right_Opnd (N));
15726 end Unary_Op_Validity_Checks;