1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Aggr; use Exp_Aggr;
33 with Exp_Atag; use Exp_Atag;
34 with Exp_Ch2; use Exp_Ch2;
35 with Exp_Ch3; use Exp_Ch3;
36 with Exp_Ch6; use Exp_Ch6;
37 with Exp_Ch7; use Exp_Ch7;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Disp; use Exp_Disp;
40 with Exp_Fixd; use Exp_Fixd;
41 with Exp_Intr; use Exp_Intr;
42 with Exp_Pakd; use Exp_Pakd;
43 with Exp_Tss; use Exp_Tss;
44 with Exp_Util; use Exp_Util;
45 with Freeze; use Freeze;
46 with Inline; use Inline;
47 with Namet; use Namet;
48 with Nlists; use Nlists;
49 with Nmake; use Nmake;
51 with Par_SCO; use Par_SCO;
52 with Restrict; use Restrict;
53 with Rident; use Rident;
54 with Rtsfind; use Rtsfind;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Cat; use Sem_Cat;
58 with Sem_Ch3; use Sem_Ch3;
59 with Sem_Ch13; use Sem_Ch13;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Res; use Sem_Res;
62 with Sem_Type; use Sem_Type;
63 with Sem_Util; use Sem_Util;
64 with Sem_Warn; use Sem_Warn;
65 with Sinfo; use Sinfo;
66 with Snames; use Snames;
67 with Stand; use Stand;
68 with SCIL_LL; use SCIL_LL;
69 with Targparm; use Targparm;
70 with Tbuild; use Tbuild;
71 with Ttypes; use Ttypes;
72 with Uintp; use Uintp;
73 with Urealp; use Urealp;
74 with Validsw; use Validsw;
75 with Warnsw; use Warnsw;
77 package body Exp_Ch4 is
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 procedure Binary_Op_Validity_Checks (N : Node_Id);
84 pragma Inline (Binary_Op_Validity_Checks);
85 -- Performs validity checks for a binary operator
87 procedure Build_Boolean_Array_Proc_Call
91 -- If a boolean array assignment can be done in place, build call to
92 -- corresponding library procedure.
94 procedure Displace_Allocator_Pointer (N : Node_Id);
95 -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
96 -- Expand_Allocator_Expression. Allocating class-wide interface objects
97 -- this routine displaces the pointer to the allocated object to reference
98 -- the component referencing the corresponding secondary dispatch table.
100 procedure Expand_Allocator_Expression (N : Node_Id);
101 -- Subsidiary to Expand_N_Allocator, for the case when the expression
102 -- is a qualified expression or an aggregate.
104 procedure Expand_Array_Comparison (N : Node_Id);
105 -- This routine handles expansion of the comparison operators (N_Op_Lt,
106 -- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
107 -- code for these operators is similar, differing only in the details of
108 -- the actual comparison call that is made. Special processing (call a
111 function Expand_Array_Equality
116 Typ : Entity_Id) return Node_Id;
117 -- Expand an array equality into a call to a function implementing this
118 -- equality, and a call to it. Loc is the location for the generated nodes.
119 -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
120 -- on which to attach bodies of local functions that are created in the
121 -- process. It is the responsibility of the caller to insert those bodies
122 -- at the right place. Nod provides the Sloc value for the generated code.
123 -- Normally the types used for the generated equality routine are taken
124 -- from Lhs and Rhs. However, in some situations of generated code, the
125 -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
126 -- the type to be used for the formal parameters.
128 procedure Expand_Boolean_Operator (N : Node_Id);
129 -- Common expansion processing for Boolean operators (And, Or, Xor) for the
130 -- case of array type arguments.
132 procedure Expand_Nonbinary_Modular_Op (N : Node_Id);
133 -- When generating C code, convert nonbinary modular arithmetic operations
134 -- into code that relies on the front-end expansion of operator Mod. No
135 -- expansion is performed if N is not a nonbinary modular operand.
137 procedure Expand_Short_Circuit_Operator (N : Node_Id);
138 -- Common expansion processing for short-circuit boolean operators
140 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
141 -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
142 -- where we allow comparison of "out of range" values.
144 function Expand_Composite_Equality
149 Bodies : List_Id) return Node_Id;
150 -- Local recursive function used to expand equality for nested composite
151 -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
152 -- to attach bodies of local functions that are created in the process. It
153 -- is the responsibility of the caller to insert those bodies at the right
154 -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are
155 -- the left and right sides for the comparison, and Typ is the type of the
156 -- objects to compare.
158 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
159 -- Routine to expand concatenation of a sequence of two or more operands
160 -- (in the list Operands) and replace node Cnode with the result of the
161 -- concatenation. The operands can be of any appropriate type, and can
162 -- include both arrays and singleton elements.
164 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
165 -- N is an N_In membership test mode, with the overflow check mode set to
166 -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
167 -- integer type. This is a case where top level processing is required to
168 -- handle overflow checks in subtrees.
170 procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
171 -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
172 -- fixed. We do not have such a type at runtime, so the purpose of this
173 -- routine is to find the real type by looking up the tree. We also
174 -- determine if the operation must be rounded.
176 function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
177 -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
178 -- discriminants if it has a constrained nominal type, unless the object
179 -- is a component of an enclosing Unchecked_Union object that is subject
180 -- to a per-object constraint and the enclosing object lacks inferable
183 -- An expression of an Unchecked_Union type has inferable discriminants
184 -- if it is either a name of an object with inferable discriminants or a
185 -- qualified expression whose subtype mark denotes a constrained subtype.
187 procedure Insert_Dereference_Action (N : Node_Id);
188 -- N is an expression whose type is an access. When the type of the
189 -- associated storage pool is derived from Checked_Pool, generate a
190 -- call to the 'Dereference' primitive operation.
192 function Make_Array_Comparison_Op
194 Nod : Node_Id) return Node_Id;
195 -- Comparisons between arrays are expanded in line. This function produces
196 -- the body of the implementation of (a > b), where a and b are one-
197 -- dimensional arrays of some discrete type. The original node is then
198 -- expanded into the appropriate call to this function. Nod provides the
199 -- Sloc value for the generated code.
201 function Make_Boolean_Array_Op
203 N : Node_Id) return Node_Id;
204 -- Boolean operations on boolean arrays are expanded in line. This function
205 -- produce the body for the node N, which is (a and b), (a or b), or (a xor
206 -- b). It is used only the normal case and not the packed case. The type
207 -- involved, Typ, is the Boolean array type, and the logical operations in
208 -- the body are simple boolean operations. Note that Typ is always a
209 -- constrained type (the caller has ensured this by using
210 -- Convert_To_Actual_Subtype if necessary).
212 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
213 -- For signed arithmetic operations when the current overflow mode is
214 -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
215 -- as the first thing we do. We then return. We count on the recursive
216 -- apparatus for overflow checks to call us back with an equivalent
217 -- operation that is in CHECKED mode, avoiding a recursive entry into this
218 -- routine, and that is when we will proceed with the expansion of the
219 -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
220 -- these optimizations without first making this check, since there may be
221 -- operands further down the tree that are relying on the recursive calls
222 -- triggered by the top level nodes to properly process overflow checking
223 -- and remaining expansion on these nodes. Note that this call back may be
224 -- skipped if the operation is done in Bignum mode but that's fine, since
225 -- the Bignum call takes care of everything.
227 procedure Optimize_Length_Comparison (N : Node_Id);
228 -- Given an expression, if it is of the form X'Length op N (or the other
229 -- way round), where N is known at compile time to be 0 or 1, and X is a
230 -- simple entity, and op is a comparison operator, optimizes it into a
231 -- comparison of First and Last.
233 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
234 -- Inspect and process statement list Stmt of if or case expression N for
235 -- transient objects. If such objects are found, the routine generates code
236 -- to clean them up when the context of the expression is evaluated.
238 procedure Process_Transient_In_Expression
242 -- Subsidiary routine to the expansion of expression_with_actions, if and
243 -- case expressions. Generate all necessary code to finalize a transient
244 -- object when the enclosing context is elaborated or evaluated. Obj_Decl
245 -- denotes the declaration of the transient object, which is usually the
246 -- result of a controlled function call. Expr denotes the expression with
247 -- actions, if expression, or case expression node. Stmts denotes the
248 -- statement list which contains Decl, either at the top level or within a
251 procedure Rewrite_Comparison (N : Node_Id);
252 -- If N is the node for a comparison whose outcome can be determined at
253 -- compile time, then the node N can be rewritten with True or False. If
254 -- the outcome cannot be determined at compile time, the call has no
255 -- effect. If N is a type conversion, then this processing is applied to
256 -- its expression. If N is neither comparison nor a type conversion, the
257 -- call has no effect.
259 procedure Tagged_Membership
261 SCIL_Node : out Node_Id;
262 Result : out Node_Id);
263 -- Construct the expression corresponding to the tagged membership test.
264 -- Deals with a second operand being (or not) a class-wide type.
266 function Safe_In_Place_Array_Op
269 Op2 : Node_Id) return Boolean;
270 -- In the context of an assignment, where the right-hand side is a boolean
271 -- operation on arrays, check whether operation can be performed in place.
273 procedure Unary_Op_Validity_Checks (N : Node_Id);
274 pragma Inline (Unary_Op_Validity_Checks);
275 -- Performs validity checks for a unary operator
277 -------------------------------
278 -- Binary_Op_Validity_Checks --
279 -------------------------------
281 procedure Binary_Op_Validity_Checks (N : Node_Id) is
283 if Validity_Checks_On and Validity_Check_Operands then
284 Ensure_Valid (Left_Opnd (N));
285 Ensure_Valid (Right_Opnd (N));
287 end Binary_Op_Validity_Checks;
289 ------------------------------------
290 -- Build_Boolean_Array_Proc_Call --
291 ------------------------------------
293 procedure Build_Boolean_Array_Proc_Call
298 Loc : constant Source_Ptr := Sloc (N);
299 Kind : constant Node_Kind := Nkind (Expression (N));
300 Target : constant Node_Id :=
301 Make_Attribute_Reference (Loc,
303 Attribute_Name => Name_Address);
305 Arg1 : Node_Id := Op1;
306 Arg2 : Node_Id := Op2;
308 Proc_Name : Entity_Id;
311 if Kind = N_Op_Not then
312 if Nkind (Op1) in N_Binary_Op then
314 -- Use negated version of the binary operators
316 if Nkind (Op1) = N_Op_And then
317 Proc_Name := RTE (RE_Vector_Nand);
319 elsif Nkind (Op1) = N_Op_Or then
320 Proc_Name := RTE (RE_Vector_Nor);
322 else pragma Assert (Nkind (Op1) = N_Op_Xor);
323 Proc_Name := RTE (RE_Vector_Xor);
327 Make_Procedure_Call_Statement (Loc,
328 Name => New_Occurrence_Of (Proc_Name, Loc),
330 Parameter_Associations => New_List (
332 Make_Attribute_Reference (Loc,
333 Prefix => Left_Opnd (Op1),
334 Attribute_Name => Name_Address),
336 Make_Attribute_Reference (Loc,
337 Prefix => Right_Opnd (Op1),
338 Attribute_Name => Name_Address),
340 Make_Attribute_Reference (Loc,
341 Prefix => Left_Opnd (Op1),
342 Attribute_Name => Name_Length)));
345 Proc_Name := RTE (RE_Vector_Not);
348 Make_Procedure_Call_Statement (Loc,
349 Name => New_Occurrence_Of (Proc_Name, Loc),
350 Parameter_Associations => New_List (
353 Make_Attribute_Reference (Loc,
355 Attribute_Name => Name_Address),
357 Make_Attribute_Reference (Loc,
359 Attribute_Name => Name_Length)));
363 -- We use the following equivalences:
365 -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
366 -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
367 -- (not X) xor (not Y) = X xor Y
368 -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
370 if Nkind (Op1) = N_Op_Not then
371 Arg1 := Right_Opnd (Op1);
372 Arg2 := Right_Opnd (Op2);
374 if Kind = N_Op_And then
375 Proc_Name := RTE (RE_Vector_Nor);
376 elsif Kind = N_Op_Or then
377 Proc_Name := RTE (RE_Vector_Nand);
379 Proc_Name := RTE (RE_Vector_Xor);
383 if Kind = N_Op_And then
384 Proc_Name := RTE (RE_Vector_And);
385 elsif Kind = N_Op_Or then
386 Proc_Name := RTE (RE_Vector_Or);
387 elsif Nkind (Op2) = N_Op_Not then
388 Proc_Name := RTE (RE_Vector_Nxor);
389 Arg2 := Right_Opnd (Op2);
391 Proc_Name := RTE (RE_Vector_Xor);
396 Make_Procedure_Call_Statement (Loc,
397 Name => New_Occurrence_Of (Proc_Name, Loc),
398 Parameter_Associations => New_List (
400 Make_Attribute_Reference (Loc,
402 Attribute_Name => Name_Address),
403 Make_Attribute_Reference (Loc,
405 Attribute_Name => Name_Address),
406 Make_Attribute_Reference (Loc,
408 Attribute_Name => Name_Length)));
411 Rewrite (N, Call_Node);
415 when RE_Not_Available =>
417 end Build_Boolean_Array_Proc_Call;
419 -----------------------
421 -----------------------
423 function Build_Eq_Call
427 Rhs : Node_Id) return Node_Id
433 Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
434 while Present (Prim_E) loop
435 Prim := Node (Prim_E);
437 -- Locate primitive equality with the right signature
439 if Chars (Prim) = Name_Op_Eq
440 and then Etype (First_Formal (Prim)) =
441 Etype (Next_Formal (First_Formal (Prim)))
442 and then Etype (Prim) = Standard_Boolean
444 if Is_Abstract_Subprogram (Prim) then
446 Make_Raise_Program_Error (Loc,
447 Reason => PE_Explicit_Raise);
451 Make_Function_Call (Loc,
452 Name => New_Occurrence_Of (Prim, Loc),
453 Parameter_Associations => New_List (Lhs, Rhs));
460 -- If not found, predefined operation will be used
465 --------------------------------
466 -- Displace_Allocator_Pointer --
467 --------------------------------
469 procedure Displace_Allocator_Pointer (N : Node_Id) is
470 Loc : constant Source_Ptr := Sloc (N);
471 Orig_Node : constant Node_Id := Original_Node (N);
477 -- Do nothing in case of VM targets: the virtual machine will handle
478 -- interfaces directly.
480 if not Tagged_Type_Expansion then
484 pragma Assert (Nkind (N) = N_Identifier
485 and then Nkind (Orig_Node) = N_Allocator);
487 PtrT := Etype (Orig_Node);
488 Dtyp := Available_View (Designated_Type (PtrT));
489 Etyp := Etype (Expression (Orig_Node));
491 if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
493 -- If the type of the allocator expression is not an interface type
494 -- we can generate code to reference the record component containing
495 -- the pointer to the secondary dispatch table.
497 if not Is_Interface (Etyp) then
499 Saved_Typ : constant Entity_Id := Etype (Orig_Node);
502 -- 1) Get access to the allocated object
505 Make_Explicit_Dereference (Loc, Relocate_Node (N)));
509 -- 2) Add the conversion to displace the pointer to reference
510 -- the secondary dispatch table.
512 Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
513 Analyze_And_Resolve (N, Dtyp);
515 -- 3) The 'access to the secondary dispatch table will be used
516 -- as the value returned by the allocator.
519 Make_Attribute_Reference (Loc,
520 Prefix => Relocate_Node (N),
521 Attribute_Name => Name_Access));
522 Set_Etype (N, Saved_Typ);
526 -- If the type of the allocator expression is an interface type we
527 -- generate a run-time call to displace "this" to reference the
528 -- component containing the pointer to the secondary dispatch table
529 -- or else raise Constraint_Error if the actual object does not
530 -- implement the target interface. This case corresponds to the
531 -- following example:
533 -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is
535 -- return new Iface_2'Class'(Obj);
540 Unchecked_Convert_To (PtrT,
541 Make_Function_Call (Loc,
542 Name => New_Occurrence_Of (RTE (RE_Displace), Loc),
543 Parameter_Associations => New_List (
544 Unchecked_Convert_To (RTE (RE_Address),
550 (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
552 Analyze_And_Resolve (N, PtrT);
555 end Displace_Allocator_Pointer;
557 ---------------------------------
558 -- Expand_Allocator_Expression --
559 ---------------------------------
561 procedure Expand_Allocator_Expression (N : Node_Id) is
562 Loc : constant Source_Ptr := Sloc (N);
563 Exp : constant Node_Id := Expression (Expression (N));
564 PtrT : constant Entity_Id := Etype (N);
565 DesigT : constant Entity_Id := Designated_Type (PtrT);
567 procedure Apply_Accessibility_Check
569 Built_In_Place : Boolean := False);
570 -- Ada 2005 (AI-344): For an allocator with a class-wide designated
571 -- type, generate an accessibility check to verify that the level of the
572 -- type of the created object is not deeper than the level of the access
573 -- type. If the type of the qualified expression is class-wide, then
574 -- always generate the check (except in the case where it is known to be
575 -- unnecessary, see comment below). Otherwise, only generate the check
576 -- if the level of the qualified expression type is statically deeper
577 -- than the access type.
579 -- Although the static accessibility will generally have been performed
580 -- as a legality check, it won't have been done in cases where the
581 -- allocator appears in generic body, so a run-time check is needed in
582 -- general. One special case is when the access type is declared in the
583 -- same scope as the class-wide allocator, in which case the check can
584 -- never fail, so it need not be generated.
586 -- As an open issue, there seem to be cases where the static level
587 -- associated with the class-wide object's underlying type is not
588 -- sufficient to perform the proper accessibility check, such as for
589 -- allocators in nested subprograms or accept statements initialized by
590 -- class-wide formals when the actual originates outside at a deeper
591 -- static level. The nested subprogram case might require passing
592 -- accessibility levels along with class-wide parameters, and the task
593 -- case seems to be an actual gap in the language rules that needs to
594 -- be fixed by the ARG. ???
596 -------------------------------
597 -- Apply_Accessibility_Check --
598 -------------------------------
600 procedure Apply_Accessibility_Check
602 Built_In_Place : Boolean := False)
604 Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
612 if Ada_Version >= Ada_2005
613 and then Is_Class_Wide_Type (DesigT)
614 and then Tagged_Type_Expansion
615 and then not Scope_Suppress.Suppress (Accessibility_Check)
617 (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
619 (Is_Class_Wide_Type (Etype (Exp))
620 and then Scope (PtrT) /= Current_Scope))
622 -- If the allocator was built in place, Ref is already a reference
623 -- to the access object initialized to the result of the allocator
624 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
625 -- Remove_Side_Effects for cases where the build-in-place call may
626 -- still be the prefix of the reference (to avoid generating
627 -- duplicate calls). Otherwise, it is the entity associated with
628 -- the object containing the address of the allocated object.
630 if Built_In_Place then
631 Remove_Side_Effects (Ref);
632 Obj_Ref := New_Copy_Tree (Ref);
634 Obj_Ref := New_Occurrence_Of (Ref, Loc);
637 -- For access to interface types we must generate code to displace
638 -- the pointer to the base of the object since the subsequent code
639 -- references components located in the TSD of the object (which
640 -- is associated with the primary dispatch table --see a-tags.ads)
641 -- and also generates code invoking Free, which requires also a
642 -- reference to the base of the unallocated object.
644 if Is_Interface (DesigT) and then Tagged_Type_Expansion then
646 Unchecked_Convert_To (Etype (Obj_Ref),
647 Make_Function_Call (Loc,
649 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
650 Parameter_Associations => New_List (
651 Unchecked_Convert_To (RTE (RE_Address),
652 New_Copy_Tree (Obj_Ref)))));
655 -- Step 1: Create the object clean up code
659 -- Deallocate the object if the accessibility check fails. This
660 -- is done only on targets or profiles that support deallocation.
664 if RTE_Available (RE_Free) then
665 Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
666 Set_Storage_Pool (Free_Stmt, Pool_Id);
668 Append_To (Stmts, Free_Stmt);
670 -- The target or profile cannot deallocate objects
676 -- Finalize the object if applicable. Generate:
678 -- [Deep_]Finalize (Obj_Ref.all);
680 if Needs_Finalization (DesigT)
681 and then not No_Heap_Finalization (PtrT)
686 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
689 -- Guard against a missing [Deep_]Finalize when the designated
690 -- type was not properly frozen.
692 if No (Fin_Call) then
693 Fin_Call := Make_Null_Statement (Loc);
696 -- When the target or profile supports deallocation, wrap the
697 -- finalization call in a block to ensure proper deallocation
698 -- even if finalization fails. Generate:
708 if Present (Free_Stmt) then
710 Make_Block_Statement (Loc,
711 Handled_Statement_Sequence =>
712 Make_Handled_Sequence_Of_Statements (Loc,
713 Statements => New_List (Fin_Call),
715 Exception_Handlers => New_List (
716 Make_Exception_Handler (Loc,
717 Exception_Choices => New_List (
718 Make_Others_Choice (Loc)),
719 Statements => New_List (
720 New_Copy_Tree (Free_Stmt),
721 Make_Raise_Statement (Loc))))));
724 Prepend_To (Stmts, Fin_Call);
727 -- Signal the accessibility failure through a Program_Error
730 Make_Raise_Program_Error (Loc,
731 Condition => New_Occurrence_Of (Standard_True, Loc),
732 Reason => PE_Accessibility_Check_Failed));
734 -- Step 2: Create the accessibility comparison
740 Make_Attribute_Reference (Loc,
742 Attribute_Name => Name_Tag);
744 -- For tagged types, determine the accessibility level by looking
745 -- at the type specific data of the dispatch table. Generate:
747 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
749 if Tagged_Type_Expansion then
750 Cond := Build_Get_Access_Level (Loc, Obj_Ref);
752 -- Use a runtime call to determine the accessibility level when
753 -- compiling on virtual machine targets. Generate:
755 -- Get_Access_Level (Ref'Tag)
759 Make_Function_Call (Loc,
761 New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
762 Parameter_Associations => New_List (Obj_Ref));
769 Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
771 -- Due to the complexity and side effects of the check, utilize an
772 -- if statement instead of the regular Program_Error circuitry.
775 Make_Implicit_If_Statement (N,
777 Then_Statements => Stmts));
779 end Apply_Accessibility_Check;
783 Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
784 Indic : constant Node_Id := Subtype_Mark (Expression (N));
785 T : constant Entity_Id := Entity (Indic);
788 Tag_Assign : Node_Id;
792 TagT : Entity_Id := Empty;
793 -- Type used as source for tag assignment
795 TagR : Node_Id := Empty;
796 -- Target reference for tag assignment
798 -- Start of processing for Expand_Allocator_Expression
801 -- Handle call to C++ constructor
803 if Is_CPP_Constructor_Call (Exp) then
804 Make_CPP_Constructor_Call_In_Allocator
806 Function_Call => Exp);
810 -- In the case of an Ada 2012 allocator whose initial value comes from a
811 -- function call, pass "the accessibility level determined by the point
812 -- of call" (AI05-0234) to the function. Conceptually, this belongs in
813 -- Expand_Call but it couldn't be done there (because the Etype of the
814 -- allocator wasn't set then) so we generate the parameter here. See
815 -- the Boolean variable Defer in (a block within) Expand_Call.
817 if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
822 if Nkind (Name (Exp)) = N_Explicit_Dereference then
823 Subp := Designated_Type (Etype (Prefix (Name (Exp))));
825 Subp := Entity (Name (Exp));
828 Subp := Ultimate_Alias (Subp);
830 if Present (Extra_Accessibility_Of_Result (Subp)) then
831 Add_Extra_Actual_To_Call
832 (Subprogram_Call => Exp,
833 Extra_Formal => Extra_Accessibility_Of_Result (Subp),
834 Extra_Actual => Dynamic_Accessibility_Level (PtrT));
839 -- Case of tagged type or type requiring finalization
841 if Is_Tagged_Type (T) or else Needs_Finalization (T) then
843 -- Ada 2005 (AI-318-02): If the initialization expression is a call
844 -- to a build-in-place function, then access to the allocated object
845 -- must be passed to the function.
847 if Is_Build_In_Place_Function_Call (Exp) then
848 Make_Build_In_Place_Call_In_Allocator (N, Exp);
849 Apply_Accessibility_Check (N, Built_In_Place => True);
852 -- Ada 2005 (AI-318-02): Specialization of the previous case for
853 -- expressions containing a build-in-place function call whose
854 -- returned object covers interface types, and Expr has calls to
855 -- Ada.Tags.Displace to displace the pointer to the returned build-
856 -- in-place object to reference the secondary dispatch table of a
857 -- covered interface type.
859 elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then
860 Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
861 Apply_Accessibility_Check (N, Built_In_Place => True);
865 -- Actions inserted before:
866 -- Temp : constant ptr_T := new T'(Expression);
867 -- Temp._tag = T'tag; -- when not class-wide
868 -- [Deep_]Adjust (Temp.all);
870 -- We analyze by hand the new internal allocator to avoid any
871 -- recursion and inappropriate call to Initialize.
873 -- We don't want to remove side effects when the expression must be
874 -- built in place. In the case of a build-in-place function call,
875 -- that could lead to a duplication of the call, which was already
876 -- substituted for the allocator.
878 if not Aggr_In_Place then
879 Remove_Side_Effects (Exp);
882 Temp := Make_Temporary (Loc, 'P', N);
884 -- For a class wide allocation generate the following code:
886 -- type Equiv_Record is record ... end record;
887 -- implicit subtype CW is <Class_Wide_Subytpe>;
888 -- temp : PtrT := new CW'(CW!(expr));
890 if Is_Class_Wide_Type (T) then
891 Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
893 -- Ada 2005 (AI-251): If the expression is a class-wide interface
894 -- object we generate code to move up "this" to reference the
895 -- base of the object before allocating the new object.
897 -- Note that Exp'Address is recursively expanded into a call
898 -- to Base_Address (Exp.Tag)
900 if Is_Class_Wide_Type (Etype (Exp))
901 and then Is_Interface (Etype (Exp))
902 and then Tagged_Type_Expansion
906 Unchecked_Convert_To (Entity (Indic),
907 Make_Explicit_Dereference (Loc,
908 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
909 Make_Attribute_Reference (Loc,
911 Attribute_Name => Name_Address)))));
915 Unchecked_Convert_To (Entity (Indic), Exp));
918 Analyze_And_Resolve (Expression (N), Entity (Indic));
921 -- Processing for allocators returning non-interface types
923 if not Is_Interface (Directly_Designated_Type (PtrT)) then
924 if Aggr_In_Place then
926 Make_Object_Declaration (Loc,
927 Defining_Identifier => Temp,
928 Object_Definition => New_Occurrence_Of (PtrT, Loc),
932 New_Occurrence_Of (Etype (Exp), Loc)));
934 -- Copy the Comes_From_Source flag for the allocator we just
935 -- built, since logically this allocator is a replacement of
936 -- the original allocator node. This is for proper handling of
937 -- restriction No_Implicit_Heap_Allocations.
939 Set_Comes_From_Source
940 (Expression (Temp_Decl), Comes_From_Source (N));
942 Set_No_Initialization (Expression (Temp_Decl));
943 Insert_Action (N, Temp_Decl);
945 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
946 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
949 Node := Relocate_Node (N);
953 Make_Object_Declaration (Loc,
954 Defining_Identifier => Temp,
955 Constant_Present => True,
956 Object_Definition => New_Occurrence_Of (PtrT, Loc),
959 Insert_Action (N, Temp_Decl);
960 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
963 -- Ada 2005 (AI-251): Handle allocators whose designated type is an
964 -- interface type. In this case we use the type of the qualified
965 -- expression to allocate the object.
969 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
974 Make_Full_Type_Declaration (Loc,
975 Defining_Identifier => Def_Id,
977 Make_Access_To_Object_Definition (Loc,
979 Null_Exclusion_Present => False,
981 Is_Access_Constant (Etype (N)),
982 Subtype_Indication =>
983 New_Occurrence_Of (Etype (Exp), Loc)));
985 Insert_Action (N, New_Decl);
987 -- Inherit the allocation-related attributes from the original
990 Set_Finalization_Master
991 (Def_Id, Finalization_Master (PtrT));
993 Set_Associated_Storage_Pool
994 (Def_Id, Associated_Storage_Pool (PtrT));
996 -- Declare the object using the previous type declaration
998 if Aggr_In_Place then
1000 Make_Object_Declaration (Loc,
1001 Defining_Identifier => Temp,
1002 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1004 Make_Allocator (Loc,
1005 New_Occurrence_Of (Etype (Exp), Loc)));
1007 -- Copy the Comes_From_Source flag for the allocator we just
1008 -- built, since logically this allocator is a replacement of
1009 -- the original allocator node. This is for proper handling
1010 -- of restriction No_Implicit_Heap_Allocations.
1012 Set_Comes_From_Source
1013 (Expression (Temp_Decl), Comes_From_Source (N));
1015 Set_No_Initialization (Expression (Temp_Decl));
1016 Insert_Action (N, Temp_Decl);
1018 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1019 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1022 Node := Relocate_Node (N);
1023 Set_Analyzed (Node);
1026 Make_Object_Declaration (Loc,
1027 Defining_Identifier => Temp,
1028 Constant_Present => True,
1029 Object_Definition => New_Occurrence_Of (Def_Id, Loc),
1030 Expression => Node);
1032 Insert_Action (N, Temp_Decl);
1033 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1036 -- Generate an additional object containing the address of the
1037 -- returned object. The type of this second object declaration
1038 -- is the correct type required for the common processing that
1039 -- is still performed by this subprogram. The displacement of
1040 -- this pointer to reference the component associated with the
1041 -- interface type will be done at the end of common processing.
1044 Make_Object_Declaration (Loc,
1045 Defining_Identifier => Make_Temporary (Loc, 'P'),
1046 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1048 Unchecked_Convert_To (PtrT,
1049 New_Occurrence_Of (Temp, Loc)));
1051 Insert_Action (N, New_Decl);
1053 Temp_Decl := New_Decl;
1054 Temp := Defining_Identifier (New_Decl);
1058 -- Generate the tag assignment
1060 -- Suppress the tag assignment for VM targets because VM tags are
1061 -- represented implicitly in objects.
1063 if not Tagged_Type_Expansion then
1066 -- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1067 -- interface objects because in this case the tag does not change.
1069 elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1070 pragma Assert (Is_Class_Wide_Type
1071 (Directly_Designated_Type (Etype (N))));
1074 elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1076 TagR := New_Occurrence_Of (Temp, Loc);
1078 elsif Is_Private_Type (T)
1079 and then Is_Tagged_Type (Underlying_Type (T))
1081 TagT := Underlying_Type (T);
1083 Unchecked_Convert_To (Underlying_Type (T),
1084 Make_Explicit_Dereference (Loc,
1085 Prefix => New_Occurrence_Of (Temp, Loc)));
1088 if Present (TagT) then
1090 Full_T : constant Entity_Id := Underlying_Type (TagT);
1094 Make_Assignment_Statement (Loc,
1096 Make_Selected_Component (Loc,
1100 (First_Tag_Component (Full_T), Loc)),
1103 Unchecked_Convert_To (RTE (RE_Tag),
1106 (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1109 -- The previous assignment has to be done in any case
1111 Set_Assignment_OK (Name (Tag_Assign));
1112 Insert_Action (N, Tag_Assign);
1115 -- Generate an Adjust call if the object will be moved. In Ada 2005,
1116 -- the object may be inherently limited, in which case there is no
1117 -- Adjust procedure, and the object is built in place. In Ada 95, the
1118 -- object can be limited but not inherently limited if this allocator
1119 -- came from a return statement (we're allocating the result on the
1120 -- secondary stack). In that case, the object will be moved, so we do
1121 -- want to Adjust. However, if it's a nonlimited build-in-place
1122 -- function call, Adjust is not wanted.
1124 if Needs_Finalization (DesigT)
1125 and then Needs_Finalization (T)
1126 and then not Aggr_In_Place
1127 and then not Is_Limited_View (T)
1128 and then not Alloc_For_BIP_Return (N)
1129 and then not Is_Build_In_Place_Function_Call (Expression (N))
1131 -- An unchecked conversion is needed in the classwide case because
1132 -- the designated type can be an ancestor of the subtype mark of
1138 Unchecked_Convert_To (T,
1139 Make_Explicit_Dereference (Loc,
1140 Prefix => New_Occurrence_Of (Temp, Loc))),
1143 if Present (Adj_Call) then
1144 Insert_Action (N, Adj_Call);
1148 -- Note: the accessibility check must be inserted after the call to
1149 -- [Deep_]Adjust to ensure proper completion of the assignment.
1151 Apply_Accessibility_Check (Temp);
1153 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1154 Analyze_And_Resolve (N, PtrT);
1156 -- Ada 2005 (AI-251): Displace the pointer to reference the record
1157 -- component containing the secondary dispatch table of the interface
1160 if Is_Interface (Directly_Designated_Type (PtrT)) then
1161 Displace_Allocator_Pointer (N);
1164 -- Always force the generation of a temporary for aggregates when
1165 -- generating C code, to simplify the work in the code generator.
1168 or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate)
1170 Temp := Make_Temporary (Loc, 'P', N);
1172 Make_Object_Declaration (Loc,
1173 Defining_Identifier => Temp,
1174 Object_Definition => New_Occurrence_Of (PtrT, Loc),
1176 Make_Allocator (Loc,
1177 Expression => New_Occurrence_Of (Etype (Exp), Loc)));
1179 -- Copy the Comes_From_Source flag for the allocator we just built,
1180 -- since logically this allocator is a replacement of the original
1181 -- allocator node. This is for proper handling of restriction
1182 -- No_Implicit_Heap_Allocations.
1184 Set_Comes_From_Source
1185 (Expression (Temp_Decl), Comes_From_Source (N));
1187 Set_No_Initialization (Expression (Temp_Decl));
1188 Insert_Action (N, Temp_Decl);
1190 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1191 Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1193 Rewrite (N, New_Occurrence_Of (Temp, Loc));
1194 Analyze_And_Resolve (N, PtrT);
1196 elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
1197 Install_Null_Excluding_Check (Exp);
1199 elsif Is_Access_Type (DesigT)
1200 and then Nkind (Exp) = N_Allocator
1201 and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1203 -- Apply constraint to designated subtype indication
1205 Apply_Constraint_Check
1206 (Expression (Exp), Designated_Type (DesigT), No_Sliding => True);
1208 if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1210 -- Propagate constraint_error to enclosing allocator
1212 Rewrite (Exp, New_Copy (Expression (Exp)));
1216 Build_Allocate_Deallocate_Proc (N, True);
1219 -- type A is access T1;
1220 -- X : A := new T2'(...);
1221 -- T1 and T2 can be different subtypes, and we might need to check
1222 -- both constraints. First check against the type of the qualified
1225 Apply_Constraint_Check (Exp, T, No_Sliding => True);
1227 if Do_Range_Check (Exp) then
1228 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1231 -- A check is also needed in cases where the designated subtype is
1232 -- constrained and differs from the subtype given in the qualified
1233 -- expression. Note that the check on the qualified expression does
1234 -- not allow sliding, but this check does (a relaxation from Ada 83).
1236 if Is_Constrained (DesigT)
1237 and then not Subtypes_Statically_Match (T, DesigT)
1239 Apply_Constraint_Check
1240 (Exp, DesigT, No_Sliding => False);
1242 if Do_Range_Check (Exp) then
1243 Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1247 -- For an access to unconstrained packed array, GIGI needs to see an
1248 -- expression with a constrained subtype in order to compute the
1249 -- proper size for the allocator.
1251 if Is_Array_Type (T)
1252 and then not Is_Constrained (T)
1253 and then Is_Packed (T)
1256 ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
1257 Internal_Exp : constant Node_Id := Relocate_Node (Exp);
1260 Make_Subtype_Declaration (Loc,
1261 Defining_Identifier => ConstrT,
1262 Subtype_Indication =>
1263 Make_Subtype_From_Expr (Internal_Exp, T)));
1264 Freeze_Itype (ConstrT, Exp);
1265 Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1269 -- Ada 2005 (AI-318-02): If the initialization expression is a call
1270 -- to a build-in-place function, then access to the allocated object
1271 -- must be passed to the function.
1273 if Is_Build_In_Place_Function_Call (Exp) then
1274 Make_Build_In_Place_Call_In_Allocator (N, Exp);
1279 when RE_Not_Available =>
1281 end Expand_Allocator_Expression;
1283 -----------------------------
1284 -- Expand_Array_Comparison --
1285 -----------------------------
1287 -- Expansion is only required in the case of array types. For the unpacked
1288 -- case, an appropriate runtime routine is called. For packed cases, and
1289 -- also in some other cases where a runtime routine cannot be called, the
1290 -- form of the expansion is:
1292 -- [body for greater_nn; boolean_expression]
1294 -- The body is built by Make_Array_Comparison_Op, and the form of the
1295 -- Boolean expression depends on the operator involved.
1297 procedure Expand_Array_Comparison (N : Node_Id) is
1298 Loc : constant Source_Ptr := Sloc (N);
1299 Op1 : Node_Id := Left_Opnd (N);
1300 Op2 : Node_Id := Right_Opnd (N);
1301 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
1302 Ctyp : constant Entity_Id := Component_Type (Typ1);
1305 Func_Body : Node_Id;
1306 Func_Name : Entity_Id;
1310 Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1311 -- True for byte addressable target
1313 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1314 -- Returns True if the length of the given operand is known to be less
1315 -- than 4. Returns False if this length is known to be four or greater
1316 -- or is not known at compile time.
1318 ------------------------
1319 -- Length_Less_Than_4 --
1320 ------------------------
1322 function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1323 Otyp : constant Entity_Id := Etype (Opnd);
1326 if Ekind (Otyp) = E_String_Literal_Subtype then
1327 return String_Literal_Length (Otyp) < 4;
1331 Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1332 Lo : constant Node_Id := Type_Low_Bound (Ityp);
1333 Hi : constant Node_Id := Type_High_Bound (Ityp);
1338 if Compile_Time_Known_Value (Lo) then
1339 Lov := Expr_Value (Lo);
1344 if Compile_Time_Known_Value (Hi) then
1345 Hiv := Expr_Value (Hi);
1350 return Hiv < Lov + 3;
1353 end Length_Less_Than_4;
1355 -- Start of processing for Expand_Array_Comparison
1358 -- Deal first with unpacked case, where we can call a runtime routine
1359 -- except that we avoid this for targets for which are not addressable
1362 if not Is_Bit_Packed_Array (Typ1)
1363 and then Byte_Addressable
1365 -- The call we generate is:
1367 -- Compare_Array_xn[_Unaligned]
1368 -- (left'address, right'address, left'length, right'length) <op> 0
1370 -- x = U for unsigned, S for signed
1371 -- n = 8,16,32,64 for component size
1372 -- Add _Unaligned if length < 4 and component size is 8.
1373 -- <op> is the standard comparison operator
1375 if Component_Size (Typ1) = 8 then
1376 if Length_Less_Than_4 (Op1)
1378 Length_Less_Than_4 (Op2)
1380 if Is_Unsigned_Type (Ctyp) then
1381 Comp := RE_Compare_Array_U8_Unaligned;
1383 Comp := RE_Compare_Array_S8_Unaligned;
1387 if Is_Unsigned_Type (Ctyp) then
1388 Comp := RE_Compare_Array_U8;
1390 Comp := RE_Compare_Array_S8;
1394 elsif Component_Size (Typ1) = 16 then
1395 if Is_Unsigned_Type (Ctyp) then
1396 Comp := RE_Compare_Array_U16;
1398 Comp := RE_Compare_Array_S16;
1401 elsif Component_Size (Typ1) = 32 then
1402 if Is_Unsigned_Type (Ctyp) then
1403 Comp := RE_Compare_Array_U32;
1405 Comp := RE_Compare_Array_S32;
1408 else pragma Assert (Component_Size (Typ1) = 64);
1409 if Is_Unsigned_Type (Ctyp) then
1410 Comp := RE_Compare_Array_U64;
1412 Comp := RE_Compare_Array_S64;
1416 if RTE_Available (Comp) then
1418 -- Expand to a call only if the runtime function is available,
1419 -- otherwise fall back to inline code.
1421 Remove_Side_Effects (Op1, Name_Req => True);
1422 Remove_Side_Effects (Op2, Name_Req => True);
1425 Make_Function_Call (Sloc (Op1),
1426 Name => New_Occurrence_Of (RTE (Comp), Loc),
1428 Parameter_Associations => New_List (
1429 Make_Attribute_Reference (Loc,
1430 Prefix => Relocate_Node (Op1),
1431 Attribute_Name => Name_Address),
1433 Make_Attribute_Reference (Loc,
1434 Prefix => Relocate_Node (Op2),
1435 Attribute_Name => Name_Address),
1437 Make_Attribute_Reference (Loc,
1438 Prefix => Relocate_Node (Op1),
1439 Attribute_Name => Name_Length),
1441 Make_Attribute_Reference (Loc,
1442 Prefix => Relocate_Node (Op2),
1443 Attribute_Name => Name_Length))));
1446 Make_Integer_Literal (Sloc (Op2),
1449 Analyze_And_Resolve (Op1, Standard_Integer);
1450 Analyze_And_Resolve (Op2, Standard_Integer);
1455 -- Cases where we cannot make runtime call
1457 -- For (a <= b) we convert to not (a > b)
1459 if Chars (N) = Name_Op_Le then
1465 Right_Opnd => Op2)));
1466 Analyze_And_Resolve (N, Standard_Boolean);
1469 -- For < the Boolean expression is
1470 -- greater__nn (op2, op1)
1472 elsif Chars (N) = Name_Op_Lt then
1473 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1477 Op1 := Right_Opnd (N);
1478 Op2 := Left_Opnd (N);
1480 -- For (a >= b) we convert to not (a < b)
1482 elsif Chars (N) = Name_Op_Ge then
1488 Right_Opnd => Op2)));
1489 Analyze_And_Resolve (N, Standard_Boolean);
1492 -- For > the Boolean expression is
1493 -- greater__nn (op1, op2)
1496 pragma Assert (Chars (N) = Name_Op_Gt);
1497 Func_Body := Make_Array_Comparison_Op (Typ1, N);
1500 Func_Name := Defining_Unit_Name (Specification (Func_Body));
1502 Make_Function_Call (Loc,
1503 Name => New_Occurrence_Of (Func_Name, Loc),
1504 Parameter_Associations => New_List (Op1, Op2));
1506 Insert_Action (N, Func_Body);
1508 Analyze_And_Resolve (N, Standard_Boolean);
1509 end Expand_Array_Comparison;
1511 ---------------------------
1512 -- Expand_Array_Equality --
1513 ---------------------------
1515 -- Expand an equality function for multi-dimensional arrays. Here is an
1516 -- example of such a function for Nb_Dimension = 2
1518 -- function Enn (A : atyp; B : btyp) return boolean is
1520 -- if (A'length (1) = 0 or else A'length (2) = 0)
1522 -- (B'length (1) = 0 or else B'length (2) = 0)
1524 -- return True; -- RM 4.5.2(22)
1527 -- if A'length (1) /= B'length (1)
1529 -- A'length (2) /= B'length (2)
1531 -- return False; -- RM 4.5.2(23)
1535 -- A1 : Index_T1 := A'first (1);
1536 -- B1 : Index_T1 := B'first (1);
1540 -- A2 : Index_T2 := A'first (2);
1541 -- B2 : Index_T2 := B'first (2);
1544 -- if A (A1, A2) /= B (B1, B2) then
1548 -- exit when A2 = A'last (2);
1549 -- A2 := Index_T2'succ (A2);
1550 -- B2 := Index_T2'succ (B2);
1554 -- exit when A1 = A'last (1);
1555 -- A1 := Index_T1'succ (A1);
1556 -- B1 := Index_T1'succ (B1);
1563 -- Note on the formal types used (atyp and btyp). If either of the arrays
1564 -- is of a private type, we use the underlying type, and do an unchecked
1565 -- conversion of the actual. If either of the arrays has a bound depending
1566 -- on a discriminant, then we use the base type since otherwise we have an
1567 -- escaped discriminant in the function.
1569 -- If both arrays are constrained and have the same bounds, we can generate
1570 -- a loop with an explicit iteration scheme using a 'Range attribute over
1573 function Expand_Array_Equality
1578 Typ : Entity_Id) return Node_Id
1580 Loc : constant Source_Ptr := Sloc (Nod);
1581 Decls : constant List_Id := New_List;
1582 Index_List1 : constant List_Id := New_List;
1583 Index_List2 : constant List_Id := New_List;
1585 First_Idx : Node_Id;
1587 Func_Name : Entity_Id;
1588 Func_Body : Node_Id;
1590 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1591 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1595 -- The parameter types to be used for the formals
1599 -- The LHS and RHS converted to the parameter types
1604 Num : Int) return Node_Id;
1605 -- This builds the attribute reference Arr'Nam (Expr)
1607 function Component_Equality (Typ : Entity_Id) return Node_Id;
1608 -- Create one statement to compare corresponding components, designated
1609 -- by a full set of indexes.
1611 function Get_Arg_Type (N : Node_Id) return Entity_Id;
1612 -- Given one of the arguments, computes the appropriate type to be used
1613 -- for that argument in the corresponding function formal
1615 function Handle_One_Dimension
1617 Index : Node_Id) return Node_Id;
1618 -- This procedure returns the following code
1621 -- Bn : Index_T := B'First (N);
1625 -- exit when An = A'Last (N);
1626 -- An := Index_T'Succ (An)
1627 -- Bn := Index_T'Succ (Bn)
1631 -- If both indexes are constrained and identical, the procedure
1632 -- returns a simpler loop:
1634 -- for An in A'Range (N) loop
1638 -- N is the dimension for which we are generating a loop. Index is the
1639 -- N'th index node, whose Etype is Index_Type_n in the above code. The
1640 -- xxx statement is either the loop or declare for the next dimension
1641 -- or if this is the last dimension the comparison of corresponding
1642 -- components of the arrays.
1644 -- The actual way the code works is to return the comparison of
1645 -- corresponding components for the N+1 call. That's neater.
1647 function Test_Empty_Arrays return Node_Id;
1648 -- This function constructs the test for both arrays being empty
1649 -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1651 -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1653 function Test_Lengths_Correspond return Node_Id;
1654 -- This function constructs the test for arrays having different lengths
1655 -- in at least one index position, in which case the resulting code is:
1657 -- A'length (1) /= B'length (1)
1659 -- A'length (2) /= B'length (2)
1670 Num : Int) return Node_Id
1674 Make_Attribute_Reference (Loc,
1675 Attribute_Name => Nam,
1676 Prefix => New_Occurrence_Of (Arr, Loc),
1677 Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1680 ------------------------
1681 -- Component_Equality --
1682 ------------------------
1684 function Component_Equality (Typ : Entity_Id) return Node_Id is
1689 -- if a(i1...) /= b(j1...) then return false; end if;
1692 Make_Indexed_Component (Loc,
1693 Prefix => Make_Identifier (Loc, Chars (A)),
1694 Expressions => Index_List1);
1697 Make_Indexed_Component (Loc,
1698 Prefix => Make_Identifier (Loc, Chars (B)),
1699 Expressions => Index_List2);
1701 Test := Expand_Composite_Equality
1702 (Nod, Component_Type (Typ), L, R, Decls);
1704 -- If some (sub)component is an unchecked_union, the whole operation
1705 -- will raise program error.
1707 if Nkind (Test) = N_Raise_Program_Error then
1709 -- This node is going to be inserted at a location where a
1710 -- statement is expected: clear its Etype so analysis will set
1711 -- it to the expected Standard_Void_Type.
1713 Set_Etype (Test, Empty);
1718 Make_Implicit_If_Statement (Nod,
1719 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1720 Then_Statements => New_List (
1721 Make_Simple_Return_Statement (Loc,
1722 Expression => New_Occurrence_Of (Standard_False, Loc))));
1724 end Component_Equality;
1730 function Get_Arg_Type (N : Node_Id) return Entity_Id is
1741 T := Underlying_Type (T);
1743 X := First_Index (T);
1744 while Present (X) loop
1745 if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1747 Denotes_Discriminant (Type_High_Bound (Etype (X)))
1760 --------------------------
1761 -- Handle_One_Dimension --
1762 ---------------------------
1764 function Handle_One_Dimension
1766 Index : Node_Id) return Node_Id
1768 Need_Separate_Indexes : constant Boolean :=
1769 Ltyp /= Rtyp or else not Is_Constrained (Ltyp);
1770 -- If the index types are identical, and we are working with
1771 -- constrained types, then we can use the same index for both
1774 An : constant Entity_Id := Make_Temporary (Loc, 'A');
1777 Index_T : Entity_Id;
1782 if N > Number_Dimensions (Ltyp) then
1783 return Component_Equality (Ltyp);
1786 -- Case where we generate a loop
1788 Index_T := Base_Type (Etype (Index));
1790 if Need_Separate_Indexes then
1791 Bn := Make_Temporary (Loc, 'B');
1796 Append (New_Occurrence_Of (An, Loc), Index_List1);
1797 Append (New_Occurrence_Of (Bn, Loc), Index_List2);
1799 Stm_List := New_List (
1800 Handle_One_Dimension (N + 1, Next_Index (Index)));
1802 if Need_Separate_Indexes then
1804 -- Generate guard for loop, followed by increments of indexes
1806 Append_To (Stm_List,
1807 Make_Exit_Statement (Loc,
1810 Left_Opnd => New_Occurrence_Of (An, Loc),
1811 Right_Opnd => Arr_Attr (A, Name_Last, N))));
1813 Append_To (Stm_List,
1814 Make_Assignment_Statement (Loc,
1815 Name => New_Occurrence_Of (An, Loc),
1817 Make_Attribute_Reference (Loc,
1818 Prefix => New_Occurrence_Of (Index_T, Loc),
1819 Attribute_Name => Name_Succ,
1820 Expressions => New_List (
1821 New_Occurrence_Of (An, Loc)))));
1823 Append_To (Stm_List,
1824 Make_Assignment_Statement (Loc,
1825 Name => New_Occurrence_Of (Bn, Loc),
1827 Make_Attribute_Reference (Loc,
1828 Prefix => New_Occurrence_Of (Index_T, Loc),
1829 Attribute_Name => Name_Succ,
1830 Expressions => New_List (
1831 New_Occurrence_Of (Bn, Loc)))));
1834 -- If separate indexes, we need a declare block for An and Bn, and a
1835 -- loop without an iteration scheme.
1837 if Need_Separate_Indexes then
1839 Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1842 Make_Block_Statement (Loc,
1843 Declarations => New_List (
1844 Make_Object_Declaration (Loc,
1845 Defining_Identifier => An,
1846 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1847 Expression => Arr_Attr (A, Name_First, N)),
1849 Make_Object_Declaration (Loc,
1850 Defining_Identifier => Bn,
1851 Object_Definition => New_Occurrence_Of (Index_T, Loc),
1852 Expression => Arr_Attr (B, Name_First, N))),
1854 Handled_Statement_Sequence =>
1855 Make_Handled_Sequence_Of_Statements (Loc,
1856 Statements => New_List (Loop_Stm)));
1858 -- If no separate indexes, return loop statement with explicit
1859 -- iteration scheme on its own.
1863 Make_Implicit_Loop_Statement (Nod,
1864 Statements => Stm_List,
1866 Make_Iteration_Scheme (Loc,
1867 Loop_Parameter_Specification =>
1868 Make_Loop_Parameter_Specification (Loc,
1869 Defining_Identifier => An,
1870 Discrete_Subtype_Definition =>
1871 Arr_Attr (A, Name_Range, N))));
1874 end Handle_One_Dimension;
1876 -----------------------
1877 -- Test_Empty_Arrays --
1878 -----------------------
1880 function Test_Empty_Arrays return Node_Id is
1890 for J in 1 .. Number_Dimensions (Ltyp) loop
1893 Left_Opnd => Arr_Attr (A, Name_Length, J),
1894 Right_Opnd => Make_Integer_Literal (Loc, 0));
1898 Left_Opnd => Arr_Attr (B, Name_Length, J),
1899 Right_Opnd => Make_Integer_Literal (Loc, 0));
1908 Left_Opnd => Relocate_Node (Alist),
1909 Right_Opnd => Atest);
1913 Left_Opnd => Relocate_Node (Blist),
1914 Right_Opnd => Btest);
1921 Right_Opnd => Blist);
1922 end Test_Empty_Arrays;
1924 -----------------------------
1925 -- Test_Lengths_Correspond --
1926 -----------------------------
1928 function Test_Lengths_Correspond return Node_Id is
1934 for J in 1 .. Number_Dimensions (Ltyp) loop
1937 Left_Opnd => Arr_Attr (A, Name_Length, J),
1938 Right_Opnd => Arr_Attr (B, Name_Length, J));
1945 Left_Opnd => Relocate_Node (Result),
1946 Right_Opnd => Rtest);
1951 end Test_Lengths_Correspond;
1953 -- Start of processing for Expand_Array_Equality
1956 Ltyp := Get_Arg_Type (Lhs);
1957 Rtyp := Get_Arg_Type (Rhs);
1959 -- For now, if the argument types are not the same, go to the base type,
1960 -- since the code assumes that the formals have the same type. This is
1961 -- fixable in future ???
1963 if Ltyp /= Rtyp then
1964 Ltyp := Base_Type (Ltyp);
1965 Rtyp := Base_Type (Rtyp);
1966 pragma Assert (Ltyp = Rtyp);
1969 -- If the array type is distinct from the type of the arguments, it
1970 -- is the full view of a private type. Apply an unchecked conversion
1971 -- to ensure that analysis of the code below succeeds.
1974 or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
1976 New_Lhs := OK_Convert_To (Ltyp, Lhs);
1982 or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
1984 New_Rhs := OK_Convert_To (Rtyp, Rhs);
1989 First_Idx := First_Index (Ltyp);
1991 -- If optimization is enabled and the array boils down to a couple of
1992 -- consecutive elements, generate a simple conjunction of comparisons
1993 -- which should be easier to optimize by the code generator.
1995 if Optimization_Level > 0
1996 and then Ltyp = Rtyp
1997 and then Is_Constrained (Ltyp)
1998 and then Number_Dimensions (Ltyp) = 1
1999 and then Nkind (First_Idx) = N_Range
2000 and then Compile_Time_Known_Value (Low_Bound (First_Idx))
2001 and then Compile_Time_Known_Value (High_Bound (First_Idx))
2002 and then Expr_Value (High_Bound (First_Idx)) =
2003 Expr_Value (Low_Bound (First_Idx)) + 1
2006 Ctyp : constant Entity_Id := Component_Type (Ltyp);
2008 TestL, TestH : Node_Id;
2009 Index_List : List_Id;
2012 Index_List := New_List (New_Copy_Tree (Low_Bound (First_Idx)));
2015 Make_Indexed_Component (Loc,
2016 Prefix => New_Copy_Tree (New_Lhs),
2017 Expressions => Index_List);
2020 Make_Indexed_Component (Loc,
2021 Prefix => New_Copy_Tree (New_Rhs),
2022 Expressions => Index_List);
2024 TestL := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies);
2026 Index_List := New_List (New_Copy_Tree (High_Bound (First_Idx)));
2029 Make_Indexed_Component (Loc,
2031 Expressions => Index_List);
2034 Make_Indexed_Component (Loc,
2036 Expressions => Index_List);
2038 TestH := Expand_Composite_Equality (Nod, Ctyp, L, R, Bodies);
2041 Make_And_Then (Loc, Left_Opnd => TestL, Right_Opnd => TestH);
2045 -- Build list of formals for function
2047 Formals := New_List (
2048 Make_Parameter_Specification (Loc,
2049 Defining_Identifier => A,
2050 Parameter_Type => New_Occurrence_Of (Ltyp, Loc)),
2052 Make_Parameter_Specification (Loc,
2053 Defining_Identifier => B,
2054 Parameter_Type => New_Occurrence_Of (Rtyp, Loc)));
2056 Func_Name := Make_Temporary (Loc, 'E');
2058 -- Build statement sequence for function
2061 Make_Subprogram_Body (Loc,
2063 Make_Function_Specification (Loc,
2064 Defining_Unit_Name => Func_Name,
2065 Parameter_Specifications => Formals,
2066 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
2068 Declarations => Decls,
2070 Handled_Statement_Sequence =>
2071 Make_Handled_Sequence_Of_Statements (Loc,
2072 Statements => New_List (
2074 Make_Implicit_If_Statement (Nod,
2075 Condition => Test_Empty_Arrays,
2076 Then_Statements => New_List (
2077 Make_Simple_Return_Statement (Loc,
2079 New_Occurrence_Of (Standard_True, Loc)))),
2081 Make_Implicit_If_Statement (Nod,
2082 Condition => Test_Lengths_Correspond,
2083 Then_Statements => New_List (
2084 Make_Simple_Return_Statement (Loc,
2085 Expression => New_Occurrence_Of (Standard_False, Loc)))),
2087 Handle_One_Dimension (1, First_Idx),
2089 Make_Simple_Return_Statement (Loc,
2090 Expression => New_Occurrence_Of (Standard_True, Loc)))));
2092 Set_Has_Completion (Func_Name, True);
2093 Set_Is_Inlined (Func_Name);
2095 Append_To (Bodies, Func_Body);
2098 Make_Function_Call (Loc,
2099 Name => New_Occurrence_Of (Func_Name, Loc),
2100 Parameter_Associations => New_List (New_Lhs, New_Rhs));
2101 end Expand_Array_Equality;
2103 -----------------------------
2104 -- Expand_Boolean_Operator --
2105 -----------------------------
2107 -- Note that we first get the actual subtypes of the operands, since we
2108 -- always want to deal with types that have bounds.
2110 procedure Expand_Boolean_Operator (N : Node_Id) is
2111 Typ : constant Entity_Id := Etype (N);
2114 -- Special case of bit packed array where both operands are known to be
2115 -- properly aligned. In this case we use an efficient run time routine
2116 -- to carry out the operation (see System.Bit_Ops).
2118 if Is_Bit_Packed_Array (Typ)
2119 and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2120 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2122 Expand_Packed_Boolean_Operator (N);
2126 -- For the normal non-packed case, the general expansion is to build
2127 -- function for carrying out the comparison (use Make_Boolean_Array_Op)
2128 -- and then inserting it into the tree. The original operator node is
2129 -- then rewritten as a call to this function. We also use this in the
2130 -- packed case if either operand is a possibly unaligned object.
2133 Loc : constant Source_Ptr := Sloc (N);
2134 L : constant Node_Id := Relocate_Node (Left_Opnd (N));
2135 R : Node_Id := Relocate_Node (Right_Opnd (N));
2136 Func_Body : Node_Id;
2137 Func_Name : Entity_Id;
2140 Convert_To_Actual_Subtype (L);
2141 Convert_To_Actual_Subtype (R);
2142 Ensure_Defined (Etype (L), N);
2143 Ensure_Defined (Etype (R), N);
2144 Apply_Length_Check (R, Etype (L));
2146 if Nkind (N) = N_Op_Xor then
2147 R := Duplicate_Subexpr (R);
2148 Silly_Boolean_Array_Xor_Test (N, R, Etype (L));
2151 if Nkind (Parent (N)) = N_Assignment_Statement
2152 and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2154 Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2156 elsif Nkind (Parent (N)) = N_Op_Not
2157 and then Nkind (N) = N_Op_And
2158 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
2159 and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2164 Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2165 Func_Name := Defining_Unit_Name (Specification (Func_Body));
2166 Insert_Action (N, Func_Body);
2168 -- Now rewrite the expression with a call
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))));
2179 Analyze_And_Resolve (N, Typ);
2182 end Expand_Boolean_Operator;
2184 ------------------------------------------------
2185 -- Expand_Compare_Minimize_Eliminate_Overflow --
2186 ------------------------------------------------
2188 procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2189 Loc : constant Source_Ptr := Sloc (N);
2191 Result_Type : constant Entity_Id := Etype (N);
2192 -- Capture result type (could be a derived boolean type)
2197 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2198 -- Entity for Long_Long_Integer'Base
2200 Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
2201 -- Current overflow checking mode
2204 procedure Set_False;
2205 -- These procedures rewrite N with an occurrence of Standard_True or
2206 -- Standard_False, and then makes a call to Warn_On_Known_Condition.
2212 procedure Set_False is
2214 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2215 Warn_On_Known_Condition (N);
2222 procedure Set_True is
2224 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2225 Warn_On_Known_Condition (N);
2228 -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2231 -- Nothing to do unless we have a comparison operator with operands
2232 -- that are signed integer types, and we are operating in either
2233 -- MINIMIZED or ELIMINATED overflow checking mode.
2235 if Nkind (N) not in N_Op_Compare
2236 or else Check not in Minimized_Or_Eliminated
2237 or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
2242 -- OK, this is the case we are interested in. First step is to process
2243 -- our operands using the Minimize_Eliminate circuitry which applies
2244 -- this processing to the two operand subtrees.
2246 Minimize_Eliminate_Overflows
2247 (Left_Opnd (N), Llo, Lhi, Top_Level => False);
2248 Minimize_Eliminate_Overflows
2249 (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
2251 -- See if the range information decides the result of the comparison.
2252 -- We can only do this if we in fact have full range information (which
2253 -- won't be the case if either operand is bignum at this stage).
2255 if Llo /= No_Uint and then Rlo /= No_Uint then
2256 case N_Op_Compare (Nkind (N)) is
2258 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2260 elsif Llo > Rhi or else Lhi < Rlo then
2267 elsif Lhi < Rlo then
2274 elsif Lhi <= Rlo then
2281 elsif Lhi <= Rlo then
2288 elsif Lhi < Rlo then
2293 if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2295 elsif Llo > Rhi or else Lhi < Rlo then
2300 -- All done if we did the rewrite
2302 if Nkind (N) not in N_Op_Compare then
2307 -- Otherwise, time to do the comparison
2310 Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2311 Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2314 -- If the two operands have the same signed integer type we are
2315 -- all set, nothing more to do. This is the case where either
2316 -- both operands were unchanged, or we rewrote both of them to
2317 -- be Long_Long_Integer.
2319 -- Note: Entity for the comparison may be wrong, but it's not worth
2320 -- the effort to change it, since the back end does not use it.
2322 if Is_Signed_Integer_Type (Ltype)
2323 and then Base_Type (Ltype) = Base_Type (Rtype)
2327 -- Here if bignums are involved (can only happen in ELIMINATED mode)
2329 elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2331 Left : Node_Id := Left_Opnd (N);
2332 Right : Node_Id := Right_Opnd (N);
2333 -- Bignum references for left and right operands
2336 if not Is_RTE (Ltype, RE_Bignum) then
2337 Left := Convert_To_Bignum (Left);
2338 elsif not Is_RTE (Rtype, RE_Bignum) then
2339 Right := Convert_To_Bignum (Right);
2342 -- We rewrite our node with:
2345 -- Bnn : Result_Type;
2347 -- M : Mark_Id := SS_Mark;
2349 -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2357 Blk : constant Node_Id := Make_Bignum_Block (Loc);
2358 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2362 case N_Op_Compare (Nkind (N)) is
2363 when N_Op_Eq => Ent := RE_Big_EQ;
2364 when N_Op_Ge => Ent := RE_Big_GE;
2365 when N_Op_Gt => Ent := RE_Big_GT;
2366 when N_Op_Le => Ent := RE_Big_LE;
2367 when N_Op_Lt => Ent := RE_Big_LT;
2368 when N_Op_Ne => Ent := RE_Big_NE;
2371 -- Insert assignment to Bnn into the bignum block
2374 (First (Statements (Handled_Statement_Sequence (Blk))),
2375 Make_Assignment_Statement (Loc,
2376 Name => New_Occurrence_Of (Bnn, Loc),
2378 Make_Function_Call (Loc,
2380 New_Occurrence_Of (RTE (Ent), Loc),
2381 Parameter_Associations => New_List (Left, Right))));
2383 -- Now do the rewrite with expression actions
2386 Make_Expression_With_Actions (Loc,
2387 Actions => New_List (
2388 Make_Object_Declaration (Loc,
2389 Defining_Identifier => Bnn,
2390 Object_Definition =>
2391 New_Occurrence_Of (Result_Type, Loc)),
2393 Expression => New_Occurrence_Of (Bnn, Loc)));
2394 Analyze_And_Resolve (N, Result_Type);
2398 -- No bignums involved, but types are different, so we must have
2399 -- rewritten one of the operands as a Long_Long_Integer but not
2402 -- If left operand is Long_Long_Integer, convert right operand
2403 -- and we are done (with a comparison of two Long_Long_Integers).
2405 elsif Ltype = LLIB then
2406 Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2407 Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2410 -- If right operand is Long_Long_Integer, convert left operand
2411 -- and we are done (with a comparison of two Long_Long_Integers).
2413 -- This is the only remaining possibility
2415 else pragma Assert (Rtype = LLIB);
2416 Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2417 Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2421 end Expand_Compare_Minimize_Eliminate_Overflow;
2423 -------------------------------
2424 -- Expand_Composite_Equality --
2425 -------------------------------
2427 -- This function is only called for comparing internal fields of composite
2428 -- types when these fields are themselves composites. This is a special
2429 -- case because it is not possible to respect normal Ada visibility rules.
2431 function Expand_Composite_Equality
2436 Bodies : List_Id) return Node_Id
2438 Loc : constant Source_Ptr := Sloc (Nod);
2439 Full_Type : Entity_Id;
2442 -- Start of processing for Expand_Composite_Equality
2445 if Is_Private_Type (Typ) then
2446 Full_Type := Underlying_Type (Typ);
2451 -- If the private type has no completion the context may be the
2452 -- expansion of a composite equality for a composite type with some
2453 -- still incomplete components. The expression will not be analyzed
2454 -- until the enclosing type is completed, at which point this will be
2455 -- properly expanded, unless there is a bona fide completion error.
2457 if No (Full_Type) then
2458 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2461 Full_Type := Base_Type (Full_Type);
2463 -- When the base type itself is private, use the full view to expand
2464 -- the composite equality.
2466 if Is_Private_Type (Full_Type) then
2467 Full_Type := Underlying_Type (Full_Type);
2470 -- Case of array types
2472 if Is_Array_Type (Full_Type) then
2474 -- If the operand is an elementary type other than a floating-point
2475 -- type, then we can simply use the built-in block bitwise equality,
2476 -- since the predefined equality operators always apply and bitwise
2477 -- equality is fine for all these cases.
2479 if Is_Elementary_Type (Component_Type (Full_Type))
2480 and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2482 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2484 -- For composite component types, and floating-point types, use the
2485 -- expansion. This deals with tagged component types (where we use
2486 -- the applicable equality routine) and floating-point (where we
2487 -- need to worry about negative zeroes), and also the case of any
2488 -- composite type recursively containing such fields.
2492 Comp_Typ : Entity_Id;
2499 -- Do the comparison in the type (or its full view) and not in
2500 -- its unconstrained base type, because the latter operation is
2501 -- more complex and would also require an unchecked conversion.
2503 if Is_Private_Type (Typ) then
2504 Comp_Typ := Underlying_Type (Typ);
2509 -- Except for the case where the bounds of the type depend on a
2510 -- discriminant, or else we would run into scoping issues.
2512 Indx := First_Index (Comp_Typ);
2513 while Present (Indx) loop
2514 Ityp := Etype (Indx);
2516 Lo := Type_Low_Bound (Ityp);
2517 Hi := Type_High_Bound (Ityp);
2519 if (Nkind (Lo) = N_Identifier
2520 and then Ekind (Entity (Lo)) = E_Discriminant)
2522 (Nkind (Hi) = N_Identifier
2523 and then Ekind (Entity (Hi)) = E_Discriminant)
2525 Comp_Typ := Full_Type;
2532 return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Comp_Typ);
2536 -- Case of tagged record types
2538 elsif Is_Tagged_Type (Full_Type) then
2539 Eq_Op := Find_Primitive_Eq (Typ);
2540 pragma Assert (Present (Eq_Op));
2543 Make_Function_Call (Loc,
2544 Name => New_Occurrence_Of (Eq_Op, Loc),
2545 Parameter_Associations =>
2547 (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2548 Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2550 -- Case of untagged record types
2552 elsif Is_Record_Type (Full_Type) then
2553 Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2555 if Present (Eq_Op) then
2556 if Etype (First_Formal (Eq_Op)) /= Full_Type then
2558 -- Inherited equality from parent type. Convert the actuals to
2559 -- match signature of operation.
2562 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2566 Make_Function_Call (Loc,
2567 Name => New_Occurrence_Of (Eq_Op, Loc),
2568 Parameter_Associations => New_List (
2569 OK_Convert_To (T, Lhs),
2570 OK_Convert_To (T, Rhs)));
2574 -- Comparison between Unchecked_Union components
2576 if Is_Unchecked_Union (Full_Type) then
2578 Lhs_Type : Node_Id := Full_Type;
2579 Rhs_Type : Node_Id := Full_Type;
2580 Lhs_Discr_Val : Node_Id;
2581 Rhs_Discr_Val : Node_Id;
2586 if Nkind (Lhs) = N_Selected_Component then
2587 Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2592 if Nkind (Rhs) = N_Selected_Component then
2593 Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2596 -- Lhs of the composite equality
2598 if Is_Constrained (Lhs_Type) then
2600 -- Since the enclosing record type can never be an
2601 -- Unchecked_Union (this code is executed for records
2602 -- that do not have variants), we may reference its
2605 if Nkind (Lhs) = N_Selected_Component
2606 and then Has_Per_Object_Constraint
2607 (Entity (Selector_Name (Lhs)))
2610 Make_Selected_Component (Loc,
2611 Prefix => Prefix (Lhs),
2614 (Get_Discriminant_Value
2615 (First_Discriminant (Lhs_Type),
2617 Stored_Constraint (Lhs_Type))));
2622 (Get_Discriminant_Value
2623 (First_Discriminant (Lhs_Type),
2625 Stored_Constraint (Lhs_Type)));
2629 -- It is not possible to infer the discriminant since
2630 -- the subtype is not constrained.
2633 Make_Raise_Program_Error (Loc,
2634 Reason => PE_Unchecked_Union_Restriction);
2637 -- Rhs of the composite equality
2639 if Is_Constrained (Rhs_Type) then
2640 if Nkind (Rhs) = N_Selected_Component
2641 and then Has_Per_Object_Constraint
2642 (Entity (Selector_Name (Rhs)))
2645 Make_Selected_Component (Loc,
2646 Prefix => Prefix (Rhs),
2649 (Get_Discriminant_Value
2650 (First_Discriminant (Rhs_Type),
2652 Stored_Constraint (Rhs_Type))));
2657 (Get_Discriminant_Value
2658 (First_Discriminant (Rhs_Type),
2660 Stored_Constraint (Rhs_Type)));
2665 Make_Raise_Program_Error (Loc,
2666 Reason => PE_Unchecked_Union_Restriction);
2669 -- Call the TSS equality function with the inferred
2670 -- discriminant values.
2673 Make_Function_Call (Loc,
2674 Name => New_Occurrence_Of (Eq_Op, Loc),
2675 Parameter_Associations => New_List (
2682 -- All cases other than comparing Unchecked_Union types
2686 T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2689 Make_Function_Call (Loc,
2691 New_Occurrence_Of (Eq_Op, Loc),
2692 Parameter_Associations => New_List (
2693 OK_Convert_To (T, Lhs),
2694 OK_Convert_To (T, Rhs)));
2699 -- Equality composes in Ada 2012 for untagged record types. It also
2700 -- composes for bounded strings, because they are part of the
2701 -- predefined environment. We could make it compose for bounded
2702 -- strings by making them tagged, or by making sure all subcomponents
2703 -- are set to the same value, even when not used. Instead, we have
2704 -- this special case in the compiler, because it's more efficient.
2706 elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
2708 -- If no TSS has been created for the type, check whether there is
2709 -- a primitive equality declared for it.
2712 Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
2715 -- Use user-defined primitive if it exists, otherwise use
2716 -- predefined equality.
2718 if Present (Op) then
2721 return Make_Op_Eq (Loc, Lhs, Rhs);
2726 return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2729 -- Non-composite types (always use predefined equality)
2732 return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2734 end Expand_Composite_Equality;
2736 ------------------------
2737 -- Expand_Concatenate --
2738 ------------------------
2740 procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2741 Loc : constant Source_Ptr := Sloc (Cnode);
2743 Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2744 -- Result type of concatenation
2746 Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2747 -- Component type. Elements of this component type can appear as one
2748 -- of the operands of concatenation as well as arrays.
2750 Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2753 Ityp : constant Entity_Id := Base_Type (Istyp);
2754 -- Index type. This is the base type of the index subtype, and is used
2755 -- for all computed bounds (which may be out of range of Istyp in the
2756 -- case of null ranges).
2759 -- This is the type we use to do arithmetic to compute the bounds and
2760 -- lengths of operands. The choice of this type is a little subtle and
2761 -- is discussed in a separate section at the start of the body code.
2763 Concatenation_Error : exception;
2764 -- Raised if concatenation is sure to raise a CE
2766 Result_May_Be_Null : Boolean := True;
2767 -- Reset to False if at least one operand is encountered which is known
2768 -- at compile time to be non-null. Used for handling the special case
2769 -- of setting the high bound to the last operand high bound for a null
2770 -- result, thus ensuring a proper high bound in the super-flat case.
2772 N : constant Nat := List_Length (Opnds);
2773 -- Number of concatenation operands including possibly null operands
2776 -- Number of operands excluding any known to be null, except that the
2777 -- last operand is always retained, in case it provides the bounds for
2780 Opnd : Node_Id := Empty;
2781 -- Current operand being processed in the loop through operands. After
2782 -- this loop is complete, always contains the last operand (which is not
2783 -- the same as Operands (NN), since null operands are skipped).
2785 -- Arrays describing the operands, only the first NN entries of each
2786 -- array are set (NN < N when we exclude known null operands).
2788 Is_Fixed_Length : array (1 .. N) of Boolean;
2789 -- True if length of corresponding operand known at compile time
2791 Operands : array (1 .. N) of Node_Id;
2792 -- Set to the corresponding entry in the Opnds list (but note that null
2793 -- operands are excluded, so not all entries in the list are stored).
2795 Fixed_Length : array (1 .. N) of Uint;
2796 -- Set to length of operand. Entries in this array are set only if the
2797 -- corresponding entry in Is_Fixed_Length is True.
2799 Opnd_Low_Bound : array (1 .. N) of Node_Id;
2800 -- Set to lower bound of operand. Either an integer literal in the case
2801 -- where the bound is known at compile time, else actual lower bound.
2802 -- The operand low bound is of type Ityp.
2804 Var_Length : array (1 .. N) of Entity_Id;
2805 -- Set to an entity of type Natural that contains the length of an
2806 -- operand whose length is not known at compile time. Entries in this
2807 -- array are set only if the corresponding entry in Is_Fixed_Length
2808 -- is False. The entity is of type Artyp.
2810 Aggr_Length : array (0 .. N) of Node_Id;
2811 -- The J'th entry in an expression node that represents the total length
2812 -- of operands 1 through J. It is either an integer literal node, or a
2813 -- reference to a constant entity with the right value, so it is fine
2814 -- to just do a Copy_Node to get an appropriate copy. The extra zeroth
2815 -- entry always is set to zero. The length is of type Artyp.
2817 Low_Bound : Node_Id;
2818 -- A tree node representing the low bound of the result (of type Ityp).
2819 -- This is either an integer literal node, or an identifier reference to
2820 -- a constant entity initialized to the appropriate value.
2822 Last_Opnd_Low_Bound : Node_Id := Empty;
2823 -- A tree node representing the low bound of the last operand. This
2824 -- need only be set if the result could be null. It is used for the
2825 -- special case of setting the right low bound for a null result.
2826 -- This is of type Ityp.
2828 Last_Opnd_High_Bound : Node_Id := Empty;
2829 -- A tree node representing the high bound of the last operand. This
2830 -- need only be set if the result could be null. It is used for the
2831 -- special case of setting the right high bound for a null result.
2832 -- This is of type Ityp.
2834 High_Bound : Node_Id := Empty;
2835 -- A tree node representing the high bound of the result (of type Ityp)
2838 -- Result of the concatenation (of type Ityp)
2840 Actions : constant List_Id := New_List;
2841 -- Collect actions to be inserted
2843 Known_Non_Null_Operand_Seen : Boolean;
2844 -- Set True during generation of the assignments of operands into
2845 -- result once an operand known to be non-null has been seen.
2847 function Library_Level_Target return Boolean;
2848 -- Return True if the concatenation is within the expression of the
2849 -- declaration of a library-level object.
2851 function Make_Artyp_Literal (Val : Nat) return Node_Id;
2852 -- This function makes an N_Integer_Literal node that is returned in
2853 -- analyzed form with the type set to Artyp. Importantly this literal
2854 -- is not flagged as static, so that if we do computations with it that
2855 -- result in statically detected out of range conditions, we will not
2856 -- generate error messages but instead warning messages.
2858 function To_Artyp (X : Node_Id) return Node_Id;
2859 -- Given a node of type Ityp, returns the corresponding value of type
2860 -- Artyp. For non-enumeration types, this is a plain integer conversion.
2861 -- For enum types, the Pos of the value is returned.
2863 function To_Ityp (X : Node_Id) return Node_Id;
2864 -- The inverse function (uses Val in the case of enumeration types)
2866 --------------------------
2867 -- Library_Level_Target --
2868 --------------------------
2870 function Library_Level_Target return Boolean is
2871 P : Node_Id := Parent (Cnode);
2874 while Present (P) loop
2875 if Nkind (P) = N_Object_Declaration then
2876 return Is_Library_Level_Entity (Defining_Identifier (P));
2878 -- Prevent the search from going too far
2880 elsif Is_Body_Or_Package_Declaration (P) then
2888 end Library_Level_Target;
2890 ------------------------
2891 -- Make_Artyp_Literal --
2892 ------------------------
2894 function Make_Artyp_Literal (Val : Nat) return Node_Id is
2895 Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2897 Set_Etype (Result, Artyp);
2898 Set_Analyzed (Result, True);
2899 Set_Is_Static_Expression (Result, False);
2901 end Make_Artyp_Literal;
2907 function To_Artyp (X : Node_Id) return Node_Id is
2909 if Ityp = Base_Type (Artyp) then
2912 elsif Is_Enumeration_Type (Ityp) then
2914 Make_Attribute_Reference (Loc,
2915 Prefix => New_Occurrence_Of (Ityp, Loc),
2916 Attribute_Name => Name_Pos,
2917 Expressions => New_List (X));
2920 return Convert_To (Artyp, X);
2928 function To_Ityp (X : Node_Id) return Node_Id is
2930 if Is_Enumeration_Type (Ityp) then
2932 Make_Attribute_Reference (Loc,
2933 Prefix => New_Occurrence_Of (Ityp, Loc),
2934 Attribute_Name => Name_Val,
2935 Expressions => New_List (X));
2937 -- Case where we will do a type conversion
2940 if Ityp = Base_Type (Artyp) then
2943 return Convert_To (Ityp, X);
2948 -- Local Declarations
2950 Opnd_Typ : Entity_Id;
2957 -- Start of processing for Expand_Concatenate
2960 -- Choose an appropriate computational type
2962 -- We will be doing calculations of lengths and bounds in this routine
2963 -- and computing one from the other in some cases, e.g. getting the high
2964 -- bound by adding the length-1 to the low bound.
2966 -- We can't just use the index type, or even its base type for this
2967 -- purpose for two reasons. First it might be an enumeration type which
2968 -- is not suitable for computations of any kind, and second it may
2969 -- simply not have enough range. For example if the index type is
2970 -- -128..+127 then lengths can be up to 256, which is out of range of
2973 -- For enumeration types, we can simply use Standard_Integer, this is
2974 -- sufficient since the actual number of enumeration literals cannot
2975 -- possibly exceed the range of integer (remember we will be doing the
2976 -- arithmetic with POS values, not representation values).
2978 if Is_Enumeration_Type (Ityp) then
2979 Artyp := Standard_Integer;
2981 -- If index type is Positive, we use the standard unsigned type, to give
2982 -- more room on the top of the range, obviating the need for an overflow
2983 -- check when creating the upper bound. This is needed to avoid junk
2984 -- overflow checks in the common case of String types.
2986 -- ??? Disabled for now
2988 -- elsif Istyp = Standard_Positive then
2989 -- Artyp := Standard_Unsigned;
2991 -- For modular types, we use a 32-bit modular type for types whose size
2992 -- is in the range 1-31 bits. For 32-bit unsigned types, we use the
2993 -- identity type, and for larger unsigned types we use 64-bits.
2995 elsif Is_Modular_Integer_Type (Ityp) then
2996 if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
2997 Artyp := Standard_Unsigned;
2998 elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
3001 Artyp := RTE (RE_Long_Long_Unsigned);
3004 -- Similar treatment for signed types
3007 if RM_Size (Ityp) < RM_Size (Standard_Integer) then
3008 Artyp := Standard_Integer;
3009 elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
3012 Artyp := Standard_Long_Long_Integer;
3016 -- Supply dummy entry at start of length array
3018 Aggr_Length (0) := Make_Artyp_Literal (0);
3020 -- Go through operands setting up the above arrays
3024 Opnd := Remove_Head (Opnds);
3025 Opnd_Typ := Etype (Opnd);
3027 -- The parent got messed up when we put the operands in a list,
3028 -- so now put back the proper parent for the saved operand, that
3029 -- is to say the concatenation node, to make sure that each operand
3030 -- is seen as a subexpression, e.g. if actions must be inserted.
3032 Set_Parent (Opnd, Cnode);
3034 -- Set will be True when we have setup one entry in the array
3038 -- Singleton element (or character literal) case
3040 if Base_Type (Opnd_Typ) = Ctyp then
3042 Operands (NN) := Opnd;
3043 Is_Fixed_Length (NN) := True;
3044 Fixed_Length (NN) := Uint_1;
3045 Result_May_Be_Null := False;
3047 -- Set low bound of operand (no need to set Last_Opnd_High_Bound
3048 -- since we know that the result cannot be null).
3050 Opnd_Low_Bound (NN) :=
3051 Make_Attribute_Reference (Loc,
3052 Prefix => New_Occurrence_Of (Istyp, Loc),
3053 Attribute_Name => Name_First);
3057 -- String literal case (can only occur for strings of course)
3059 elsif Nkind (Opnd) = N_String_Literal then
3060 Len := String_Literal_Length (Opnd_Typ);
3063 Result_May_Be_Null := False;
3066 -- Capture last operand low and high bound if result could be null
3068 if J = N and then Result_May_Be_Null then
3069 Last_Opnd_Low_Bound :=
3070 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3072 Last_Opnd_High_Bound :=
3073 Make_Op_Subtract (Loc,
3075 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
3076 Right_Opnd => Make_Integer_Literal (Loc, 1));
3079 -- Skip null string literal
3081 if J < N and then Len = 0 then
3086 Operands (NN) := Opnd;
3087 Is_Fixed_Length (NN) := True;
3089 -- Set length and bounds
3091 Fixed_Length (NN) := Len;
3093 Opnd_Low_Bound (NN) :=
3094 New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3101 -- Check constrained case with known bounds
3103 if Is_Constrained (Opnd_Typ) then
3105 Index : constant Node_Id := First_Index (Opnd_Typ);
3106 Indx_Typ : constant Entity_Id := Etype (Index);
3107 Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
3108 Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
3111 -- Fixed length constrained array type with known at compile
3112 -- time bounds is last case of fixed length operand.
3114 if Compile_Time_Known_Value (Lo)
3116 Compile_Time_Known_Value (Hi)
3119 Loval : constant Uint := Expr_Value (Lo);
3120 Hival : constant Uint := Expr_Value (Hi);
3121 Len : constant Uint :=
3122 UI_Max (Hival - Loval + 1, Uint_0);
3126 Result_May_Be_Null := False;
3129 -- Capture last operand bounds if result could be null
3131 if J = N and then Result_May_Be_Null then
3132 Last_Opnd_Low_Bound :=
3134 Make_Integer_Literal (Loc, Expr_Value (Lo)));
3136 Last_Opnd_High_Bound :=
3138 Make_Integer_Literal (Loc, Expr_Value (Hi)));
3141 -- Exclude null length case unless last operand
3143 if J < N and then Len = 0 then
3148 Operands (NN) := Opnd;
3149 Is_Fixed_Length (NN) := True;
3150 Fixed_Length (NN) := Len;
3152 Opnd_Low_Bound (NN) :=
3154 (Make_Integer_Literal (Loc, Expr_Value (Lo)));
3161 -- All cases where the length is not known at compile time, or the
3162 -- special case of an operand which is known to be null but has a
3163 -- lower bound other than 1 or is other than a string type.
3168 -- Capture operand bounds
3170 Opnd_Low_Bound (NN) :=
3171 Make_Attribute_Reference (Loc,
3173 Duplicate_Subexpr (Opnd, Name_Req => True),
3174 Attribute_Name => Name_First);
3176 -- Capture last operand bounds if result could be null
3178 if J = N and Result_May_Be_Null then
3179 Last_Opnd_Low_Bound :=
3181 Make_Attribute_Reference (Loc,
3183 Duplicate_Subexpr (Opnd, Name_Req => True),
3184 Attribute_Name => Name_First));
3186 Last_Opnd_High_Bound :=
3188 Make_Attribute_Reference (Loc,
3190 Duplicate_Subexpr (Opnd, Name_Req => True),
3191 Attribute_Name => Name_Last));
3194 -- Capture length of operand in entity
3196 Operands (NN) := Opnd;
3197 Is_Fixed_Length (NN) := False;
3199 Var_Length (NN) := Make_Temporary (Loc, 'L');
3202 Make_Object_Declaration (Loc,
3203 Defining_Identifier => Var_Length (NN),
3204 Constant_Present => True,
3205 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3207 Make_Attribute_Reference (Loc,
3209 Duplicate_Subexpr (Opnd, Name_Req => True),
3210 Attribute_Name => Name_Length)));
3214 -- Set next entry in aggregate length array
3216 -- For first entry, make either integer literal for fixed length
3217 -- or a reference to the saved length for variable length.
3220 if Is_Fixed_Length (1) then
3221 Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
3223 Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
3226 -- If entry is fixed length and only fixed lengths so far, make
3227 -- appropriate new integer literal adding new length.
3229 elsif Is_Fixed_Length (NN)
3230 and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3233 Make_Integer_Literal (Loc,
3234 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3236 -- All other cases, construct an addition node for the length and
3237 -- create an entity initialized to this length.
3240 Ent := Make_Temporary (Loc, 'L');
3242 if Is_Fixed_Length (NN) then
3243 Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3245 Clen := New_Occurrence_Of (Var_Length (NN), Loc);
3249 Make_Object_Declaration (Loc,
3250 Defining_Identifier => Ent,
3251 Constant_Present => True,
3252 Object_Definition => New_Occurrence_Of (Artyp, Loc),
3255 Left_Opnd => New_Copy_Tree (Aggr_Length (NN - 1)),
3256 Right_Opnd => Clen)));
3258 Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
3265 -- If we have only skipped null operands, return the last operand
3272 -- If we have only one non-null operand, return it and we are done.
3273 -- There is one case in which this cannot be done, and that is when
3274 -- the sole operand is of the element type, in which case it must be
3275 -- converted to an array, and the easiest way of doing that is to go
3276 -- through the normal general circuit.
3278 if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
3279 Result := Operands (1);
3283 -- Cases where we have a real concatenation
3285 -- Next step is to find the low bound for the result array that we
3286 -- will allocate. The rules for this are in (RM 4.5.6(5-7)).
3288 -- If the ultimate ancestor of the index subtype is a constrained array
3289 -- definition, then the lower bound is that of the index subtype as
3290 -- specified by (RM 4.5.3(6)).
3292 -- The right test here is to go to the root type, and then the ultimate
3293 -- ancestor is the first subtype of this root type.
3295 if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
3297 Make_Attribute_Reference (Loc,
3299 New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
3300 Attribute_Name => Name_First);
3302 -- If the first operand in the list has known length we know that
3303 -- the lower bound of the result is the lower bound of this operand.
3305 elsif Is_Fixed_Length (1) then
3306 Low_Bound := Opnd_Low_Bound (1);
3308 -- OK, we don't know the lower bound, we have to build a horrible
3309 -- if expression node of the form
3311 -- if Cond1'Length /= 0 then
3314 -- if Opnd2'Length /= 0 then
3319 -- The nesting ends either when we hit an operand whose length is known
3320 -- at compile time, or on reaching the last operand, whose low bound we
3321 -- take unconditionally whether or not it is null. It's easiest to do
3322 -- this with a recursive procedure:
3326 function Get_Known_Bound (J : Nat) return Node_Id;
3327 -- Returns the lower bound determined by operands J .. NN
3329 ---------------------
3330 -- Get_Known_Bound --
3331 ---------------------
3333 function Get_Known_Bound (J : Nat) return Node_Id is
3335 if Is_Fixed_Length (J) or else J = NN then
3336 return New_Copy_Tree (Opnd_Low_Bound (J));
3340 Make_If_Expression (Loc,
3341 Expressions => New_List (
3345 New_Occurrence_Of (Var_Length (J), Loc),
3347 Make_Integer_Literal (Loc, 0)),
3349 New_Copy_Tree (Opnd_Low_Bound (J)),
3350 Get_Known_Bound (J + 1)));
3352 end Get_Known_Bound;
3355 Ent := Make_Temporary (Loc, 'L');
3358 Make_Object_Declaration (Loc,
3359 Defining_Identifier => Ent,
3360 Constant_Present => True,
3361 Object_Definition => New_Occurrence_Of (Ityp, Loc),
3362 Expression => Get_Known_Bound (1)));
3364 Low_Bound := New_Occurrence_Of (Ent, Loc);
3368 -- Now we can safely compute the upper bound, normally
3369 -- Low_Bound + Length - 1.
3374 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3376 Make_Op_Subtract (Loc,
3377 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3378 Right_Opnd => Make_Artyp_Literal (1))));
3380 -- Note that calculation of the high bound may cause overflow in some
3381 -- very weird cases, so in the general case we need an overflow check on
3382 -- the high bound. We can avoid this for the common case of string types
3383 -- and other types whose index is Positive, since we chose a wider range
3384 -- for the arithmetic type. If checks are suppressed we do not set the
3385 -- flag, and possibly superfluous warnings will be omitted.
3387 if Istyp /= Standard_Positive
3388 and then not Overflow_Checks_Suppressed (Istyp)
3390 Activate_Overflow_Check (High_Bound);
3393 -- Handle the exceptional case where the result is null, in which case
3394 -- case the bounds come from the last operand (so that we get the proper
3395 -- bounds if the last operand is super-flat).
3397 if Result_May_Be_Null then
3399 Make_If_Expression (Loc,
3400 Expressions => New_List (
3402 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3403 Right_Opnd => Make_Artyp_Literal (0)),
3404 Last_Opnd_Low_Bound,
3408 Make_If_Expression (Loc,
3409 Expressions => New_List (
3411 Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
3412 Right_Opnd => Make_Artyp_Literal (0)),
3413 Last_Opnd_High_Bound,
3417 -- Here is where we insert the saved up actions
3419 Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3421 -- Now we construct an array object with appropriate bounds. We mark
3422 -- the target as internal to prevent useless initialization when
3423 -- Initialize_Scalars is enabled. Also since this is the actual result
3424 -- entity, we make sure we have debug information for the result.
3426 Ent := Make_Temporary (Loc, 'S');
3427 Set_Is_Internal (Ent);
3428 Set_Debug_Info_Needed (Ent);
3430 -- If the bound is statically known to be out of range, we do not want
3431 -- to abort, we want a warning and a runtime constraint error. Note that
3432 -- we have arranged that the result will not be treated as a static
3433 -- constant, so we won't get an illegality during this insertion.
3435 Insert_Action (Cnode,
3436 Make_Object_Declaration (Loc,
3437 Defining_Identifier => Ent,
3438 Object_Definition =>
3439 Make_Subtype_Indication (Loc,
3440 Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3442 Make_Index_Or_Discriminant_Constraint (Loc,
3443 Constraints => New_List (
3445 Low_Bound => Low_Bound,
3446 High_Bound => High_Bound))))),
3447 Suppress => All_Checks);
3449 -- If the result of the concatenation appears as the initializing
3450 -- expression of an object declaration, we can just rename the
3451 -- result, rather than copying it.
3453 Set_OK_To_Rename (Ent);
3455 -- Catch the static out of range case now
3457 if Raises_Constraint_Error (High_Bound) then
3458 raise Concatenation_Error;
3461 -- Now we will generate the assignments to do the actual concatenation
3463 -- There is one case in which we will not do this, namely when all the
3464 -- following conditions are met:
3466 -- The result type is Standard.String
3468 -- There are nine or fewer retained (non-null) operands
3470 -- The optimization level is -O0 or the debug flag gnatd.C is set,
3471 -- and the debug flag gnatd.c is not set.
3473 -- The corresponding System.Concat_n.Str_Concat_n routine is
3474 -- available in the run time.
3476 -- If all these conditions are met then we generate a call to the
3477 -- relevant concatenation routine. The purpose of this is to avoid
3478 -- undesirable code bloat at -O0.
3480 -- If the concatenation is within the declaration of a library-level
3481 -- object, we call the built-in concatenation routines to prevent code
3482 -- bloat, regardless of the optimization level. This is space efficient
3483 -- and prevents linking problems when units are compiled with different
3484 -- optimization levels.
3486 if Atyp = Standard_String
3487 and then NN in 2 .. 9
3488 and then (((Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3489 and then not Debug_Flag_Dot_C)
3490 or else Library_Level_Target)
3493 RR : constant array (Nat range 2 .. 9) of RE_Id :=
3504 if RTE_Available (RR (NN)) then
3506 Opnds : constant List_Id :=
3507 New_List (New_Occurrence_Of (Ent, Loc));
3510 for J in 1 .. NN loop
3511 if Is_List_Member (Operands (J)) then
3512 Remove (Operands (J));
3515 if Base_Type (Etype (Operands (J))) = Ctyp then
3517 Make_Aggregate (Loc,
3518 Component_Associations => New_List (
3519 Make_Component_Association (Loc,
3520 Choices => New_List (
3521 Make_Integer_Literal (Loc, 1)),
3522 Expression => Operands (J)))));
3525 Append_To (Opnds, Operands (J));
3529 Insert_Action (Cnode,
3530 Make_Procedure_Call_Statement (Loc,
3531 Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
3532 Parameter_Associations => Opnds));
3534 Result := New_Occurrence_Of (Ent, Loc);
3541 -- Not special case so generate the assignments
3543 Known_Non_Null_Operand_Seen := False;
3545 for J in 1 .. NN loop
3547 Lo : constant Node_Id :=
3549 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3550 Right_Opnd => Aggr_Length (J - 1));
3552 Hi : constant Node_Id :=
3554 Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
3556 Make_Op_Subtract (Loc,
3557 Left_Opnd => Aggr_Length (J),
3558 Right_Opnd => Make_Artyp_Literal (1)));
3561 -- Singleton case, simple assignment
3563 if Base_Type (Etype (Operands (J))) = Ctyp then
3564 Known_Non_Null_Operand_Seen := True;
3565 Insert_Action (Cnode,
3566 Make_Assignment_Statement (Loc,
3568 Make_Indexed_Component (Loc,
3569 Prefix => New_Occurrence_Of (Ent, Loc),
3570 Expressions => New_List (To_Ityp (Lo))),
3571 Expression => Operands (J)),
3572 Suppress => All_Checks);
3574 -- Array case, slice assignment, skipped when argument is fixed
3575 -- length and known to be null.
3577 elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3580 Make_Assignment_Statement (Loc,
3584 New_Occurrence_Of (Ent, Loc),
3587 Low_Bound => To_Ityp (Lo),
3588 High_Bound => To_Ityp (Hi))),
3589 Expression => Operands (J));
3591 if Is_Fixed_Length (J) then
3592 Known_Non_Null_Operand_Seen := True;
3594 elsif not Known_Non_Null_Operand_Seen then
3596 -- Here if operand length is not statically known and no
3597 -- operand known to be non-null has been processed yet.
3598 -- If operand length is 0, we do not need to perform the
3599 -- assignment, and we must avoid the evaluation of the
3600 -- high bound of the slice, since it may underflow if the
3601 -- low bound is Ityp'First.
3604 Make_Implicit_If_Statement (Cnode,
3608 New_Occurrence_Of (Var_Length (J), Loc),
3609 Right_Opnd => Make_Integer_Literal (Loc, 0)),
3610 Then_Statements => New_List (Assign));
3613 Insert_Action (Cnode, Assign, Suppress => All_Checks);
3619 -- Finally we build the result, which is a reference to the array object
3621 Result := New_Occurrence_Of (Ent, Loc);
3624 Rewrite (Cnode, Result);
3625 Analyze_And_Resolve (Cnode, Atyp);
3628 when Concatenation_Error =>
3630 -- Kill warning generated for the declaration of the static out of
3631 -- range high bound, and instead generate a Constraint_Error with
3632 -- an appropriate specific message.
3634 Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3635 Apply_Compile_Time_Constraint_Error
3637 Msg => "concatenation result upper bound out of range??",
3638 Reason => CE_Range_Check_Failed);
3639 end Expand_Concatenate;
3641 ---------------------------------------------------
3642 -- Expand_Membership_Minimize_Eliminate_Overflow --
3643 ---------------------------------------------------
3645 procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3646 pragma Assert (Nkind (N) = N_In);
3647 -- Despite the name, this routine applies only to N_In, not to
3648 -- N_Not_In. The latter is always rewritten as not (X in Y).
3650 Result_Type : constant Entity_Id := Etype (N);
3651 -- Capture result type, may be a derived boolean type
3653 Loc : constant Source_Ptr := Sloc (N);
3654 Lop : constant Node_Id := Left_Opnd (N);
3655 Rop : constant Node_Id := Right_Opnd (N);
3657 -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3658 -- is thus tempting to capture these values, but due to the rewrites
3659 -- that occur as a result of overflow checking, these values change
3660 -- as we go along, and it is safe just to always use Etype explicitly.
3662 Restype : constant Entity_Id := Etype (N);
3666 -- Bounds in Minimize calls, not used currently
3668 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3669 -- Entity for Long_Long_Integer'Base (Standard should export this???)
3672 Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3674 -- If right operand is a subtype name, and the subtype name has no
3675 -- predicate, then we can just replace the right operand with an
3676 -- explicit range T'First .. T'Last, and use the explicit range code.
3678 if Nkind (Rop) /= N_Range
3679 and then No (Predicate_Function (Etype (Rop)))
3682 Rtyp : constant Entity_Id := Etype (Rop);
3687 Make_Attribute_Reference (Loc,
3688 Attribute_Name => Name_First,
3689 Prefix => New_Occurrence_Of (Rtyp, Loc)),
3691 Make_Attribute_Reference (Loc,
3692 Attribute_Name => Name_Last,
3693 Prefix => New_Occurrence_Of (Rtyp, Loc))));
3694 Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3698 -- Here for the explicit range case. Note that the bounds of the range
3699 -- have not been processed for minimized or eliminated checks.
3701 if Nkind (Rop) = N_Range then
3702 Minimize_Eliminate_Overflows
3703 (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3704 Minimize_Eliminate_Overflows
3705 (High_Bound (Rop), Lo, Hi, Top_Level => False);
3707 -- We have A in B .. C, treated as A >= B and then A <= C
3711 if Is_RTE (Etype (Lop), RE_Bignum)
3712 or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3713 or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3716 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3717 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3718 L : constant Entity_Id :=
3719 Make_Defining_Identifier (Loc, Name_uL);
3720 Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
3721 Lbound : constant Node_Id :=
3722 Convert_To_Bignum (Low_Bound (Rop));
3723 Hbound : constant Node_Id :=
3724 Convert_To_Bignum (High_Bound (Rop));
3726 -- Now we rewrite the membership test node to look like
3729 -- Bnn : Result_Type;
3731 -- M : Mark_Id := SS_Mark;
3732 -- L : Bignum := Lopnd;
3734 -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3742 -- Insert declaration of L into declarations of bignum block
3745 (Last (Declarations (Blk)),
3746 Make_Object_Declaration (Loc,
3747 Defining_Identifier => L,
3748 Object_Definition =>
3749 New_Occurrence_Of (RTE (RE_Bignum), Loc),
3750 Expression => Lopnd));
3752 -- Insert assignment to Bnn into expressions of bignum block
3755 (First (Statements (Handled_Statement_Sequence (Blk))),
3756 Make_Assignment_Statement (Loc,
3757 Name => New_Occurrence_Of (Bnn, Loc),
3761 Make_Function_Call (Loc,
3763 New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3764 Parameter_Associations => New_List (
3765 New_Occurrence_Of (L, Loc),
3769 Make_Function_Call (Loc,
3771 New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3772 Parameter_Associations => New_List (
3773 New_Occurrence_Of (L, Loc),
3776 -- Now rewrite the node
3779 Make_Expression_With_Actions (Loc,
3780 Actions => New_List (
3781 Make_Object_Declaration (Loc,
3782 Defining_Identifier => Bnn,
3783 Object_Definition =>
3784 New_Occurrence_Of (Result_Type, Loc)),
3786 Expression => New_Occurrence_Of (Bnn, Loc)));
3787 Analyze_And_Resolve (N, Result_Type);
3791 -- Here if no bignums around
3794 -- Case where types are all the same
3796 if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3798 Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3802 -- If types are not all the same, it means that we have rewritten
3803 -- at least one of them to be of type Long_Long_Integer, and we
3804 -- will convert the other operands to Long_Long_Integer.
3807 Convert_To_And_Rewrite (LLIB, Lop);
3808 Set_Analyzed (Lop, False);
3809 Analyze_And_Resolve (Lop, LLIB);
3811 -- For the right operand, avoid unnecessary recursion into
3812 -- this routine, we know that overflow is not possible.
3814 Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3815 Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3816 Set_Analyzed (Rop, False);
3817 Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3820 -- Now the three operands are of the same signed integer type,
3821 -- so we can use the normal expansion routine for membership,
3822 -- setting the flag to prevent recursion into this procedure.
3824 Set_No_Minimize_Eliminate (N);
3828 -- Right operand is a subtype name and the subtype has a predicate. We
3829 -- have to make sure the predicate is checked, and for that we need to
3830 -- use the standard N_In circuitry with appropriate types.
3833 pragma Assert (Present (Predicate_Function (Etype (Rop))));
3835 -- If types are "right", just call Expand_N_In preventing recursion
3837 if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3838 Set_No_Minimize_Eliminate (N);
3843 elsif Is_RTE (Etype (Lop), RE_Bignum) then
3845 -- For X in T, we want to rewrite our node as
3848 -- Bnn : Result_Type;
3851 -- M : Mark_Id := SS_Mark;
3852 -- Lnn : Long_Long_Integer'Base
3858 -- if not Bignum_In_LLI_Range (Nnn) then
3861 -- Lnn := From_Bignum (Nnn);
3863 -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3864 -- and then T'Base (Lnn) in T;
3873 -- A bit gruesome, but there doesn't seem to be a simpler way
3876 Blk : constant Node_Id := Make_Bignum_Block (Loc);
3877 Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3878 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
3879 Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
3880 T : constant Entity_Id := Etype (Rop);
3881 TB : constant Entity_Id := Base_Type (T);
3885 -- Mark the last membership operation to prevent recursion
3889 Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
3890 Right_Opnd => New_Occurrence_Of (T, Loc));
3891 Set_No_Minimize_Eliminate (Nin);
3893 -- Now decorate the block
3896 (Last (Declarations (Blk)),
3897 Make_Object_Declaration (Loc,
3898 Defining_Identifier => Lnn,
3899 Object_Definition => New_Occurrence_Of (LLIB, Loc)));
3902 (Last (Declarations (Blk)),
3903 Make_Object_Declaration (Loc,
3904 Defining_Identifier => Nnn,
3905 Object_Definition =>
3906 New_Occurrence_Of (RTE (RE_Bignum), Loc)));
3909 (First (Statements (Handled_Statement_Sequence (Blk))),
3911 Make_Assignment_Statement (Loc,
3912 Name => New_Occurrence_Of (Nnn, Loc),
3913 Expression => Relocate_Node (Lop)),
3915 Make_Implicit_If_Statement (N,
3919 Make_Function_Call (Loc,
3922 (RTE (RE_Bignum_In_LLI_Range), Loc),
3923 Parameter_Associations => New_List (
3924 New_Occurrence_Of (Nnn, Loc)))),
3926 Then_Statements => New_List (
3927 Make_Assignment_Statement (Loc,
3928 Name => New_Occurrence_Of (Bnn, Loc),
3930 New_Occurrence_Of (Standard_False, Loc))),
3932 Else_Statements => New_List (
3933 Make_Assignment_Statement (Loc,
3934 Name => New_Occurrence_Of (Lnn, Loc),
3936 Make_Function_Call (Loc,
3938 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
3939 Parameter_Associations => New_List (
3940 New_Occurrence_Of (Nnn, Loc)))),
3942 Make_Assignment_Statement (Loc,
3943 Name => New_Occurrence_Of (Bnn, Loc),
3948 Left_Opnd => New_Occurrence_Of (Lnn, Loc),
3953 Make_Attribute_Reference (Loc,
3954 Attribute_Name => Name_First,
3956 New_Occurrence_Of (TB, Loc))),
3960 Make_Attribute_Reference (Loc,
3961 Attribute_Name => Name_Last,
3963 New_Occurrence_Of (TB, Loc))))),
3965 Right_Opnd => Nin))))));
3967 -- Now we can do the rewrite
3970 Make_Expression_With_Actions (Loc,
3971 Actions => New_List (
3972 Make_Object_Declaration (Loc,
3973 Defining_Identifier => Bnn,
3974 Object_Definition =>
3975 New_Occurrence_Of (Result_Type, Loc)),
3977 Expression => New_Occurrence_Of (Bnn, Loc)));
3978 Analyze_And_Resolve (N, Result_Type);
3982 -- Not bignum case, but types don't match (this means we rewrote the
3983 -- left operand to be Long_Long_Integer).
3986 pragma Assert (Base_Type (Etype (Lop)) = LLIB);
3988 -- We rewrite the membership test as (where T is the type with
3989 -- the predicate, i.e. the type of the right operand)
3991 -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3992 -- and then T'Base (Lop) in T
3995 T : constant Entity_Id := Etype (Rop);
3996 TB : constant Entity_Id := Base_Type (T);
4000 -- The last membership test is marked to prevent recursion
4004 Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
4005 Right_Opnd => New_Occurrence_Of (T, Loc));
4006 Set_No_Minimize_Eliminate (Nin);
4008 -- Now do the rewrite
4019 Make_Attribute_Reference (Loc,
4020 Attribute_Name => Name_First,
4022 New_Occurrence_Of (TB, Loc))),
4025 Make_Attribute_Reference (Loc,
4026 Attribute_Name => Name_Last,
4028 New_Occurrence_Of (TB, Loc))))),
4029 Right_Opnd => Nin));
4030 Set_Analyzed (N, False);
4031 Analyze_And_Resolve (N, Restype);
4035 end Expand_Membership_Minimize_Eliminate_Overflow;
4037 ---------------------------------
4038 -- Expand_Nonbinary_Modular_Op --
4039 ---------------------------------
4041 procedure Expand_Nonbinary_Modular_Op (N : Node_Id) is
4042 Loc : constant Source_Ptr := Sloc (N);
4043 Typ : constant Entity_Id := Etype (N);
4045 procedure Expand_Modular_Addition;
4046 -- Expand the modular addition, handling the special case of adding a
4049 procedure Expand_Modular_Op;
4050 -- Compute the general rule: (lhs OP rhs) mod Modulus
4052 procedure Expand_Modular_Subtraction;
4053 -- Expand the modular addition, handling the special case of subtracting
4056 -----------------------------
4057 -- Expand_Modular_Addition --
4058 -----------------------------
4060 procedure Expand_Modular_Addition is
4062 -- If this is not the addition of a constant then compute it using
4063 -- the general rule: (lhs + rhs) mod Modulus
4065 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4068 -- If this is an addition of a constant, convert it to a subtraction
4069 -- plus a conditional expression since we can compute it faster than
4070 -- computing the modulus.
4072 -- modMinusRhs = Modulus - rhs
4073 -- if lhs < modMinusRhs then lhs + rhs
4074 -- else lhs - modMinusRhs
4078 Mod_Minus_Right : constant Uint :=
4079 Modulus (Typ) - Intval (Right_Opnd (N));
4081 Exprs : constant List_Id := New_List;
4082 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4083 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4084 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4087 -- To prevent spurious visibility issues, convert all
4088 -- operands to Standard.Unsigned.
4090 Set_Left_Opnd (Cond_Expr,
4091 Unchecked_Convert_To (Standard_Unsigned,
4092 New_Copy_Tree (Left_Opnd (N))));
4093 Set_Right_Opnd (Cond_Expr,
4094 Make_Integer_Literal (Loc, Mod_Minus_Right));
4095 Append_To (Exprs, Cond_Expr);
4097 Set_Left_Opnd (Then_Expr,
4098 Unchecked_Convert_To (Standard_Unsigned,
4099 New_Copy_Tree (Left_Opnd (N))));
4100 Set_Right_Opnd (Then_Expr,
4101 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4102 Append_To (Exprs, Then_Expr);
4104 Set_Left_Opnd (Else_Expr,
4105 Unchecked_Convert_To (Standard_Unsigned,
4106 New_Copy_Tree (Left_Opnd (N))));
4107 Set_Right_Opnd (Else_Expr,
4108 Make_Integer_Literal (Loc, Mod_Minus_Right));
4109 Append_To (Exprs, Else_Expr);
4112 Unchecked_Convert_To (Typ,
4113 Make_If_Expression (Loc, Expressions => Exprs)));
4116 end Expand_Modular_Addition;
4118 -----------------------
4119 -- Expand_Modular_Op --
4120 -----------------------
4122 procedure Expand_Modular_Op is
4123 Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc);
4124 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc);
4126 Target_Type : Entity_Id;
4129 -- Convert nonbinary modular type operands into integer values. Thus
4130 -- we avoid never-ending loops expanding them, and we also ensure
4131 -- the back end never receives nonbinary modular type expressions.
4133 if Nkind_In (Nkind (N), N_Op_And, N_Op_Or, N_Op_Xor) then
4134 Set_Left_Opnd (Op_Expr,
4135 Unchecked_Convert_To (Standard_Unsigned,
4136 New_Copy_Tree (Left_Opnd (N))));
4137 Set_Right_Opnd (Op_Expr,
4138 Unchecked_Convert_To (Standard_Unsigned,
4139 New_Copy_Tree (Right_Opnd (N))));
4140 Set_Left_Opnd (Mod_Expr,
4141 Unchecked_Convert_To (Standard_Integer, Op_Expr));
4144 -- If the modulus of the type is larger than Integer'Last use a
4145 -- larger type for the operands, to prevent spurious constraint
4146 -- errors on large legal literals of the type.
4148 if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then
4149 Target_Type := Standard_Long_Integer;
4151 Target_Type := Standard_Integer;
4154 Set_Left_Opnd (Op_Expr,
4155 Unchecked_Convert_To (Target_Type,
4156 New_Copy_Tree (Left_Opnd (N))));
4157 Set_Right_Opnd (Op_Expr,
4158 Unchecked_Convert_To (Target_Type,
4159 New_Copy_Tree (Right_Opnd (N))));
4161 -- Link this node to the tree to analyze it
4163 -- If the parent node is an expression with actions we link it to
4164 -- N since otherwise Force_Evaluation cannot identify if this node
4165 -- comes from the Expression and rejects generating the temporary.
4167 if Nkind (Parent (N)) = N_Expression_With_Actions then
4168 Set_Parent (Op_Expr, N);
4173 Set_Parent (Op_Expr, Parent (N));
4178 -- Force generating a temporary because in the expansion of this
4179 -- expression we may generate code that performs this computation
4182 Force_Evaluation (Op_Expr, Mode => Strict);
4184 Set_Left_Opnd (Mod_Expr, Op_Expr);
4187 Set_Right_Opnd (Mod_Expr,
4188 Make_Integer_Literal (Loc, Modulus (Typ)));
4191 Unchecked_Convert_To (Typ, Mod_Expr));
4192 end Expand_Modular_Op;
4194 --------------------------------
4195 -- Expand_Modular_Subtraction --
4196 --------------------------------
4198 procedure Expand_Modular_Subtraction is
4200 -- If this is not the addition of a constant then compute it using
4201 -- the general rule: (lhs + rhs) mod Modulus
4203 if Nkind (Right_Opnd (N)) /= N_Integer_Literal then
4206 -- If this is an addition of a constant, convert it to a subtraction
4207 -- plus a conditional expression since we can compute it faster than
4208 -- computing the modulus.
4210 -- modMinusRhs = Modulus - rhs
4211 -- if lhs < rhs then lhs + modMinusRhs
4216 Mod_Minus_Right : constant Uint :=
4217 Modulus (Typ) - Intval (Right_Opnd (N));
4219 Exprs : constant List_Id := New_List;
4220 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
4221 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
4222 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
4225 Set_Left_Opnd (Cond_Expr,
4226 Unchecked_Convert_To (Standard_Unsigned,
4227 New_Copy_Tree (Left_Opnd (N))));
4228 Set_Right_Opnd (Cond_Expr,
4229 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
4230 Append_To (Exprs, Cond_Expr);
4232 Set_Left_Opnd (Then_Expr,
4233 Unchecked_Convert_To (Standard_Unsigned,
4234 New_Copy_Tree (Left_Opnd (N))));
4235 Set_Right_Opnd (Then_Expr,
4236 Make_Integer_Literal (Loc, Mod_Minus_Right));
4237 Append_To (Exprs, Then_Expr);
4239 Set_Left_Opnd (Else_Expr,
4240 Unchecked_Convert_To (Standard_Unsigned,
4241 New_Copy_Tree (Left_Opnd (N))));
4242 Set_Right_Opnd (Else_Expr,
4243 Unchecked_Convert_To (Standard_Unsigned,
4244 New_Copy_Tree (Right_Opnd (N))));
4245 Append_To (Exprs, Else_Expr);
4248 Unchecked_Convert_To (Typ,
4249 Make_If_Expression (Loc, Expressions => Exprs)));
4252 end Expand_Modular_Subtraction;
4254 -- Start of processing for Expand_Nonbinary_Modular_Op
4257 -- No action needed if front-end expansion is not required or if we
4258 -- have a binary modular operand.
4260 if not Expand_Nonbinary_Modular_Ops
4261 or else not Non_Binary_Modulus (Typ)
4268 Expand_Modular_Addition;
4270 when N_Op_Subtract =>
4271 Expand_Modular_Subtraction;
4275 -- Expand -expr into (0 - expr)
4278 Make_Op_Subtract (Loc,
4279 Left_Opnd => Make_Integer_Literal (Loc, 0),
4280 Right_Opnd => Right_Opnd (N)));
4281 Analyze_And_Resolve (N, Typ);
4287 Analyze_And_Resolve (N, Typ);
4288 end Expand_Nonbinary_Modular_Op;
4290 ------------------------
4291 -- Expand_N_Allocator --
4292 ------------------------
4294 procedure Expand_N_Allocator (N : Node_Id) is
4295 Etyp : constant Entity_Id := Etype (Expression (N));
4296 Loc : constant Source_Ptr := Sloc (N);
4297 PtrT : constant Entity_Id := Etype (N);
4299 procedure Rewrite_Coextension (N : Node_Id);
4300 -- Static coextensions have the same lifetime as the entity they
4301 -- constrain. Such occurrences can be rewritten as aliased objects
4302 -- and their unrestricted access used instead of the coextension.
4304 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
4305 -- Given a constrained array type E, returns a node representing the
4306 -- code to compute a close approximation of the size in storage elements
4307 -- for the given type; for indexes that are modular types we compute
4308 -- 'Last - First (instead of 'Length) because for large arrays computing
4309 -- 'Last -'First + 1 causes overflow. This is done without using the
4310 -- attribute 'Size_In_Storage_Elements (which malfunctions for large
4313 -------------------------
4314 -- Rewrite_Coextension --
4315 -------------------------
4317 procedure Rewrite_Coextension (N : Node_Id) is
4318 Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
4319 Temp_Decl : Node_Id;
4323 -- Cnn : aliased Etyp;
4326 Make_Object_Declaration (Loc,
4327 Defining_Identifier => Temp_Id,
4328 Aliased_Present => True,
4329 Object_Definition => New_Occurrence_Of (Etyp, Loc));
4331 if Nkind (Expression (N)) = N_Qualified_Expression then
4332 Set_Expression (Temp_Decl, Expression (Expression (N)));
4335 Insert_Action (N, Temp_Decl);
4337 Make_Attribute_Reference (Loc,
4338 Prefix => New_Occurrence_Of (Temp_Id, Loc),
4339 Attribute_Name => Name_Unrestricted_Access));
4341 Analyze_And_Resolve (N, PtrT);
4342 end Rewrite_Coextension;
4344 ------------------------------
4345 -- Size_In_Storage_Elements --
4346 ------------------------------
4348 function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
4350 -- Logically this just returns E'Max_Size_In_Storage_Elements.
4351 -- However, the reason for the existence of this function is
4352 -- to construct a test for sizes too large, which means near the
4353 -- 32-bit limit on a 32-bit machine, and precisely the trouble
4354 -- is that we get overflows when sizes are greater than 2**31.
4356 -- So what we end up doing for array types is to use the expression:
4358 -- number-of-elements * component_type'Max_Size_In_Storage_Elements
4360 -- which avoids this problem. All this is a bit bogus, but it does
4361 -- mean we catch common cases of trying to allocate arrays that
4362 -- are too large, and which in the absence of a check results in
4363 -- undetected chaos ???
4365 -- Note in particular that this is a pessimistic estimate in the
4366 -- case of packed array types, where an array element might occupy
4367 -- just a fraction of a storage element???
4370 Idx : Node_Id := First_Index (E);
4373 pragma Warnings (Off, Res);
4376 for J in 1 .. Number_Dimensions (E) loop
4378 if not Is_Modular_Integer_Type (Etype (Idx)) then
4380 Make_Attribute_Reference (Loc,
4381 Prefix => New_Occurrence_Of (E, Loc),
4382 Attribute_Name => Name_Length,
4383 Expressions => New_List
4384 (Make_Integer_Literal (Loc, J)));
4386 -- For indexes that are modular types we cannot generate code
4387 -- to compute 'Length since for large arrays 'Last -'First + 1
4388 -- causes overflow; therefore we compute 'Last - 'First (which
4389 -- is not the exact number of components but it is valid for
4390 -- the purpose of this runtime check on 32-bit targets).
4394 Len_Minus_1_Expr : Node_Id;
4400 Make_Attribute_Reference (Loc,
4401 Prefix => New_Occurrence_Of (E, Loc),
4402 Attribute_Name => Name_Last,
4404 New_List (Make_Integer_Literal (Loc, J))),
4405 Make_Attribute_Reference (Loc,
4406 Prefix => New_Occurrence_Of (E, Loc),
4407 Attribute_Name => Name_First,
4409 New_List (Make_Integer_Literal (Loc, J))));
4412 Convert_To (Standard_Unsigned,
4413 Make_Op_Subtract (Loc,
4414 Make_Attribute_Reference (Loc,
4415 Prefix => New_Occurrence_Of (E, Loc),
4416 Attribute_Name => Name_Last,
4419 (Make_Integer_Literal (Loc, J))),
4420 Make_Attribute_Reference (Loc,
4421 Prefix => New_Occurrence_Of (E, Loc),
4422 Attribute_Name => Name_First,
4425 (Make_Integer_Literal (Loc, J)))));
4427 -- Handle superflat arrays, i.e. arrays with such bounds
4428 -- as 4 .. 2, to ensure that the result is correct.
4431 -- (if X'Last > X'First then X'Last - X'First else 0)
4434 Make_If_Expression (Loc,
4435 Expressions => New_List (
4438 Make_Integer_Literal (Loc, Uint_0)));
4447 Make_Op_Multiply (Loc,
4456 Make_Op_Multiply (Loc,
4459 Make_Attribute_Reference (Loc,
4460 Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4461 Attribute_Name => Name_Max_Size_In_Storage_Elements));
4463 end Size_In_Storage_Elements;
4467 Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
4471 Rel_Typ : Entity_Id;
4474 -- Start of processing for Expand_N_Allocator
4477 -- Warn on the presence of an allocator of an anonymous access type when
4478 -- enabled, except when it's an object declaration at library level.
4480 if Warn_On_Anonymous_Allocators
4481 and then Ekind (PtrT) = E_Anonymous_Access_Type
4482 and then not (Is_Library_Level_Entity (PtrT)
4483 and then Nkind (Associated_Node_For_Itype (PtrT)) =
4484 N_Object_Declaration)
4486 Error_Msg_N ("?use of an anonymous access type allocator", N);
4489 -- RM E.2.3(22). We enforce that the expected type of an allocator
4490 -- shall not be a remote access-to-class-wide-limited-private type
4492 -- Why is this being done at expansion time, seems clearly wrong ???
4494 Validate_Remote_Access_To_Class_Wide_Type (N);
4496 -- Processing for anonymous access-to-controlled types. These access
4497 -- types receive a special finalization master which appears in the
4498 -- declarations of the enclosing semantic unit. This expansion is done
4499 -- now to ensure that any additional types generated by this routine or
4500 -- Expand_Allocator_Expression inherit the proper type attributes.
4502 if (Ekind (PtrT) = E_Anonymous_Access_Type
4503 or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4504 and then Needs_Finalization (Dtyp)
4506 -- Detect the allocation of an anonymous controlled object where the
4507 -- type of the context is named. For example:
4509 -- procedure Proc (Ptr : Named_Access_Typ);
4510 -- Proc (new Designated_Typ);
4512 -- Regardless of the anonymous-to-named access type conversion, the
4513 -- lifetime of the object must be associated with the named access
4514 -- type. Use the finalization-related attributes of this type.
4516 if Nkind_In (Parent (N), N_Type_Conversion,
4517 N_Unchecked_Type_Conversion)
4518 and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
4520 E_General_Access_Type)
4522 Rel_Typ := Etype (Parent (N));
4527 -- Anonymous access-to-controlled types allocate on the global pool.
4528 -- Note that this is a "root type only" attribute.
4530 if No (Associated_Storage_Pool (PtrT)) then
4531 if Present (Rel_Typ) then
4532 Set_Associated_Storage_Pool
4533 (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ));
4535 Set_Associated_Storage_Pool
4536 (Root_Type (PtrT), RTE (RE_Global_Pool_Object));
4540 -- The finalization master must be inserted and analyzed as part of
4541 -- the current semantic unit. Note that the master is updated when
4542 -- analysis changes current units. Note that this is a "root type
4545 if Present (Rel_Typ) then
4546 Set_Finalization_Master
4547 (Root_Type (PtrT), Finalization_Master (Rel_Typ));
4549 Build_Anonymous_Master (Root_Type (PtrT));
4553 -- Set the storage pool and find the appropriate version of Allocate to
4554 -- call. Do not overwrite the storage pool if it is already set, which
4555 -- can happen for build-in-place function returns (see
4556 -- Exp_Ch4.Expand_N_Extended_Return_Statement).
4558 if No (Storage_Pool (N)) then
4559 Pool := Associated_Storage_Pool (Root_Type (PtrT));
4561 if Present (Pool) then
4562 Set_Storage_Pool (N, Pool);
4564 if Is_RTE (Pool, RE_SS_Pool) then
4565 Check_Restriction (No_Secondary_Stack, N);
4566 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4568 -- In the case of an allocator for a simple storage pool, locate
4569 -- and save a reference to the pool type's Allocate routine.
4571 elsif Present (Get_Rep_Pragma
4572 (Etype (Pool), Name_Simple_Storage_Pool_Type))
4575 Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4576 Alloc_Op : Entity_Id;
4578 Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4579 while Present (Alloc_Op) loop
4580 if Scope (Alloc_Op) = Scope (Pool_Type)
4581 and then Present (First_Formal (Alloc_Op))
4582 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4584 Set_Procedure_To_Call (N, Alloc_Op);
4587 Alloc_Op := Homonym (Alloc_Op);
4592 elsif Is_Class_Wide_Type (Etype (Pool)) then
4593 Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4596 Set_Procedure_To_Call (N,
4597 Find_Prim_Op (Etype (Pool), Name_Allocate));
4602 -- Under certain circumstances we can replace an allocator by an access
4603 -- to statically allocated storage. The conditions, as noted in AARM
4604 -- 3.10 (10c) are as follows:
4606 -- Size and initial value is known at compile time
4607 -- Access type is access-to-constant
4609 -- The allocator is not part of a constraint on a record component,
4610 -- because in that case the inserted actions are delayed until the
4611 -- record declaration is fully analyzed, which is too late for the
4612 -- analysis of the rewritten allocator.
4614 if Is_Access_Constant (PtrT)
4615 and then Nkind (Expression (N)) = N_Qualified_Expression
4616 and then Compile_Time_Known_Value (Expression (Expression (N)))
4617 and then Size_Known_At_Compile_Time
4618 (Etype (Expression (Expression (N))))
4619 and then not Is_Record_Type (Current_Scope)
4621 -- Here we can do the optimization. For the allocator
4625 -- We insert an object declaration
4627 -- Tnn : aliased x := y;
4629 -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4630 -- marked as requiring static allocation.
4632 Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4633 Desig := Subtype_Mark (Expression (N));
4635 -- If context is constrained, use constrained subtype directly,
4636 -- so that the constant is not labelled as having a nominally
4637 -- unconstrained subtype.
4639 if Entity (Desig) = Base_Type (Dtyp) then
4640 Desig := New_Occurrence_Of (Dtyp, Loc);
4644 Make_Object_Declaration (Loc,
4645 Defining_Identifier => Temp,
4646 Aliased_Present => True,
4647 Constant_Present => Is_Access_Constant (PtrT),
4648 Object_Definition => Desig,
4649 Expression => Expression (Expression (N))));
4652 Make_Attribute_Reference (Loc,
4653 Prefix => New_Occurrence_Of (Temp, Loc),
4654 Attribute_Name => Name_Unrestricted_Access));
4656 Analyze_And_Resolve (N, PtrT);
4658 -- We set the variable as statically allocated, since we don't want
4659 -- it going on the stack of the current procedure.
4661 Set_Is_Statically_Allocated (Temp);
4665 -- Same if the allocator is an access discriminant for a local object:
4666 -- instead of an allocator we create a local value and constrain the
4667 -- enclosing object with the corresponding access attribute.
4669 if Is_Static_Coextension (N) then
4670 Rewrite_Coextension (N);
4674 -- Check for size too large, we do this because the back end misses
4675 -- proper checks here and can generate rubbish allocation calls when
4676 -- we are near the limit. We only do this for the 32-bit address case
4677 -- since that is from a practical point of view where we see a problem.
4679 if System_Address_Size = 32
4680 and then not Storage_Checks_Suppressed (PtrT)
4681 and then not Storage_Checks_Suppressed (Dtyp)
4682 and then not Storage_Checks_Suppressed (Etyp)
4684 -- The check we want to generate should look like
4686 -- if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4687 -- raise Storage_Error;
4690 -- where 3.5 gigabytes is a constant large enough to accommodate any
4691 -- reasonable request for. But we can't do it this way because at
4692 -- least at the moment we don't compute this attribute right, and
4693 -- can silently give wrong results when the result gets large. Since
4694 -- this is all about large results, that's bad, so instead we only
4695 -- apply the check for constrained arrays, and manually compute the
4696 -- value of the attribute ???
4698 -- The check on No_Initialization is used here to prevent generating
4699 -- this runtime check twice when the allocator is locally replaced by
4700 -- the expander with another one.
4702 if Is_Array_Type (Etyp) and then not No_Initialization (N) then
4705 Ins_Nod : Node_Id := N;
4706 Siz_Typ : Entity_Id := Etyp;
4710 -- For unconstrained array types initialized with a qualified
4711 -- expression we use its type to perform this check
4713 if not Is_Constrained (Etyp)
4714 and then not No_Initialization (N)
4715 and then Nkind (Expression (N)) = N_Qualified_Expression
4717 Expr := Expression (Expression (N));
4718 Siz_Typ := Etype (Expression (Expression (N)));
4720 -- If the qualified expression has been moved to an internal
4721 -- temporary (to remove side effects) then we must insert
4722 -- the runtime check before its declaration to ensure that
4723 -- the check is performed before the execution of the code
4724 -- computing the qualified expression.
4726 if Nkind (Expr) = N_Identifier
4727 and then Is_Internal_Name (Chars (Expr))
4729 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
4731 Ins_Nod := Parent (Entity (Expr));
4737 if Is_Constrained (Siz_Typ)
4738 and then Ekind (Siz_Typ) /= E_String_Literal_Subtype
4740 -- For CCG targets, the largest array may have up to 2**31-1
4741 -- components (i.e. 2 gigabytes if each array component is
4742 -- one byte). This ensures that fat pointer fields do not
4743 -- overflow, since they are 32-bit integer types, and also
4744 -- ensures that 'Length can be computed at run time.
4746 if Modify_Tree_For_C then
4749 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4750 Right_Opnd => Make_Integer_Literal (Loc,
4751 Uint_2 ** 31 - Uint_1));
4753 -- For native targets the largest object is 3.5 gigabytes
4758 Left_Opnd => Size_In_Storage_Elements (Siz_Typ),
4759 Right_Opnd => Make_Integer_Literal (Loc,
4760 Uint_7 * (Uint_2 ** 29)));
4763 Insert_Action (Ins_Nod,
4764 Make_Raise_Storage_Error (Loc,
4766 Reason => SE_Object_Too_Large));
4768 if Entity (Cond) = Standard_True then
4770 ("object too large: Storage_Error will be raised at "
4778 -- If no storage pool has been specified, or the storage pool
4779 -- is System.Pool_Global.Global_Pool_Object, and the restriction
4780 -- No_Standard_Allocators_After_Elaboration is present, then generate
4781 -- a call to Elaboration_Allocators.Check_Standard_Allocator.
4783 if Nkind (N) = N_Allocator
4784 and then (No (Storage_Pool (N))
4785 or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object))
4786 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
4789 Make_Procedure_Call_Statement (Loc,
4791 New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc)));
4794 -- Handle case of qualified expression (other than optimization above)
4795 -- First apply constraint checks, because the bounds or discriminants
4796 -- in the aggregate might not match the subtype mark in the allocator.
4798 if Nkind (Expression (N)) = N_Qualified_Expression then
4800 Exp : constant Node_Id := Expression (Expression (N));
4801 Typ : constant Entity_Id := Etype (Expression (N));
4804 Apply_Constraint_Check (Exp, Typ);
4805 Apply_Predicate_Check (Exp, Typ);
4808 Expand_Allocator_Expression (N);
4812 -- If the allocator is for a type which requires initialization, and
4813 -- there is no initial value (i.e. operand is a subtype indication
4814 -- rather than a qualified expression), then we must generate a call to
4815 -- the initialization routine using an expressions action node:
4817 -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4819 -- Here ptr_T is the pointer type for the allocator, and T is the
4820 -- subtype of the allocator. A special case arises if the designated
4821 -- type of the access type is a task or contains tasks. In this case
4822 -- the call to Init (Temp.all ...) is replaced by code that ensures
4823 -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4824 -- for details). In addition, if the type T is a task type, then the
4825 -- first argument to Init must be converted to the task record type.
4828 T : constant Entity_Id := Etype (Expression (N));
4834 Init_Arg1 : Node_Id;
4835 Init_Call : Node_Id;
4836 Temp_Decl : Node_Id;
4837 Temp_Type : Entity_Id;
4840 if No_Initialization (N) then
4842 -- Even though this might be a simple allocation, create a custom
4843 -- Allocate if the context requires it.
4845 if Present (Finalization_Master (PtrT)) then
4846 Build_Allocate_Deallocate_Proc
4848 Is_Allocate => True);
4851 -- Optimize the default allocation of an array object when pragma
4852 -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
4853 -- in-place initialization aggregate which may be convert into a fast
4854 -- memset by the backend.
4856 elsif Init_Or_Norm_Scalars
4857 and then Is_Array_Type (T)
4859 -- The array must lack atomic components because they are treated
4860 -- as non-static, and as a result the backend will not initialize
4861 -- the memory in one go.
4863 and then not Has_Atomic_Components (T)
4865 -- The array must not be packed because the invalid values in
4866 -- System.Scalar_Values are multiples of Storage_Unit.
4868 and then not Is_Packed (T)
4870 -- The array must have static non-empty ranges, otherwise the
4871 -- backend cannot initialize the memory in one go.
4873 and then Has_Static_Non_Empty_Array_Bounds (T)
4875 -- The optimization is only relevant for arrays of scalar types
4877 and then Is_Scalar_Type (Component_Type (T))
4879 -- Similar to regular array initialization using a type init proc,
4880 -- predicate checks are not performed because the initialization
4881 -- values are intentionally invalid, and may violate the predicate.
4883 and then not Has_Predicates (Component_Type (T))
4885 -- The component type must have a single initialization value
4887 and then Needs_Simple_Initialization
4888 (Typ => Component_Type (T),
4889 Consider_IS => True)
4892 Temp := Make_Temporary (Loc, 'P');
4895 -- Temp : Ptr_Typ := new ...;
4900 Make_Object_Declaration (Loc,
4901 Defining_Identifier => Temp,
4902 Object_Definition => New_Occurrence_Of (PtrT, Loc),
4903 Expression => Relocate_Node (N)),
4904 Suppress => All_Checks);
4907 -- Temp.all := (others => ...);
4912 Make_Assignment_Statement (Loc,
4914 Make_Explicit_Dereference (Loc,
4915 Prefix => New_Occurrence_Of (Temp, Loc)),
4920 Size => Esize (Component_Type (T)))),
4921 Suppress => All_Checks);
4923 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4924 Analyze_And_Resolve (N, PtrT);
4926 -- Case of no initialization procedure present
4928 elsif not Has_Non_Null_Base_Init_Proc (T) then
4930 -- Case of simple initialization required
4932 if Needs_Simple_Initialization (T) then
4933 Check_Restriction (No_Default_Initialization, N);
4934 Rewrite (Expression (N),
4935 Make_Qualified_Expression (Loc,
4936 Subtype_Mark => New_Occurrence_Of (T, Loc),
4937 Expression => Get_Simple_Init_Val (T, N)));
4939 Analyze_And_Resolve (Expression (Expression (N)), T);
4940 Analyze_And_Resolve (Expression (N), T);
4941 Set_Paren_Count (Expression (Expression (N)), 1);
4942 Expand_N_Allocator (N);
4944 -- No initialization required
4947 Build_Allocate_Deallocate_Proc
4949 Is_Allocate => True);
4952 -- Case of initialization procedure present, must be called
4954 -- NOTE: There is a *huge* amount of code duplication here from
4955 -- Build_Initialization_Call. We should probably refactor???
4958 Check_Restriction (No_Default_Initialization, N);
4960 if not Restriction_Active (No_Default_Initialization) then
4961 Init := Base_Init_Proc (T);
4963 Temp := Make_Temporary (Loc, 'P');
4965 -- Construct argument list for the initialization routine call
4968 Make_Explicit_Dereference (Loc,
4970 New_Occurrence_Of (Temp, Loc));
4972 Set_Assignment_OK (Init_Arg1);
4975 -- The initialization procedure expects a specific type. if the
4976 -- context is access to class wide, indicate that the object
4977 -- being allocated has the right specific type.
4979 if Is_Class_Wide_Type (Dtyp) then
4980 Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
4983 -- If designated type is a concurrent type or if it is private
4984 -- type whose definition is a concurrent type, the first
4985 -- argument in the Init routine has to be unchecked conversion
4986 -- to the corresponding record type. If the designated type is
4987 -- a derived type, also convert the argument to its root type.
4989 if Is_Concurrent_Type (T) then
4991 Unchecked_Convert_To (
4992 Corresponding_Record_Type (T), Init_Arg1);
4994 elsif Is_Private_Type (T)
4995 and then Present (Full_View (T))
4996 and then Is_Concurrent_Type (Full_View (T))
4999 Unchecked_Convert_To
5000 (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
5002 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
5004 Ftyp : constant Entity_Id := Etype (First_Formal (Init));
5007 Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
5008 Set_Etype (Init_Arg1, Ftyp);
5012 Args := New_List (Init_Arg1);
5014 -- For the task case, pass the Master_Id of the access type as
5015 -- the value of the _Master parameter, and _Chain as the value
5016 -- of the _Chain parameter (_Chain will be defined as part of
5017 -- the generated code for the allocator).
5019 -- In Ada 2005, the context may be a function that returns an
5020 -- anonymous access type. In that case the Master_Id has been
5021 -- created when expanding the function declaration.
5023 if Has_Task (T) then
5024 if No (Master_Id (Base_Type (PtrT))) then
5026 -- The designated type was an incomplete type, and the
5027 -- access type did not get expanded. Salvage it now.
5029 if not Restriction_Active (No_Task_Hierarchy) then
5030 if Present (Parent (Base_Type (PtrT))) then
5031 Expand_N_Full_Type_Declaration
5032 (Parent (Base_Type (PtrT)));
5034 -- The only other possibility is an itype. For this
5035 -- case, the master must exist in the context. This is
5036 -- the case when the allocator initializes an access
5037 -- component in an init-proc.
5040 pragma Assert (Is_Itype (PtrT));
5041 Build_Master_Renaming (PtrT, N);
5046 -- If the context of the allocator is a declaration or an
5047 -- assignment, we can generate a meaningful image for it,
5048 -- even though subsequent assignments might remove the
5049 -- connection between task and entity. We build this image
5050 -- when the left-hand side is a simple variable, a simple
5051 -- indexed assignment or a simple selected component.
5053 if Nkind (Parent (N)) = N_Assignment_Statement then
5055 Nam : constant Node_Id := Name (Parent (N));
5058 if Is_Entity_Name (Nam) then
5060 Build_Task_Image_Decls
5063 (Entity (Nam), Sloc (Nam)), T);
5065 elsif Nkind_In (Nam, N_Indexed_Component,
5066 N_Selected_Component)
5067 and then Is_Entity_Name (Prefix (Nam))
5070 Build_Task_Image_Decls
5071 (Loc, Nam, Etype (Prefix (Nam)));
5073 Decls := Build_Task_Image_Decls (Loc, T, T);
5077 elsif Nkind (Parent (N)) = N_Object_Declaration then
5079 Build_Task_Image_Decls
5080 (Loc, Defining_Identifier (Parent (N)), T);
5083 Decls := Build_Task_Image_Decls (Loc, T, T);
5086 if Restriction_Active (No_Task_Hierarchy) then
5088 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
5092 (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
5095 Append_To (Args, Make_Identifier (Loc, Name_uChain));
5097 Decl := Last (Decls);
5099 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
5101 -- Has_Task is false, Decls not used
5107 -- Add discriminants if discriminated type
5110 Dis : Boolean := False;
5111 Typ : Entity_Id := Empty;
5114 if Has_Discriminants (T) then
5118 -- Type may be a private type with no visible discriminants
5119 -- in which case check full view if in scope, or the
5120 -- underlying_full_view if dealing with a type whose full
5121 -- view may be derived from a private type whose own full
5122 -- view has discriminants.
5124 elsif Is_Private_Type (T) then
5125 if Present (Full_View (T))
5126 and then Has_Discriminants (Full_View (T))
5129 Typ := Full_View (T);
5131 elsif Present (Underlying_Full_View (T))
5132 and then Has_Discriminants (Underlying_Full_View (T))
5135 Typ := Underlying_Full_View (T);
5141 -- If the allocated object will be constrained by the
5142 -- default values for discriminants, then build a subtype
5143 -- with those defaults, and change the allocated subtype
5144 -- to that. Note that this happens in fewer cases in Ada
5147 if not Is_Constrained (Typ)
5148 and then Present (Discriminant_Default_Value
5149 (First_Discriminant (Typ)))
5150 and then (Ada_Version < Ada_2005
5152 Object_Type_Has_Constrained_Partial_View
5153 (Typ, Current_Scope))
5155 Typ := Build_Default_Subtype (Typ, N);
5156 Set_Expression (N, New_Occurrence_Of (Typ, Loc));
5159 Discr := First_Elmt (Discriminant_Constraint (Typ));
5160 while Present (Discr) loop
5161 Nod := Node (Discr);
5162 Append (New_Copy_Tree (Node (Discr)), Args);
5164 -- AI-416: when the discriminant constraint is an
5165 -- anonymous access type make sure an accessibility
5166 -- check is inserted if necessary (3.10.2(22.q/2))
5168 if Ada_Version >= Ada_2005
5170 Ekind (Etype (Nod)) = E_Anonymous_Access_Type
5172 Apply_Accessibility_Check
5173 (Nod, Typ, Insert_Node => Nod);
5181 -- We set the allocator as analyzed so that when we analyze
5182 -- the if expression node, we do not get an unwanted recursive
5183 -- expansion of the allocator expression.
5185 Set_Analyzed (N, True);
5186 Nod := Relocate_Node (N);
5188 -- Here is the transformation:
5189 -- input: new Ctrl_Typ
5190 -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
5191 -- Ctrl_TypIP (Temp.all, ...);
5192 -- [Deep_]Initialize (Temp.all);
5194 -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
5195 -- is the subtype of the allocator.
5198 Make_Object_Declaration (Loc,
5199 Defining_Identifier => Temp,
5200 Constant_Present => True,
5201 Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
5204 Set_Assignment_OK (Temp_Decl);
5205 Insert_Action (N, Temp_Decl, Suppress => All_Checks);
5207 Build_Allocate_Deallocate_Proc (Temp_Decl, True);
5209 -- If the designated type is a task type or contains tasks,
5210 -- create block to activate created tasks, and insert
5211 -- declaration for Task_Image variable ahead of call.
5213 if Has_Task (T) then
5215 L : constant List_Id := New_List;
5218 Build_Task_Allocate_Block (L, Nod, Args);
5220 Insert_List_Before (First (Declarations (Blk)), Decls);
5221 Insert_Actions (N, L);
5226 Make_Procedure_Call_Statement (Loc,
5227 Name => New_Occurrence_Of (Init, Loc),
5228 Parameter_Associations => Args));
5231 if Needs_Finalization (T) then
5234 -- [Deep_]Initialize (Init_Arg1);
5238 (Obj_Ref => New_Copy_Tree (Init_Arg1),
5241 -- Guard against a missing [Deep_]Initialize when the
5242 -- designated type was not properly frozen.
5244 if Present (Init_Call) then
5245 Insert_Action (N, Init_Call);
5249 Rewrite (N, New_Occurrence_Of (Temp, Loc));
5250 Analyze_And_Resolve (N, PtrT);
5255 -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
5256 -- object that has been rewritten as a reference, we displace "this"
5257 -- to reference properly its secondary dispatch table.
5259 if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
5260 Displace_Allocator_Pointer (N);
5264 when RE_Not_Available =>
5266 end Expand_N_Allocator;
5268 -----------------------
5269 -- Expand_N_And_Then --
5270 -----------------------
5272 procedure Expand_N_And_Then (N : Node_Id)
5273 renames Expand_Short_Circuit_Operator;
5275 ------------------------------
5276 -- Expand_N_Case_Expression --
5277 ------------------------------
5279 procedure Expand_N_Case_Expression (N : Node_Id) is
5280 function Is_Copy_Type (Typ : Entity_Id) return Boolean;
5281 -- Return True if we can copy objects of this type when expanding a case
5288 function Is_Copy_Type (Typ : Entity_Id) return Boolean is
5290 -- If Minimize_Expression_With_Actions is True, we can afford to copy
5291 -- large objects, as long as they are constrained and not limited.
5294 Is_Elementary_Type (Underlying_Type (Typ))
5296 (Minimize_Expression_With_Actions
5297 and then Is_Constrained (Underlying_Type (Typ))
5298 and then not Is_Limited_Type (Underlying_Type (Typ)));
5303 Loc : constant Source_Ptr := Sloc (N);
5304 Par : constant Node_Id := Parent (N);
5305 Typ : constant Entity_Id := Etype (N);
5309 Case_Stmt : Node_Id;
5313 Target_Typ : Entity_Id;
5315 In_Predicate : Boolean := False;
5316 -- Flag set when the case expression appears within a predicate
5318 Optimize_Return_Stmt : Boolean := False;
5319 -- Flag set when the case expression can be optimized in the context of
5320 -- a simple return statement.
5322 -- Start of processing for Expand_N_Case_Expression
5325 -- Check for MINIMIZED/ELIMINATED overflow mode
5327 if Minimized_Eliminated_Overflow_Check (N) then
5328 Apply_Arithmetic_Overflow_Check (N);
5332 -- If the case expression is a predicate specification, and the type
5333 -- to which it applies has a static predicate aspect, do not expand,
5334 -- because it will be converted to the proper predicate form later.
5336 if Ekind_In (Current_Scope, E_Function, E_Procedure)
5337 and then Is_Predicate_Function (Current_Scope)
5339 In_Predicate := True;
5341 if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
5347 -- When the type of the case expression is elementary, expand
5349 -- (case X is when A => AX, when B => BX ...)
5364 -- In all other cases expand into
5367 -- type Ptr_Typ is access all Typ;
5368 -- Target : Ptr_Typ;
5371 -- Target := AX'Unrestricted_Access;
5373 -- Target := BX'Unrestricted_Access;
5376 -- in Target.all end;
5378 -- This approach avoids extra copies of potentially large objects. It
5379 -- also allows handling of values of limited or unconstrained types.
5380 -- Note that we do the copy also for constrained, nonlimited types
5381 -- when minimizing expressions with actions (e.g. when generating C
5382 -- code) since it allows us to do the optimization below in more cases.
5384 -- Small optimization: when the case expression appears in the context
5385 -- of a simple return statement, expand into
5396 Make_Case_Statement (Loc,
5397 Expression => Expression (N),
5398 Alternatives => New_List);
5400 -- Preserve the original context for which the case statement is being
5401 -- generated. This is needed by the finalization machinery to prevent
5402 -- the premature finalization of controlled objects found within the
5405 Set_From_Conditional_Expression (Case_Stmt);
5410 if Is_Copy_Type (Typ) then
5413 -- ??? Do not perform the optimization when the return statement is
5414 -- within a predicate function, as this causes spurious errors. Could
5415 -- this be a possible mismatch in handling this case somewhere else
5416 -- in semantic analysis?
5418 Optimize_Return_Stmt :=
5419 Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
5421 -- Otherwise create an access type to handle the general case using
5422 -- 'Unrestricted_Access.
5425 -- type Ptr_Typ is access all Typ;
5428 if Generate_C_Code then
5430 -- We cannot ensure that correct C code will be generated if any
5431 -- temporary is created down the line (to e.g. handle checks or
5432 -- capture values) since we might end up with dangling references
5433 -- to local variables, so better be safe and reject the construct.
5436 ("case expression too complex, use case statement instead", N);
5439 Target_Typ := Make_Temporary (Loc, 'P');
5442 Make_Full_Type_Declaration (Loc,
5443 Defining_Identifier => Target_Typ,
5445 Make_Access_To_Object_Definition (Loc,
5446 All_Present => True,
5447 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5450 -- Create the declaration of the target which captures the value of the
5454 -- Target : [Ptr_]Typ;
5456 if not Optimize_Return_Stmt then
5457 Target := Make_Temporary (Loc, 'T');
5460 Make_Object_Declaration (Loc,
5461 Defining_Identifier => Target,
5462 Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
5463 Set_No_Initialization (Decl);
5465 Append_To (Acts, Decl);
5468 -- Process the alternatives
5470 Alt := First (Alternatives (N));
5471 while Present (Alt) loop
5473 Alt_Expr : Node_Id := Expression (Alt);
5474 Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
5479 -- Take the unrestricted access of the expression value for non-
5480 -- scalar types. This approach avoids big copies and covers the
5481 -- limited and unconstrained cases.
5484 -- AX'Unrestricted_Access
5486 if not Is_Copy_Type (Typ) then
5488 Make_Attribute_Reference (Alt_Loc,
5489 Prefix => Relocate_Node (Alt_Expr),
5490 Attribute_Name => Name_Unrestricted_Access);
5494 -- return AX['Unrestricted_Access];
5496 if Optimize_Return_Stmt then
5498 Make_Simple_Return_Statement (Alt_Loc,
5499 Expression => Alt_Expr));
5502 -- Target := AX['Unrestricted_Access];
5505 LHS := New_Occurrence_Of (Target, Loc);
5506 Set_Assignment_OK (LHS);
5509 Make_Assignment_Statement (Alt_Loc,
5511 Expression => Alt_Expr));
5514 -- Propagate declarations inserted in the node by Insert_Actions
5515 -- (for example, temporaries generated to remove side effects).
5516 -- These actions must remain attached to the alternative, given
5517 -- that they are generated by the corresponding expression.
5519 if Present (Actions (Alt)) then
5520 Prepend_List (Actions (Alt), Stmts);
5523 -- Finalize any transient objects on exit from the alternative.
5524 -- This is done only in the return optimization case because
5525 -- otherwise the case expression is converted into an expression
5526 -- with actions which already contains this form of processing.
5528 if Optimize_Return_Stmt then
5529 Process_If_Case_Statements (N, Stmts);
5533 (Alternatives (Case_Stmt),
5534 Make_Case_Statement_Alternative (Sloc (Alt),
5535 Discrete_Choices => Discrete_Choices (Alt),
5536 Statements => Stmts));
5542 -- Rewrite the parent return statement as a case statement
5544 if Optimize_Return_Stmt then
5545 Rewrite (Par, Case_Stmt);
5548 -- Otherwise convert the case expression into an expression with actions
5551 Append_To (Acts, Case_Stmt);
5553 if Is_Copy_Type (Typ) then
5554 Expr := New_Occurrence_Of (Target, Loc);
5558 Make_Explicit_Dereference (Loc,
5559 Prefix => New_Occurrence_Of (Target, Loc));
5565 -- in Target[.all] end;
5568 Make_Expression_With_Actions (Loc,
5572 Analyze_And_Resolve (N, Typ);
5574 end Expand_N_Case_Expression;
5576 -----------------------------------
5577 -- Expand_N_Explicit_Dereference --
5578 -----------------------------------
5580 procedure Expand_N_Explicit_Dereference (N : Node_Id) is
5582 -- Insert explicit dereference call for the checked storage pool case
5584 Insert_Dereference_Action (Prefix (N));
5586 -- If the type is an Atomic type for which Atomic_Sync is enabled, then
5587 -- we set the atomic sync flag.
5589 if Is_Atomic (Etype (N))
5590 and then not Atomic_Synchronization_Disabled (Etype (N))
5592 Activate_Atomic_Synchronization (N);
5594 end Expand_N_Explicit_Dereference;
5596 --------------------------------------
5597 -- Expand_N_Expression_With_Actions --
5598 --------------------------------------
5600 procedure Expand_N_Expression_With_Actions (N : Node_Id) is
5601 Acts : constant List_Id := Actions (N);
5603 procedure Force_Boolean_Evaluation (Expr : Node_Id);
5604 -- Force the evaluation of Boolean expression Expr
5606 function Process_Action (Act : Node_Id) return Traverse_Result;
5607 -- Inspect and process a single action of an expression_with_actions for
5608 -- transient objects. If such objects are found, the routine generates
5609 -- code to clean them up when the context of the expression is evaluated
5612 ------------------------------
5613 -- Force_Boolean_Evaluation --
5614 ------------------------------
5616 procedure Force_Boolean_Evaluation (Expr : Node_Id) is
5617 Loc : constant Source_Ptr := Sloc (N);
5618 Flag_Decl : Node_Id;
5619 Flag_Id : Entity_Id;
5622 -- Relocate the expression to the actions list by capturing its value
5623 -- in a Boolean flag. Generate:
5624 -- Flag : constant Boolean := Expr;
5626 Flag_Id := Make_Temporary (Loc, 'F');
5629 Make_Object_Declaration (Loc,
5630 Defining_Identifier => Flag_Id,
5631 Constant_Present => True,
5632 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
5633 Expression => Relocate_Node (Expr));
5635 Append (Flag_Decl, Acts);
5636 Analyze (Flag_Decl);
5638 -- Replace the expression with a reference to the flag
5640 Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc));
5641 Analyze (Expression (N));
5642 end Force_Boolean_Evaluation;
5644 --------------------
5645 -- Process_Action --
5646 --------------------
5648 function Process_Action (Act : Node_Id) return Traverse_Result is
5650 if Nkind (Act) = N_Object_Declaration
5651 and then Is_Finalizable_Transient (Act, N)
5653 Process_Transient_In_Expression (Act, N, Acts);
5656 -- Avoid processing temporary function results multiple times when
5657 -- dealing with nested expression_with_actions.
5659 elsif Nkind (Act) = N_Expression_With_Actions then
5662 -- Do not process temporary function results in loops. This is done
5663 -- by Expand_N_Loop_Statement and Build_Finalizer.
5665 elsif Nkind (Act) = N_Loop_Statement then
5672 procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5678 -- Start of processing for Expand_N_Expression_With_Actions
5681 -- Do not evaluate the expression when it denotes an entity because the
5682 -- expression_with_actions node will be replaced by the reference.
5684 if Is_Entity_Name (Expression (N)) then
5687 -- Do not evaluate the expression when there are no actions because the
5688 -- expression_with_actions node will be replaced by the expression.
5690 elsif No (Acts) or else Is_Empty_List (Acts) then
5693 -- Force the evaluation of the expression by capturing its value in a
5694 -- temporary. This ensures that aliases of transient objects do not leak
5695 -- to the expression of the expression_with_actions node:
5698 -- Trans_Id : Ctrl_Typ := ...;
5699 -- Alias : ... := Trans_Id;
5700 -- in ... Alias ... end;
5702 -- In the example above, Trans_Id cannot be finalized at the end of the
5703 -- actions list because this may affect the alias and the final value of
5704 -- the expression_with_actions. Forcing the evaluation encapsulates the
5705 -- reference to the Alias within the actions list:
5708 -- Trans_Id : Ctrl_Typ := ...;
5709 -- Alias : ... := Trans_Id;
5710 -- Val : constant Boolean := ... Alias ...;
5711 -- <finalize Trans_Id>
5714 -- Once this transformation is performed, it is safe to finalize the
5715 -- transient object at the end of the actions list.
5717 -- Note that Force_Evaluation does not remove side effects in operators
5718 -- because it assumes that all operands are evaluated and side effect
5719 -- free. This is not the case when an operand depends implicitly on the
5720 -- transient object through the use of access types.
5722 elsif Is_Boolean_Type (Etype (Expression (N))) then
5723 Force_Boolean_Evaluation (Expression (N));
5725 -- The expression of an expression_with_actions node may not necessarily
5726 -- be Boolean when the node appears in an if expression. In this case do
5727 -- the usual forced evaluation to encapsulate potential aliasing.
5730 Force_Evaluation (Expression (N));
5733 -- Process all transient objects found within the actions of the EWA
5736 Act := First (Acts);
5737 while Present (Act) loop
5738 Process_Single_Action (Act);
5742 -- Deal with case where there are no actions. In this case we simply
5743 -- rewrite the node with its expression since we don't need the actions
5744 -- and the specification of this node does not allow a null action list.
5746 -- Note: we use Rewrite instead of Replace, because Codepeer is using
5747 -- the expanded tree and relying on being able to retrieve the original
5748 -- tree in cases like this. This raises a whole lot of issues of whether
5749 -- we have problems elsewhere, which will be addressed in the future???
5751 if Is_Empty_List (Acts) then
5752 Rewrite (N, Relocate_Node (Expression (N)));
5754 end Expand_N_Expression_With_Actions;
5756 ----------------------------
5757 -- Expand_N_If_Expression --
5758 ----------------------------
5760 -- Deal with limited types and condition actions
5762 procedure Expand_N_If_Expression (N : Node_Id) is
5763 Cond : constant Node_Id := First (Expressions (N));
5764 Loc : constant Source_Ptr := Sloc (N);
5765 Thenx : constant Node_Id := Next (Cond);
5766 Elsex : constant Node_Id := Next (Thenx);
5767 Typ : constant Entity_Id := Etype (N);
5776 -- Check for MINIMIZED/ELIMINATED overflow mode
5778 if Minimized_Eliminated_Overflow_Check (N) then
5779 Apply_Arithmetic_Overflow_Check (N);
5783 -- Fold at compile time if condition known. We have already folded
5784 -- static if expressions, but it is possible to fold any case in which
5785 -- the condition is known at compile time, even though the result is
5788 -- Note that we don't do the fold of such cases in Sem_Elab because
5789 -- it can cause infinite loops with the expander adding a conditional
5790 -- expression, and Sem_Elab circuitry removing it repeatedly.
5792 if Compile_Time_Known_Value (Cond) then
5794 function Fold_Known_Value (Cond : Node_Id) return Boolean;
5795 -- Fold at compile time. Assumes condition known. Return True if
5796 -- folding occurred, meaning we're done.
5798 ----------------------
5799 -- Fold_Known_Value --
5800 ----------------------
5802 function Fold_Known_Value (Cond : Node_Id) return Boolean is
5804 if Is_True (Expr_Value (Cond)) then
5806 Actions := Then_Actions (N);
5809 Actions := Else_Actions (N);
5814 if Present (Actions) then
5816 -- To minimize the use of Expression_With_Actions, just skip
5817 -- the optimization as it is not critical for correctness.
5819 if Minimize_Expression_With_Actions then
5824 Make_Expression_With_Actions (Loc,
5825 Expression => Relocate_Node (Expr),
5826 Actions => Actions));
5827 Analyze_And_Resolve (N, Typ);
5830 Rewrite (N, Relocate_Node (Expr));
5833 -- Note that the result is never static (legitimate cases of
5834 -- static if expressions were folded in Sem_Eval).
5836 Set_Is_Static_Expression (N, False);
5838 end Fold_Known_Value;
5841 if Fold_Known_Value (Cond) then
5847 -- If the type is limited, and the back end does not handle limited
5848 -- types, then we expand as follows to avoid the possibility of
5849 -- improper copying.
5851 -- type Ptr is access all Typ;
5855 -- Cnn := then-expr'Unrestricted_Access;
5858 -- Cnn := else-expr'Unrestricted_Access;
5861 -- and replace the if expression by a reference to Cnn.all.
5863 -- This special case can be skipped if the back end handles limited
5864 -- types properly and ensures that no incorrect copies are made.
5866 if Is_By_Reference_Type (Typ)
5867 and then not Back_End_Handles_Limited_Types
5869 -- When the "then" or "else" expressions involve controlled function
5870 -- calls, generated temporaries are chained on the corresponding list
5871 -- of actions. These temporaries need to be finalized after the if
5872 -- expression is evaluated.
5874 Process_If_Case_Statements (N, Then_Actions (N));
5875 Process_If_Case_Statements (N, Else_Actions (N));
5878 Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N);
5879 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
5883 -- type Ann is access all Typ;
5886 Make_Full_Type_Declaration (Loc,
5887 Defining_Identifier => Ptr_Typ,
5889 Make_Access_To_Object_Definition (Loc,
5890 All_Present => True,
5891 Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
5897 Make_Object_Declaration (Loc,
5898 Defining_Identifier => Cnn,
5899 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
5903 -- Cnn := <Thenx>'Unrestricted_Access;
5905 -- Cnn := <Elsex>'Unrestricted_Access;
5909 Make_Implicit_If_Statement (N,
5910 Condition => Relocate_Node (Cond),
5911 Then_Statements => New_List (
5912 Make_Assignment_Statement (Sloc (Thenx),
5913 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5915 Make_Attribute_Reference (Loc,
5916 Prefix => Relocate_Node (Thenx),
5917 Attribute_Name => Name_Unrestricted_Access))),
5919 Else_Statements => New_List (
5920 Make_Assignment_Statement (Sloc (Elsex),
5921 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5923 Make_Attribute_Reference (Loc,
5924 Prefix => Relocate_Node (Elsex),
5925 Attribute_Name => Name_Unrestricted_Access))));
5927 -- Preserve the original context for which the if statement is
5928 -- being generated. This is needed by the finalization machinery
5929 -- to prevent the premature finalization of controlled objects
5930 -- found within the if statement.
5932 Set_From_Conditional_Expression (New_If);
5935 Make_Explicit_Dereference (Loc,
5936 Prefix => New_Occurrence_Of (Cnn, Loc));
5939 -- If the result is an unconstrained array and the if expression is in a
5940 -- context other than the initializing expression of the declaration of
5941 -- an object, then we pull out the if expression as follows:
5943 -- Cnn : constant typ := if-expression
5945 -- and then replace the if expression with an occurrence of Cnn. This
5946 -- avoids the need in the back end to create on-the-fly variable length
5947 -- temporaries (which it cannot do!)
5949 -- Note that the test for being in an object declaration avoids doing an
5950 -- unnecessary expansion, and also avoids infinite recursion.
5952 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ)
5953 and then (Nkind (Parent (N)) /= N_Object_Declaration
5954 or else Expression (Parent (N)) /= N)
5957 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
5961 Make_Object_Declaration (Loc,
5962 Defining_Identifier => Cnn,
5963 Constant_Present => True,
5964 Object_Definition => New_Occurrence_Of (Typ, Loc),
5965 Expression => Relocate_Node (N),
5966 Has_Init_Expression => True));
5968 Rewrite (N, New_Occurrence_Of (Cnn, Loc));
5972 -- For other types, we only need to expand if there are other actions
5973 -- associated with either branch.
5975 elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
5977 -- We now wrap the actions into the appropriate expression
5979 if Minimize_Expression_With_Actions
5980 and then (Is_Elementary_Type (Underlying_Type (Typ))
5981 or else Is_Constrained (Underlying_Type (Typ)))
5983 -- If we can't use N_Expression_With_Actions nodes, then we insert
5984 -- the following sequence of actions (using Insert_Actions):
5989 -- Cnn := then-expr;
5995 -- and replace the if expression by a reference to Cnn
5998 Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
6002 Make_Object_Declaration (Loc,
6003 Defining_Identifier => Cnn,
6004 Object_Definition => New_Occurrence_Of (Typ, Loc));
6007 Make_Implicit_If_Statement (N,
6008 Condition => Relocate_Node (Cond),
6010 Then_Statements => New_List (
6011 Make_Assignment_Statement (Sloc (Thenx),
6012 Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
6013 Expression => Relocate_Node (Thenx))),
6015 Else_Statements => New_List (
6016 Make_Assignment_Statement (Sloc (Elsex),
6017 Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
6018 Expression => Relocate_Node (Elsex))));
6020 Set_Assignment_OK (Name (First (Then_Statements (New_If))));
6021 Set_Assignment_OK (Name (First (Else_Statements (New_If))));
6023 New_N := New_Occurrence_Of (Cnn, Loc);
6026 -- Regular path using Expression_With_Actions
6029 if Present (Then_Actions (N)) then
6031 Make_Expression_With_Actions (Sloc (Thenx),
6032 Actions => Then_Actions (N),
6033 Expression => Relocate_Node (Thenx)));
6035 Set_Then_Actions (N, No_List);
6036 Analyze_And_Resolve (Thenx, Typ);
6039 if Present (Else_Actions (N)) then
6041 Make_Expression_With_Actions (Sloc (Elsex),
6042 Actions => Else_Actions (N),
6043 Expression => Relocate_Node (Elsex)));
6045 Set_Else_Actions (N, No_List);
6046 Analyze_And_Resolve (Elsex, Typ);
6052 -- If no actions then no expansion needed, gigi will handle it using the
6053 -- same approach as a C conditional expression.
6059 -- Fall through here for either the limited expansion, or the case of
6060 -- inserting actions for nonlimited types. In both these cases, we must
6061 -- move the SLOC of the parent If statement to the newly created one and
6062 -- change it to the SLOC of the expression which, after expansion, will
6063 -- correspond to what is being evaluated.
6065 if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
6066 Set_Sloc (New_If, Sloc (Parent (N)));
6067 Set_Sloc (Parent (N), Loc);
6070 -- Make sure Then_Actions and Else_Actions are appropriately moved
6071 -- to the new if statement.
6073 if Present (Then_Actions (N)) then
6075 (First (Then_Statements (New_If)), Then_Actions (N));
6078 if Present (Else_Actions (N)) then
6080 (First (Else_Statements (New_If)), Else_Actions (N));
6083 Insert_Action (N, Decl);
6084 Insert_Action (N, New_If);
6086 Analyze_And_Resolve (N, Typ);
6087 end Expand_N_If_Expression;
6093 procedure Expand_N_In (N : Node_Id) is
6094 Loc : constant Source_Ptr := Sloc (N);
6095 Restyp : constant Entity_Id := Etype (N);
6096 Lop : constant Node_Id := Left_Opnd (N);
6097 Rop : constant Node_Id := Right_Opnd (N);
6098 Static : constant Boolean := Is_OK_Static_Expression (N);
6100 procedure Substitute_Valid_Check;
6101 -- Replaces node N by Lop'Valid. This is done when we have an explicit
6102 -- test for the left operand being in range of its subtype.
6104 ----------------------------
6105 -- Substitute_Valid_Check --
6106 ----------------------------
6108 procedure Substitute_Valid_Check is
6109 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
6110 -- Determine whether arbitrary node Nod denotes a source object that
6111 -- may safely act as prefix of attribute 'Valid.
6113 ----------------------------
6114 -- Is_OK_Object_Reference --
6115 ----------------------------
6117 function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is
6121 -- Inspect the original operand
6123 Obj_Ref := Original_Node (Nod);
6125 -- The object reference must be a source construct, otherwise the
6126 -- codefix suggestion may refer to nonexistent code from a user
6129 if Comes_From_Source (Obj_Ref) then
6131 -- Recover the actual object reference. There may be more cases
6135 if Nkind_In (Obj_Ref, N_Type_Conversion,
6136 N_Unchecked_Type_Conversion)
6138 Obj_Ref := Expression (Obj_Ref);
6144 return Is_Object_Reference (Obj_Ref);
6148 end Is_OK_Object_Reference;
6150 -- Start of processing for Substitute_Valid_Check
6154 Make_Attribute_Reference (Loc,
6155 Prefix => Relocate_Node (Lop),
6156 Attribute_Name => Name_Valid));
6158 Analyze_And_Resolve (N, Restyp);
6160 -- Emit a warning when the left-hand operand of the membership test
6161 -- is a source object, otherwise the use of attribute 'Valid would be
6162 -- illegal. The warning is not given when overflow checking is either
6163 -- MINIMIZED or ELIMINATED, as the danger of optimization has been
6164 -- eliminated above.
6166 if Is_OK_Object_Reference (Lop)
6167 and then Overflow_Check_Mode not in Minimized_Or_Eliminated
6170 ("??explicit membership test may be optimized away", N);
6171 Error_Msg_N -- CODEFIX
6172 ("\??use ''Valid attribute instead", N);
6174 end Substitute_Valid_Check;
6181 -- Start of processing for Expand_N_In
6184 -- If set membership case, expand with separate procedure
6186 if Present (Alternatives (N)) then
6187 Expand_Set_Membership (N);
6191 -- Not set membership, proceed with expansion
6193 Ltyp := Etype (Left_Opnd (N));
6194 Rtyp := Etype (Right_Opnd (N));
6196 -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
6197 -- type, then expand with a separate procedure. Note the use of the
6198 -- flag No_Minimize_Eliminate to prevent infinite recursion.
6200 if Overflow_Check_Mode in Minimized_Or_Eliminated
6201 and then Is_Signed_Integer_Type (Ltyp)
6202 and then not No_Minimize_Eliminate (N)
6204 Expand_Membership_Minimize_Eliminate_Overflow (N);
6208 -- Check case of explicit test for an expression in range of its
6209 -- subtype. This is suspicious usage and we replace it with a 'Valid
6210 -- test and give a warning for scalar types.
6212 if Is_Scalar_Type (Ltyp)
6214 -- Only relevant for source comparisons
6216 and then Comes_From_Source (N)
6218 -- In floating-point this is a standard way to check for finite values
6219 -- and using 'Valid would typically be a pessimization.
6221 and then not Is_Floating_Point_Type (Ltyp)
6223 -- Don't give the message unless right operand is a type entity and
6224 -- the type of the left operand matches this type. Note that this
6225 -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
6226 -- checks have changed the type of the left operand.
6228 and then Nkind (Rop) in N_Has_Entity
6229 and then Ltyp = Entity (Rop)
6231 -- Skip this for predicated types, where such expressions are a
6232 -- reasonable way of testing if something meets the predicate.
6234 and then not Present (Predicate_Function (Ltyp))
6236 Substitute_Valid_Check;
6240 -- Do validity check on operands
6242 if Validity_Checks_On and Validity_Check_Operands then
6243 Ensure_Valid (Left_Opnd (N));
6244 Validity_Check_Range (Right_Opnd (N));
6247 -- Case of explicit range
6249 if Nkind (Rop) = N_Range then
6251 Lo : constant Node_Id := Low_Bound (Rop);
6252 Hi : constant Node_Id := High_Bound (Rop);
6254 Lo_Orig : constant Node_Id := Original_Node (Lo);
6255 Hi_Orig : constant Node_Id := Original_Node (Hi);
6257 Lcheck : Compare_Result;
6258 Ucheck : Compare_Result;
6260 Warn1 : constant Boolean :=
6261 Constant_Condition_Warnings
6262 and then Comes_From_Source (N)
6263 and then not In_Instance;
6264 -- This must be true for any of the optimization warnings, we
6265 -- clearly want to give them only for source with the flag on. We
6266 -- also skip these warnings in an instance since it may be the
6267 -- case that different instantiations have different ranges.
6269 Warn2 : constant Boolean :=
6271 and then Nkind (Original_Node (Rop)) = N_Range
6272 and then Is_Integer_Type (Etype (Lo));
6273 -- For the case where only one bound warning is elided, we also
6274 -- insist on an explicit range and an integer type. The reason is
6275 -- that the use of enumeration ranges including an end point is
6276 -- common, as is the use of a subtype name, one of whose bounds is
6277 -- the same as the type of the expression.
6280 -- If test is explicit x'First .. x'Last, replace by valid check
6282 -- Could use some individual comments for this complex test ???
6284 if Is_Scalar_Type (Ltyp)
6286 -- And left operand is X'First where X matches left operand
6287 -- type (this eliminates cases of type mismatch, including
6288 -- the cases where ELIMINATED/MINIMIZED mode has changed the
6289 -- type of the left operand.
6291 and then Nkind (Lo_Orig) = N_Attribute_Reference
6292 and then Attribute_Name (Lo_Orig) = Name_First
6293 and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
6294 and then Entity (Prefix (Lo_Orig)) = Ltyp
6296 -- Same tests for right operand
6298 and then Nkind (Hi_Orig) = N_Attribute_Reference
6299 and then Attribute_Name (Hi_Orig) = Name_Last
6300 and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
6301 and then Entity (Prefix (Hi_Orig)) = Ltyp
6303 -- Relevant only for source cases
6305 and then Comes_From_Source (N)
6307 Substitute_Valid_Check;
6311 -- If bounds of type are known at compile time, and the end points
6312 -- are known at compile time and identical, this is another case
6313 -- for substituting a valid test. We only do this for discrete
6314 -- types, since it won't arise in practice for float types.
6316 if Comes_From_Source (N)
6317 and then Is_Discrete_Type (Ltyp)
6318 and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
6319 and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
6320 and then Compile_Time_Known_Value (Lo)
6321 and then Compile_Time_Known_Value (Hi)
6322 and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
6323 and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
6325 -- Kill warnings in instances, since they may be cases where we
6326 -- have a test in the generic that makes sense with some types
6327 -- and not with other types.
6329 -- Similarly, do not rewrite membership as a validity check if
6330 -- within the predicate function for the type.
6332 -- Finally, if the original bounds are type conversions, even
6333 -- if they have been folded into constants, there are different
6334 -- types involved and 'Valid is not appropriate.
6338 or else (Ekind (Current_Scope) = E_Function
6339 and then Is_Predicate_Function (Current_Scope))
6343 elsif Nkind (Lo_Orig) = N_Type_Conversion
6344 or else Nkind (Hi_Orig) = N_Type_Conversion
6349 Substitute_Valid_Check;
6354 -- If we have an explicit range, do a bit of optimization based on
6355 -- range analysis (we may be able to kill one or both checks).
6357 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
6358 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
6360 -- If either check is known to fail, replace result by False since
6361 -- the other check does not matter. Preserve the static flag for
6362 -- legality checks, because we are constant-folding beyond RM 4.9.
6364 if Lcheck = LT or else Ucheck = GT then
6366 Error_Msg_N ("?c?range test optimized away", N);
6367 Error_Msg_N ("\?c?value is known to be out of range", N);
6370 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6371 Analyze_And_Resolve (N, Restyp);
6372 Set_Is_Static_Expression (N, Static);
6375 -- If both checks are known to succeed, replace result by True,
6376 -- since we know we are in range.
6378 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6380 Error_Msg_N ("?c?range test optimized away", N);
6381 Error_Msg_N ("\?c?value is known to be in range", N);
6384 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6385 Analyze_And_Resolve (N, Restyp);
6386 Set_Is_Static_Expression (N, Static);
6389 -- If lower bound check succeeds and upper bound check is not
6390 -- known to succeed or fail, then replace the range check with
6391 -- a comparison against the upper bound.
6393 elsif Lcheck in Compare_GE then
6394 if Warn2 and then not In_Instance then
6395 Error_Msg_N ("??lower bound test optimized away", Lo);
6396 Error_Msg_N ("\??value is known to be in range", Lo);
6402 Right_Opnd => High_Bound (Rop)));
6403 Analyze_And_Resolve (N, Restyp);
6406 -- If upper bound check succeeds and lower bound check is not
6407 -- known to succeed or fail, then replace the range check with
6408 -- a comparison against the lower bound.
6410 elsif Ucheck in Compare_LE then
6411 if Warn2 and then not In_Instance then
6412 Error_Msg_N ("??upper bound test optimized away", Hi);
6413 Error_Msg_N ("\??value is known to be in range", Hi);
6419 Right_Opnd => Low_Bound (Rop)));
6420 Analyze_And_Resolve (N, Restyp);
6424 -- We couldn't optimize away the range check, but there is one
6425 -- more issue. If we are checking constant conditionals, then we
6426 -- see if we can determine the outcome assuming everything is
6427 -- valid, and if so give an appropriate warning.
6429 if Warn1 and then not Assume_No_Invalid_Values then
6430 Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
6431 Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
6433 -- Result is out of range for valid value
6435 if Lcheck = LT or else Ucheck = GT then
6437 ("?c?value can only be in range if it is invalid", N);
6439 -- Result is in range for valid value
6441 elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
6443 ("?c?value can only be out of range if it is invalid", N);
6445 -- Lower bound check succeeds if value is valid
6447 elsif Warn2 and then Lcheck in Compare_GE then
6449 ("?c?lower bound check only fails if it is invalid", Lo);
6451 -- Upper bound check succeeds if value is valid
6453 elsif Warn2 and then Ucheck in Compare_LE then
6455 ("?c?upper bound check only fails for invalid values", Hi);
6460 -- For all other cases of an explicit range, nothing to be done
6464 -- Here right operand is a subtype mark
6468 Typ : Entity_Id := Etype (Rop);
6469 Is_Acc : constant Boolean := Is_Access_Type (Typ);
6470 Cond : Node_Id := Empty;
6472 Obj : Node_Id := Lop;
6473 SCIL_Node : Node_Id;
6476 Remove_Side_Effects (Obj);
6478 -- For tagged type, do tagged membership operation
6480 if Is_Tagged_Type (Typ) then
6482 -- No expansion will be performed for VM targets, as the VM
6483 -- back ends will handle the membership tests directly.
6485 if Tagged_Type_Expansion then
6486 Tagged_Membership (N, SCIL_Node, New_N);
6488 Analyze_And_Resolve (N, Restyp, Suppress => All_Checks);
6490 -- Update decoration of relocated node referenced by the
6493 if Generate_SCIL and then Present (SCIL_Node) then
6494 Set_SCIL_Node (N, SCIL_Node);
6500 -- If type is scalar type, rewrite as x in t'First .. t'Last.
6501 -- This reason we do this is that the bounds may have the wrong
6502 -- type if they come from the original type definition. Also this
6503 -- way we get all the processing above for an explicit range.
6505 -- Don't do this for predicated types, since in this case we
6506 -- want to check the predicate.
6508 elsif Is_Scalar_Type (Typ) then
6509 if No (Predicate_Function (Typ)) then
6513 Make_Attribute_Reference (Loc,
6514 Attribute_Name => Name_First,
6515 Prefix => New_Occurrence_Of (Typ, Loc)),
6518 Make_Attribute_Reference (Loc,
6519 Attribute_Name => Name_Last,
6520 Prefix => New_Occurrence_Of (Typ, Loc))));
6521 Analyze_And_Resolve (N, Restyp);
6526 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
6527 -- a membership test if the subtype mark denotes a constrained
6528 -- Unchecked_Union subtype and the expression lacks inferable
6531 elsif Is_Unchecked_Union (Base_Type (Typ))
6532 and then Is_Constrained (Typ)
6533 and then not Has_Inferable_Discriminants (Lop)
6536 Make_Raise_Program_Error (Loc,
6537 Reason => PE_Unchecked_Union_Restriction));
6539 -- Prevent Gigi from generating incorrect code by rewriting the
6540 -- test as False. What is this undocumented thing about ???
6542 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6546 -- Here we have a non-scalar type
6549 Typ := Designated_Type (Typ);
6552 if not Is_Constrained (Typ) then
6553 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6554 Analyze_And_Resolve (N, Restyp);
6556 -- For the constrained array case, we have to check the subscripts
6557 -- for an exact match if the lengths are non-zero (the lengths
6558 -- must match in any case).
6560 elsif Is_Array_Type (Typ) then
6561 Check_Subscripts : declare
6562 function Build_Attribute_Reference
6565 Dim : Nat) return Node_Id;
6566 -- Build attribute reference E'Nam (Dim)
6568 -------------------------------
6569 -- Build_Attribute_Reference --
6570 -------------------------------
6572 function Build_Attribute_Reference
6575 Dim : Nat) return Node_Id
6579 Make_Attribute_Reference (Loc,
6581 Attribute_Name => Nam,
6582 Expressions => New_List (
6583 Make_Integer_Literal (Loc, Dim)));
6584 end Build_Attribute_Reference;
6586 -- Start of processing for Check_Subscripts
6589 for J in 1 .. Number_Dimensions (Typ) loop
6590 Evolve_And_Then (Cond,
6593 Build_Attribute_Reference
6594 (Duplicate_Subexpr_No_Checks (Obj),
6597 Build_Attribute_Reference
6598 (New_Occurrence_Of (Typ, Loc), Name_First, J)));
6600 Evolve_And_Then (Cond,
6603 Build_Attribute_Reference
6604 (Duplicate_Subexpr_No_Checks (Obj),
6607 Build_Attribute_Reference
6608 (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
6617 Right_Opnd => Make_Null (Loc)),
6618 Right_Opnd => Cond);
6622 Analyze_And_Resolve (N, Restyp);
6623 end Check_Subscripts;
6625 -- These are the cases where constraint checks may be required,
6626 -- e.g. records with possible discriminants
6629 -- Expand the test into a series of discriminant comparisons.
6630 -- The expression that is built is the negation of the one that
6631 -- is used for checking discriminant constraints.
6633 Obj := Relocate_Node (Left_Opnd (N));
6635 if Has_Discriminants (Typ) then
6636 Cond := Make_Op_Not (Loc,
6637 Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
6640 Cond := Make_Or_Else (Loc,
6644 Right_Opnd => Make_Null (Loc)),
6645 Right_Opnd => Cond);
6649 Cond := New_Occurrence_Of (Standard_True, Loc);
6653 Analyze_And_Resolve (N, Restyp);
6656 -- Ada 2012 (AI05-0149): Handle membership tests applied to an
6657 -- expression of an anonymous access type. This can involve an
6658 -- accessibility test and a tagged type membership test in the
6659 -- case of tagged designated types.
6661 if Ada_Version >= Ada_2012
6663 and then Ekind (Ltyp) = E_Anonymous_Access_Type
6666 Expr_Entity : Entity_Id := Empty;
6668 Param_Level : Node_Id;
6669 Type_Level : Node_Id;
6672 if Is_Entity_Name (Lop) then
6673 Expr_Entity := Param_Entity (Lop);
6675 if not Present (Expr_Entity) then
6676 Expr_Entity := Entity (Lop);
6680 -- If a conversion of the anonymous access value to the
6681 -- tested type would be illegal, then the result is False.
6683 if not Valid_Conversion
6684 (Lop, Rtyp, Lop, Report_Errs => False)
6686 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6687 Analyze_And_Resolve (N, Restyp);
6689 -- Apply an accessibility check if the access object has an
6690 -- associated access level and when the level of the type is
6691 -- less deep than the level of the access parameter. This
6692 -- only occur for access parameters and stand-alone objects
6693 -- of an anonymous access type.
6696 if Present (Expr_Entity)
6699 (Effective_Extra_Accessibility (Expr_Entity))
6700 and then UI_Gt (Object_Access_Level (Lop),
6701 Type_Access_Level (Rtyp))
6705 (Effective_Extra_Accessibility (Expr_Entity), Loc);
6708 Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
6710 -- Return True only if the accessibility level of the
6711 -- expression entity is not deeper than the level of
6712 -- the tested access type.
6716 Left_Opnd => Relocate_Node (N),
6717 Right_Opnd => Make_Op_Le (Loc,
6718 Left_Opnd => Param_Level,
6719 Right_Opnd => Type_Level)));
6721 Analyze_And_Resolve (N);
6724 -- If the designated type is tagged, do tagged membership
6727 -- *** NOTE: we have to check not null before doing the
6728 -- tagged membership test (but maybe that can be done
6729 -- inside Tagged_Membership?).
6731 if Is_Tagged_Type (Typ) then
6734 Left_Opnd => Relocate_Node (N),
6738 Right_Opnd => Make_Null (Loc))));
6740 -- No expansion will be performed for VM targets, as
6741 -- the VM back ends will handle the membership tests
6744 if Tagged_Type_Expansion then
6746 -- Note that we have to pass Original_Node, because
6747 -- the membership test might already have been
6748 -- rewritten by earlier parts of membership test.
6751 (Original_Node (N), SCIL_Node, New_N);
6753 -- Update decoration of relocated node referenced
6754 -- by the SCIL node.
6756 if Generate_SCIL and then Present (SCIL_Node) then
6757 Set_SCIL_Node (New_N, SCIL_Node);
6762 Left_Opnd => Relocate_Node (N),
6763 Right_Opnd => New_N));
6765 Analyze_And_Resolve (N, Restyp);
6774 -- At this point, we have done the processing required for the basic
6775 -- membership test, but not yet dealt with the predicate.
6779 -- If a predicate is present, then we do the predicate test, but we
6780 -- most certainly want to omit this if we are within the predicate
6781 -- function itself, since otherwise we have an infinite recursion.
6782 -- The check should also not be emitted when testing against a range
6783 -- (the check is only done when the right operand is a subtype; see
6784 -- RM12-4.5.2 (28.1/3-30/3)).
6786 Predicate_Check : declare
6787 function In_Range_Check return Boolean;
6788 -- Within an expanded range check that may raise Constraint_Error do
6789 -- not generate a predicate check as well. It is redundant because
6790 -- the context will add an explicit predicate check, and it will
6791 -- raise the wrong exception if it fails.
6793 --------------------
6794 -- In_Range_Check --
6795 --------------------
6797 function In_Range_Check return Boolean is
6801 while Present (P) loop
6802 if Nkind (P) = N_Raise_Constraint_Error then
6805 elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call
6806 or else Nkind (P) = N_Procedure_Call_Statement
6807 or else Nkind (P) in N_Declaration
6820 PFunc : constant Entity_Id := Predicate_Function (Rtyp);
6823 -- Start of processing for Predicate_Check
6827 and then Current_Scope /= PFunc
6828 and then Nkind (Rop) /= N_Range
6830 if not In_Range_Check then
6831 R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True);
6833 R_Op := New_Occurrence_Of (Standard_True, Loc);
6838 Left_Opnd => Relocate_Node (N),
6839 Right_Opnd => R_Op));
6841 -- Analyze new expression, mark left operand as analyzed to
6842 -- avoid infinite recursion adding predicate calls. Similarly,
6843 -- suppress further range checks on the call.
6845 Set_Analyzed (Left_Opnd (N));
6846 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6848 -- All done, skip attempt at compile time determination of result
6852 end Predicate_Check;
6855 --------------------------------
6856 -- Expand_N_Indexed_Component --
6857 --------------------------------
6859 procedure Expand_N_Indexed_Component (N : Node_Id) is
6860 Loc : constant Source_Ptr := Sloc (N);
6861 Typ : constant Entity_Id := Etype (N);
6862 P : constant Node_Id := Prefix (N);
6863 T : constant Entity_Id := Etype (P);
6867 -- A special optimization, if we have an indexed component that is
6868 -- selecting from a slice, then we can eliminate the slice, since, for
6869 -- example, x (i .. j)(k) is identical to x(k). The only difference is
6870 -- the range check required by the slice. The range check for the slice
6871 -- itself has already been generated. The range check for the
6872 -- subscripting operation is ensured by converting the subject to
6873 -- the subtype of the slice.
6875 -- This optimization not only generates better code, avoiding slice
6876 -- messing especially in the packed case, but more importantly bypasses
6877 -- some problems in handling this peculiar case, for example, the issue
6878 -- of dealing specially with object renamings.
6880 if Nkind (P) = N_Slice
6882 -- This optimization is disabled for CodePeer because it can transform
6883 -- an index-check constraint_error into a range-check constraint_error
6884 -- and CodePeer cares about that distinction.
6886 and then not CodePeer_Mode
6889 Make_Indexed_Component (Loc,
6890 Prefix => Prefix (P),
6891 Expressions => New_List (
6893 (Etype (First_Index (Etype (P))),
6894 First (Expressions (N))))));
6895 Analyze_And_Resolve (N, Typ);
6899 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6900 -- function, then additional actuals must be passed.
6902 if Is_Build_In_Place_Function_Call (P) then
6903 Make_Build_In_Place_Call_In_Anonymous_Context (P);
6905 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
6906 -- containing build-in-place function calls whose returned object covers
6909 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
6910 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
6913 -- If the prefix is an access type, then we unconditionally rewrite if
6914 -- as an explicit dereference. This simplifies processing for several
6915 -- cases, including packed array cases and certain cases in which checks
6916 -- must be generated. We used to try to do this only when it was
6917 -- necessary, but it cleans up the code to do it all the time.
6919 if Is_Access_Type (T) then
6920 Insert_Explicit_Dereference (P);
6921 Analyze_And_Resolve (P, Designated_Type (T));
6922 Atp := Designated_Type (T);
6927 -- Generate index and validity checks
6929 Generate_Index_Checks (N);
6931 if Validity_Checks_On and then Validity_Check_Subscripts then
6932 Apply_Subscript_Validity_Checks (N);
6935 -- If selecting from an array with atomic components, and atomic sync
6936 -- is not suppressed for this array type, set atomic sync flag.
6938 if (Has_Atomic_Components (Atp)
6939 and then not Atomic_Synchronization_Disabled (Atp))
6940 or else (Is_Atomic (Typ)
6941 and then not Atomic_Synchronization_Disabled (Typ))
6942 or else (Is_Entity_Name (P)
6943 and then Has_Atomic_Components (Entity (P))
6944 and then not Atomic_Synchronization_Disabled (Entity (P)))
6946 Activate_Atomic_Synchronization (N);
6949 -- All done if the prefix is not a packed array implemented specially
6951 if not (Is_Packed (Etype (Prefix (N)))
6952 and then Present (Packed_Array_Impl_Type (Etype (Prefix (N)))))
6957 -- For packed arrays that are not bit-packed (i.e. the case of an array
6958 -- with one or more index types with a non-contiguous enumeration type),
6959 -- we can always use the normal packed element get circuit.
6961 if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
6962 Expand_Packed_Element_Reference (N);
6966 -- For a reference to a component of a bit packed array, we convert it
6967 -- to a reference to the corresponding Packed_Array_Impl_Type. We only
6968 -- want to do this for simple references, and not for:
6970 -- Left side of assignment, or prefix of left side of assignment, or
6971 -- prefix of the prefix, to handle packed arrays of packed arrays,
6972 -- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6974 -- Renaming objects in renaming associations
6975 -- This case is handled when a use of the renamed variable occurs
6977 -- Actual parameters for a subprogram call
6978 -- This case is handled in Exp_Ch6.Expand_Actuals
6980 -- The second expression in a 'Read attribute reference
6982 -- The prefix of an address or bit or size attribute reference
6984 -- The following circuit detects these exceptions. Note that we need to
6985 -- deal with implicit dereferences when climbing up the parent chain,
6986 -- with the additional difficulty that the type of parents may have yet
6987 -- to be resolved since prefixes are usually resolved first.
6990 Child : Node_Id := N;
6991 Parnt : Node_Id := Parent (N);
6995 if Nkind (Parnt) = N_Unchecked_Expression then
6998 elsif Nkind (Parnt) = N_Object_Renaming_Declaration then
7001 elsif Nkind (Parnt) in N_Subprogram_Call
7002 or else (Nkind (Parnt) = N_Parameter_Association
7003 and then Nkind (Parent (Parnt)) in N_Subprogram_Call)
7007 elsif Nkind (Parnt) = N_Attribute_Reference
7008 and then Nam_In (Attribute_Name (Parnt), Name_Address,
7011 and then Prefix (Parnt) = Child
7015 elsif Nkind (Parnt) = N_Assignment_Statement
7016 and then Name (Parnt) = Child
7020 -- If the expression is an index of an indexed component, it must
7021 -- be expanded regardless of context.
7023 elsif Nkind (Parnt) = N_Indexed_Component
7024 and then Child /= Prefix (Parnt)
7026 Expand_Packed_Element_Reference (N);
7029 elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
7030 and then Name (Parent (Parnt)) = Parnt
7034 elsif Nkind (Parnt) = N_Attribute_Reference
7035 and then Attribute_Name (Parnt) = Name_Read
7036 and then Next (First (Expressions (Parnt))) = Child
7040 elsif Nkind (Parnt) = N_Indexed_Component
7041 and then Prefix (Parnt) = Child
7045 elsif Nkind (Parnt) = N_Selected_Component
7046 and then Prefix (Parnt) = Child
7047 and then not (Present (Etype (Selector_Name (Parnt)))
7049 Is_Access_Type (Etype (Selector_Name (Parnt))))
7053 -- If the parent is a dereference, either implicit or explicit,
7054 -- then the packed reference needs to be expanded.
7057 Expand_Packed_Element_Reference (N);
7061 -- Keep looking up tree for unchecked expression, or if we are the
7062 -- prefix of a possible assignment left side.
7065 Parnt := Parent (Child);
7068 end Expand_N_Indexed_Component;
7070 ---------------------
7071 -- Expand_N_Not_In --
7072 ---------------------
7074 -- Replace a not in b by not (a in b) so that the expansions for (a in b)
7075 -- can be done. This avoids needing to duplicate this expansion code.
7077 procedure Expand_N_Not_In (N : Node_Id) is
7078 Loc : constant Source_Ptr := Sloc (N);
7079 Typ : constant Entity_Id := Etype (N);
7080 Cfs : constant Boolean := Comes_From_Source (N);
7087 Left_Opnd => Left_Opnd (N),
7088 Right_Opnd => Right_Opnd (N))));
7090 -- If this is a set membership, preserve list of alternatives
7092 Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
7094 -- We want this to appear as coming from source if original does (see
7095 -- transformations in Expand_N_In).
7097 Set_Comes_From_Source (N, Cfs);
7098 Set_Comes_From_Source (Right_Opnd (N), Cfs);
7100 -- Now analyze transformed node
7102 Analyze_And_Resolve (N, Typ);
7103 end Expand_N_Not_In;
7109 -- The only replacement required is for the case of a null of a type that
7110 -- is an access to protected subprogram, or a subtype thereof. We represent
7111 -- such access values as a record, and so we must replace the occurrence of
7112 -- null by the equivalent record (with a null address and a null pointer in
7113 -- it), so that the back end creates the proper value.
7115 procedure Expand_N_Null (N : Node_Id) is
7116 Loc : constant Source_Ptr := Sloc (N);
7117 Typ : constant Entity_Id := Base_Type (Etype (N));
7121 if Is_Access_Protected_Subprogram_Type (Typ) then
7123 Make_Aggregate (Loc,
7124 Expressions => New_List (
7125 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
7129 Analyze_And_Resolve (N, Equivalent_Type (Typ));
7131 -- For subsequent semantic analysis, the node must retain its type.
7132 -- Gigi in any case replaces this type by the corresponding record
7133 -- type before processing the node.
7139 when RE_Not_Available =>
7143 ---------------------
7144 -- Expand_N_Op_Abs --
7145 ---------------------
7147 procedure Expand_N_Op_Abs (N : Node_Id) is
7148 Loc : constant Source_Ptr := Sloc (N);
7149 Expr : constant Node_Id := Right_Opnd (N);
7152 Unary_Op_Validity_Checks (N);
7154 -- Check for MINIMIZED/ELIMINATED overflow mode
7156 if Minimized_Eliminated_Overflow_Check (N) then
7157 Apply_Arithmetic_Overflow_Check (N);
7161 -- Deal with software overflow checking
7163 if Is_Signed_Integer_Type (Etype (N))
7164 and then Do_Overflow_Check (N)
7166 -- The only case to worry about is when the argument is equal to the
7167 -- largest negative number, so what we do is to insert the check:
7169 -- [constraint_error when Expr = typ'Base'First]
7171 -- with the usual Duplicate_Subexpr use coding for expr
7174 Make_Raise_Constraint_Error (Loc,
7177 Left_Opnd => Duplicate_Subexpr (Expr),
7179 Make_Attribute_Reference (Loc,
7181 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
7182 Attribute_Name => Name_First)),
7183 Reason => CE_Overflow_Check_Failed));
7185 Set_Do_Overflow_Check (N, False);
7187 end Expand_N_Op_Abs;
7189 ---------------------
7190 -- Expand_N_Op_Add --
7191 ---------------------
7193 procedure Expand_N_Op_Add (N : Node_Id) is
7194 Typ : constant Entity_Id := Etype (N);
7197 Binary_Op_Validity_Checks (N);
7199 -- Check for MINIMIZED/ELIMINATED overflow mode
7201 if Minimized_Eliminated_Overflow_Check (N) then
7202 Apply_Arithmetic_Overflow_Check (N);
7206 -- N + 0 = 0 + N = N for integer types
7208 if Is_Integer_Type (Typ) then
7209 if Compile_Time_Known_Value (Right_Opnd (N))
7210 and then Expr_Value (Right_Opnd (N)) = Uint_0
7212 Rewrite (N, Left_Opnd (N));
7215 elsif Compile_Time_Known_Value (Left_Opnd (N))
7216 and then Expr_Value (Left_Opnd (N)) = Uint_0
7218 Rewrite (N, Right_Opnd (N));
7223 -- Arithmetic overflow checks for signed integer/fixed point types
7225 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
7226 Apply_Arithmetic_Overflow_Check (N);
7230 -- Overflow checks for floating-point if -gnateF mode active
7232 Check_Float_Op_Overflow (N);
7234 Expand_Nonbinary_Modular_Op (N);
7235 end Expand_N_Op_Add;
7237 ---------------------
7238 -- Expand_N_Op_And --
7239 ---------------------
7241 procedure Expand_N_Op_And (N : Node_Id) is
7242 Typ : constant Entity_Id := Etype (N);
7245 Binary_Op_Validity_Checks (N);
7247 if Is_Array_Type (Etype (N)) then
7248 Expand_Boolean_Operator (N);
7250 elsif Is_Boolean_Type (Etype (N)) then
7251 Adjust_Condition (Left_Opnd (N));
7252 Adjust_Condition (Right_Opnd (N));
7253 Set_Etype (N, Standard_Boolean);
7254 Adjust_Result_Type (N, Typ);
7256 elsif Is_Intrinsic_Subprogram (Entity (N)) then
7257 Expand_Intrinsic_Call (N, Entity (N));
7260 Expand_Nonbinary_Modular_Op (N);
7261 end Expand_N_Op_And;
7263 ------------------------
7264 -- Expand_N_Op_Concat --
7265 ------------------------
7267 procedure Expand_N_Op_Concat (N : Node_Id) is
7269 -- List of operands to be concatenated
7272 -- Node which is to be replaced by the result of concatenating the nodes
7273 -- in the list Opnds.
7276 -- Ensure validity of both operands
7278 Binary_Op_Validity_Checks (N);
7280 -- If we are the left operand of a concatenation higher up the tree,
7281 -- then do nothing for now, since we want to deal with a series of
7282 -- concatenations as a unit.
7284 if Nkind (Parent (N)) = N_Op_Concat
7285 and then N = Left_Opnd (Parent (N))
7290 -- We get here with a concatenation whose left operand may be a
7291 -- concatenation itself with a consistent type. We need to process
7292 -- these concatenation operands from left to right, which means
7293 -- from the deepest node in the tree to the highest node.
7296 while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
7297 Cnode := Left_Opnd (Cnode);
7300 -- Now Cnode is the deepest concatenation, and its parents are the
7301 -- concatenation nodes above, so now we process bottom up, doing the
7304 -- The outer loop runs more than once if more than one concatenation
7305 -- type is involved.
7308 Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
7309 Set_Parent (Opnds, N);
7311 -- The inner loop gathers concatenation operands
7313 Inner : while Cnode /= N
7314 and then Base_Type (Etype (Cnode)) =
7315 Base_Type (Etype (Parent (Cnode)))
7317 Cnode := Parent (Cnode);
7318 Append (Right_Opnd (Cnode), Opnds);
7321 -- Note: The following code is a temporary workaround for N731-034
7322 -- and N829-028 and will be kept until the general issue of internal
7323 -- symbol serialization is addressed. The workaround is kept under a
7324 -- debug switch to avoid permiating into the general case.
7326 -- Wrap the node to concatenate into an expression actions node to
7327 -- keep it nicely packaged. This is useful in the case of an assert
7328 -- pragma with a concatenation where we want to be able to delete
7329 -- the concatenation and all its expansion stuff.
7331 if Debug_Flag_Dot_H then
7333 Cnod : constant Node_Id := New_Copy_Tree (Cnode);
7334 Typ : constant Entity_Id := Base_Type (Etype (Cnode));
7337 -- Note: use Rewrite rather than Replace here, so that for
7338 -- example Why_Not_Static can find the original concatenation
7342 Make_Expression_With_Actions (Sloc (Cnode),
7343 Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
7344 Expression => Cnod));
7346 Expand_Concatenate (Cnod, Opnds);
7347 Analyze_And_Resolve (Cnode, Typ);
7353 Expand_Concatenate (Cnode, Opnds);
7356 exit Outer when Cnode = N;
7357 Cnode := Parent (Cnode);
7359 end Expand_N_Op_Concat;
7361 ------------------------
7362 -- Expand_N_Op_Divide --
7363 ------------------------
7365 procedure Expand_N_Op_Divide (N : Node_Id) is
7366 Loc : constant Source_Ptr := Sloc (N);
7367 Lopnd : constant Node_Id := Left_Opnd (N);
7368 Ropnd : constant Node_Id := Right_Opnd (N);
7369 Ltyp : constant Entity_Id := Etype (Lopnd);
7370 Rtyp : constant Entity_Id := Etype (Ropnd);
7371 Typ : Entity_Id := Etype (N);
7372 Rknow : constant Boolean := Is_Integer_Type (Typ)
7374 Compile_Time_Known_Value (Ropnd);
7378 Binary_Op_Validity_Checks (N);
7380 -- Check for MINIMIZED/ELIMINATED overflow mode
7382 if Minimized_Eliminated_Overflow_Check (N) then
7383 Apply_Arithmetic_Overflow_Check (N);
7387 -- Otherwise proceed with expansion of division
7390 Rval := Expr_Value (Ropnd);
7393 -- N / 1 = N for integer types
7395 if Rknow and then Rval = Uint_1 then
7400 -- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
7401 -- Is_Power_Of_2_For_Shift is set means that we know that our left
7402 -- operand is an unsigned integer, as required for this to work.
7404 if Nkind (Ropnd) = N_Op_Expon
7405 and then Is_Power_Of_2_For_Shift (Ropnd)
7407 -- We cannot do this transformation in configurable run time mode if we
7408 -- have 64-bit integers and long shifts are not available.
7410 and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target)
7413 Make_Op_Shift_Right (Loc,
7416 Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
7417 Analyze_And_Resolve (N, Typ);
7421 -- Do required fixup of universal fixed operation
7423 if Typ = Universal_Fixed then
7424 Fixup_Universal_Fixed_Operation (N);
7428 -- Divisions with fixed-point results
7430 if Is_Fixed_Point_Type (Typ) then
7432 -- No special processing if Treat_Fixed_As_Integer is set, since
7433 -- from a semantic point of view such operations are simply integer
7434 -- operations and will be treated that way.
7436 if not Treat_Fixed_As_Integer (N) then
7437 if Is_Integer_Type (Rtyp) then
7438 Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
7440 Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
7444 -- Deal with divide-by-zero check if back end cannot handle them
7445 -- and the flag is set indicating that we need such a check. Note
7446 -- that we don't need to bother here with the case of mixed-mode
7447 -- (Right operand an integer type), since these will be rewritten
7448 -- with conversions to a divide with a fixed-point right operand.
7450 if Nkind (N) = N_Op_Divide
7451 and then Do_Division_Check (N)
7452 and then not Backend_Divide_Checks_On_Target
7453 and then not Is_Integer_Type (Rtyp)
7455 Set_Do_Division_Check (N, False);
7457 Make_Raise_Constraint_Error (Loc,
7460 Left_Opnd => Duplicate_Subexpr_Move_Checks (Ropnd),
7461 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
7462 Reason => CE_Divide_By_Zero));
7465 -- Other cases of division of fixed-point operands. Again we exclude the
7466 -- case where Treat_Fixed_As_Integer is set.
7468 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
7469 and then not Treat_Fixed_As_Integer (N)
7471 if Is_Integer_Type (Typ) then
7472 Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
7474 pragma Assert (Is_Floating_Point_Type (Typ));
7475 Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
7478 -- Mixed-mode operations can appear in a non-static universal context,
7479 -- in which case the integer argument must be converted explicitly.
7481 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
7483 Convert_To (Universal_Real, Relocate_Node (Ropnd)));
7485 Analyze_And_Resolve (Ropnd, Universal_Real);
7487 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
7489 Convert_To (Universal_Real, Relocate_Node (Lopnd)));
7491 Analyze_And_Resolve (Lopnd, Universal_Real);
7493 -- Non-fixed point cases, do integer zero divide and overflow checks
7495 elsif Is_Integer_Type (Typ) then
7496 Apply_Divide_Checks (N);
7499 -- Overflow checks for floating-point if -gnateF mode active
7501 Check_Float_Op_Overflow (N);
7503 Expand_Nonbinary_Modular_Op (N);
7504 end Expand_N_Op_Divide;
7506 --------------------
7507 -- Expand_N_Op_Eq --
7508 --------------------
7510 procedure Expand_N_Op_Eq (N : Node_Id) is
7511 Loc : constant Source_Ptr := Sloc (N);
7512 Typ : constant Entity_Id := Etype (N);
7513 Lhs : constant Node_Id := Left_Opnd (N);
7514 Rhs : constant Node_Id := Right_Opnd (N);
7515 Bodies : constant List_Id := New_List;
7516 A_Typ : constant Entity_Id := Etype (Lhs);
7518 procedure Build_Equality_Call (Eq : Entity_Id);
7519 -- If a constructed equality exists for the type or for its parent,
7520 -- build and analyze call, adding conversions if the operation is
7523 function Is_Equality (Subp : Entity_Id;
7524 Typ : Entity_Id := Empty) return Boolean;
7525 -- Determine whether arbitrary Entity_Id denotes a function with the
7526 -- right name and profile for an equality op, specifically for the
7527 -- base type Typ if Typ is nonempty.
7529 function Find_Equality (Prims : Elist_Id) return Entity_Id;
7530 -- Find a primitive equality function within primitive operation list
7533 function User_Defined_Primitive_Equality_Op
7534 (Typ : Entity_Id) return Entity_Id;
7535 -- Find a user-defined primitive equality function for a given untagged
7536 -- record type, ignoring visibility. Return Empty if no such op found.
7538 function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean;
7539 -- Determines whether a type has a subcomponent of an unconstrained
7540 -- Unchecked_Union subtype. Typ is a record type.
7542 -------------------------
7543 -- Build_Equality_Call --
7544 -------------------------
7546 procedure Build_Equality_Call (Eq : Entity_Id) is
7547 Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
7548 L_Exp : Node_Id := Relocate_Node (Lhs);
7549 R_Exp : Node_Id := Relocate_Node (Rhs);
7552 -- Adjust operands if necessary to comparison type
7554 if Base_Type (Op_Type) /= Base_Type (A_Typ)
7555 and then not Is_Class_Wide_Type (A_Typ)
7557 L_Exp := OK_Convert_To (Op_Type, L_Exp);
7558 R_Exp := OK_Convert_To (Op_Type, R_Exp);
7561 -- If we have an Unchecked_Union, we need to add the inferred
7562 -- discriminant values as actuals in the function call. At this
7563 -- point, the expansion has determined that both operands have
7564 -- inferable discriminants.
7566 if Is_Unchecked_Union (Op_Type) then
7568 Lhs_Type : constant Node_Id := Etype (L_Exp);
7569 Rhs_Type : constant Node_Id := Etype (R_Exp);
7571 Lhs_Discr_Vals : Elist_Id;
7572 -- List of inferred discriminant values for left operand.
7574 Rhs_Discr_Vals : Elist_Id;
7575 -- List of inferred discriminant values for right operand.
7580 Lhs_Discr_Vals := New_Elmt_List;
7581 Rhs_Discr_Vals := New_Elmt_List;
7583 -- Per-object constrained selected components require special
7584 -- attention. If the enclosing scope of the component is an
7585 -- Unchecked_Union, we cannot reference its discriminants
7586 -- directly. This is why we use the extra parameters of the
7587 -- equality function of the enclosing Unchecked_Union.
7589 -- type UU_Type (Discr : Integer := 0) is
7592 -- pragma Unchecked_Union (UU_Type);
7594 -- 1. Unchecked_Union enclosing record:
7596 -- type Enclosing_UU_Type (Discr : Integer := 0) is record
7598 -- Comp : UU_Type (Discr);
7600 -- end Enclosing_UU_Type;
7601 -- pragma Unchecked_Union (Enclosing_UU_Type);
7603 -- Obj1 : Enclosing_UU_Type;
7604 -- Obj2 : Enclosing_UU_Type (1);
7606 -- [. . .] Obj1 = Obj2 [. . .]
7610 -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
7612 -- A and B are the formal parameters of the equality function
7613 -- of Enclosing_UU_Type. The function always has two extra
7614 -- formals to capture the inferred discriminant values for
7615 -- each discriminant of the type.
7617 -- 2. Non-Unchecked_Union enclosing record:
7620 -- Enclosing_Non_UU_Type (Discr : Integer := 0)
7623 -- Comp : UU_Type (Discr);
7625 -- end Enclosing_Non_UU_Type;
7627 -- Obj1 : Enclosing_Non_UU_Type;
7628 -- Obj2 : Enclosing_Non_UU_Type (1);
7630 -- ... Obj1 = Obj2 ...
7634 -- if not (uu_typeEQ (obj1.comp, obj2.comp,
7635 -- obj1.discr, obj2.discr)) then
7637 -- In this case we can directly reference the discriminants of
7638 -- the enclosing record.
7640 -- Process left operand of equality
7642 if Nkind (Lhs) = N_Selected_Component
7644 Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
7646 -- If enclosing record is an Unchecked_Union, use formals
7647 -- corresponding to each discriminant. The name of the
7648 -- formal is that of the discriminant, with added suffix,
7649 -- see Exp_Ch3.Build_Record_Equality for details.
7651 if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs))))
7655 (Scope (Entity (Selector_Name (Lhs))));
7656 while Present (Discr) loop
7658 (Make_Identifier (Loc,
7659 Chars => New_External_Name (Chars (Discr), 'A')),
7660 To => Lhs_Discr_Vals);
7661 Next_Discriminant (Discr);
7664 -- If enclosing record is of a non-Unchecked_Union type, it
7665 -- is possible to reference its discriminants directly.
7668 Discr := First_Discriminant (Lhs_Type);
7669 while Present (Discr) loop
7671 (Make_Selected_Component (Loc,
7672 Prefix => Prefix (Lhs),
7675 (Get_Discriminant_Value (Discr,
7677 Stored_Constraint (Lhs_Type)))),
7678 To => Lhs_Discr_Vals);
7679 Next_Discriminant (Discr);
7683 -- Otherwise operand is on object with a constrained type.
7684 -- Infer the discriminant values from the constraint.
7687 Discr := First_Discriminant (Lhs_Type);
7688 while Present (Discr) loop
7691 (Get_Discriminant_Value (Discr,
7693 Stored_Constraint (Lhs_Type))),
7694 To => Lhs_Discr_Vals);
7695 Next_Discriminant (Discr);
7699 -- Similar processing for right operand of equality
7701 if Nkind (Rhs) = N_Selected_Component
7703 Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
7705 if Is_Unchecked_Union
7706 (Scope (Entity (Selector_Name (Rhs))))
7710 (Scope (Entity (Selector_Name (Rhs))));
7711 while Present (Discr) loop
7713 (Make_Identifier (Loc,
7714 Chars => New_External_Name (Chars (Discr), 'B')),
7715 To => Rhs_Discr_Vals);
7716 Next_Discriminant (Discr);
7720 Discr := First_Discriminant (Rhs_Type);
7721 while Present (Discr) loop
7723 (Make_Selected_Component (Loc,
7724 Prefix => Prefix (Rhs),
7726 New_Copy (Get_Discriminant_Value
7729 Stored_Constraint (Rhs_Type)))),
7730 To => Rhs_Discr_Vals);
7731 Next_Discriminant (Discr);
7736 Discr := First_Discriminant (Rhs_Type);
7737 while Present (Discr) loop
7739 (New_Copy (Get_Discriminant_Value
7742 Stored_Constraint (Rhs_Type))),
7743 To => Rhs_Discr_Vals);
7744 Next_Discriminant (Discr);
7748 -- Now merge the list of discriminant values so that values
7749 -- of corresponding discriminants are adjacent.
7757 Params := New_List (L_Exp, R_Exp);
7758 L_Elmt := First_Elmt (Lhs_Discr_Vals);
7759 R_Elmt := First_Elmt (Rhs_Discr_Vals);
7760 while Present (L_Elmt) loop
7761 Append_To (Params, Node (L_Elmt));
7762 Append_To (Params, Node (R_Elmt));
7768 Make_Function_Call (Loc,
7769 Name => New_Occurrence_Of (Eq, Loc),
7770 Parameter_Associations => Params));
7774 -- Normal case, not an unchecked union
7778 Make_Function_Call (Loc,
7779 Name => New_Occurrence_Of (Eq, Loc),
7780 Parameter_Associations => New_List (L_Exp, R_Exp)));
7783 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7784 end Build_Equality_Call;
7790 function Is_Equality (Subp : Entity_Id;
7791 Typ : Entity_Id := Empty) return Boolean is
7792 Formal_1 : Entity_Id;
7793 Formal_2 : Entity_Id;
7795 -- The equality function carries name "=", returns Boolean, and has
7796 -- exactly two formal parameters of an identical type.
7798 if Ekind (Subp) = E_Function
7799 and then Chars (Subp) = Name_Op_Eq
7800 and then Base_Type (Etype (Subp)) = Standard_Boolean
7802 Formal_1 := First_Formal (Subp);
7805 if Present (Formal_1) then
7806 Formal_2 := Next_Formal (Formal_1);
7811 and then Present (Formal_2)
7812 and then No (Next_Formal (Formal_2))
7813 and then Base_Type (Etype (Formal_1)) =
7814 Base_Type (Etype (Formal_2))
7817 or else Implementation_Base_Type (Etype (Formal_1)) = Typ);
7827 function Find_Equality (Prims : Elist_Id) return Entity_Id is
7828 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id;
7829 -- Find an equality in a possible alias chain starting from primitive
7832 ---------------------------
7833 -- Find_Aliased_Equality --
7834 ---------------------------
7836 function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id is
7840 -- Inspect each candidate in the alias chain, checking whether it
7841 -- denotes an equality.
7844 while Present (Candid) loop
7845 if Is_Equality (Candid) then
7849 Candid := Alias (Candid);
7853 end Find_Aliased_Equality;
7857 Eq_Prim : Entity_Id;
7858 Prim_Elmt : Elmt_Id;
7860 -- Start of processing for Find_Equality
7863 -- Assume that the tagged type lacks an equality
7867 -- Inspect the list of primitives looking for a suitable equality
7868 -- within a possible chain of aliases.
7870 Prim_Elmt := First_Elmt (Prims);
7871 while Present (Prim_Elmt) and then No (Eq_Prim) loop
7872 Eq_Prim := Find_Aliased_Equality (Node (Prim_Elmt));
7874 Next_Elmt (Prim_Elmt);
7877 -- A tagged type should always have an equality
7879 pragma Assert (Present (Eq_Prim));
7884 ----------------------------------------
7885 -- User_Defined_Primitive_Equality_Op --
7886 ----------------------------------------
7888 function User_Defined_Primitive_Equality_Op
7889 (Typ : Entity_Id) return Entity_Id
7891 Enclosing_Scope : constant Node_Id := Scope (Typ);
7894 -- Prune this search by somehow not looking at decls that precede
7895 -- the declaration of the first view of Typ (which might be a partial
7898 for Private_Entities in Boolean loop
7899 if Private_Entities then
7900 if Ekind (Enclosing_Scope) /= E_Package then
7903 E := First_Private_Entity (Enclosing_Scope);
7906 E := First_Entity (Enclosing_Scope);
7909 while Present (E) loop
7910 if Is_Equality (E, Typ) then
7913 E := Next_Entity (E);
7917 if Is_Derived_Type (Typ) then
7918 return User_Defined_Primitive_Equality_Op
7919 (Implementation_Base_Type (Etype (Typ)));
7923 end User_Defined_Primitive_Equality_Op;
7925 ------------------------------------
7926 -- Has_Unconstrained_UU_Component --
7927 ------------------------------------
7929 function Has_Unconstrained_UU_Component
7930 (Typ : Entity_Id) return Boolean
7932 Tdef : constant Node_Id :=
7933 Type_Definition (Declaration_Node (Base_Type (Typ)));
7937 function Component_Is_Unconstrained_UU
7938 (Comp : Node_Id) return Boolean;
7939 -- Determines whether the subtype of the component is an
7940 -- unconstrained Unchecked_Union.
7942 function Variant_Is_Unconstrained_UU
7943 (Variant : Node_Id) return Boolean;
7944 -- Determines whether a component of the variant has an unconstrained
7945 -- Unchecked_Union subtype.
7947 -----------------------------------
7948 -- Component_Is_Unconstrained_UU --
7949 -----------------------------------
7951 function Component_Is_Unconstrained_UU
7952 (Comp : Node_Id) return Boolean
7955 if Nkind (Comp) /= N_Component_Declaration then
7960 Sindic : constant Node_Id :=
7961 Subtype_Indication (Component_Definition (Comp));
7964 -- Unconstrained nominal type. In the case of a constraint
7965 -- present, the node kind would have been N_Subtype_Indication.
7967 if Nkind (Sindic) = N_Identifier then
7968 return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
7973 end Component_Is_Unconstrained_UU;
7975 ---------------------------------
7976 -- Variant_Is_Unconstrained_UU --
7977 ---------------------------------
7979 function Variant_Is_Unconstrained_UU
7980 (Variant : Node_Id) return Boolean
7982 Clist : constant Node_Id := Component_List (Variant);
7985 if Is_Empty_List (Component_Items (Clist)) then
7989 -- We only need to test one component
7992 Comp : Node_Id := First (Component_Items (Clist));
7995 while Present (Comp) loop
7996 if Component_Is_Unconstrained_UU (Comp) then
8004 -- None of the components withing the variant were of
8005 -- unconstrained Unchecked_Union type.
8008 end Variant_Is_Unconstrained_UU;
8010 -- Start of processing for Has_Unconstrained_UU_Component
8013 if Null_Present (Tdef) then
8017 Clist := Component_List (Tdef);
8018 Vpart := Variant_Part (Clist);
8020 -- Inspect available components
8022 if Present (Component_Items (Clist)) then
8024 Comp : Node_Id := First (Component_Items (Clist));
8027 while Present (Comp) loop
8029 -- One component is sufficient
8031 if Component_Is_Unconstrained_UU (Comp) then
8040 -- Inspect available components withing variants
8042 if Present (Vpart) then
8044 Variant : Node_Id := First (Variants (Vpart));
8047 while Present (Variant) loop
8049 -- One component within a variant is sufficient
8051 if Variant_Is_Unconstrained_UU (Variant) then
8060 -- Neither the available components, nor the components inside the
8061 -- variant parts were of an unconstrained Unchecked_Union subtype.
8064 end Has_Unconstrained_UU_Component;
8070 -- Start of processing for Expand_N_Op_Eq
8073 Binary_Op_Validity_Checks (N);
8075 -- Deal with private types
8079 if Ekind (Typl) = E_Private_Type then
8080 Typl := Underlying_Type (Typl);
8082 elsif Ekind (Typl) = E_Private_Subtype then
8083 Typl := Underlying_Type (Base_Type (Typl));
8086 -- It may happen in error situations that the underlying type is not
8087 -- set. The error will be detected later, here we just defend the
8094 -- Now get the implementation base type (note that plain Base_Type here
8095 -- might lead us back to the private type, which is not what we want!)
8097 Typl := Implementation_Base_Type (Typl);
8099 -- Equality between variant records results in a call to a routine
8100 -- that has conditional tests of the discriminant value(s), and hence
8101 -- violates the No_Implicit_Conditionals restriction.
8103 if Has_Variant_Part (Typl) then
8108 Check_Restriction (Msg, No_Implicit_Conditionals, N);
8112 ("\comparison of variant records tests discriminants", N);
8118 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8119 -- means we no longer have a comparison operation, we are all done.
8121 Expand_Compare_Minimize_Eliminate_Overflow (N);
8123 if Nkind (N) /= N_Op_Eq then
8127 -- Boolean types (requiring handling of non-standard case)
8129 if Is_Boolean_Type (Typl) then
8130 Adjust_Condition (Left_Opnd (N));
8131 Adjust_Condition (Right_Opnd (N));
8132 Set_Etype (N, Standard_Boolean);
8133 Adjust_Result_Type (N, Typ);
8137 elsif Is_Array_Type (Typl) then
8139 -- If we are doing full validity checking, and it is possible for the
8140 -- array elements to be invalid then expand out array comparisons to
8141 -- make sure that we check the array elements.
8143 if Validity_Check_Operands
8144 and then not Is_Known_Valid (Component_Type (Typl))
8147 Save_Force_Validity_Checks : constant Boolean :=
8148 Force_Validity_Checks;
8150 Force_Validity_Checks := True;
8152 Expand_Array_Equality
8154 Relocate_Node (Lhs),
8155 Relocate_Node (Rhs),
8158 Insert_Actions (N, Bodies);
8159 Analyze_And_Resolve (N, Standard_Boolean);
8160 Force_Validity_Checks := Save_Force_Validity_Checks;
8163 -- Packed case where both operands are known aligned
8165 elsif Is_Bit_Packed_Array (Typl)
8166 and then not Is_Possibly_Unaligned_Object (Lhs)
8167 and then not Is_Possibly_Unaligned_Object (Rhs)
8169 Expand_Packed_Eq (N);
8171 -- Where the component type is elementary we can use a block bit
8172 -- comparison (if supported on the target) exception in the case
8173 -- of floating-point (negative zero issues require element by
8174 -- element comparison), and atomic/VFA types (where we must be sure
8175 -- to load elements independently) and possibly unaligned arrays.
8177 elsif Is_Elementary_Type (Component_Type (Typl))
8178 and then not Is_Floating_Point_Type (Component_Type (Typl))
8179 and then not Is_Atomic_Or_VFA (Component_Type (Typl))
8180 and then not Is_Possibly_Unaligned_Object (Lhs)
8181 and then not Is_Possibly_Unaligned_Slice (Lhs)
8182 and then not Is_Possibly_Unaligned_Object (Rhs)
8183 and then not Is_Possibly_Unaligned_Slice (Rhs)
8184 and then Support_Composite_Compare_On_Target
8188 -- For composite and floating-point cases, expand equality loop to
8189 -- make sure of using proper comparisons for tagged types, and
8190 -- correctly handling the floating-point case.
8194 Expand_Array_Equality
8196 Relocate_Node (Lhs),
8197 Relocate_Node (Rhs),
8200 Insert_Actions (N, Bodies, Suppress => All_Checks);
8201 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8206 elsif Is_Record_Type (Typl) then
8208 -- For tagged types, use the primitive "="
8210 if Is_Tagged_Type (Typl) then
8212 -- No need to do anything else compiling under restriction
8213 -- No_Dispatching_Calls. During the semantic analysis we
8214 -- already notified such violation.
8216 if Restriction_Active (No_Dispatching_Calls) then
8220 -- If this is an untagged private type completed with a derivation
8221 -- of an untagged private type whose full view is a tagged type,
8222 -- we use the primitive operations of the private type (since it
8223 -- does not have a full view, and also because its equality
8224 -- primitive may have been overridden in its untagged full view).
8226 if Inherits_From_Tagged_Full_View (A_Typ) then
8228 (Find_Equality (Collect_Primitive_Operations (A_Typ)));
8230 -- Find the type's predefined equality or an overriding
8231 -- user-defined equality. The reason for not simply calling
8232 -- Find_Prim_Op here is that there may be a user-defined
8233 -- overloaded equality op that precedes the equality that we
8234 -- want, so we have to explicitly search (e.g., there could be
8235 -- an equality with two different parameter types).
8238 if Is_Class_Wide_Type (Typl) then
8239 Typl := Find_Specific_Type (Typl);
8243 (Find_Equality (Primitive_Operations (Typl)));
8246 -- See AI12-0101 (which only removes a legality rule) and then
8247 -- AI05-0123 (which then applies in the previously illegal case).
8248 -- AI12-0101 is a binding interpretation.
8250 elsif Ada_Version >= Ada_2012
8251 and then Present (User_Defined_Primitive_Equality_Op (Typl))
8253 Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl));
8255 -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
8256 -- predefined equality operator for a type which has a subcomponent
8257 -- of an Unchecked_Union type whose nominal subtype is unconstrained.
8259 elsif Has_Unconstrained_UU_Component (Typl) then
8261 Make_Raise_Program_Error (Loc,
8262 Reason => PE_Unchecked_Union_Restriction));
8264 -- Prevent Gigi from generating incorrect code by rewriting the
8265 -- equality as a standard False. (is this documented somewhere???)
8268 New_Occurrence_Of (Standard_False, Loc));
8270 elsif Is_Unchecked_Union (Typl) then
8272 -- If we can infer the discriminants of the operands, we make a
8273 -- call to the TSS equality function.
8275 if Has_Inferable_Discriminants (Lhs)
8277 Has_Inferable_Discriminants (Rhs)
8280 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8283 -- Ada 2005 (AI-216): Program_Error is raised when evaluating
8284 -- the predefined equality operator for an Unchecked_Union type
8285 -- if either of the operands lack inferable discriminants.
8288 Make_Raise_Program_Error (Loc,
8289 Reason => PE_Unchecked_Union_Restriction));
8291 -- Emit a warning on source equalities only, otherwise the
8292 -- message may appear out of place due to internal use. The
8293 -- warning is unconditional because it is required by the
8296 if Comes_From_Source (N) then
8298 ("Unchecked_Union discriminants cannot be determined??",
8301 ("\Program_Error will be raised for equality operation??",
8305 -- Prevent Gigi from generating incorrect code by rewriting
8306 -- the equality as a standard False (documented where???).
8309 New_Occurrence_Of (Standard_False, Loc));
8312 -- If a type support function is present (for complex cases), use it
8314 elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
8316 (TSS (Root_Type (Typl), TSS_Composite_Equality));
8318 -- When comparing two Bounded_Strings, use the primitive equality of
8319 -- the root Super_String type.
8321 elsif Is_Bounded_String (Typl) then
8324 (Collect_Primitive_Operations (Root_Type (Typl))));
8326 -- Otherwise expand the component by component equality. Note that
8327 -- we never use block-bit comparisons for records, because of the
8328 -- problems with gaps. The back end will often be able to recombine
8329 -- the separate comparisons that we generate here.
8332 Remove_Side_Effects (Lhs);
8333 Remove_Side_Effects (Rhs);
8335 Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
8337 Insert_Actions (N, Bodies, Suppress => All_Checks);
8338 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8341 -- If unnesting, handle elementary types whose Equivalent_Types are
8342 -- records because there may be padding or undefined fields.
8344 elsif Unnest_Subprogram_Mode
8345 and then Ekind_In (Typl, E_Class_Wide_Type,
8346 E_Class_Wide_Subtype,
8347 E_Access_Subprogram_Type,
8348 E_Access_Protected_Subprogram_Type,
8349 E_Anonymous_Access_Protected_Subprogram_Type,
8350 E_Access_Subprogram_Type,
8352 and then Present (Equivalent_Type (Typl))
8353 and then Is_Record_Type (Equivalent_Type (Typl))
8355 Typl := Equivalent_Type (Typl);
8356 Remove_Side_Effects (Lhs);
8357 Remove_Side_Effects (Rhs);
8359 Expand_Record_Equality (N, Typl,
8360 Unchecked_Convert_To (Typl, Lhs),
8361 Unchecked_Convert_To (Typl, Rhs),
8364 Insert_Actions (N, Bodies, Suppress => All_Checks);
8365 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
8368 -- Test if result is known at compile time
8370 Rewrite_Comparison (N);
8372 -- Special optimization of length comparison
8374 Optimize_Length_Comparison (N);
8376 -- One more special case: if we have a comparison of X'Result = expr
8377 -- in floating-point, then if not already there, change expr to be
8378 -- f'Machine (expr) to eliminate surprise from extra precision.
8380 if Is_Floating_Point_Type (Typl)
8381 and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference
8382 and then Attribute_Name (Original_Node (Lhs)) = Name_Result
8384 -- Stick in the Typ'Machine call if not already there
8386 if Nkind (Rhs) /= N_Attribute_Reference
8387 or else Attribute_Name (Rhs) /= Name_Machine
8390 Make_Attribute_Reference (Loc,
8391 Prefix => New_Occurrence_Of (Typl, Loc),
8392 Attribute_Name => Name_Machine,
8393 Expressions => New_List (Relocate_Node (Rhs))));
8394 Analyze_And_Resolve (Rhs, Typl);
8399 -----------------------
8400 -- Expand_N_Op_Expon --
8401 -----------------------
8403 procedure Expand_N_Op_Expon (N : Node_Id) is
8404 Loc : constant Source_Ptr := Sloc (N);
8405 Ovflo : constant Boolean := Do_Overflow_Check (N);
8406 Typ : constant Entity_Id := Etype (N);
8407 Rtyp : constant Entity_Id := Root_Type (Typ);
8411 function Wrap_MA (Exp : Node_Id) return Node_Id;
8412 -- Given an expression Exp, if the root type is Float or Long_Float,
8413 -- then wrap the expression in a call of Bastyp'Machine, to stop any
8414 -- extra precision. This is done to ensure that X**A = X**B when A is
8415 -- a static constant and B is a variable with the same value. For any
8416 -- other type, the node Exp is returned unchanged.
8422 function Wrap_MA (Exp : Node_Id) return Node_Id is
8423 Loc : constant Source_Ptr := Sloc (Exp);
8426 if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then
8428 Make_Attribute_Reference (Loc,
8429 Attribute_Name => Name_Machine,
8430 Prefix => New_Occurrence_Of (Bastyp, Loc),
8431 Expressions => New_List (Relocate_Node (Exp)));
8449 -- Start of processing for Expand_N_Op_Expon
8452 Binary_Op_Validity_Checks (N);
8454 -- CodePeer wants to see the unexpanded N_Op_Expon node
8456 if CodePeer_Mode then
8460 -- Relocation of left and right operands must be done after performing
8461 -- the validity checks since the generation of validation checks may
8462 -- remove side effects.
8464 Base := Relocate_Node (Left_Opnd (N));
8465 Bastyp := Etype (Base);
8466 Exp := Relocate_Node (Right_Opnd (N));
8467 Exptyp := Etype (Exp);
8469 -- If either operand is of a private type, then we have the use of an
8470 -- intrinsic operator, and we get rid of the privateness, by using root
8471 -- types of underlying types for the actual operation. Otherwise the
8472 -- private types will cause trouble if we expand multiplications or
8473 -- shifts etc. We also do this transformation if the result type is
8474 -- different from the base type.
8476 if Is_Private_Type (Etype (Base))
8477 or else Is_Private_Type (Typ)
8478 or else Is_Private_Type (Exptyp)
8479 or else Rtyp /= Root_Type (Bastyp)
8482 Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
8483 Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
8486 Unchecked_Convert_To (Typ,
8488 Left_Opnd => Unchecked_Convert_To (Bt, Base),
8489 Right_Opnd => Unchecked_Convert_To (Et, Exp))));
8490 Analyze_And_Resolve (N, Typ);
8495 -- Check for MINIMIZED/ELIMINATED overflow mode
8497 if Minimized_Eliminated_Overflow_Check (N) then
8498 Apply_Arithmetic_Overflow_Check (N);
8502 -- Test for case of known right argument where we can replace the
8503 -- exponentiation by an equivalent expression using multiplication.
8505 -- Note: use CRT_Safe version of Compile_Time_Known_Value because in
8506 -- configurable run-time mode, we may not have the exponentiation
8507 -- routine available, and we don't want the legality of the program
8508 -- to depend on how clever the compiler is in knowing values.
8510 if CRT_Safe_Compile_Time_Known_Value (Exp) then
8511 Expv := Expr_Value (Exp);
8513 -- We only fold small non-negative exponents. You might think we
8514 -- could fold small negative exponents for the real case, but we
8515 -- can't because we are required to raise Constraint_Error for
8516 -- the case of 0.0 ** (negative) even if Machine_Overflows = False.
8517 -- See ACVC test C4A012B, and it is not worth generating the test.
8519 -- For small negative exponents, we return the reciprocal of
8520 -- the folding of the exponentiation for the opposite (positive)
8521 -- exponent, as required by Ada RM 4.5.6(11/3).
8523 if abs Expv <= 4 then
8525 -- X ** 0 = 1 (or 1.0)
8529 -- Call Remove_Side_Effects to ensure that any side effects
8530 -- in the ignored left operand (in particular function calls
8531 -- to user defined functions) are properly executed.
8533 Remove_Side_Effects (Base);
8535 if Ekind (Typ) in Integer_Kind then
8536 Xnode := Make_Integer_Literal (Loc, Intval => 1);
8538 Xnode := Make_Real_Literal (Loc, Ureal_1);
8551 Make_Op_Multiply (Loc,
8552 Left_Opnd => Duplicate_Subexpr (Base),
8553 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
8555 -- X ** 3 = X * X * X
8560 Make_Op_Multiply (Loc,
8562 Make_Op_Multiply (Loc,
8563 Left_Opnd => Duplicate_Subexpr (Base),
8564 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
8565 Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
8570 -- En : constant base'type := base * base;
8575 Temp := Make_Temporary (Loc, 'E', Base);
8578 Make_Expression_With_Actions (Loc,
8579 Actions => New_List (
8580 Make_Object_Declaration (Loc,
8581 Defining_Identifier => Temp,
8582 Constant_Present => True,
8583 Object_Definition => New_Occurrence_Of (Typ, Loc),
8586 Make_Op_Multiply (Loc,
8588 Duplicate_Subexpr (Base),
8590 Duplicate_Subexpr_No_Checks (Base))))),
8594 Make_Op_Multiply (Loc,
8595 Left_Opnd => New_Occurrence_Of (Temp, Loc),
8596 Right_Opnd => New_Occurrence_Of (Temp, Loc))));
8598 -- X ** N = 1.0 / X ** (-N)
8603 (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4);
8606 Make_Op_Divide (Loc,
8608 Make_Float_Literal (Loc,
8610 Significand => Uint_1,
8611 Exponent => Uint_0),
8614 Left_Opnd => Duplicate_Subexpr (Base),
8616 Make_Integer_Literal (Loc,
8621 Analyze_And_Resolve (N, Typ);
8626 -- Deal with optimizing 2 ** expression to shift where possible
8628 -- Note: we used to check that Exptyp was an unsigned type. But that is
8629 -- an unnecessary check, since if Exp is negative, we have a run-time
8630 -- error that is either caught (so we get the right result) or we have
8631 -- suppressed the check, in which case the code is erroneous anyway.
8633 if Is_Integer_Type (Rtyp)
8635 -- The base value must be "safe compile-time known", and exactly 2
8637 and then Nkind (Base) = N_Integer_Literal
8638 and then CRT_Safe_Compile_Time_Known_Value (Base)
8639 and then Expr_Value (Base) = Uint_2
8641 -- We only handle cases where the right type is a integer
8643 and then Is_Integer_Type (Root_Type (Exptyp))
8644 and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
8646 -- This transformation is not applicable for a modular type with a
8647 -- nonbinary modulus because we do not handle modular reduction in
8648 -- a correct manner if we attempt this transformation in this case.
8650 and then not Non_Binary_Modulus (Typ)
8652 -- Handle the cases where our parent is a division or multiplication
8653 -- specially. In these cases we can convert to using a shift at the
8654 -- parent level if we are not doing overflow checking, since it is
8655 -- too tricky to combine the overflow check at the parent level.
8658 and then Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply)
8661 P : constant Node_Id := Parent (N);
8662 L : constant Node_Id := Left_Opnd (P);
8663 R : constant Node_Id := Right_Opnd (P);
8666 if (Nkind (P) = N_Op_Multiply
8668 ((Is_Integer_Type (Etype (L)) and then R = N)
8670 (Is_Integer_Type (Etype (R)) and then L = N))
8671 and then not Do_Overflow_Check (P))
8674 (Nkind (P) = N_Op_Divide
8675 and then Is_Integer_Type (Etype (L))
8676 and then Is_Unsigned_Type (Etype (L))
8678 and then not Do_Overflow_Check (P))
8680 Set_Is_Power_Of_2_For_Shift (N);
8685 -- Here we just have 2 ** N on its own, so we can convert this to a
8686 -- shift node. We are prepared to deal with overflow here, and we
8687 -- also have to handle proper modular reduction for binary modular.
8696 -- Maximum shift count with no overflow
8699 -- Set True if we must test the shift count
8702 -- Node for test against TestS
8705 -- Compute maximum shift based on the underlying size. For a
8706 -- modular type this is one less than the size.
8708 if Is_Modular_Integer_Type (Typ) then
8710 -- For modular integer types, this is the size of the value
8711 -- being shifted minus one. Any larger values will cause
8712 -- modular reduction to a result of zero. Note that we do
8713 -- want the RM_Size here (e.g. mod 2 ** 7, we want a result
8714 -- of 6, since 2**7 should be reduced to zero).
8716 MaxS := RM_Size (Rtyp) - 1;
8718 -- For signed integer types, we use the size of the value
8719 -- being shifted minus 2. Larger values cause overflow.
8722 MaxS := Esize (Rtyp) - 2;
8725 -- Determine range to see if it can be larger than MaxS
8728 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
8729 TestS := (not OK) or else Hi > MaxS;
8731 -- Signed integer case
8733 if Is_Signed_Integer_Type (Typ) then
8735 -- Generate overflow check if overflow is active. Note that
8736 -- we can simply ignore the possibility of overflow if the
8737 -- flag is not set (means that overflow cannot happen or
8738 -- that overflow checks are suppressed).
8740 if Ovflo and TestS then
8742 Make_Raise_Constraint_Error (Loc,
8745 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
8746 Right_Opnd => Make_Integer_Literal (Loc, MaxS)),
8747 Reason => CE_Overflow_Check_Failed));
8750 -- Now rewrite node as Shift_Left (1, right-operand)
8753 Make_Op_Shift_Left (Loc,
8754 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8755 Right_Opnd => Right_Opnd (N)));
8757 -- Modular integer case
8759 else pragma Assert (Is_Modular_Integer_Type (Typ));
8761 -- If shift count can be greater than MaxS, we need to wrap
8762 -- the shift in a test that will reduce the result value to
8763 -- zero if this shift count is exceeded.
8767 -- Note: build node for the comparison first, before we
8768 -- reuse the Right_Opnd, so that we have proper parents
8769 -- in place for the Duplicate_Subexpr call.
8773 Left_Opnd => Duplicate_Subexpr (Right_Opnd (N)),
8774 Right_Opnd => Make_Integer_Literal (Loc, MaxS));
8777 Make_If_Expression (Loc,
8778 Expressions => New_List (
8780 Make_Integer_Literal (Loc, Uint_0),
8781 Make_Op_Shift_Left (Loc,
8782 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8783 Right_Opnd => Right_Opnd (N)))));
8785 -- If we know shift count cannot be greater than MaxS, then
8786 -- it is safe to just rewrite as a shift with no test.
8790 Make_Op_Shift_Left (Loc,
8791 Left_Opnd => Make_Integer_Literal (Loc, Uint_1),
8792 Right_Opnd => Right_Opnd (N)));
8796 Analyze_And_Resolve (N, Typ);
8802 -- Fall through if exponentiation must be done using a runtime routine
8804 -- First deal with modular case
8806 if Is_Modular_Integer_Type (Rtyp) then
8808 -- Nonbinary modular case, we call the special exponentiation
8809 -- routine for the nonbinary case, converting the argument to
8810 -- Long_Long_Integer and passing the modulus value. Then the
8811 -- result is converted back to the base type.
8813 if Non_Binary_Modulus (Rtyp) then
8816 Make_Function_Call (Loc,
8818 New_Occurrence_Of (RTE (RE_Exp_Modular), Loc),
8819 Parameter_Associations => New_List (
8820 Convert_To (RTE (RE_Unsigned), Base),
8821 Make_Integer_Literal (Loc, Modulus (Rtyp)),
8824 -- Binary modular case, in this case, we call one of two routines,
8825 -- either the unsigned integer case, or the unsigned long long
8826 -- integer case, with a final "and" operation to do the required mod.
8829 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
8830 Ent := RTE (RE_Exp_Unsigned);
8832 Ent := RTE (RE_Exp_Long_Long_Unsigned);
8839 Make_Function_Call (Loc,
8840 Name => New_Occurrence_Of (Ent, Loc),
8841 Parameter_Associations => New_List (
8842 Convert_To (Etype (First_Formal (Ent)), Base),
8845 Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
8849 -- Common exit point for modular type case
8851 Analyze_And_Resolve (N, Typ);
8854 -- Signed integer cases, done using either Integer or Long_Long_Integer.
8855 -- It is not worth having routines for Short_[Short_]Integer, since for
8856 -- most machines it would not help, and it would generate more code that
8857 -- might need certification when a certified run time is required.
8859 -- In the integer cases, we have two routines, one for when overflow
8860 -- checks are required, and one when they are not required, since there
8861 -- is a real gain in omitting checks on many machines.
8863 elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
8864 or else (Rtyp = Base_Type (Standard_Long_Integer)
8866 Esize (Standard_Long_Integer) > Esize (Standard_Integer))
8867 or else Rtyp = Universal_Integer
8869 Etyp := Standard_Long_Long_Integer;
8872 Rent := RE_Exp_Long_Long_Integer;
8874 Rent := RE_Exn_Long_Long_Integer;
8877 elsif Is_Signed_Integer_Type (Rtyp) then
8878 Etyp := Standard_Integer;
8881 Rent := RE_Exp_Integer;
8883 Rent := RE_Exn_Integer;
8886 -- Floating-point cases. We do not need separate routines for the
8887 -- overflow case here, since in the case of floating-point, we generate
8888 -- infinities anyway as a rule (either that or we automatically trap
8889 -- overflow), and if there is an infinity generated and a range check
8890 -- is required, the check will fail anyway.
8892 -- Historical note: we used to convert everything to Long_Long_Float
8893 -- and call a single common routine, but this had the undesirable effect
8894 -- of giving different results for small static exponent values and the
8895 -- same dynamic values.
8898 pragma Assert (Is_Floating_Point_Type (Rtyp));
8900 if Rtyp = Standard_Float then
8901 Etyp := Standard_Float;
8902 Rent := RE_Exn_Float;
8904 elsif Rtyp = Standard_Long_Float then
8905 Etyp := Standard_Long_Float;
8906 Rent := RE_Exn_Long_Float;
8909 Etyp := Standard_Long_Long_Float;
8910 Rent := RE_Exn_Long_Long_Float;
8914 -- Common processing for integer cases and floating-point cases.
8915 -- If we are in the right type, we can call runtime routine directly
8918 and then Rtyp /= Universal_Integer
8919 and then Rtyp /= Universal_Real
8923 Make_Function_Call (Loc,
8924 Name => New_Occurrence_Of (RTE (Rent), Loc),
8925 Parameter_Associations => New_List (Base, Exp))));
8927 -- Otherwise we have to introduce conversions (conversions are also
8928 -- required in the universal cases, since the runtime routine is
8929 -- typed using one of the standard types).
8934 Make_Function_Call (Loc,
8935 Name => New_Occurrence_Of (RTE (Rent), Loc),
8936 Parameter_Associations => New_List (
8937 Convert_To (Etyp, Base),
8941 Analyze_And_Resolve (N, Typ);
8945 when RE_Not_Available =>
8947 end Expand_N_Op_Expon;
8949 --------------------
8950 -- Expand_N_Op_Ge --
8951 --------------------
8953 procedure Expand_N_Op_Ge (N : Node_Id) is
8954 Typ : constant Entity_Id := Etype (N);
8955 Op1 : constant Node_Id := Left_Opnd (N);
8956 Op2 : constant Node_Id := Right_Opnd (N);
8957 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8960 Binary_Op_Validity_Checks (N);
8962 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8963 -- means we no longer have a comparison operation, we are all done.
8965 Expand_Compare_Minimize_Eliminate_Overflow (N);
8967 if Nkind (N) /= N_Op_Ge then
8973 if Is_Array_Type (Typ1) then
8974 Expand_Array_Comparison (N);
8978 -- Deal with boolean operands
8980 if Is_Boolean_Type (Typ1) then
8981 Adjust_Condition (Op1);
8982 Adjust_Condition (Op2);
8983 Set_Etype (N, Standard_Boolean);
8984 Adjust_Result_Type (N, Typ);
8987 Rewrite_Comparison (N);
8989 Optimize_Length_Comparison (N);
8992 --------------------
8993 -- Expand_N_Op_Gt --
8994 --------------------
8996 procedure Expand_N_Op_Gt (N : Node_Id) is
8997 Typ : constant Entity_Id := Etype (N);
8998 Op1 : constant Node_Id := Left_Opnd (N);
8999 Op2 : constant Node_Id := Right_Opnd (N);
9000 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9003 Binary_Op_Validity_Checks (N);
9005 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9006 -- means we no longer have a comparison operation, we are all done.
9008 Expand_Compare_Minimize_Eliminate_Overflow (N);
9010 if Nkind (N) /= N_Op_Gt then
9014 -- Deal with array type operands
9016 if Is_Array_Type (Typ1) then
9017 Expand_Array_Comparison (N);
9021 -- Deal with boolean type operands
9023 if Is_Boolean_Type (Typ1) then
9024 Adjust_Condition (Op1);
9025 Adjust_Condition (Op2);
9026 Set_Etype (N, Standard_Boolean);
9027 Adjust_Result_Type (N, Typ);
9030 Rewrite_Comparison (N);
9032 Optimize_Length_Comparison (N);
9035 --------------------
9036 -- Expand_N_Op_Le --
9037 --------------------
9039 procedure Expand_N_Op_Le (N : Node_Id) is
9040 Typ : constant Entity_Id := Etype (N);
9041 Op1 : constant Node_Id := Left_Opnd (N);
9042 Op2 : constant Node_Id := Right_Opnd (N);
9043 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9046 Binary_Op_Validity_Checks (N);
9048 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9049 -- means we no longer have a comparison operation, we are all done.
9051 Expand_Compare_Minimize_Eliminate_Overflow (N);
9053 if Nkind (N) /= N_Op_Le then
9057 -- Deal with array type operands
9059 if Is_Array_Type (Typ1) then
9060 Expand_Array_Comparison (N);
9064 -- Deal with Boolean type operands
9066 if Is_Boolean_Type (Typ1) then
9067 Adjust_Condition (Op1);
9068 Adjust_Condition (Op2);
9069 Set_Etype (N, Standard_Boolean);
9070 Adjust_Result_Type (N, Typ);
9073 Rewrite_Comparison (N);
9075 Optimize_Length_Comparison (N);
9078 --------------------
9079 -- Expand_N_Op_Lt --
9080 --------------------
9082 procedure Expand_N_Op_Lt (N : Node_Id) is
9083 Typ : constant Entity_Id := Etype (N);
9084 Op1 : constant Node_Id := Left_Opnd (N);
9085 Op2 : constant Node_Id := Right_Opnd (N);
9086 Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
9089 Binary_Op_Validity_Checks (N);
9091 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
9092 -- means we no longer have a comparison operation, we are all done.
9094 Expand_Compare_Minimize_Eliminate_Overflow (N);
9096 if Nkind (N) /= N_Op_Lt then
9100 -- Deal with array type operands
9102 if Is_Array_Type (Typ1) then
9103 Expand_Array_Comparison (N);
9107 -- Deal with Boolean type operands
9109 if Is_Boolean_Type (Typ1) then
9110 Adjust_Condition (Op1);
9111 Adjust_Condition (Op2);
9112 Set_Etype (N, Standard_Boolean);
9113 Adjust_Result_Type (N, Typ);
9116 Rewrite_Comparison (N);
9118 Optimize_Length_Comparison (N);
9121 -----------------------
9122 -- Expand_N_Op_Minus --
9123 -----------------------
9125 procedure Expand_N_Op_Minus (N : Node_Id) is
9126 Loc : constant Source_Ptr := Sloc (N);
9127 Typ : constant Entity_Id := Etype (N);
9130 Unary_Op_Validity_Checks (N);
9132 -- Check for MINIMIZED/ELIMINATED overflow mode
9134 if Minimized_Eliminated_Overflow_Check (N) then
9135 Apply_Arithmetic_Overflow_Check (N);
9139 if not Backend_Overflow_Checks_On_Target
9140 and then Is_Signed_Integer_Type (Etype (N))
9141 and then Do_Overflow_Check (N)
9143 -- Software overflow checking expands -expr into (0 - expr)
9146 Make_Op_Subtract (Loc,
9147 Left_Opnd => Make_Integer_Literal (Loc, 0),
9148 Right_Opnd => Right_Opnd (N)));
9150 Analyze_And_Resolve (N, Typ);
9153 Expand_Nonbinary_Modular_Op (N);
9154 end Expand_N_Op_Minus;
9156 ---------------------
9157 -- Expand_N_Op_Mod --
9158 ---------------------
9160 procedure Expand_N_Op_Mod (N : Node_Id) is
9161 Loc : constant Source_Ptr := Sloc (N);
9162 Typ : constant Entity_Id := Etype (N);
9163 DDC : constant Boolean := Do_Division_Check (N);
9176 pragma Warnings (Off, Lhi);
9179 Binary_Op_Validity_Checks (N);
9181 -- Check for MINIMIZED/ELIMINATED overflow mode
9183 if Minimized_Eliminated_Overflow_Check (N) then
9184 Apply_Arithmetic_Overflow_Check (N);
9188 if Is_Integer_Type (Etype (N)) then
9189 Apply_Divide_Checks (N);
9191 -- All done if we don't have a MOD any more, which can happen as a
9192 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
9194 if Nkind (N) /= N_Op_Mod then
9199 -- Proceed with expansion of mod operator
9201 Left := Left_Opnd (N);
9202 Right := Right_Opnd (N);
9204 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
9205 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
9207 -- Convert mod to rem if operands are both known to be non-negative, or
9208 -- both known to be non-positive (these are the cases in which rem and
9209 -- mod are the same, see (RM 4.5.5(28-30)). We do this since it is quite
9210 -- likely that this will improve the quality of code, (the operation now
9211 -- corresponds to the hardware remainder), and it does not seem likely
9212 -- that it could be harmful. It also avoids some cases of the elaborate
9213 -- expansion in Modify_Tree_For_C mode below (since Ada rem = C %).
9216 and then ((Llo >= 0 and then Rlo >= 0)
9218 (Lhi <= 0 and then Rhi <= 0))
9221 Make_Op_Rem (Sloc (N),
9222 Left_Opnd => Left_Opnd (N),
9223 Right_Opnd => Right_Opnd (N)));
9225 -- Instead of reanalyzing the node we do the analysis manually. This
9226 -- avoids anomalies when the replacement is done in an instance and
9227 -- is epsilon more efficient.
9229 Set_Entity (N, Standard_Entity (S_Op_Rem));
9231 Set_Do_Division_Check (N, DDC);
9232 Expand_N_Op_Rem (N);
9236 -- Otherwise, normal mod processing
9239 -- Apply optimization x mod 1 = 0. We don't really need that with
9240 -- gcc, but it is useful with other back ends and is certainly
9243 if Is_Integer_Type (Etype (N))
9244 and then Compile_Time_Known_Value (Right)
9245 and then Expr_Value (Right) = Uint_1
9247 -- Call Remove_Side_Effects to ensure that any side effects in
9248 -- the ignored left operand (in particular function calls to
9249 -- user defined functions) are properly executed.
9251 Remove_Side_Effects (Left);
9253 Rewrite (N, Make_Integer_Literal (Loc, 0));
9254 Analyze_And_Resolve (N, Typ);
9258 -- If we still have a mod operator and we are in Modify_Tree_For_C
9259 -- mode, and we have a signed integer type, then here is where we do
9260 -- the rewrite in terms of Rem. Note this rewrite bypasses the need
9261 -- for the special handling of the annoying case of largest negative
9262 -- number mod minus one.
9264 if Nkind (N) = N_Op_Mod
9265 and then Is_Signed_Integer_Type (Typ)
9266 and then Modify_Tree_For_C
9268 -- In the general case, we expand A mod B as
9270 -- Tnn : constant typ := A rem B;
9272 -- (if (A >= 0) = (B >= 0) then Tnn
9273 -- elsif Tnn = 0 then 0
9276 -- The comparison can be written simply as A >= 0 if we know that
9277 -- B >= 0 which is a very common case.
9279 -- An important optimization is when B is known at compile time
9280 -- to be 2**K for some constant. In this case we can simply AND
9281 -- the left operand with the bit string 2**K-1 (i.e. K 1-bits)
9282 -- and that works for both the positive and negative cases.
9285 P2 : constant Nat := Power_Of_Two (Right);
9290 Unchecked_Convert_To (Typ,
9293 Unchecked_Convert_To
9294 (Corresponding_Unsigned_Type (Typ), Left),
9296 Make_Integer_Literal (Loc, 2 ** P2 - 1))));
9297 Analyze_And_Resolve (N, Typ);
9302 -- Here for the full rewrite
9305 Tnn : constant Entity_Id := Make_Temporary (Sloc (N), 'T', N);
9311 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
9312 Right_Opnd => Make_Integer_Literal (Loc, 0));
9314 if not LOK or else Rlo < 0 then
9320 Left_Opnd => Duplicate_Subexpr_No_Checks (Right),
9321 Right_Opnd => Make_Integer_Literal (Loc, 0)));
9325 Make_Object_Declaration (Loc,
9326 Defining_Identifier => Tnn,
9327 Constant_Present => True,
9328 Object_Definition => New_Occurrence_Of (Typ, Loc),
9332 Right_Opnd => Right)));
9335 Make_If_Expression (Loc,
9336 Expressions => New_List (
9338 New_Occurrence_Of (Tnn, Loc),
9339 Make_If_Expression (Loc,
9341 Expressions => New_List (
9343 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9344 Right_Opnd => Make_Integer_Literal (Loc, 0)),
9345 Make_Integer_Literal (Loc, 0),
9347 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
9349 Duplicate_Subexpr_No_Checks (Right)))))));
9351 Analyze_And_Resolve (N, Typ);
9356 -- Deal with annoying case of largest negative number mod minus one.
9357 -- Gigi may not handle this case correctly, because on some targets,
9358 -- the mod value is computed using a divide instruction which gives
9359 -- an overflow trap for this case.
9361 -- It would be a bit more efficient to figure out which targets
9362 -- this is really needed for, but in practice it is reasonable
9363 -- to do the following special check in all cases, since it means
9364 -- we get a clearer message, and also the overhead is minimal given
9365 -- that division is expensive in any case.
9367 -- In fact the check is quite easy, if the right operand is -1, then
9368 -- the mod value is always 0, and we can just ignore the left operand
9369 -- completely in this case.
9371 -- This only applies if we still have a mod operator. Skip if we
9372 -- have already rewritten this (e.g. in the case of eliminated
9373 -- overflow checks which have driven us into bignum mode).
9375 if Nkind (N) = N_Op_Mod then
9377 -- The operand type may be private (e.g. in the expansion of an
9378 -- intrinsic operation) so we must use the underlying type to get
9379 -- the bounds, and convert the literals explicitly.
9383 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
9385 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
9386 and then ((not LOK) or else (Llo = LLB))
9389 Make_If_Expression (Loc,
9390 Expressions => New_List (
9392 Left_Opnd => Duplicate_Subexpr (Right),
9394 Unchecked_Convert_To (Typ,
9395 Make_Integer_Literal (Loc, -1))),
9396 Unchecked_Convert_To (Typ,
9397 Make_Integer_Literal (Loc, Uint_0)),
9398 Relocate_Node (N))));
9400 Set_Analyzed (Next (Next (First (Expressions (N)))));
9401 Analyze_And_Resolve (N, Typ);
9405 end Expand_N_Op_Mod;
9407 --------------------------
9408 -- Expand_N_Op_Multiply --
9409 --------------------------
9411 procedure Expand_N_Op_Multiply (N : Node_Id) is
9412 Loc : constant Source_Ptr := Sloc (N);
9413 Lop : constant Node_Id := Left_Opnd (N);
9414 Rop : constant Node_Id := Right_Opnd (N);
9416 Lp2 : constant Boolean :=
9417 Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
9418 Rp2 : constant Boolean :=
9419 Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
9421 Ltyp : constant Entity_Id := Etype (Lop);
9422 Rtyp : constant Entity_Id := Etype (Rop);
9423 Typ : Entity_Id := Etype (N);
9426 Binary_Op_Validity_Checks (N);
9428 -- Check for MINIMIZED/ELIMINATED overflow mode
9430 if Minimized_Eliminated_Overflow_Check (N) then
9431 Apply_Arithmetic_Overflow_Check (N);
9435 -- Special optimizations for integer types
9437 if Is_Integer_Type (Typ) then
9439 -- N * 0 = 0 for integer types
9441 if Compile_Time_Known_Value (Rop)
9442 and then Expr_Value (Rop) = Uint_0
9444 -- Call Remove_Side_Effects to ensure that any side effects in
9445 -- the ignored left operand (in particular function calls to
9446 -- user defined functions) are properly executed.
9448 Remove_Side_Effects (Lop);
9450 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
9451 Analyze_And_Resolve (N, Typ);
9455 -- Similar handling for 0 * N = 0
9457 if Compile_Time_Known_Value (Lop)
9458 and then Expr_Value (Lop) = Uint_0
9460 Remove_Side_Effects (Rop);
9461 Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
9462 Analyze_And_Resolve (N, Typ);
9466 -- N * 1 = 1 * N = N for integer types
9468 -- This optimisation is not done if we are going to
9469 -- rewrite the product 1 * 2 ** N to a shift.
9471 if Compile_Time_Known_Value (Rop)
9472 and then Expr_Value (Rop) = Uint_1
9478 elsif Compile_Time_Known_Value (Lop)
9479 and then Expr_Value (Lop) = Uint_1
9487 -- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
9488 -- Is_Power_Of_2_For_Shift is set means that we know that our left
9489 -- operand is an integer, as required for this to work.
9494 -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
9498 Left_Opnd => Make_Integer_Literal (Loc, 2),
9501 Left_Opnd => Right_Opnd (Lop),
9502 Right_Opnd => Right_Opnd (Rop))));
9503 Analyze_And_Resolve (N, Typ);
9507 -- If the result is modular, perform the reduction of the result
9510 if Is_Modular_Integer_Type (Typ)
9511 and then not Non_Binary_Modulus (Typ)
9516 Make_Op_Shift_Left (Loc,
9519 Convert_To (Standard_Natural, Right_Opnd (Rop))),
9521 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
9525 Make_Op_Shift_Left (Loc,
9528 Convert_To (Standard_Natural, Right_Opnd (Rop))));
9531 Analyze_And_Resolve (N, Typ);
9535 -- Same processing for the operands the other way round
9538 if Is_Modular_Integer_Type (Typ)
9539 and then not Non_Binary_Modulus (Typ)
9544 Make_Op_Shift_Left (Loc,
9547 Convert_To (Standard_Natural, Right_Opnd (Lop))),
9549 Make_Integer_Literal (Loc, Modulus (Typ) - 1)));
9553 Make_Op_Shift_Left (Loc,
9556 Convert_To (Standard_Natural, Right_Opnd (Lop))));
9559 Analyze_And_Resolve (N, Typ);
9563 -- Do required fixup of universal fixed operation
9565 if Typ = Universal_Fixed then
9566 Fixup_Universal_Fixed_Operation (N);
9570 -- Multiplications with fixed-point results
9572 if Is_Fixed_Point_Type (Typ) then
9574 -- No special processing if Treat_Fixed_As_Integer is set, since from
9575 -- a semantic point of view such operations are simply integer
9576 -- operations and will be treated that way.
9578 if not Treat_Fixed_As_Integer (N) then
9580 -- Case of fixed * integer => fixed
9582 if Is_Integer_Type (Rtyp) then
9583 Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
9585 -- Case of integer * fixed => fixed
9587 elsif Is_Integer_Type (Ltyp) then
9588 Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
9590 -- Case of fixed * fixed => fixed
9593 Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
9597 -- Other cases of multiplication of fixed-point operands. Again we
9598 -- exclude the cases where Treat_Fixed_As_Integer flag is set.
9600 elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
9601 and then not Treat_Fixed_As_Integer (N)
9603 if Is_Integer_Type (Typ) then
9604 Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
9606 pragma Assert (Is_Floating_Point_Type (Typ));
9607 Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
9610 -- Mixed-mode operations can appear in a non-static universal context,
9611 -- in which case the integer argument must be converted explicitly.
9613 elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
9614 Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
9615 Analyze_And_Resolve (Rop, Universal_Real);
9617 elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
9618 Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
9619 Analyze_And_Resolve (Lop, Universal_Real);
9621 -- Non-fixed point cases, check software overflow checking required
9623 elsif Is_Signed_Integer_Type (Etype (N)) then
9624 Apply_Arithmetic_Overflow_Check (N);
9627 -- Overflow checks for floating-point if -gnateF mode active
9629 Check_Float_Op_Overflow (N);
9631 Expand_Nonbinary_Modular_Op (N);
9632 end Expand_N_Op_Multiply;
9634 --------------------
9635 -- Expand_N_Op_Ne --
9636 --------------------
9638 procedure Expand_N_Op_Ne (N : Node_Id) is
9639 Typ : constant Entity_Id := Etype (Left_Opnd (N));
9642 -- Case of elementary type with standard operator. But if unnesting,
9643 -- handle elementary types whose Equivalent_Types are records because
9644 -- there may be padding or undefined fields.
9646 if Is_Elementary_Type (Typ)
9647 and then Sloc (Entity (N)) = Standard_Location
9648 and then not (Ekind_In (Typ, E_Class_Wide_Type,
9649 E_Class_Wide_Subtype,
9650 E_Access_Subprogram_Type,
9651 E_Access_Protected_Subprogram_Type,
9652 E_Anonymous_Access_Protected_Subprogram_Type,
9653 E_Access_Subprogram_Type,
9655 and then Present (Equivalent_Type (Typ))
9656 and then Is_Record_Type (Equivalent_Type (Typ)))
9658 Binary_Op_Validity_Checks (N);
9660 -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
9661 -- means we no longer have a /= operation, we are all done.
9663 Expand_Compare_Minimize_Eliminate_Overflow (N);
9665 if Nkind (N) /= N_Op_Ne then
9669 -- Boolean types (requiring handling of non-standard case)
9671 if Is_Boolean_Type (Typ) then
9672 Adjust_Condition (Left_Opnd (N));
9673 Adjust_Condition (Right_Opnd (N));
9674 Set_Etype (N, Standard_Boolean);
9675 Adjust_Result_Type (N, Typ);
9678 Rewrite_Comparison (N);
9680 -- For all cases other than elementary types, we rewrite node as the
9681 -- negation of an equality operation, and reanalyze. The equality to be
9682 -- used is defined in the same scope and has the same signature. This
9683 -- signature must be set explicitly since in an instance it may not have
9684 -- the same visibility as in the generic unit. This avoids duplicating
9685 -- or factoring the complex code for record/array equality tests etc.
9687 -- This case is also used for the minimal expansion performed in
9692 Loc : constant Source_Ptr := Sloc (N);
9694 Ne : constant Entity_Id := Entity (N);
9697 Binary_Op_Validity_Checks (N);
9703 Left_Opnd => Left_Opnd (N),
9704 Right_Opnd => Right_Opnd (N)));
9706 -- The level of parentheses is useless in GNATprove mode, and
9707 -- bumping its level here leads to wrong columns being used in
9708 -- check messages, hence skip it in this mode.
9710 if not GNATprove_Mode then
9711 Set_Paren_Count (Right_Opnd (Neg), 1);
9714 if Scope (Ne) /= Standard_Standard then
9715 Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
9718 -- For navigation purposes, we want to treat the inequality as an
9719 -- implicit reference to the corresponding equality. Preserve the
9720 -- Comes_From_ source flag to generate proper Xref entries.
9722 Preserve_Comes_From_Source (Neg, N);
9723 Preserve_Comes_From_Source (Right_Opnd (Neg), N);
9725 Analyze_And_Resolve (N, Standard_Boolean);
9729 -- No need for optimization in GNATprove mode, where we would rather see
9730 -- the original source expression.
9732 if not GNATprove_Mode then
9733 Optimize_Length_Comparison (N);
9737 ---------------------
9738 -- Expand_N_Op_Not --
9739 ---------------------
9741 -- If the argument is other than a Boolean array type, there is no special
9742 -- expansion required, except for dealing with validity checks, and non-
9743 -- standard boolean representations.
9745 -- For the packed array case, we call the special routine in Exp_Pakd,
9746 -- except that if the component size is greater than one, we use the
9747 -- standard routine generating a gruesome loop (it is so peculiar to have
9748 -- packed arrays with non-standard Boolean representations anyway, so it
9749 -- does not matter that we do not handle this case efficiently).
9751 -- For the unpacked array case (and for the special packed case where we
9752 -- have non standard Booleans, as discussed above), we generate and insert
9753 -- into the tree the following function definition:
9755 -- function Nnnn (A : arr) is
9758 -- for J in a'range loop
9759 -- B (J) := not A (J);
9764 -- Here arr is the actual subtype of the parameter (and hence always
9765 -- constrained). Then we replace the not with a call to this function.
9767 procedure Expand_N_Op_Not (N : Node_Id) is
9768 Loc : constant Source_Ptr := Sloc (N);
9769 Typ : constant Entity_Id := Etype (N);
9778 Func_Name : Entity_Id;
9779 Loop_Statement : Node_Id;
9782 Unary_Op_Validity_Checks (N);
9784 -- For boolean operand, deal with non-standard booleans
9786 if Is_Boolean_Type (Typ) then
9787 Adjust_Condition (Right_Opnd (N));
9788 Set_Etype (N, Standard_Boolean);
9789 Adjust_Result_Type (N, Typ);
9793 -- Only array types need any other processing
9795 if not Is_Array_Type (Typ) then
9799 -- Case of array operand. If bit packed with a component size of 1,
9800 -- handle it in Exp_Pakd if the operand is known to be aligned.
9802 if Is_Bit_Packed_Array (Typ)
9803 and then Component_Size (Typ) = 1
9804 and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
9806 Expand_Packed_Not (N);
9810 -- Case of array operand which is not bit-packed. If the context is
9811 -- a safe assignment, call in-place operation, If context is a larger
9812 -- boolean expression in the context of a safe assignment, expansion is
9813 -- done by enclosing operation.
9815 Opnd := Relocate_Node (Right_Opnd (N));
9816 Convert_To_Actual_Subtype (Opnd);
9817 Arr := Etype (Opnd);
9818 Ensure_Defined (Arr, N);
9819 Silly_Boolean_Array_Not_Test (N, Arr);
9821 if Nkind (Parent (N)) = N_Assignment_Statement then
9822 if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
9823 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
9826 -- Special case the negation of a binary operation
9828 elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
9829 and then Safe_In_Place_Array_Op
9830 (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
9832 Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
9836 elsif Nkind (Parent (N)) in N_Binary_Op
9837 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
9840 Op1 : constant Node_Id := Left_Opnd (Parent (N));
9841 Op2 : constant Node_Id := Right_Opnd (Parent (N));
9842 Lhs : constant Node_Id := Name (Parent (Parent (N)));
9845 if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
9847 -- (not A) op (not B) can be reduced to a single call
9849 if N = Op1 and then Nkind (Op2) = N_Op_Not then
9852 elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
9855 -- A xor (not B) can also be special-cased
9857 elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
9864 A := Make_Defining_Identifier (Loc, Name_uA);
9865 B := Make_Defining_Identifier (Loc, Name_uB);
9866 J := Make_Defining_Identifier (Loc, Name_uJ);
9869 Make_Indexed_Component (Loc,
9870 Prefix => New_Occurrence_Of (A, Loc),
9871 Expressions => New_List (New_Occurrence_Of (J, Loc)));
9874 Make_Indexed_Component (Loc,
9875 Prefix => New_Occurrence_Of (B, Loc),
9876 Expressions => New_List (New_Occurrence_Of (J, Loc)));
9879 Make_Implicit_Loop_Statement (N,
9880 Identifier => Empty,
9883 Make_Iteration_Scheme (Loc,
9884 Loop_Parameter_Specification =>
9885 Make_Loop_Parameter_Specification (Loc,
9886 Defining_Identifier => J,
9887 Discrete_Subtype_Definition =>
9888 Make_Attribute_Reference (Loc,
9889 Prefix => Make_Identifier (Loc, Chars (A)),
9890 Attribute_Name => Name_Range))),
9892 Statements => New_List (
9893 Make_Assignment_Statement (Loc,
9895 Expression => Make_Op_Not (Loc, A_J))));
9897 Func_Name := Make_Temporary (Loc, 'N');
9898 Set_Is_Inlined (Func_Name);
9901 Make_Subprogram_Body (Loc,
9903 Make_Function_Specification (Loc,
9904 Defining_Unit_Name => Func_Name,
9905 Parameter_Specifications => New_List (
9906 Make_Parameter_Specification (Loc,
9907 Defining_Identifier => A,
9908 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9909 Result_Definition => New_Occurrence_Of (Typ, Loc)),
9911 Declarations => New_List (
9912 Make_Object_Declaration (Loc,
9913 Defining_Identifier => B,
9914 Object_Definition => New_Occurrence_Of (Arr, Loc))),
9916 Handled_Statement_Sequence =>
9917 Make_Handled_Sequence_Of_Statements (Loc,
9918 Statements => New_List (
9920 Make_Simple_Return_Statement (Loc,
9921 Expression => Make_Identifier (Loc, Chars (B)))))));
9924 Make_Function_Call (Loc,
9925 Name => New_Occurrence_Of (Func_Name, Loc),
9926 Parameter_Associations => New_List (Opnd)));
9928 Analyze_And_Resolve (N, Typ);
9929 end Expand_N_Op_Not;
9931 --------------------
9932 -- Expand_N_Op_Or --
9933 --------------------
9935 procedure Expand_N_Op_Or (N : Node_Id) is
9936 Typ : constant Entity_Id := Etype (N);
9939 Binary_Op_Validity_Checks (N);
9941 if Is_Array_Type (Etype (N)) then
9942 Expand_Boolean_Operator (N);
9944 elsif Is_Boolean_Type (Etype (N)) then
9945 Adjust_Condition (Left_Opnd (N));
9946 Adjust_Condition (Right_Opnd (N));
9947 Set_Etype (N, Standard_Boolean);
9948 Adjust_Result_Type (N, Typ);
9950 elsif Is_Intrinsic_Subprogram (Entity (N)) then
9951 Expand_Intrinsic_Call (N, Entity (N));
9954 Expand_Nonbinary_Modular_Op (N);
9957 ----------------------
9958 -- Expand_N_Op_Plus --
9959 ----------------------
9961 procedure Expand_N_Op_Plus (N : Node_Id) is
9963 Unary_Op_Validity_Checks (N);
9965 -- Check for MINIMIZED/ELIMINATED overflow mode
9967 if Minimized_Eliminated_Overflow_Check (N) then
9968 Apply_Arithmetic_Overflow_Check (N);
9971 end Expand_N_Op_Plus;
9973 ---------------------
9974 -- Expand_N_Op_Rem --
9975 ---------------------
9977 procedure Expand_N_Op_Rem (N : Node_Id) is
9978 Loc : constant Source_Ptr := Sloc (N);
9979 Typ : constant Entity_Id := Etype (N);
9990 -- Set if corresponding operand can be negative
9992 pragma Unreferenced (Hi);
9995 Binary_Op_Validity_Checks (N);
9997 -- Check for MINIMIZED/ELIMINATED overflow mode
9999 if Minimized_Eliminated_Overflow_Check (N) then
10000 Apply_Arithmetic_Overflow_Check (N);
10004 if Is_Integer_Type (Etype (N)) then
10005 Apply_Divide_Checks (N);
10007 -- All done if we don't have a REM any more, which can happen as a
10008 -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
10010 if Nkind (N) /= N_Op_Rem then
10015 -- Proceed with expansion of REM
10017 Left := Left_Opnd (N);
10018 Right := Right_Opnd (N);
10020 -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
10021 -- but it is useful with other back ends, and is certainly harmless.
10023 if Is_Integer_Type (Etype (N))
10024 and then Compile_Time_Known_Value (Right)
10025 and then Expr_Value (Right) = Uint_1
10027 -- Call Remove_Side_Effects to ensure that any side effects in the
10028 -- ignored left operand (in particular function calls to user defined
10029 -- functions) are properly executed.
10031 Remove_Side_Effects (Left);
10033 Rewrite (N, Make_Integer_Literal (Loc, 0));
10034 Analyze_And_Resolve (N, Typ);
10038 -- Deal with annoying case of largest negative number remainder minus
10039 -- one. Gigi may not handle this case correctly, because on some
10040 -- targets, the mod value is computed using a divide instruction
10041 -- which gives an overflow trap for this case.
10043 -- It would be a bit more efficient to figure out which targets this
10044 -- is really needed for, but in practice it is reasonable to do the
10045 -- following special check in all cases, since it means we get a clearer
10046 -- message, and also the overhead is minimal given that division is
10047 -- expensive in any case.
10049 -- In fact the check is quite easy, if the right operand is -1, then
10050 -- the remainder is always 0, and we can just ignore the left operand
10051 -- completely in this case.
10053 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10054 Lneg := (not OK) or else Lo < 0;
10056 Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
10057 Rneg := (not OK) or else Lo < 0;
10059 -- We won't mess with trying to find out if the left operand can really
10060 -- be the largest negative number (that's a pain in the case of private
10061 -- types and this is really marginal). We will just assume that we need
10062 -- the test if the left operand can be negative at all.
10064 if Lneg and Rneg then
10066 Make_If_Expression (Loc,
10067 Expressions => New_List (
10069 Left_Opnd => Duplicate_Subexpr (Right),
10071 Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
10073 Unchecked_Convert_To (Typ,
10074 Make_Integer_Literal (Loc, Uint_0)),
10076 Relocate_Node (N))));
10078 Set_Analyzed (Next (Next (First (Expressions (N)))));
10079 Analyze_And_Resolve (N, Typ);
10081 end Expand_N_Op_Rem;
10083 -----------------------------
10084 -- Expand_N_Op_Rotate_Left --
10085 -----------------------------
10087 procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
10089 Binary_Op_Validity_Checks (N);
10091 -- If we are in Modify_Tree_For_C mode, there is no rotate left in C,
10092 -- so we rewrite in terms of logical shifts
10094 -- Shift_Left (Num, Bits) or Shift_Right (num, Esize - Bits)
10096 -- where Bits is the shift count mod Esize (the mod operation here
10097 -- deals with ludicrous large shift counts, which are apparently OK).
10099 -- What about nonbinary modulus ???
10102 Loc : constant Source_Ptr := Sloc (N);
10103 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10104 Typ : constant Entity_Id := Etype (N);
10107 if Modify_Tree_For_C then
10108 Rewrite (Right_Opnd (N),
10110 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10111 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10113 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10118 Make_Op_Shift_Left (Loc,
10119 Left_Opnd => Left_Opnd (N),
10120 Right_Opnd => Right_Opnd (N)),
10123 Make_Op_Shift_Right (Loc,
10124 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10126 Make_Op_Subtract (Loc,
10127 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10129 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10131 Analyze_And_Resolve (N, Typ);
10134 end Expand_N_Op_Rotate_Left;
10136 ------------------------------
10137 -- Expand_N_Op_Rotate_Right --
10138 ------------------------------
10140 procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
10142 Binary_Op_Validity_Checks (N);
10144 -- If we are in Modify_Tree_For_C mode, there is no rotate right in C,
10145 -- so we rewrite in terms of logical shifts
10147 -- Shift_Right (Num, Bits) or Shift_Left (num, Esize - Bits)
10149 -- where Bits is the shift count mod Esize (the mod operation here
10150 -- deals with ludicrous large shift counts, which are apparently OK).
10152 -- What about nonbinary modulus ???
10155 Loc : constant Source_Ptr := Sloc (N);
10156 Rtp : constant Entity_Id := Etype (Right_Opnd (N));
10157 Typ : constant Entity_Id := Etype (N);
10160 Rewrite (Right_Opnd (N),
10162 Left_Opnd => Relocate_Node (Right_Opnd (N)),
10163 Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ))));
10165 Analyze_And_Resolve (Right_Opnd (N), Rtp);
10167 if Modify_Tree_For_C then
10171 Make_Op_Shift_Right (Loc,
10172 Left_Opnd => Left_Opnd (N),
10173 Right_Opnd => Right_Opnd (N)),
10176 Make_Op_Shift_Left (Loc,
10177 Left_Opnd => Duplicate_Subexpr_No_Checks (Left_Opnd (N)),
10179 Make_Op_Subtract (Loc,
10180 Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
10182 Duplicate_Subexpr_No_Checks (Right_Opnd (N))))));
10184 Analyze_And_Resolve (N, Typ);
10187 end Expand_N_Op_Rotate_Right;
10189 ----------------------------
10190 -- Expand_N_Op_Shift_Left --
10191 ----------------------------
10193 -- Note: nothing in this routine depends on left as opposed to right shifts
10194 -- so we share the routine for expanding shift right operations.
10196 procedure Expand_N_Op_Shift_Left (N : Node_Id) is
10198 Binary_Op_Validity_Checks (N);
10200 -- If we are in Modify_Tree_For_C mode, then ensure that the right
10201 -- operand is not greater than the word size (since that would not
10202 -- be defined properly by the corresponding C shift operator).
10204 if Modify_Tree_For_C then
10206 Right : constant Node_Id := Right_Opnd (N);
10207 Loc : constant Source_Ptr := Sloc (Right);
10208 Typ : constant Entity_Id := Etype (N);
10209 Siz : constant Uint := Esize (Typ);
10216 if Compile_Time_Known_Value (Right) then
10217 if Expr_Value (Right) >= Siz then
10218 Rewrite (N, Make_Integer_Literal (Loc, 0));
10219 Analyze_And_Resolve (N, Typ);
10222 -- Not compile time known, find range
10225 Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
10227 -- Nothing to do if known to be OK range, otherwise expand
10229 if not OK or else Hi >= Siz then
10231 -- Prevent recursion on copy of shift node
10233 Orig := Relocate_Node (N);
10234 Set_Analyzed (Orig);
10236 -- Now do the rewrite
10239 Make_If_Expression (Loc,
10240 Expressions => New_List (
10242 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
10243 Right_Opnd => Make_Integer_Literal (Loc, Siz)),
10244 Make_Integer_Literal (Loc, 0),
10246 Analyze_And_Resolve (N, Typ);
10251 end Expand_N_Op_Shift_Left;
10253 -----------------------------
10254 -- Expand_N_Op_Shift_Right --
10255 -----------------------------
10257 procedure Expand_N_Op_Shift_Right (N : Node_Id) is
10259 -- Share shift left circuit
10261 Expand_N_Op_Shift_Left (N);
10262 end Expand_N_Op_Shift_Right;
10264 ----------------------------------------
10265 -- Expand_N_Op_Shift_Right_Arithmetic --
10266 ----------------------------------------
10268 procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
10270 Binary_Op_Validity_Checks (N);
10272 -- If we are in Modify_Tree_For_C mode, there is no shift right
10273 -- arithmetic in C, so we rewrite in terms of logical shifts.
10275 -- Shift_Right (Num, Bits) or
10277 -- then not (Shift_Right (Mask, bits))
10280 -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1)
10282 -- Note: in almost all C compilers it would work to just shift a
10283 -- signed integer right, but it's undefined and we cannot rely on it.
10285 -- Note: the above works fine for shift counts greater than or equal
10286 -- to the word size, since in this case (not (Shift_Right (Mask, bits)))
10287 -- generates all 1'bits.
10289 -- What about nonbinary modulus ???
10292 Loc : constant Source_Ptr := Sloc (N);
10293 Typ : constant Entity_Id := Etype (N);
10294 Sign : constant Uint := 2 ** (Esize (Typ) - 1);
10295 Mask : constant Uint := (2 ** Esize (Typ)) - 1;
10296 Left : constant Node_Id := Left_Opnd (N);
10297 Right : constant Node_Id := Right_Opnd (N);
10301 if Modify_Tree_For_C then
10303 -- Here if not (Shift_Right (Mask, bits)) can be computed at
10304 -- compile time as a single constant.
10306 if Compile_Time_Known_Value (Right) then
10308 Val : constant Uint := Expr_Value (Right);
10311 if Val >= Esize (Typ) then
10312 Maskx := Make_Integer_Literal (Loc, Mask);
10316 Make_Integer_Literal (Loc,
10317 Intval => Mask - (Mask / (2 ** Expr_Value (Right))));
10325 Make_Op_Shift_Right (Loc,
10326 Left_Opnd => Make_Integer_Literal (Loc, Mask),
10327 Right_Opnd => Duplicate_Subexpr_No_Checks (Right)));
10330 -- Now do the rewrite
10335 Make_Op_Shift_Right (Loc,
10337 Right_Opnd => Right),
10339 Make_If_Expression (Loc,
10340 Expressions => New_List (
10342 Left_Opnd => Duplicate_Subexpr_No_Checks (Left),
10343 Right_Opnd => Make_Integer_Literal (Loc, Sign)),
10345 Make_Integer_Literal (Loc, 0)))));
10346 Analyze_And_Resolve (N, Typ);
10349 end Expand_N_Op_Shift_Right_Arithmetic;
10351 --------------------------
10352 -- Expand_N_Op_Subtract --
10353 --------------------------
10355 procedure Expand_N_Op_Subtract (N : Node_Id) is
10356 Typ : constant Entity_Id := Etype (N);
10359 Binary_Op_Validity_Checks (N);
10361 -- Check for MINIMIZED/ELIMINATED overflow mode
10363 if Minimized_Eliminated_Overflow_Check (N) then
10364 Apply_Arithmetic_Overflow_Check (N);
10368 -- N - 0 = N for integer types
10370 if Is_Integer_Type (Typ)
10371 and then Compile_Time_Known_Value (Right_Opnd (N))
10372 and then Expr_Value (Right_Opnd (N)) = 0
10374 Rewrite (N, Left_Opnd (N));
10378 -- Arithmetic overflow checks for signed integer/fixed point types
10380 if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then
10381 Apply_Arithmetic_Overflow_Check (N);
10384 -- Overflow checks for floating-point if -gnateF mode active
10386 Check_Float_Op_Overflow (N);
10388 Expand_Nonbinary_Modular_Op (N);
10389 end Expand_N_Op_Subtract;
10391 ---------------------
10392 -- Expand_N_Op_Xor --
10393 ---------------------
10395 procedure Expand_N_Op_Xor (N : Node_Id) is
10396 Typ : constant Entity_Id := Etype (N);
10399 Binary_Op_Validity_Checks (N);
10401 if Is_Array_Type (Etype (N)) then
10402 Expand_Boolean_Operator (N);
10404 elsif Is_Boolean_Type (Etype (N)) then
10405 Adjust_Condition (Left_Opnd (N));
10406 Adjust_Condition (Right_Opnd (N));
10407 Set_Etype (N, Standard_Boolean);
10408 Adjust_Result_Type (N, Typ);
10410 elsif Is_Intrinsic_Subprogram (Entity (N)) then
10411 Expand_Intrinsic_Call (N, Entity (N));
10414 Expand_Nonbinary_Modular_Op (N);
10415 end Expand_N_Op_Xor;
10417 ----------------------
10418 -- Expand_N_Or_Else --
10419 ----------------------
10421 procedure Expand_N_Or_Else (N : Node_Id)
10422 renames Expand_Short_Circuit_Operator;
10424 -----------------------------------
10425 -- Expand_N_Qualified_Expression --
10426 -----------------------------------
10428 procedure Expand_N_Qualified_Expression (N : Node_Id) is
10429 Operand : constant Node_Id := Expression (N);
10430 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
10433 -- Do validity check if validity checking operands
10435 if Validity_Checks_On and Validity_Check_Operands then
10436 Ensure_Valid (Operand);
10439 -- Apply possible constraint check
10441 Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
10443 if Do_Range_Check (Operand) then
10444 Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
10446 end Expand_N_Qualified_Expression;
10448 ------------------------------------
10449 -- Expand_N_Quantified_Expression --
10450 ------------------------------------
10454 -- for all X in range => Cond
10459 -- for X in range loop
10460 -- if not Cond then
10466 -- Similarly, an existentially quantified expression:
10468 -- for some X in range => Cond
10473 -- for X in range loop
10480 -- In both cases, the iteration may be over a container in which case it is
10481 -- given by an iterator specification, not a loop parameter specification.
10483 procedure Expand_N_Quantified_Expression (N : Node_Id) is
10484 Actions : constant List_Id := New_List;
10485 For_All : constant Boolean := All_Present (N);
10486 Iter_Spec : constant Node_Id := Iterator_Specification (N);
10487 Loc : constant Source_Ptr := Sloc (N);
10488 Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
10496 -- Ensure that the bound variable is properly frozen. We must do
10497 -- this before expansion because the expression is about to be
10498 -- converted into a loop, and resulting freeze nodes may end up
10499 -- in the wrong place in the tree.
10501 if Present (Iter_Spec) then
10502 Var := Defining_Identifier (Iter_Spec);
10504 Var := Defining_Identifier (Loop_Spec);
10508 P : Node_Id := Parent (N);
10510 while Nkind (P) in N_Subexpr loop
10514 Freeze_Before (P, Etype (Var));
10517 -- Create the declaration of the flag which tracks the status of the
10518 -- quantified expression. Generate:
10520 -- Flag : Boolean := (True | False);
10522 Flag := Make_Temporary (Loc, 'T', N);
10524 Append_To (Actions,
10525 Make_Object_Declaration (Loc,
10526 Defining_Identifier => Flag,
10527 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
10529 New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
10531 -- Construct the circuitry which tracks the status of the quantified
10532 -- expression. Generate:
10534 -- if [not] Cond then
10535 -- Flag := (False | True);
10539 Cond := Relocate_Node (Condition (N));
10542 Cond := Make_Op_Not (Loc, Cond);
10545 Stmts := New_List (
10546 Make_Implicit_If_Statement (N,
10548 Then_Statements => New_List (
10549 Make_Assignment_Statement (Loc,
10550 Name => New_Occurrence_Of (Flag, Loc),
10552 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
10553 Make_Exit_Statement (Loc))));
10555 -- Build the loop equivalent of the quantified expression
10557 if Present (Iter_Spec) then
10559 Make_Iteration_Scheme (Loc,
10560 Iterator_Specification => Iter_Spec);
10563 Make_Iteration_Scheme (Loc,
10564 Loop_Parameter_Specification => Loop_Spec);
10567 Append_To (Actions,
10568 Make_Loop_Statement (Loc,
10569 Iteration_Scheme => Scheme,
10570 Statements => Stmts,
10571 End_Label => Empty));
10573 -- Transform the quantified expression
10576 Make_Expression_With_Actions (Loc,
10577 Expression => New_Occurrence_Of (Flag, Loc),
10578 Actions => Actions));
10579 Analyze_And_Resolve (N, Standard_Boolean);
10580 end Expand_N_Quantified_Expression;
10582 ---------------------------------
10583 -- Expand_N_Selected_Component --
10584 ---------------------------------
10586 procedure Expand_N_Selected_Component (N : Node_Id) is
10587 Loc : constant Source_Ptr := Sloc (N);
10588 Par : constant Node_Id := Parent (N);
10589 P : constant Node_Id := Prefix (N);
10590 S : constant Node_Id := Selector_Name (N);
10591 Ptyp : Entity_Id := Underlying_Type (Etype (P));
10597 function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
10598 -- Gigi needs a temporary for prefixes that depend on a discriminant,
10599 -- unless the context of an assignment can provide size information.
10600 -- Don't we have a general routine that does this???
10602 function Is_Subtype_Declaration return Boolean;
10603 -- The replacement of a discriminant reference by its value is required
10604 -- if this is part of the initialization of an temporary generated by a
10605 -- change of representation. This shows up as the construction of a
10606 -- discriminant constraint for a subtype declared at the same point as
10607 -- the entity in the prefix of the selected component. We recognize this
10608 -- case when the context of the reference is:
10609 -- subtype ST is T(Obj.D);
10610 -- where the entity for Obj comes from source, and ST has the same sloc.
10612 -----------------------
10613 -- In_Left_Hand_Side --
10614 -----------------------
10616 function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
10618 return (Nkind (Parent (Comp)) = N_Assignment_Statement
10619 and then Comp = Name (Parent (Comp)))
10620 or else (Present (Parent (Comp))
10621 and then Nkind (Parent (Comp)) in N_Subexpr
10622 and then In_Left_Hand_Side (Parent (Comp)));
10623 end In_Left_Hand_Side;
10625 -----------------------------
10626 -- Is_Subtype_Declaration --
10627 -----------------------------
10629 function Is_Subtype_Declaration return Boolean is
10630 Par : constant Node_Id := Parent (N);
10633 Nkind (Par) = N_Index_Or_Discriminant_Constraint
10634 and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
10635 and then Comes_From_Source (Entity (Prefix (N)))
10636 and then Sloc (Par) = Sloc (Entity (Prefix (N)));
10637 end Is_Subtype_Declaration;
10639 -- Start of processing for Expand_N_Selected_Component
10642 -- Insert explicit dereference if required
10644 if Is_Access_Type (Ptyp) then
10646 -- First set prefix type to proper access type, in case it currently
10647 -- has a private (non-access) view of this type.
10649 Set_Etype (P, Ptyp);
10651 Insert_Explicit_Dereference (P);
10652 Analyze_And_Resolve (P, Designated_Type (Ptyp));
10657 -- Deal with discriminant check required
10659 if Do_Discriminant_Check (N) then
10660 if Present (Discriminant_Checking_Func
10661 (Original_Record_Component (Entity (S))))
10663 -- Present the discriminant checking function to the backend, so
10664 -- that it can inline the call to the function.
10667 (Discriminant_Checking_Func
10668 (Original_Record_Component (Entity (S))),
10671 -- Now reset the flag and generate the call
10673 Set_Do_Discriminant_Check (N, False);
10674 Generate_Discriminant_Check (N);
10676 -- In the case of Unchecked_Union, no discriminant checking is
10677 -- actually performed.
10680 Set_Do_Discriminant_Check (N, False);
10684 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
10685 -- function, then additional actuals must be passed.
10687 if Is_Build_In_Place_Function_Call (P) then
10688 Make_Build_In_Place_Call_In_Anonymous_Context (P);
10690 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
10691 -- containing build-in-place function calls whose returned object covers
10692 -- interface types.
10694 elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
10695 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
10698 -- Gigi cannot handle unchecked conversions that are the prefix of a
10699 -- selected component with discriminants. This must be checked during
10700 -- expansion, because during analysis the type of the selector is not
10701 -- known at the point the prefix is analyzed. If the conversion is the
10702 -- target of an assignment, then we cannot force the evaluation.
10704 if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
10705 and then Has_Discriminants (Etype (N))
10706 and then not In_Left_Hand_Side (N)
10708 Force_Evaluation (Prefix (N));
10711 -- Remaining processing applies only if selector is a discriminant
10713 if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
10715 -- If the selector is a discriminant of a constrained record type,
10716 -- we may be able to rewrite the expression with the actual value
10717 -- of the discriminant, a useful optimization in some cases.
10719 if Is_Record_Type (Ptyp)
10720 and then Has_Discriminants (Ptyp)
10721 and then Is_Constrained (Ptyp)
10723 -- Do this optimization for discrete types only, and not for
10724 -- access types (access discriminants get us into trouble).
10726 if not Is_Discrete_Type (Etype (N)) then
10729 -- Don't do this on the left-hand side of an assignment statement.
10730 -- Normally one would think that references like this would not
10731 -- occur, but they do in generated code, and mean that we really
10732 -- do want to assign the discriminant.
10734 elsif Nkind (Par) = N_Assignment_Statement
10735 and then Name (Par) = N
10739 -- Don't do this optimization for the prefix of an attribute or
10740 -- the name of an object renaming declaration since these are
10741 -- contexts where we do not want the value anyway.
10743 elsif (Nkind (Par) = N_Attribute_Reference
10744 and then Prefix (Par) = N)
10745 or else Is_Renamed_Object (N)
10749 -- Don't do this optimization if we are within the code for a
10750 -- discriminant check, since the whole point of such a check may
10751 -- be to verify the condition on which the code below depends.
10753 elsif Is_In_Discriminant_Check (N) then
10756 -- Green light to see if we can do the optimization. There is
10757 -- still one condition that inhibits the optimization below but
10758 -- now is the time to check the particular discriminant.
10761 -- Loop through discriminants to find the matching discriminant
10762 -- constraint to see if we can copy it.
10764 Disc := First_Discriminant (Ptyp);
10765 Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
10766 Discr_Loop : while Present (Dcon) loop
10767 Dval := Node (Dcon);
10769 -- Check if this is the matching discriminant and if the
10770 -- discriminant value is simple enough to make sense to
10771 -- copy. We don't want to copy complex expressions, and
10772 -- indeed to do so can cause trouble (before we put in
10773 -- this guard, a discriminant expression containing an
10774 -- AND THEN was copied, causing problems for coverage
10775 -- analysis tools).
10777 -- However, if the reference is part of the initialization
10778 -- code generated for an object declaration, we must use
10779 -- the discriminant value from the subtype constraint,
10780 -- because the selected component may be a reference to the
10781 -- object being initialized, whose discriminant is not yet
10782 -- set. This only happens in complex cases involving changes
10783 -- or representation.
10785 if Disc = Entity (Selector_Name (N))
10786 and then (Is_Entity_Name (Dval)
10787 or else Compile_Time_Known_Value (Dval)
10788 or else Is_Subtype_Declaration)
10790 -- Here we have the matching discriminant. Check for
10791 -- the case of a discriminant of a component that is
10792 -- constrained by an outer discriminant, which cannot
10793 -- be optimized away.
10795 if Denotes_Discriminant
10796 (Dval, Check_Concurrent => True)
10800 elsif Nkind (Original_Node (Dval)) = N_Selected_Component
10802 Denotes_Discriminant
10803 (Selector_Name (Original_Node (Dval)), True)
10807 -- Do not retrieve value if constraint is not static. It
10808 -- is generally not useful, and the constraint may be a
10809 -- rewritten outer discriminant in which case it is in
10812 elsif Is_Entity_Name (Dval)
10814 Nkind (Parent (Entity (Dval))) = N_Object_Declaration
10815 and then Present (Expression (Parent (Entity (Dval))))
10817 Is_OK_Static_Expression
10818 (Expression (Parent (Entity (Dval))))
10822 -- In the context of a case statement, the expression may
10823 -- have the base type of the discriminant, and we need to
10824 -- preserve the constraint to avoid spurious errors on
10827 elsif Nkind (Parent (N)) = N_Case_Statement
10828 and then Etype (Dval) /= Etype (Disc)
10831 Make_Qualified_Expression (Loc,
10833 New_Occurrence_Of (Etype (Disc), Loc),
10835 New_Copy_Tree (Dval)));
10836 Analyze_And_Resolve (N, Etype (Disc));
10838 -- In case that comes out as a static expression,
10839 -- reset it (a selected component is never static).
10841 Set_Is_Static_Expression (N, False);
10844 -- Otherwise we can just copy the constraint, but the
10845 -- result is certainly not static. In some cases the
10846 -- discriminant constraint has been analyzed in the
10847 -- context of the original subtype indication, but for
10848 -- itypes the constraint might not have been analyzed
10849 -- yet, and this must be done now.
10852 Rewrite (N, New_Copy_Tree (Dval));
10853 Analyze_And_Resolve (N);
10854 Set_Is_Static_Expression (N, False);
10860 Next_Discriminant (Disc);
10861 end loop Discr_Loop;
10863 -- Note: the above loop should always find a matching
10864 -- discriminant, but if it does not, we just missed an
10865 -- optimization due to some glitch (perhaps a previous
10866 -- error), so ignore.
10871 -- The only remaining processing is in the case of a discriminant of
10872 -- a concurrent object, where we rewrite the prefix to denote the
10873 -- corresponding record type. If the type is derived and has renamed
10874 -- discriminants, use corresponding discriminant, which is the one
10875 -- that appears in the corresponding record.
10877 if not Is_Concurrent_Type (Ptyp) then
10881 Disc := Entity (Selector_Name (N));
10883 if Is_Derived_Type (Ptyp)
10884 and then Present (Corresponding_Discriminant (Disc))
10886 Disc := Corresponding_Discriminant (Disc);
10890 Make_Selected_Component (Loc,
10892 Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
10893 New_Copy_Tree (P)),
10894 Selector_Name => Make_Identifier (Loc, Chars (Disc)));
10896 Rewrite (N, New_N);
10900 -- Set Atomic_Sync_Required if necessary for atomic component
10902 if Nkind (N) = N_Selected_Component then
10904 E : constant Entity_Id := Entity (Selector_Name (N));
10908 -- If component is atomic, but type is not, setting depends on
10909 -- disable/enable state for the component.
10911 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
10912 Set := not Atomic_Synchronization_Disabled (E);
10914 -- If component is not atomic, but its type is atomic, setting
10915 -- depends on disable/enable state for the type.
10917 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
10918 Set := not Atomic_Synchronization_Disabled (Etype (E));
10920 -- If both component and type are atomic, we disable if either
10921 -- component or its type have sync disabled.
10923 elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
10924 Set := (not Atomic_Synchronization_Disabled (E))
10926 (not Atomic_Synchronization_Disabled (Etype (E)));
10932 -- Set flag if required
10935 Activate_Atomic_Synchronization (N);
10939 end Expand_N_Selected_Component;
10941 --------------------
10942 -- Expand_N_Slice --
10943 --------------------
10945 procedure Expand_N_Slice (N : Node_Id) is
10946 Loc : constant Source_Ptr := Sloc (N);
10947 Typ : constant Entity_Id := Etype (N);
10949 function Is_Procedure_Actual (N : Node_Id) return Boolean;
10950 -- Check whether the argument is an actual for a procedure call, in
10951 -- which case the expansion of a bit-packed slice is deferred until the
10952 -- call itself is expanded. The reason this is required is that we might
10953 -- have an IN OUT or OUT parameter, and the copy out is essential, and
10954 -- that copy out would be missed if we created a temporary here in
10955 -- Expand_N_Slice. Note that we don't bother to test specifically for an
10956 -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
10957 -- is harmless to defer expansion in the IN case, since the call
10958 -- processing will still generate the appropriate copy in operation,
10959 -- which will take care of the slice.
10961 procedure Make_Temporary_For_Slice;
10962 -- Create a named variable for the value of the slice, in cases where
10963 -- the back end cannot handle it properly, e.g. when packed types or
10964 -- unaligned slices are involved.
10966 -------------------------
10967 -- Is_Procedure_Actual --
10968 -------------------------
10970 function Is_Procedure_Actual (N : Node_Id) return Boolean is
10971 Par : Node_Id := Parent (N);
10975 -- If our parent is a procedure call we can return
10977 if Nkind (Par) = N_Procedure_Call_Statement then
10980 -- If our parent is a type conversion, keep climbing the tree,
10981 -- since a type conversion can be a procedure actual. Also keep
10982 -- climbing if parameter association or a qualified expression,
10983 -- since these are additional cases that do can appear on
10984 -- procedure actuals.
10986 elsif Nkind_In (Par, N_Type_Conversion,
10987 N_Parameter_Association,
10988 N_Qualified_Expression)
10990 Par := Parent (Par);
10992 -- Any other case is not what we are looking for
10998 end Is_Procedure_Actual;
11000 ------------------------------
11001 -- Make_Temporary_For_Slice --
11002 ------------------------------
11004 procedure Make_Temporary_For_Slice is
11005 Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
11010 Make_Object_Declaration (Loc,
11011 Defining_Identifier => Ent,
11012 Object_Definition => New_Occurrence_Of (Typ, Loc));
11014 Set_No_Initialization (Decl);
11016 Insert_Actions (N, New_List (
11018 Make_Assignment_Statement (Loc,
11019 Name => New_Occurrence_Of (Ent, Loc),
11020 Expression => Relocate_Node (N))));
11022 Rewrite (N, New_Occurrence_Of (Ent, Loc));
11023 Analyze_And_Resolve (N, Typ);
11024 end Make_Temporary_For_Slice;
11028 Pref : constant Node_Id := Prefix (N);
11029 Pref_Typ : Entity_Id := Etype (Pref);
11031 -- Start of processing for Expand_N_Slice
11034 -- Special handling for access types
11036 if Is_Access_Type (Pref_Typ) then
11037 Pref_Typ := Designated_Type (Pref_Typ);
11040 Make_Explicit_Dereference (Sloc (N),
11041 Prefix => Relocate_Node (Pref)));
11043 Analyze_And_Resolve (Pref, Pref_Typ);
11046 -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
11047 -- function, then additional actuals must be passed.
11049 if Is_Build_In_Place_Function_Call (Pref) then
11050 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
11052 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
11053 -- containing build-in-place function calls whose returned object covers
11054 -- interface types.
11056 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
11057 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
11060 -- The remaining case to be handled is packed slices. We can leave
11061 -- packed slices as they are in the following situations:
11063 -- 1. Right or left side of an assignment (we can handle this
11064 -- situation correctly in the assignment statement expansion).
11066 -- 2. Prefix of indexed component (the slide is optimized away in this
11067 -- case, see the start of Expand_N_Slice.)
11069 -- 3. Object renaming declaration, since we want the name of the
11070 -- slice, not the value.
11072 -- 4. Argument to procedure call, since copy-in/copy-out handling may
11073 -- be required, and this is handled in the expansion of call
11076 -- 5. Prefix of an address attribute (this is an error which is caught
11077 -- elsewhere, and the expansion would interfere with generating the
11078 -- error message) or of a size attribute (because 'Size may change
11079 -- when applied to the temporary instead of the slice directly).
11081 if not Is_Packed (Typ) then
11083 -- Apply transformation for actuals of a function call, where
11084 -- Expand_Actuals is not used.
11086 if Nkind (Parent (N)) = N_Function_Call
11087 and then Is_Possibly_Unaligned_Slice (N)
11089 Make_Temporary_For_Slice;
11092 elsif Nkind (Parent (N)) = N_Assignment_Statement
11093 or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
11094 and then Parent (N) = Name (Parent (Parent (N))))
11098 elsif Nkind (Parent (N)) = N_Indexed_Component
11099 or else Is_Renamed_Object (N)
11100 or else Is_Procedure_Actual (N)
11104 elsif Nkind (Parent (N)) = N_Attribute_Reference
11105 and then (Attribute_Name (Parent (N)) = Name_Address
11106 or else Attribute_Name (Parent (N)) = Name_Size)
11111 Make_Temporary_For_Slice;
11113 end Expand_N_Slice;
11115 ------------------------------
11116 -- Expand_N_Type_Conversion --
11117 ------------------------------
11119 procedure Expand_N_Type_Conversion (N : Node_Id) is
11120 Loc : constant Source_Ptr := Sloc (N);
11121 Operand : constant Node_Id := Expression (N);
11122 Operand_Acc : Node_Id := Operand;
11123 Target_Type : Entity_Id := Etype (N);
11124 Operand_Type : Entity_Id := Etype (Operand);
11126 procedure Discrete_Range_Check;
11127 -- Handles generation of range check for discrete target value
11129 procedure Handle_Changed_Representation;
11130 -- This is called in the case of record and array type conversions to
11131 -- see if there is a change of representation to be handled. Change of
11132 -- representation is actually handled at the assignment statement level,
11133 -- and what this procedure does is rewrite node N conversion as an
11134 -- assignment to temporary. If there is no change of representation,
11135 -- then the conversion node is unchanged.
11137 procedure Raise_Accessibility_Error;
11138 -- Called when we know that an accessibility check will fail. Rewrites
11139 -- node N to an appropriate raise statement and outputs warning msgs.
11140 -- The Etype of the raise node is set to Target_Type. Note that in this
11141 -- case the rest of the processing should be skipped (i.e. the call to
11142 -- this procedure will be followed by "goto Done").
11144 procedure Real_Range_Check;
11145 -- Handles generation of range check for real target value
11147 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
11148 -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
11149 -- evaluates to True.
11151 --------------------------
11152 -- Discrete_Range_Check --
11153 --------------------------
11155 -- Case of conversions to a discrete type. We let Generate_Range_Check
11156 -- do the heavy lifting, after converting a fixed-point operand to an
11157 -- appropriate integer type.
11159 procedure Discrete_Range_Check is
11164 -- Nothing to do if conversion was rewritten
11166 if Nkind (N) /= N_Type_Conversion then
11170 Expr := Expression (N);
11172 -- Nothing to do if range checks suppressed
11174 if Range_Checks_Suppressed (Target_Type) then
11178 -- Nothing to do if expression is an entity on which checks have been
11181 if Is_Entity_Name (Expr)
11182 and then Range_Checks_Suppressed (Entity (Expr))
11187 -- Before we do a range check, we have to deal with treating
11188 -- a fixed-point operand as an integer. The way we do this
11189 -- is simply to do an unchecked conversion to an appropriate
11190 -- integer type large enough to hold the result.
11192 if Is_Fixed_Point_Type (Etype (Expr)) then
11193 if Esize (Base_Type (Etype (Expr))) > Esize (Standard_Integer) then
11194 Ityp := Standard_Long_Long_Integer;
11196 Ityp := Standard_Integer;
11199 Set_Do_Range_Check (Expr, False);
11200 Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
11203 -- Reset overflow flag, since the range check will include
11204 -- dealing with possible overflow, and generate the check.
11206 Set_Do_Overflow_Check (N, False);
11208 Generate_Range_Check (Expr, Target_Type, CE_Range_Check_Failed);
11209 end Discrete_Range_Check;
11211 -----------------------------------
11212 -- Handle_Changed_Representation --
11213 -----------------------------------
11215 procedure Handle_Changed_Representation is
11223 -- Nothing else to do if no change of representation
11225 if Same_Representation (Operand_Type, Target_Type) then
11228 -- The real change of representation work is done by the assignment
11229 -- statement processing. So if this type conversion is appearing as
11230 -- the expression of an assignment statement, nothing needs to be
11231 -- done to the conversion.
11233 elsif Nkind (Parent (N)) = N_Assignment_Statement then
11236 -- Otherwise we need to generate a temporary variable, and do the
11237 -- change of representation assignment into that temporary variable.
11238 -- The conversion is then replaced by a reference to this variable.
11243 -- If type is unconstrained we have to add a constraint, copied
11244 -- from the actual value of the left-hand side.
11246 if not Is_Constrained (Target_Type) then
11247 if Has_Discriminants (Operand_Type) then
11249 -- A change of representation can only apply to untagged
11250 -- types. We need to build the constraint that applies to
11251 -- the target type, using the constraints of the operand.
11252 -- The analysis is complicated if there are both inherited
11253 -- discriminants and constrained discriminants.
11254 -- We iterate over the discriminants of the target, and
11255 -- find the discriminant of the same name:
11257 -- a) If there is a corresponding discriminant in the object
11258 -- then the value is a selected component of the operand.
11260 -- b) Otherwise the value of a constrained discriminant is
11261 -- found in the stored constraint of the operand.
11264 Stored : constant Elist_Id :=
11265 Stored_Constraint (Operand_Type);
11269 Disc_O : Entity_Id;
11270 -- Discriminant of the operand type. Its value in the
11271 -- object is captured in a selected component.
11273 Disc_S : Entity_Id;
11274 -- Stored discriminant of the operand. If present, it
11275 -- corresponds to a constrained discriminant of the
11278 Disc_T : Entity_Id;
11279 -- Discriminant of the target type
11282 Disc_T := First_Discriminant (Target_Type);
11283 Disc_O := First_Discriminant (Operand_Type);
11284 Disc_S := First_Stored_Discriminant (Operand_Type);
11286 if Present (Stored) then
11287 Elmt := First_Elmt (Stored);
11289 Elmt := No_Elmt; -- init to avoid warning
11293 while Present (Disc_T) loop
11294 if Present (Disc_O)
11295 and then Chars (Disc_T) = Chars (Disc_O)
11298 Make_Selected_Component (Loc,
11300 Duplicate_Subexpr_Move_Checks (Operand),
11302 Make_Identifier (Loc, Chars (Disc_O))));
11303 Next_Discriminant (Disc_O);
11305 elsif Present (Disc_S) then
11306 Append_To (Cons, New_Copy_Tree (Node (Elmt)));
11310 Next_Discriminant (Disc_T);
11314 elsif Is_Array_Type (Operand_Type) then
11315 N_Ix := First_Index (Target_Type);
11318 for J in 1 .. Number_Dimensions (Operand_Type) loop
11320 -- We convert the bounds explicitly. We use an unchecked
11321 -- conversion because bounds checks are done elsewhere.
11326 Unchecked_Convert_To (Etype (N_Ix),
11327 Make_Attribute_Reference (Loc,
11329 Duplicate_Subexpr_No_Checks
11330 (Operand, Name_Req => True),
11331 Attribute_Name => Name_First,
11332 Expressions => New_List (
11333 Make_Integer_Literal (Loc, J)))),
11336 Unchecked_Convert_To (Etype (N_Ix),
11337 Make_Attribute_Reference (Loc,
11339 Duplicate_Subexpr_No_Checks
11340 (Operand, Name_Req => True),
11341 Attribute_Name => Name_Last,
11342 Expressions => New_List (
11343 Make_Integer_Literal (Loc, J))))));
11350 Odef := New_Occurrence_Of (Target_Type, Loc);
11352 if Present (Cons) then
11354 Make_Subtype_Indication (Loc,
11355 Subtype_Mark => Odef,
11357 Make_Index_Or_Discriminant_Constraint (Loc,
11358 Constraints => Cons));
11361 Temp := Make_Temporary (Loc, 'C');
11363 Make_Object_Declaration (Loc,
11364 Defining_Identifier => Temp,
11365 Object_Definition => Odef);
11367 Set_No_Initialization (Decl, True);
11369 -- Insert required actions. It is essential to suppress checks
11370 -- since we have suppressed default initialization, which means
11371 -- that the variable we create may have no discriminants.
11376 Make_Assignment_Statement (Loc,
11377 Name => New_Occurrence_Of (Temp, Loc),
11378 Expression => Relocate_Node (N))),
11379 Suppress => All_Checks);
11381 Rewrite (N, New_Occurrence_Of (Temp, Loc));
11384 end Handle_Changed_Representation;
11386 -------------------------------
11387 -- Raise_Accessibility_Error --
11388 -------------------------------
11390 procedure Raise_Accessibility_Error is
11392 Error_Msg_Warn := SPARK_Mode /= On;
11394 Make_Raise_Program_Error (Sloc (N),
11395 Reason => PE_Accessibility_Check_Failed));
11396 Set_Etype (N, Target_Type);
11398 Error_Msg_N ("<<accessibility check failure", N);
11399 Error_Msg_NE ("\<<& [", N, Standard_Program_Error);
11400 end Raise_Accessibility_Error;
11402 ----------------------
11403 -- Real_Range_Check --
11404 ----------------------
11406 -- Case of conversions to floating-point or fixed-point. If range checks
11407 -- are enabled and the target type has a range constraint, we convert:
11413 -- Tnn : typ'Base := typ'Base (x);
11414 -- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
11417 -- This is necessary when there is a conversion of integer to float or
11418 -- to fixed-point to ensure that the correct checks are made. It is not
11419 -- necessary for the float-to-float case where it is enough to just set
11420 -- the Do_Range_Check flag on the expression.
11422 procedure Real_Range_Check is
11423 Btyp : constant Entity_Id := Base_Type (Target_Type);
11424 Lo : constant Node_Id := Type_Low_Bound (Target_Type);
11425 Hi : constant Node_Id := Type_High_Bound (Target_Type);
11436 -- Nothing to do if conversion was rewritten
11438 if Nkind (N) /= N_Type_Conversion then
11442 Expr := Expression (N);
11444 -- Clear the flag once for all
11446 Set_Do_Range_Check (Expr, False);
11448 -- Nothing to do if range checks suppressed, or target has the same
11449 -- range as the base type (or is the base type).
11451 if Range_Checks_Suppressed (Target_Type)
11452 or else (Lo = Type_Low_Bound (Btyp)
11454 Hi = Type_High_Bound (Btyp))
11459 -- Nothing to do if expression is an entity on which checks have been
11462 if Is_Entity_Name (Expr)
11463 and then Range_Checks_Suppressed (Entity (Expr))
11468 -- Nothing to do if expression was rewritten into a float-to-float
11469 -- conversion, since this kind of conversion is handled elsewhere.
11471 if Is_Floating_Point_Type (Etype (Expr))
11472 and then Is_Floating_Point_Type (Target_Type)
11477 -- Nothing to do if bounds are all static and we can tell that the
11478 -- expression is within the bounds of the target. Note that if the
11479 -- operand is of an unconstrained floating-point type, then we do
11480 -- not trust it to be in range (might be infinite)
11483 S_Lo : constant Node_Id := Type_Low_Bound (Etype (Expr));
11484 S_Hi : constant Node_Id := Type_High_Bound (Etype (Expr));
11487 if (not Is_Floating_Point_Type (Etype (Expr))
11488 or else Is_Constrained (Etype (Expr)))
11489 and then Compile_Time_Known_Value (S_Lo)
11490 and then Compile_Time_Known_Value (S_Hi)
11491 and then Compile_Time_Known_Value (Hi)
11492 and then Compile_Time_Known_Value (Lo)
11495 D_Lov : constant Ureal := Expr_Value_R (Lo);
11496 D_Hiv : constant Ureal := Expr_Value_R (Hi);
11501 if Is_Real_Type (Etype (Expr)) then
11502 S_Lov := Expr_Value_R (S_Lo);
11503 S_Hiv := Expr_Value_R (S_Hi);
11505 S_Lov := UR_From_Uint (Expr_Value (S_Lo));
11506 S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
11510 and then S_Lov >= D_Lov
11511 and then S_Hiv <= D_Hiv
11519 -- Otherwise rewrite the conversion as described above
11521 Conv := Convert_To (Btyp, Expr);
11523 -- If a conversion is necessary, then copy the specific flags from
11524 -- the original one and also move the Do_Overflow_Check flag since
11525 -- this new conversion is to the base type.
11527 if Nkind (Conv) = N_Type_Conversion then
11528 Set_Conversion_OK (Conv, Conversion_OK (N));
11529 Set_Float_Truncate (Conv, Float_Truncate (N));
11530 Set_Rounded_Result (Conv, Rounded_Result (N));
11532 if Do_Overflow_Check (N) then
11533 Set_Do_Overflow_Check (Conv);
11534 Set_Do_Overflow_Check (N, False);
11538 Tnn := Make_Temporary (Loc, 'T', Conv);
11540 -- For a conversion from Float to Fixed where the bounds of the
11541 -- fixed-point type are static, we can obtain a more accurate
11542 -- fixed-point value by converting the result of the floating-
11543 -- point expression to an appropriate integer type, and then
11544 -- performing an unchecked conversion to the target fixed-point
11545 -- type. The range check can then use the corresponding integer
11546 -- value of the bounds instead of requiring further conversions.
11547 -- This preserves the identity:
11549 -- Fix_Val = Fixed_Type (Float_Type (Fix_Val))
11551 -- which used to fail when Fix_Val was a bound of the type and
11552 -- the 'Small was not a representable number.
11553 -- This transformation requires an integer type large enough to
11554 -- accommodate a fixed-point value. This will not be the case
11555 -- in systems where Duration is larger than Long_Integer.
11557 if Is_Ordinary_Fixed_Point_Type (Target_Type)
11558 and then Is_Floating_Point_Type (Etype (Expr))
11559 and then RM_Size (Btyp) <= RM_Size (Standard_Long_Integer)
11560 and then Nkind (Lo) = N_Real_Literal
11561 and then Nkind (Hi) = N_Real_Literal
11564 Expr_Id : constant Entity_Id := Make_Temporary (Loc, 'T', Conv);
11565 Int_Type : Entity_Id;
11568 -- Find an integer type of the appropriate size to perform an
11569 -- unchecked conversion to the target fixed-point type.
11571 if RM_Size (Btyp) > RM_Size (Standard_Integer) then
11572 Int_Type := Standard_Long_Integer;
11574 elsif RM_Size (Btyp) > RM_Size (Standard_Short_Integer) then
11575 Int_Type := Standard_Integer;
11578 Int_Type := Standard_Short_Integer;
11581 -- Generate a temporary with the integer value. Required in the
11582 -- CCG compiler to ensure that run-time checks reference this
11583 -- integer expression (instead of the resulting fixed-point
11584 -- value because fixed-point values are handled by means of
11585 -- unsigned integer types).
11588 Make_Object_Declaration (Loc,
11589 Defining_Identifier => Expr_Id,
11590 Object_Definition => New_Occurrence_Of (Int_Type, Loc),
11591 Constant_Present => True,
11593 Convert_To (Int_Type, Expression (Conv))));
11595 -- Create integer objects for range checking of result.
11598 Unchecked_Convert_To
11599 (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
11602 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo));
11605 Unchecked_Convert_To
11606 (Int_Type, New_Occurrence_Of (Expr_Id, Loc));
11609 Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi));
11611 -- Rewrite conversion as an integer conversion of the
11612 -- original floating-point expression, followed by an
11613 -- unchecked conversion to the target fixed-point type.
11616 Make_Unchecked_Type_Conversion (Loc,
11617 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
11618 Expression => New_Occurrence_Of (Expr_Id, Loc));
11621 -- All other conversions
11624 Lo_Arg := New_Occurrence_Of (Tnn, Loc);
11626 Make_Attribute_Reference (Loc,
11627 Prefix => New_Occurrence_Of (Target_Type, Loc),
11628 Attribute_Name => Name_First);
11630 Hi_Arg := New_Occurrence_Of (Tnn, Loc);
11632 Make_Attribute_Reference (Loc,
11633 Prefix => New_Occurrence_Of (Target_Type, Loc),
11634 Attribute_Name => Name_Last);
11637 -- Build code for range checking. Note that checks are suppressed
11638 -- here since we don't want a recursive range check popping up.
11640 Insert_Actions (N, New_List (
11641 Make_Object_Declaration (Loc,
11642 Defining_Identifier => Tnn,
11643 Object_Definition => New_Occurrence_Of (Btyp, Loc),
11644 Constant_Present => True,
11645 Expression => Conv),
11647 Make_Raise_Constraint_Error (Loc,
11652 Left_Opnd => Lo_Arg,
11653 Right_Opnd => Lo_Val),
11657 Left_Opnd => Hi_Arg,
11658 Right_Opnd => Hi_Val)),
11659 Reason => CE_Range_Check_Failed)),
11660 Suppress => All_Checks);
11662 Rewrite (Expr, New_Occurrence_Of (Tnn, Loc));
11663 end Real_Range_Check;
11665 -----------------------------
11666 -- Has_Extra_Accessibility --
11667 -----------------------------
11669 -- Returns true for a formal of an anonymous access type or for an Ada
11670 -- 2012-style stand-alone object of an anonymous access type.
11672 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
11674 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
11675 return Present (Effective_Extra_Accessibility (Id));
11679 end Has_Extra_Accessibility;
11681 -- Start of processing for Expand_N_Type_Conversion
11684 -- First remove check marks put by the semantic analysis on the type
11685 -- conversion between array types. We need these checks, and they will
11686 -- be generated by this expansion routine, but we do not depend on these
11687 -- flags being set, and since we do intend to expand the checks in the
11688 -- front end, we don't want them on the tree passed to the back end.
11690 if Is_Array_Type (Target_Type) then
11691 if Is_Constrained (Target_Type) then
11692 Set_Do_Length_Check (N, False);
11694 Set_Do_Range_Check (Operand, False);
11698 -- Nothing at all to do if conversion is to the identical type so remove
11699 -- the conversion completely, it is useless, except that it may carry
11700 -- an Assignment_OK attribute, which must be propagated to the operand.
11702 if Operand_Type = Target_Type then
11703 if Assignment_OK (N) then
11704 Set_Assignment_OK (Operand);
11707 Rewrite (N, Relocate_Node (Operand));
11711 -- Nothing to do if this is the second argument of read. This is a
11712 -- "backwards" conversion that will be handled by the specialized code
11713 -- in attribute processing.
11715 if Nkind (Parent (N)) = N_Attribute_Reference
11716 and then Attribute_Name (Parent (N)) = Name_Read
11717 and then Next (First (Expressions (Parent (N)))) = N
11722 -- Check for case of converting to a type that has an invariant
11723 -- associated with it. This requires an invariant check. We insert
11726 -- invariant_check (typ (expr))
11728 -- in the code, after removing side effects from the expression.
11729 -- This is clearer than replacing the conversion into an expression
11730 -- with actions, because the context may impose additional actions
11731 -- (tag checks, membership tests, etc.) that conflict with this
11732 -- rewriting (used previously).
11734 -- Note: the Comes_From_Source check, and then the resetting of this
11735 -- flag prevents what would otherwise be an infinite recursion.
11737 if Has_Invariants (Target_Type)
11738 and then Present (Invariant_Procedure (Target_Type))
11739 and then Comes_From_Source (N)
11741 Set_Comes_From_Source (N, False);
11742 Remove_Side_Effects (N);
11743 Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
11747 -- Here if we may need to expand conversion
11749 -- If the operand of the type conversion is an arithmetic operation on
11750 -- signed integers, and the based type of the signed integer type in
11751 -- question is smaller than Standard.Integer, we promote both of the
11752 -- operands to type Integer.
11754 -- For example, if we have
11756 -- target-type (opnd1 + opnd2)
11758 -- and opnd1 and opnd2 are of type short integer, then we rewrite
11761 -- target-type (integer(opnd1) + integer(opnd2))
11763 -- We do this because we are always allowed to compute in a larger type
11764 -- if we do the right thing with the result, and in this case we are
11765 -- going to do a conversion which will do an appropriate check to make
11766 -- sure that things are in range of the target type in any case. This
11767 -- avoids some unnecessary intermediate overflows.
11769 -- We might consider a similar transformation in the case where the
11770 -- target is a real type or a 64-bit integer type, and the operand
11771 -- is an arithmetic operation using a 32-bit integer type. However,
11772 -- we do not bother with this case, because it could cause significant
11773 -- inefficiencies on 32-bit machines. On a 64-bit machine it would be
11774 -- much cheaper, but we don't want different behavior on 32-bit and
11775 -- 64-bit machines. Note that the exclusion of the 64-bit case also
11776 -- handles the configurable run-time cases where 64-bit arithmetic
11777 -- may simply be unavailable.
11779 -- Note: this circuit is partially redundant with respect to the circuit
11780 -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
11781 -- the processing here. Also we still need the Checks circuit, since we
11782 -- have to be sure not to generate junk overflow checks in the first
11783 -- place, since it would be trick to remove them here.
11785 if Integer_Promotion_Possible (N) then
11787 -- All conditions met, go ahead with transformation
11795 Make_Type_Conversion (Loc,
11796 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
11797 Expression => Relocate_Node (Right_Opnd (Operand)));
11799 Opnd := New_Op_Node (Nkind (Operand), Loc);
11800 Set_Right_Opnd (Opnd, R);
11802 if Nkind (Operand) in N_Binary_Op then
11804 Make_Type_Conversion (Loc,
11805 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
11806 Expression => Relocate_Node (Left_Opnd (Operand)));
11808 Set_Left_Opnd (Opnd, L);
11812 Make_Type_Conversion (Loc,
11813 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
11814 Expression => Opnd));
11816 Analyze_And_Resolve (N, Target_Type);
11821 -- Do validity check if validity checking operands
11823 if Validity_Checks_On and Validity_Check_Operands then
11824 Ensure_Valid (Operand);
11827 -- Special case of converting from non-standard boolean type
11829 if Is_Boolean_Type (Operand_Type)
11830 and then (Nonzero_Is_True (Operand_Type))
11832 Adjust_Condition (Operand);
11833 Set_Etype (Operand, Standard_Boolean);
11834 Operand_Type := Standard_Boolean;
11837 -- Case of converting to an access type
11839 if Is_Access_Type (Target_Type) then
11840 -- In terms of accessibility rules, an anonymous access discriminant
11841 -- is not considered separate from its parent object.
11843 if Nkind (Operand) = N_Selected_Component
11844 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
11845 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
11847 Operand_Acc := Original_Node (Prefix (Operand));
11850 -- If this type conversion was internally generated by the front end
11851 -- to displace the pointer to the object to reference an interface
11852 -- type and the original node was an Unrestricted_Access attribute,
11853 -- then skip applying accessibility checks (because, according to the
11854 -- GNAT Reference Manual, this attribute is similar to 'Access except
11855 -- that all accessibility and aliased view checks are omitted).
11857 if not Comes_From_Source (N)
11858 and then Is_Interface (Designated_Type (Target_Type))
11859 and then Nkind (Original_Node (N)) = N_Attribute_Reference
11860 and then Attribute_Name (Original_Node (N)) =
11861 Name_Unrestricted_Access
11865 -- Apply an accessibility check when the conversion operand is an
11866 -- access parameter (or a renaming thereof), unless conversion was
11867 -- expanded from an Unchecked_ or Unrestricted_Access attribute,
11868 -- or for the actual of a class-wide interface parameter. Note that
11869 -- other checks may still need to be applied below (such as tagged
11872 elsif Is_Entity_Name (Operand_Acc)
11873 and then Has_Extra_Accessibility (Entity (Operand_Acc))
11874 and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
11875 and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
11876 or else Attribute_Name (Original_Node (N)) = Name_Access)
11878 if not Comes_From_Source (N)
11879 and then Nkind_In (Parent (N), N_Function_Call,
11880 N_Parameter_Association,
11881 N_Procedure_Call_Statement)
11882 and then Is_Interface (Designated_Type (Target_Type))
11883 and then Is_Class_Wide_Type (Designated_Type (Target_Type))
11888 Apply_Accessibility_Check
11889 (Operand_Acc, Target_Type, Insert_Node => Operand);
11892 -- If the level of the operand type is statically deeper than the
11893 -- level of the target type, then force Program_Error. Note that this
11894 -- can only occur for cases where the attribute is within the body of
11895 -- an instantiation, otherwise the conversion will already have been
11896 -- rejected as illegal.
11898 -- Note: warnings are issued by the analyzer for the instance cases
11900 elsif In_Instance_Body
11902 -- The case where the target type is an anonymous access type of
11903 -- a discriminant is excluded, because the level of such a type
11904 -- depends on the context and currently the level returned for such
11905 -- types is zero, resulting in warnings about check failures
11906 -- in certain legal cases involving class-wide interfaces as the
11907 -- designated type (some cases, such as return statements, are
11908 -- checked at run time, but not clear if these are handled right
11909 -- in general, see 3.10.2(12/2-12.5/3) ???).
11912 not (Ekind (Target_Type) = E_Anonymous_Access_Type
11913 and then Present (Associated_Node_For_Itype (Target_Type))
11914 and then Nkind (Associated_Node_For_Itype (Target_Type)) =
11915 N_Discriminant_Specification)
11917 Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
11919 Raise_Accessibility_Error;
11922 -- When the operand is a selected access discriminant the check needs
11923 -- to be made against the level of the object denoted by the prefix
11924 -- of the selected name. Force Program_Error for this case as well
11925 -- (this accessibility violation can only happen if within the body
11926 -- of an instantiation).
11928 elsif In_Instance_Body
11929 and then Ekind (Operand_Type) = E_Anonymous_Access_Type
11930 and then Nkind (Operand) = N_Selected_Component
11931 and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
11932 and then Object_Access_Level (Operand) >
11933 Type_Access_Level (Target_Type)
11935 Raise_Accessibility_Error;
11940 -- Case of conversions of tagged types and access to tagged types
11942 -- When needed, that is to say when the expression is class-wide, Add
11943 -- runtime a tag check for (strict) downward conversion by using the
11944 -- membership test, generating:
11946 -- [constraint_error when Operand not in Target_Type'Class]
11948 -- or in the access type case
11950 -- [constraint_error
11951 -- when Operand /= null
11952 -- and then Operand.all not in
11953 -- Designated_Type (Target_Type)'Class]
11955 if (Is_Access_Type (Target_Type)
11956 and then Is_Tagged_Type (Designated_Type (Target_Type)))
11957 or else Is_Tagged_Type (Target_Type)
11959 -- Do not do any expansion in the access type case if the parent is a
11960 -- renaming, since this is an error situation which will be caught by
11961 -- Sem_Ch8, and the expansion can interfere with this error check.
11963 if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
11967 -- Otherwise, proceed with processing tagged conversion
11969 Tagged_Conversion : declare
11970 Actual_Op_Typ : Entity_Id;
11971 Actual_Targ_Typ : Entity_Id;
11972 Make_Conversion : Boolean := False;
11973 Root_Op_Typ : Entity_Id;
11975 procedure Make_Tag_Check (Targ_Typ : Entity_Id);
11976 -- Create a membership check to test whether Operand is a member
11977 -- of Targ_Typ. If the original Target_Type is an access, include
11978 -- a test for null value. The check is inserted at N.
11980 --------------------
11981 -- Make_Tag_Check --
11982 --------------------
11984 procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
11989 -- [Constraint_Error
11990 -- when Operand /= null
11991 -- and then Operand.all not in Targ_Typ]
11993 if Is_Access_Type (Target_Type) then
11995 Make_And_Then (Loc,
11998 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
11999 Right_Opnd => Make_Null (Loc)),
12004 Make_Explicit_Dereference (Loc,
12005 Prefix => Duplicate_Subexpr_No_Checks (Operand)),
12006 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc)));
12009 -- [Constraint_Error when Operand not in Targ_Typ]
12014 Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
12015 Right_Opnd => New_Occurrence_Of (Targ_Typ, Loc));
12019 Make_Raise_Constraint_Error (Loc,
12021 Reason => CE_Tag_Check_Failed),
12022 Suppress => All_Checks);
12023 end Make_Tag_Check;
12025 -- Start of processing for Tagged_Conversion
12028 -- Handle entities from the limited view
12030 if Is_Access_Type (Operand_Type) then
12032 Available_View (Designated_Type (Operand_Type));
12034 Actual_Op_Typ := Operand_Type;
12037 if Is_Access_Type (Target_Type) then
12039 Available_View (Designated_Type (Target_Type));
12041 Actual_Targ_Typ := Target_Type;
12044 Root_Op_Typ := Root_Type (Actual_Op_Typ);
12046 -- Ada 2005 (AI-251): Handle interface type conversion
12048 if Is_Interface (Actual_Op_Typ)
12050 Is_Interface (Actual_Targ_Typ)
12052 Expand_Interface_Conversion (N);
12056 if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
12058 -- Create a runtime tag check for a downward class-wide type
12061 if Is_Class_Wide_Type (Actual_Op_Typ)
12062 and then Actual_Op_Typ /= Actual_Targ_Typ
12063 and then Root_Op_Typ /= Actual_Targ_Typ
12064 and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
12065 Use_Full_View => True)
12067 Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
12068 Make_Conversion := True;
12071 -- AI05-0073: If the result subtype of the function is defined
12072 -- by an access_definition designating a specific tagged type
12073 -- T, a check is made that the result value is null or the tag
12074 -- of the object designated by the result value identifies T.
12075 -- Constraint_Error is raised if this check fails.
12077 if Nkind (Parent (N)) = N_Simple_Return_Statement then
12080 Func_Typ : Entity_Id;
12083 -- Climb scope stack looking for the enclosing function
12085 Func := Current_Scope;
12086 while Present (Func)
12087 and then Ekind (Func) /= E_Function
12089 Func := Scope (Func);
12092 -- The function's return subtype must be defined using
12093 -- an access definition.
12095 if Nkind (Result_Definition (Parent (Func))) =
12096 N_Access_Definition
12098 Func_Typ := Directly_Designated_Type (Etype (Func));
12100 -- The return subtype denotes a specific tagged type,
12101 -- in other words, a non class-wide type.
12103 if Is_Tagged_Type (Func_Typ)
12104 and then not Is_Class_Wide_Type (Func_Typ)
12106 Make_Tag_Check (Actual_Targ_Typ);
12107 Make_Conversion := True;
12113 -- We have generated a tag check for either a class-wide type
12114 -- conversion or for AI05-0073.
12116 if Make_Conversion then
12121 Make_Unchecked_Type_Conversion (Loc,
12122 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
12123 Expression => Relocate_Node (Expression (N)));
12125 Analyze_And_Resolve (N, Target_Type);
12129 end Tagged_Conversion;
12131 -- Case of other access type conversions
12133 elsif Is_Access_Type (Target_Type) then
12134 Apply_Constraint_Check (Operand, Target_Type);
12136 -- Case of conversions from a fixed-point type
12138 -- These conversions require special expansion and processing, found in
12139 -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
12140 -- since from a semantic point of view, these are simple integer
12141 -- conversions, which do not need further processing.
12143 elsif Is_Fixed_Point_Type (Operand_Type)
12144 and then not Conversion_OK (N)
12146 -- We should never see universal fixed at this case, since the
12147 -- expansion of the constituent divide or multiply should have
12148 -- eliminated the explicit mention of universal fixed.
12150 pragma Assert (Operand_Type /= Universal_Fixed);
12152 -- Check for special case of the conversion to universal real that
12153 -- occurs as a result of the use of a round attribute. In this case,
12154 -- the real type for the conversion is taken from the target type of
12155 -- the Round attribute and the result must be marked as rounded.
12157 if Target_Type = Universal_Real
12158 and then Nkind (Parent (N)) = N_Attribute_Reference
12159 and then Attribute_Name (Parent (N)) = Name_Round
12161 Set_Rounded_Result (N);
12162 Set_Etype (N, Etype (Parent (N)));
12163 Target_Type := Etype (N);
12166 if Is_Fixed_Point_Type (Target_Type) then
12167 Expand_Convert_Fixed_To_Fixed (N);
12170 elsif Is_Integer_Type (Target_Type) then
12171 Expand_Convert_Fixed_To_Integer (N);
12172 Discrete_Range_Check;
12175 pragma Assert (Is_Floating_Point_Type (Target_Type));
12176 Expand_Convert_Fixed_To_Float (N);
12180 -- Case of conversions to a fixed-point type
12182 -- These conversions require special expansion and processing, found in
12183 -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
12184 -- since from a semantic point of view, these are simple integer
12185 -- conversions, which do not need further processing.
12187 elsif Is_Fixed_Point_Type (Target_Type)
12188 and then not Conversion_OK (N)
12190 if Is_Integer_Type (Operand_Type) then
12191 Expand_Convert_Integer_To_Fixed (N);
12194 pragma Assert (Is_Floating_Point_Type (Operand_Type));
12195 Expand_Convert_Float_To_Fixed (N);
12199 -- Case of array conversions
12201 -- Expansion of array conversions, add required length/range checks but
12202 -- only do this if there is no change of representation. For handling of
12203 -- this case, see Handle_Changed_Representation.
12205 elsif Is_Array_Type (Target_Type) then
12206 if Is_Constrained (Target_Type) then
12207 Apply_Length_Check (Operand, Target_Type);
12209 Apply_Range_Check (Operand, Target_Type);
12212 Handle_Changed_Representation;
12214 -- Case of conversions of discriminated types
12216 -- Add required discriminant checks if target is constrained. Again this
12217 -- change is skipped if we have a change of representation.
12219 elsif Has_Discriminants (Target_Type)
12220 and then Is_Constrained (Target_Type)
12222 Apply_Discriminant_Check (Operand, Target_Type);
12223 Handle_Changed_Representation;
12225 -- Case of all other record conversions. The only processing required
12226 -- is to check for a change of representation requiring the special
12227 -- assignment processing.
12229 elsif Is_Record_Type (Target_Type) then
12231 -- Ada 2005 (AI-216): Program_Error is raised when converting from
12232 -- a derived Unchecked_Union type to an unconstrained type that is
12233 -- not Unchecked_Union if the operand lacks inferable discriminants.
12235 if Is_Derived_Type (Operand_Type)
12236 and then Is_Unchecked_Union (Base_Type (Operand_Type))
12237 and then not Is_Constrained (Target_Type)
12238 and then not Is_Unchecked_Union (Base_Type (Target_Type))
12239 and then not Has_Inferable_Discriminants (Operand)
12241 -- To prevent Gigi from generating illegal code, we generate a
12242 -- Program_Error node, but we give it the target type of the
12243 -- conversion (is this requirement documented somewhere ???)
12246 PE : constant Node_Id := Make_Raise_Program_Error (Loc,
12247 Reason => PE_Unchecked_Union_Restriction);
12250 Set_Etype (PE, Target_Type);
12255 Handle_Changed_Representation;
12258 -- Case of conversions of enumeration types
12260 elsif Is_Enumeration_Type (Target_Type) then
12262 -- Special processing is required if there is a change of
12263 -- representation (from enumeration representation clauses).
12265 if not Same_Representation (Target_Type, Operand_Type) then
12267 -- Convert: x(y) to x'val (ytyp'val (y))
12270 Make_Attribute_Reference (Loc,
12271 Prefix => New_Occurrence_Of (Target_Type, Loc),
12272 Attribute_Name => Name_Val,
12273 Expressions => New_List (
12274 Make_Attribute_Reference (Loc,
12275 Prefix => New_Occurrence_Of (Operand_Type, Loc),
12276 Attribute_Name => Name_Pos,
12277 Expressions => New_List (Operand)))));
12279 Analyze_And_Resolve (N, Target_Type);
12283 -- At this stage, either the conversion node has been transformed into
12284 -- some other equivalent expression, or left as a conversion that can be
12285 -- handled by Gigi, in the following cases:
12287 -- Conversions with no change of representation or type
12289 -- Numeric conversions involving integer, floating- and fixed-point
12290 -- values. Fixed-point values are allowed only if Conversion_OK is
12291 -- set, i.e. if the fixed-point values are to be treated as integers.
12293 -- No other conversions should be passed to Gigi
12295 -- Check: are these rules stated in sinfo??? if so, why restate here???
12297 -- The only remaining step is to generate a range check if we still have
12298 -- a type conversion at this stage and Do_Range_Check is set. Note that
12299 -- we need to deal with at most 8 out of the 9 possible cases of numeric
12300 -- conversions here, because the float-to-integer case is entirely dealt
12301 -- with by Apply_Float_Conversion_Check.
12303 if Nkind (N) = N_Type_Conversion
12304 and then Do_Range_Check (Expression (N))
12306 -- Float-to-float conversions
12308 if Is_Floating_Point_Type (Target_Type)
12309 and then Is_Floating_Point_Type (Etype (Expression (N)))
12311 -- Reset overflow flag, since the range check will include
12312 -- dealing with possible overflow, and generate the check.
12314 Set_Do_Overflow_Check (N, False);
12316 Generate_Range_Check
12317 (Expression (N), Target_Type, CE_Range_Check_Failed);
12319 -- Discrete-to-discrete conversions or fixed-point-to-discrete
12320 -- conversions when Conversion_OK is set.
12322 elsif Is_Discrete_Type (Target_Type)
12323 and then (Is_Discrete_Type (Etype (Expression (N)))
12324 or else (Is_Fixed_Point_Type (Etype (Expression (N)))
12325 and then Conversion_OK (N)))
12327 -- If Address is either a source type or target type,
12328 -- suppress range check to avoid typing anomalies when
12329 -- it is a visible integer type.
12331 if Is_Descendant_Of_Address (Etype (Expression (N)))
12332 or else Is_Descendant_Of_Address (Target_Type)
12334 Set_Do_Range_Check (Expression (N), False);
12336 Discrete_Range_Check;
12339 -- Conversions to floating- or fixed-point when Conversion_OK is set
12341 elsif Is_Floating_Point_Type (Target_Type)
12342 or else (Is_Fixed_Point_Type (Target_Type)
12343 and then Conversion_OK (N))
12349 -- Here at end of processing
12352 -- Apply predicate check if required. Note that we can't just call
12353 -- Apply_Predicate_Check here, because the type looks right after
12354 -- the conversion and it would omit the check. The Comes_From_Source
12355 -- guard is necessary to prevent infinite recursions when we generate
12356 -- internal conversions for the purpose of checking predicates.
12358 if Present (Predicate_Function (Target_Type))
12359 and then not Predicates_Ignored (Target_Type)
12360 and then Target_Type /= Operand_Type
12361 and then Comes_From_Source (N)
12364 New_Expr : constant Node_Id := Duplicate_Subexpr (N);
12367 -- Avoid infinite recursion on the subsequent expansion of
12368 -- of the copy of the original type conversion. When needed,
12369 -- a range check has already been applied to the expression.
12371 Set_Comes_From_Source (New_Expr, False);
12373 Make_Predicate_Check (Target_Type, New_Expr),
12374 Suppress => Range_Check);
12377 end Expand_N_Type_Conversion;
12379 -----------------------------------
12380 -- Expand_N_Unchecked_Expression --
12381 -----------------------------------
12383 -- Remove the unchecked expression node from the tree. Its job was simply
12384 -- to make sure that its constituent expression was handled with checks
12385 -- off, and now that is done, we can remove it from the tree, and indeed
12386 -- must, since Gigi does not expect to see these nodes.
12388 procedure Expand_N_Unchecked_Expression (N : Node_Id) is
12389 Exp : constant Node_Id := Expression (N);
12391 Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
12393 end Expand_N_Unchecked_Expression;
12395 ----------------------------------------
12396 -- Expand_N_Unchecked_Type_Conversion --
12397 ----------------------------------------
12399 -- If this cannot be handled by Gigi and we haven't already made a
12400 -- temporary for it, do it now.
12402 procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
12403 Target_Type : constant Entity_Id := Etype (N);
12404 Operand : constant Node_Id := Expression (N);
12405 Operand_Type : constant Entity_Id := Etype (Operand);
12408 -- Nothing at all to do if conversion is to the identical type so remove
12409 -- the conversion completely, it is useless, except that it may carry
12410 -- an Assignment_OK indication which must be propagated to the operand.
12412 if Operand_Type = Target_Type then
12414 -- Code duplicates Expand_N_Unchecked_Expression above, factor???
12416 if Assignment_OK (N) then
12417 Set_Assignment_OK (Operand);
12420 Rewrite (N, Relocate_Node (Operand));
12424 -- If we have a conversion of a compile time known value to a target
12425 -- type and the value is in range of the target type, then we can simply
12426 -- replace the construct by an integer literal of the correct type. We
12427 -- only apply this to integer types being converted. Possibly it may
12428 -- apply in other cases, but it is too much trouble to worry about.
12430 -- Note that we do not do this transformation if the Kill_Range_Check
12431 -- flag is set, since then the value may be outside the expected range.
12432 -- This happens in the Normalize_Scalars case.
12434 -- We also skip this if either the target or operand type is biased
12435 -- because in this case, the unchecked conversion is supposed to
12436 -- preserve the bit pattern, not the integer value.
12438 if Is_Integer_Type (Target_Type)
12439 and then not Has_Biased_Representation (Target_Type)
12440 and then Is_Integer_Type (Operand_Type)
12441 and then not Has_Biased_Representation (Operand_Type)
12442 and then Compile_Time_Known_Value (Operand)
12443 and then not Kill_Range_Check (N)
12446 Val : constant Uint := Expr_Value (Operand);
12449 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
12451 Compile_Time_Known_Value (Type_High_Bound (Target_Type))
12453 Val >= Expr_Value (Type_Low_Bound (Target_Type))
12455 Val <= Expr_Value (Type_High_Bound (Target_Type))
12457 Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
12459 -- If Address is the target type, just set the type to avoid a
12460 -- spurious type error on the literal when Address is a visible
12463 if Is_Descendant_Of_Address (Target_Type) then
12464 Set_Etype (N, Target_Type);
12466 Analyze_And_Resolve (N, Target_Type);
12474 -- Generate an extra temporary for cases unsupported by the C backend
12476 if Modify_Tree_For_C then
12478 Source : constant Node_Id := Unqual_Conv (Expression (N));
12479 Source_Typ : Entity_Id := Get_Full_View (Etype (Source));
12482 if Is_Packed_Array (Source_Typ) then
12483 Source_Typ := Packed_Array_Impl_Type (Source_Typ);
12486 if Nkind (Source) = N_Function_Call
12487 and then (Is_Composite_Type (Etype (Source))
12488 or else Is_Composite_Type (Target_Type))
12490 Force_Evaluation (Source);
12495 -- Nothing to do if conversion is safe
12497 if Safe_Unchecked_Type_Conversion (N) then
12501 -- Otherwise force evaluation unless Assignment_OK flag is set (this
12502 -- flag indicates ??? More comments needed here)
12504 if Assignment_OK (N) then
12507 Force_Evaluation (N);
12509 end Expand_N_Unchecked_Type_Conversion;
12511 ----------------------------
12512 -- Expand_Record_Equality --
12513 ----------------------------
12515 -- For non-variant records, Equality is expanded when needed into:
12517 -- and then Lhs.Discr1 = Rhs.Discr1
12519 -- and then Lhs.Discrn = Rhs.Discrn
12520 -- and then Lhs.Cmp1 = Rhs.Cmp1
12522 -- and then Lhs.Cmpn = Rhs.Cmpn
12524 -- The expression is folded by the back end for adjacent fields. This
12525 -- function is called for tagged record in only one occasion: for imple-
12526 -- menting predefined primitive equality (see Predefined_Primitives_Bodies)
12527 -- otherwise the primitive "=" is used directly.
12529 function Expand_Record_Equality
12534 Bodies : List_Id) return Node_Id
12536 Loc : constant Source_Ptr := Sloc (Nod);
12541 First_Time : Boolean := True;
12543 function Element_To_Compare (C : Entity_Id) return Entity_Id;
12544 -- Return the next discriminant or component to compare, starting with
12545 -- C, skipping inherited components.
12547 ------------------------
12548 -- Element_To_Compare --
12549 ------------------------
12551 function Element_To_Compare (C : Entity_Id) return Entity_Id is
12557 -- Exit loop when the next element to be compared is found, or
12558 -- there is no more such element.
12560 exit when No (Comp);
12562 exit when Ekind_In (Comp, E_Discriminant, E_Component)
12565 -- Skip inherited components
12567 -- Note: for a tagged type, we always generate the "=" primitive
12568 -- for the base type (not on the first subtype), so the test for
12569 -- Comp /= Original_Record_Component (Comp) is True for
12570 -- inherited components only.
12572 (Is_Tagged_Type (Typ)
12573 and then Comp /= Original_Record_Component (Comp))
12577 or else Chars (Comp) = Name_uTag
12579 -- Skip interface elements (secondary tags???)
12581 or else Is_Interface (Etype (Comp)));
12583 Next_Entity (Comp);
12587 end Element_To_Compare;
12589 -- Start of processing for Expand_Record_Equality
12592 -- Generates the following code: (assuming that Typ has one Discr and
12593 -- component C2 is also a record)
12595 -- Lhs.Discr1 = Rhs.Discr1
12596 -- and then Lhs.C1 = Rhs.C1
12597 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
12599 -- and then Lhs.Cmpn = Rhs.Cmpn
12601 Result := New_Occurrence_Of (Standard_True, Loc);
12602 C := Element_To_Compare (First_Entity (Typ));
12603 while Present (C) loop
12614 New_Lhs := New_Copy_Tree (Lhs);
12615 New_Rhs := New_Copy_Tree (Rhs);
12619 Expand_Composite_Equality (Nod, Etype (C),
12621 Make_Selected_Component (Loc,
12623 Selector_Name => New_Occurrence_Of (C, Loc)),
12625 Make_Selected_Component (Loc,
12627 Selector_Name => New_Occurrence_Of (C, Loc)),
12630 -- If some (sub)component is an unchecked_union, the whole
12631 -- operation will raise program error.
12633 if Nkind (Check) = N_Raise_Program_Error then
12635 Set_Etype (Result, Standard_Boolean);
12641 -- Generate logical "and" for CodePeer to simplify the
12642 -- generated code and analysis.
12644 elsif CodePeer_Mode then
12647 Left_Opnd => Result,
12648 Right_Opnd => Check);
12652 Make_And_Then (Loc,
12653 Left_Opnd => Result,
12654 Right_Opnd => Check);
12659 First_Time := False;
12660 C := Element_To_Compare (Next_Entity (C));
12664 end Expand_Record_Equality;
12666 ---------------------------
12667 -- Expand_Set_Membership --
12668 ---------------------------
12670 procedure Expand_Set_Membership (N : Node_Id) is
12671 Lop : constant Node_Id := Left_Opnd (N);
12675 function Make_Cond (Alt : Node_Id) return Node_Id;
12676 -- If the alternative is a subtype mark, create a simple membership
12677 -- test. Otherwise create an equality test for it.
12683 function Make_Cond (Alt : Node_Id) return Node_Id is
12685 L : constant Node_Id := New_Copy_Tree (Lop);
12686 R : constant Node_Id := Relocate_Node (Alt);
12689 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
12690 or else Nkind (Alt) = N_Range
12693 Make_In (Sloc (Alt),
12698 Make_Op_Eq (Sloc (Alt),
12706 -- Start of processing for Expand_Set_Membership
12709 Remove_Side_Effects (Lop);
12711 Alt := Last (Alternatives (N));
12712 Res := Make_Cond (Alt);
12715 while Present (Alt) loop
12717 Make_Or_Else (Sloc (Alt),
12718 Left_Opnd => Make_Cond (Alt),
12719 Right_Opnd => Res);
12724 Analyze_And_Resolve (N, Standard_Boolean);
12725 end Expand_Set_Membership;
12727 -----------------------------------
12728 -- Expand_Short_Circuit_Operator --
12729 -----------------------------------
12731 -- Deal with special expansion if actions are present for the right operand
12732 -- and deal with optimizing case of arguments being True or False. We also
12733 -- deal with the special case of non-standard boolean values.
12735 procedure Expand_Short_Circuit_Operator (N : Node_Id) is
12736 Loc : constant Source_Ptr := Sloc (N);
12737 Typ : constant Entity_Id := Etype (N);
12738 Left : constant Node_Id := Left_Opnd (N);
12739 Right : constant Node_Id := Right_Opnd (N);
12740 LocR : constant Source_Ptr := Sloc (Right);
12743 Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
12744 Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
12745 -- If Left = Shortcut_Value then Right need not be evaluated
12747 function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
12748 -- For Opnd a boolean expression, return a Boolean expression equivalent
12749 -- to Opnd /= Shortcut_Value.
12751 function Useful (Actions : List_Id) return Boolean;
12752 -- Return True if Actions is not empty and contains useful nodes to
12755 --------------------
12756 -- Make_Test_Expr --
12757 --------------------
12759 function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
12761 if Shortcut_Value then
12762 return Make_Op_Not (Sloc (Opnd), Opnd);
12766 end Make_Test_Expr;
12772 function Useful (Actions : List_Id) return Boolean is
12775 if Present (Actions) then
12776 L := First (Actions);
12778 -- For now "useful" means not N_Variable_Reference_Marker.
12779 -- Consider stripping other nodes in the future.
12781 while Present (L) loop
12782 if Nkind (L) /= N_Variable_Reference_Marker then
12795 Op_Var : Entity_Id;
12796 -- Entity for a temporary variable holding the value of the operator,
12797 -- used for expansion in the case where actions are present.
12799 -- Start of processing for Expand_Short_Circuit_Operator
12802 -- Deal with non-standard booleans
12804 if Is_Boolean_Type (Typ) then
12805 Adjust_Condition (Left);
12806 Adjust_Condition (Right);
12807 Set_Etype (N, Standard_Boolean);
12810 -- Check for cases where left argument is known to be True or False
12812 if Compile_Time_Known_Value (Left) then
12814 -- Mark SCO for left condition as compile time known
12816 if Generate_SCO and then Comes_From_Source (Left) then
12817 Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
12820 -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
12821 -- Any actions associated with Right will be executed unconditionally
12822 -- and can thus be inserted into the tree unconditionally.
12824 if Expr_Value_E (Left) /= Shortcut_Ent then
12825 if Present (Actions (N)) then
12826 Insert_Actions (N, Actions (N));
12829 Rewrite (N, Right);
12831 -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
12832 -- In this case we can forget the actions associated with Right,
12833 -- since they will never be executed.
12836 Kill_Dead_Code (Right);
12837 Kill_Dead_Code (Actions (N));
12838 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
12841 Adjust_Result_Type (N, Typ);
12845 -- If Actions are present for the right operand, we have to do some
12846 -- special processing. We can't just let these actions filter back into
12847 -- code preceding the short circuit (which is what would have happened
12848 -- if we had not trapped them in the short-circuit form), since they
12849 -- must only be executed if the right operand of the short circuit is
12850 -- executed and not otherwise.
12852 if Useful (Actions (N)) then
12853 Actlist := Actions (N);
12855 -- The old approach is to expand:
12857 -- left AND THEN right
12861 -- C : Boolean := False;
12869 -- and finally rewrite the operator into a reference to C. Similarly
12870 -- for left OR ELSE right, with negated values. Note that this
12871 -- rewrite causes some difficulties for coverage analysis because
12872 -- of the introduction of the new variable C, which obscures the
12873 -- structure of the test.
12875 -- We use this "old approach" if Minimize_Expression_With_Actions
12878 if Minimize_Expression_With_Actions then
12879 Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
12882 Make_Object_Declaration (Loc,
12883 Defining_Identifier => Op_Var,
12884 Object_Definition =>
12885 New_Occurrence_Of (Standard_Boolean, Loc),
12887 New_Occurrence_Of (Shortcut_Ent, Loc)));
12889 Append_To (Actlist,
12890 Make_Implicit_If_Statement (Right,
12891 Condition => Make_Test_Expr (Right),
12892 Then_Statements => New_List (
12893 Make_Assignment_Statement (LocR,
12894 Name => New_Occurrence_Of (Op_Var, LocR),
12897 (Boolean_Literals (not Shortcut_Value), LocR)))));
12900 Make_Implicit_If_Statement (Left,
12901 Condition => Make_Test_Expr (Left),
12902 Then_Statements => Actlist));
12904 Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
12905 Analyze_And_Resolve (N, Standard_Boolean);
12907 -- The new approach (the default) is to use an
12908 -- Expression_With_Actions node for the right operand of the
12909 -- short-circuit form. Note that this solves the traceability
12910 -- problems for coverage analysis.
12914 Make_Expression_With_Actions (LocR,
12915 Expression => Relocate_Node (Right),
12916 Actions => Actlist));
12918 Set_Actions (N, No_List);
12919 Analyze_And_Resolve (Right, Standard_Boolean);
12922 Adjust_Result_Type (N, Typ);
12926 -- No actions present, check for cases of right argument True/False
12928 if Compile_Time_Known_Value (Right) then
12930 -- Mark SCO for left condition as compile time known
12932 if Generate_SCO and then Comes_From_Source (Right) then
12933 Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
12936 -- Change (Left and then True), (Left or else False) to Left. Note
12937 -- that we know there are no actions associated with the right
12938 -- operand, since we just checked for this case above.
12940 if Expr_Value_E (Right) /= Shortcut_Ent then
12943 -- Change (Left and then False), (Left or else True) to Right,
12944 -- making sure to preserve any side effects associated with the Left
12948 Remove_Side_Effects (Left);
12949 Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
12953 Adjust_Result_Type (N, Typ);
12954 end Expand_Short_Circuit_Operator;
12956 ------------------------------------
12957 -- Fixup_Universal_Fixed_Operation --
12958 -------------------------------------
12960 procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
12961 Conv : constant Node_Id := Parent (N);
12964 -- We must have a type conversion immediately above us
12966 pragma Assert (Nkind (Conv) = N_Type_Conversion);
12968 -- Normally the type conversion gives our target type. The exception
12969 -- occurs in the case of the Round attribute, where the conversion
12970 -- will be to universal real, and our real type comes from the Round
12971 -- attribute (as well as an indication that we must round the result)
12973 if Nkind (Parent (Conv)) = N_Attribute_Reference
12974 and then Attribute_Name (Parent (Conv)) = Name_Round
12976 Set_Etype (N, Base_Type (Etype (Parent (Conv))));
12977 Set_Rounded_Result (N);
12979 -- Normal case where type comes from conversion above us
12982 Set_Etype (N, Base_Type (Etype (Conv)));
12984 end Fixup_Universal_Fixed_Operation;
12986 ---------------------------------
12987 -- Has_Inferable_Discriminants --
12988 ---------------------------------
12990 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
12992 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
12993 -- Determines whether the left-most prefix of a selected component is a
12994 -- formal parameter in a subprogram. Assumes N is a selected component.
12996 --------------------------------
12997 -- Prefix_Is_Formal_Parameter --
12998 --------------------------------
13000 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
13001 Sel_Comp : Node_Id;
13004 -- Move to the left-most prefix by climbing up the tree
13007 while Present (Parent (Sel_Comp))
13008 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
13010 Sel_Comp := Parent (Sel_Comp);
13013 return Is_Formal (Entity (Prefix (Sel_Comp)));
13014 end Prefix_Is_Formal_Parameter;
13016 -- Start of processing for Has_Inferable_Discriminants
13019 -- For selected components, the subtype of the selector must be a
13020 -- constrained Unchecked_Union. If the component is subject to a
13021 -- per-object constraint, then the enclosing object must have inferable
13024 if Nkind (N) = N_Selected_Component then
13025 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
13027 -- A small hack. If we have a per-object constrained selected
13028 -- component of a formal parameter, return True since we do not
13029 -- know the actual parameter association yet.
13031 if Prefix_Is_Formal_Parameter (N) then
13034 -- Otherwise, check the enclosing object and the selector
13037 return Has_Inferable_Discriminants (Prefix (N))
13038 and then Has_Inferable_Discriminants (Selector_Name (N));
13041 -- The call to Has_Inferable_Discriminants will determine whether
13042 -- the selector has a constrained Unchecked_Union nominal type.
13045 return Has_Inferable_Discriminants (Selector_Name (N));
13048 -- A qualified expression has inferable discriminants if its subtype
13049 -- mark is a constrained Unchecked_Union subtype.
13051 elsif Nkind (N) = N_Qualified_Expression then
13052 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
13053 and then Is_Constrained (Etype (Subtype_Mark (N)));
13055 -- For all other names, it is sufficient to have a constrained
13056 -- Unchecked_Union nominal subtype.
13059 return Is_Unchecked_Union (Base_Type (Etype (N)))
13060 and then Is_Constrained (Etype (N));
13062 end Has_Inferable_Discriminants;
13064 -------------------------------
13065 -- Insert_Dereference_Action --
13066 -------------------------------
13068 procedure Insert_Dereference_Action (N : Node_Id) is
13069 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
13070 -- Return true if type of P is derived from Checked_Pool;
13072 -----------------------------
13073 -- Is_Checked_Storage_Pool --
13074 -----------------------------
13076 function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
13085 while T /= Etype (T) loop
13086 if Is_RTE (T, RE_Checked_Pool) then
13094 end Is_Checked_Storage_Pool;
13098 Context : constant Node_Id := Parent (N);
13099 Ptr_Typ : constant Entity_Id := Etype (N);
13100 Desig_Typ : constant Entity_Id :=
13101 Available_View (Designated_Type (Ptr_Typ));
13102 Loc : constant Source_Ptr := Sloc (N);
13103 Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ);
13109 Size_Bits : Node_Id;
13112 -- Start of processing for Insert_Dereference_Action
13115 pragma Assert (Nkind (Context) = N_Explicit_Dereference);
13117 -- Do not re-expand a dereference which has already been processed by
13120 if Has_Dereference_Action (Context) then
13123 -- Do not perform this type of expansion for internally-generated
13126 elsif not Comes_From_Source (Original_Node (Context)) then
13129 -- A dereference action is only applicable to objects which have been
13130 -- allocated on a checked pool.
13132 elsif not Is_Checked_Storage_Pool (Pool) then
13136 -- Extract the address of the dereferenced object. Generate:
13138 -- Addr : System.Address := <N>'Pool_Address;
13140 Addr := Make_Temporary (Loc, 'P');
13143 Make_Object_Declaration (Loc,
13144 Defining_Identifier => Addr,
13145 Object_Definition =>
13146 New_Occurrence_Of (RTE (RE_Address), Loc),
13148 Make_Attribute_Reference (Loc,
13149 Prefix => Duplicate_Subexpr_Move_Checks (N),
13150 Attribute_Name => Name_Pool_Address)));
13152 -- Calculate the size of the dereferenced object. Generate:
13154 -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
13157 Make_Explicit_Dereference (Loc,
13158 Prefix => Duplicate_Subexpr_Move_Checks (N));
13159 Set_Has_Dereference_Action (Deref);
13162 Make_Attribute_Reference (Loc,
13164 Attribute_Name => Name_Size);
13166 -- Special case of an unconstrained array: need to add descriptor size
13168 if Is_Array_Type (Desig_Typ)
13169 and then not Is_Constrained (First_Subtype (Desig_Typ))
13174 Make_Attribute_Reference (Loc,
13176 New_Occurrence_Of (First_Subtype (Desig_Typ), Loc),
13177 Attribute_Name => Name_Descriptor_Size),
13178 Right_Opnd => Size_Bits);
13181 Size := Make_Temporary (Loc, 'S');
13183 Make_Object_Declaration (Loc,
13184 Defining_Identifier => Size,
13185 Object_Definition =>
13186 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13188 Make_Op_Divide (Loc,
13189 Left_Opnd => Size_Bits,
13190 Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
13192 -- Calculate the alignment of the dereferenced object. Generate:
13193 -- Alig : constant Storage_Count := <N>.all'Alignment;
13196 Make_Explicit_Dereference (Loc,
13197 Prefix => Duplicate_Subexpr_Move_Checks (N));
13198 Set_Has_Dereference_Action (Deref);
13200 Alig := Make_Temporary (Loc, 'A');
13202 Make_Object_Declaration (Loc,
13203 Defining_Identifier => Alig,
13204 Object_Definition =>
13205 New_Occurrence_Of (RTE (RE_Storage_Count), Loc),
13207 Make_Attribute_Reference (Loc,
13209 Attribute_Name => Name_Alignment)));
13211 -- A dereference of a controlled object requires special processing. The
13212 -- finalization machinery requests additional space from the underlying
13213 -- pool to allocate and hide two pointers. As a result, a checked pool
13214 -- may mark the wrong memory as valid. Since checked pools do not have
13215 -- knowledge of hidden pointers, we have to bring the two pointers back
13216 -- in view in order to restore the original state of the object.
13218 -- The address manipulation is not performed for access types that are
13219 -- subject to pragma No_Heap_Finalization because the two pointers do
13220 -- not exist in the first place.
13222 if No_Heap_Finalization (Ptr_Typ) then
13225 elsif Needs_Finalization (Desig_Typ) then
13227 -- Adjust the address and size of the dereferenced object. Generate:
13228 -- Adjust_Controlled_Dereference (Addr, Size, Alig);
13231 Make_Procedure_Call_Statement (Loc,
13233 New_Occurrence_Of (RTE (RE_Adjust_Controlled_Dereference), Loc),
13234 Parameter_Associations => New_List (
13235 New_Occurrence_Of (Addr, Loc),
13236 New_Occurrence_Of (Size, Loc),
13237 New_Occurrence_Of (Alig, Loc)));
13239 -- Class-wide types complicate things because we cannot determine
13240 -- statically whether the actual object is truly controlled. We must
13241 -- generate a runtime check to detect this property. Generate:
13243 -- if Needs_Finalization (<N>.all'Tag) then
13247 if Is_Class_Wide_Type (Desig_Typ) then
13249 Make_Explicit_Dereference (Loc,
13250 Prefix => Duplicate_Subexpr_Move_Checks (N));
13251 Set_Has_Dereference_Action (Deref);
13254 Make_Implicit_If_Statement (N,
13256 Make_Function_Call (Loc,
13258 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
13259 Parameter_Associations => New_List (
13260 Make_Attribute_Reference (Loc,
13262 Attribute_Name => Name_Tag))),
13263 Then_Statements => New_List (Stmt));
13266 Insert_Action (N, Stmt);
13270 -- Dereference (Pool, Addr, Size, Alig);
13273 Make_Procedure_Call_Statement (Loc,
13276 (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
13277 Parameter_Associations => New_List (
13278 New_Occurrence_Of (Pool, Loc),
13279 New_Occurrence_Of (Addr, Loc),
13280 New_Occurrence_Of (Size, Loc),
13281 New_Occurrence_Of (Alig, Loc))));
13283 -- Mark the explicit dereference as processed to avoid potential
13284 -- infinite expansion.
13286 Set_Has_Dereference_Action (Context);
13289 when RE_Not_Available =>
13291 end Insert_Dereference_Action;
13293 --------------------------------
13294 -- Integer_Promotion_Possible --
13295 --------------------------------
13297 function Integer_Promotion_Possible (N : Node_Id) return Boolean is
13298 Operand : constant Node_Id := Expression (N);
13299 Operand_Type : constant Entity_Id := Etype (Operand);
13300 Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
13303 pragma Assert (Nkind (N) = N_Type_Conversion);
13307 -- We only do the transformation for source constructs. We assume
13308 -- that the expander knows what it is doing when it generates code.
13310 Comes_From_Source (N)
13312 -- If the operand type is Short_Integer or Short_Short_Integer,
13313 -- then we will promote to Integer, which is available on all
13314 -- targets, and is sufficient to ensure no intermediate overflow.
13315 -- Furthermore it is likely to be as efficient or more efficient
13316 -- than using the smaller type for the computation so we do this
13317 -- unconditionally.
13320 (Root_Operand_Type = Base_Type (Standard_Short_Integer)
13322 Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
13324 -- Test for interesting operation, which includes addition,
13325 -- division, exponentiation, multiplication, subtraction, absolute
13326 -- value and unary negation. Unary "+" is omitted since it is a
13327 -- no-op and thus can't overflow.
13329 and then Nkind_In (Operand, N_Op_Abs,
13336 end Integer_Promotion_Possible;
13338 ------------------------------
13339 -- Make_Array_Comparison_Op --
13340 ------------------------------
13342 -- This is a hand-coded expansion of the following generic function:
13345 -- type elem is (<>);
13346 -- type index is (<>);
13347 -- type a is array (index range <>) of elem;
13349 -- function Gnnn (X : a; Y: a) return boolean is
13350 -- J : index := Y'first;
13353 -- if X'length = 0 then
13356 -- elsif Y'length = 0 then
13360 -- for I in X'range loop
13361 -- if X (I) = Y (J) then
13362 -- if J = Y'last then
13365 -- J := index'succ (J);
13369 -- return X (I) > Y (J);
13373 -- return X'length > Y'length;
13377 -- Note that since we are essentially doing this expansion by hand, we
13378 -- do not need to generate an actual or formal generic part, just the
13379 -- instantiated function itself.
13381 -- Perhaps we could have the actual generic available in the run-time,
13382 -- obtained by rtsfind, and actually expand a real instantiation ???
13384 function Make_Array_Comparison_Op
13386 Nod : Node_Id) return Node_Id
13388 Loc : constant Source_Ptr := Sloc (Nod);
13390 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
13391 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
13392 I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
13393 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
13395 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
13397 Loop_Statement : Node_Id;
13398 Loop_Body : Node_Id;
13400 Inner_If : Node_Id;
13401 Final_Expr : Node_Id;
13402 Func_Body : Node_Id;
13403 Func_Name : Entity_Id;
13409 -- if J = Y'last then
13412 -- J := index'succ (J);
13416 Make_Implicit_If_Statement (Nod,
13419 Left_Opnd => New_Occurrence_Of (J, Loc),
13421 Make_Attribute_Reference (Loc,
13422 Prefix => New_Occurrence_Of (Y, Loc),
13423 Attribute_Name => Name_Last)),
13425 Then_Statements => New_List (
13426 Make_Exit_Statement (Loc)),
13430 Make_Assignment_Statement (Loc,
13431 Name => New_Occurrence_Of (J, Loc),
13433 Make_Attribute_Reference (Loc,
13434 Prefix => New_Occurrence_Of (Index, Loc),
13435 Attribute_Name => Name_Succ,
13436 Expressions => New_List (New_Occurrence_Of (J, Loc))))));
13438 -- if X (I) = Y (J) then
13441 -- return X (I) > Y (J);
13445 Make_Implicit_If_Statement (Nod,
13449 Make_Indexed_Component (Loc,
13450 Prefix => New_Occurrence_Of (X, Loc),
13451 Expressions => New_List (New_Occurrence_Of (I, Loc))),
13454 Make_Indexed_Component (Loc,
13455 Prefix => New_Occurrence_Of (Y, Loc),
13456 Expressions => New_List (New_Occurrence_Of (J, Loc)))),
13458 Then_Statements => New_List (Inner_If),
13460 Else_Statements => New_List (
13461 Make_Simple_Return_Statement (Loc,
13465 Make_Indexed_Component (Loc,
13466 Prefix => New_Occurrence_Of (X, Loc),
13467 Expressions => New_List (New_Occurrence_Of (I, Loc))),
13470 Make_Indexed_Component (Loc,
13471 Prefix => New_Occurrence_Of (Y, Loc),
13472 Expressions => New_List (
13473 New_Occurrence_Of (J, Loc)))))));
13475 -- for I in X'range loop
13480 Make_Implicit_Loop_Statement (Nod,
13481 Identifier => Empty,
13483 Iteration_Scheme =>
13484 Make_Iteration_Scheme (Loc,
13485 Loop_Parameter_Specification =>
13486 Make_Loop_Parameter_Specification (Loc,
13487 Defining_Identifier => I,
13488 Discrete_Subtype_Definition =>
13489 Make_Attribute_Reference (Loc,
13490 Prefix => New_Occurrence_Of (X, Loc),
13491 Attribute_Name => Name_Range))),
13493 Statements => New_List (Loop_Body));
13495 -- if X'length = 0 then
13497 -- elsif Y'length = 0 then
13500 -- for ... loop ... end loop;
13501 -- return X'length > Y'length;
13505 Make_Attribute_Reference (Loc,
13506 Prefix => New_Occurrence_Of (X, Loc),
13507 Attribute_Name => Name_Length);
13510 Make_Attribute_Reference (Loc,
13511 Prefix => New_Occurrence_Of (Y, Loc),
13512 Attribute_Name => Name_Length);
13516 Left_Opnd => Length1,
13517 Right_Opnd => Length2);
13520 Make_Implicit_If_Statement (Nod,
13524 Make_Attribute_Reference (Loc,
13525 Prefix => New_Occurrence_Of (X, Loc),
13526 Attribute_Name => Name_Length),
13528 Make_Integer_Literal (Loc, 0)),
13532 Make_Simple_Return_Statement (Loc,
13533 Expression => New_Occurrence_Of (Standard_False, Loc))),
13535 Elsif_Parts => New_List (
13536 Make_Elsif_Part (Loc,
13540 Make_Attribute_Reference (Loc,
13541 Prefix => New_Occurrence_Of (Y, Loc),
13542 Attribute_Name => Name_Length),
13544 Make_Integer_Literal (Loc, 0)),
13548 Make_Simple_Return_Statement (Loc,
13549 Expression => New_Occurrence_Of (Standard_True, Loc))))),
13551 Else_Statements => New_List (
13553 Make_Simple_Return_Statement (Loc,
13554 Expression => Final_Expr)));
13558 Formals := New_List (
13559 Make_Parameter_Specification (Loc,
13560 Defining_Identifier => X,
13561 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
13563 Make_Parameter_Specification (Loc,
13564 Defining_Identifier => Y,
13565 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
13567 -- function Gnnn (...) return boolean is
13568 -- J : index := Y'first;
13573 Func_Name := Make_Temporary (Loc, 'G');
13576 Make_Subprogram_Body (Loc,
13578 Make_Function_Specification (Loc,
13579 Defining_Unit_Name => Func_Name,
13580 Parameter_Specifications => Formals,
13581 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
13583 Declarations => New_List (
13584 Make_Object_Declaration (Loc,
13585 Defining_Identifier => J,
13586 Object_Definition => New_Occurrence_Of (Index, Loc),
13588 Make_Attribute_Reference (Loc,
13589 Prefix => New_Occurrence_Of (Y, Loc),
13590 Attribute_Name => Name_First))),
13592 Handled_Statement_Sequence =>
13593 Make_Handled_Sequence_Of_Statements (Loc,
13594 Statements => New_List (If_Stat)));
13597 end Make_Array_Comparison_Op;
13599 ---------------------------
13600 -- Make_Boolean_Array_Op --
13601 ---------------------------
13603 -- For logical operations on boolean arrays, expand in line the following,
13604 -- replacing 'and' with 'or' or 'xor' where needed:
13606 -- function Annn (A : typ; B: typ) return typ is
13609 -- for J in A'range loop
13610 -- C (J) := A (J) op B (J);
13615 -- Here typ is the boolean array type
13617 function Make_Boolean_Array_Op
13619 N : Node_Id) return Node_Id
13621 Loc : constant Source_Ptr := Sloc (N);
13623 A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
13624 B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
13625 C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
13626 J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
13634 Func_Name : Entity_Id;
13635 Func_Body : Node_Id;
13636 Loop_Statement : Node_Id;
13640 Make_Indexed_Component (Loc,
13641 Prefix => New_Occurrence_Of (A, Loc),
13642 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13645 Make_Indexed_Component (Loc,
13646 Prefix => New_Occurrence_Of (B, Loc),
13647 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13650 Make_Indexed_Component (Loc,
13651 Prefix => New_Occurrence_Of (C, Loc),
13652 Expressions => New_List (New_Occurrence_Of (J, Loc)));
13654 if Nkind (N) = N_Op_And then
13658 Right_Opnd => B_J);
13660 elsif Nkind (N) = N_Op_Or then
13664 Right_Opnd => B_J);
13670 Right_Opnd => B_J);
13674 Make_Implicit_Loop_Statement (N,
13675 Identifier => Empty,
13677 Iteration_Scheme =>
13678 Make_Iteration_Scheme (Loc,
13679 Loop_Parameter_Specification =>
13680 Make_Loop_Parameter_Specification (Loc,
13681 Defining_Identifier => J,
13682 Discrete_Subtype_Definition =>
13683 Make_Attribute_Reference (Loc,
13684 Prefix => New_Occurrence_Of (A, Loc),
13685 Attribute_Name => Name_Range))),
13687 Statements => New_List (
13688 Make_Assignment_Statement (Loc,
13690 Expression => Op)));
13692 Formals := New_List (
13693 Make_Parameter_Specification (Loc,
13694 Defining_Identifier => A,
13695 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
13697 Make_Parameter_Specification (Loc,
13698 Defining_Identifier => B,
13699 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
13701 Func_Name := Make_Temporary (Loc, 'A');
13702 Set_Is_Inlined (Func_Name);
13705 Make_Subprogram_Body (Loc,
13707 Make_Function_Specification (Loc,
13708 Defining_Unit_Name => Func_Name,
13709 Parameter_Specifications => Formals,
13710 Result_Definition => New_Occurrence_Of (Typ, Loc)),
13712 Declarations => New_List (
13713 Make_Object_Declaration (Loc,
13714 Defining_Identifier => C,
13715 Object_Definition => New_Occurrence_Of (Typ, Loc))),
13717 Handled_Statement_Sequence =>
13718 Make_Handled_Sequence_Of_Statements (Loc,
13719 Statements => New_List (
13721 Make_Simple_Return_Statement (Loc,
13722 Expression => New_Occurrence_Of (C, Loc)))));
13725 end Make_Boolean_Array_Op;
13727 -----------------------------------------
13728 -- Minimized_Eliminated_Overflow_Check --
13729 -----------------------------------------
13731 function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
13734 Is_Signed_Integer_Type (Etype (N))
13735 and then Overflow_Check_Mode in Minimized_Or_Eliminated;
13736 end Minimized_Eliminated_Overflow_Check;
13738 --------------------------------
13739 -- Optimize_Length_Comparison --
13740 --------------------------------
13742 procedure Optimize_Length_Comparison (N : Node_Id) is
13743 Loc : constant Source_Ptr := Sloc (N);
13744 Typ : constant Entity_Id := Etype (N);
13749 -- First and Last attribute reference nodes, which end up as left and
13750 -- right operands of the optimized result.
13753 -- True for comparison operand of zero
13756 -- Comparison operand, set only if Is_Zero is false
13758 Ent : Entity_Id := Empty;
13759 -- Entity whose length is being compared
13761 Index : Node_Id := Empty;
13762 -- Integer_Literal node for length attribute expression, or Empty
13763 -- if there is no such expression present.
13766 -- Type of array index to which 'Length is applied
13768 Op : Node_Kind := Nkind (N);
13769 -- Kind of comparison operator, gets flipped if operands backwards
13771 function Is_Optimizable (N : Node_Id) return Boolean;
13772 -- Tests N to see if it is an optimizable comparison value (defined as
13773 -- constant zero or one, or something else where the value is known to
13774 -- be positive and in the range of 32-bits, and where the corresponding
13775 -- Length value is also known to be 32-bits. If result is true, sets
13776 -- Is_Zero, Ityp, and Comp accordingly.
13778 function Is_Entity_Length (N : Node_Id) return Boolean;
13779 -- Tests if N is a length attribute applied to a simple entity. If so,
13780 -- returns True, and sets Ent to the entity, and Index to the integer
13781 -- literal provided as an attribute expression, or to Empty if none.
13782 -- Also returns True if the expression is a generated type conversion
13783 -- whose expression is of the desired form. This latter case arises
13784 -- when Apply_Universal_Integer_Attribute_Check installs a conversion
13785 -- to check for being in range, which is not needed in this context.
13786 -- Returns False if neither condition holds.
13788 function Prepare_64 (N : Node_Id) return Node_Id;
13789 -- Given a discrete expression, returns a Long_Long_Integer typed
13790 -- expression representing the underlying value of the expression.
13791 -- This is done with an unchecked conversion to the result type. We
13792 -- use unchecked conversion to handle the enumeration type case.
13794 ----------------------
13795 -- Is_Entity_Length --
13796 ----------------------
13798 function Is_Entity_Length (N : Node_Id) return Boolean is
13800 if Nkind (N) = N_Attribute_Reference
13801 and then Attribute_Name (N) = Name_Length
13802 and then Is_Entity_Name (Prefix (N))
13804 Ent := Entity (Prefix (N));
13806 if Present (Expressions (N)) then
13807 Index := First (Expressions (N));
13814 elsif Nkind (N) = N_Type_Conversion
13815 and then not Comes_From_Source (N)
13817 return Is_Entity_Length (Expression (N));
13822 end Is_Entity_Length;
13824 --------------------
13825 -- Is_Optimizable --
13826 --------------------
13828 function Is_Optimizable (N : Node_Id) return Boolean is
13836 if Compile_Time_Known_Value (N) then
13837 Val := Expr_Value (N);
13839 if Val = Uint_0 then
13844 elsif Val = Uint_1 then
13851 -- Here we have to make sure of being within 32-bits
13853 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
13856 or else Lo < Uint_1
13857 or else Hi > UI_From_Int (Int'Last)
13862 -- Comparison value was within range, so now we must check the index
13863 -- value to make sure it is also within 32-bits.
13865 Indx := First_Index (Etype (Ent));
13867 if Present (Index) then
13868 for J in 2 .. UI_To_Int (Intval (Index)) loop
13873 Ityp := Etype (Indx);
13875 if Esize (Ityp) > 32 then
13882 end Is_Optimizable;
13888 function Prepare_64 (N : Node_Id) return Node_Id is
13890 return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
13893 -- Start of processing for Optimize_Length_Comparison
13896 -- Nothing to do if not a comparison
13898 if Op not in N_Op_Compare then
13902 -- Nothing to do if special -gnatd.P debug flag set.
13904 if Debug_Flag_Dot_PP then
13908 -- Ent'Length op 0/1
13910 if Is_Entity_Length (Left_Opnd (N))
13911 and then Is_Optimizable (Right_Opnd (N))
13915 -- 0/1 op Ent'Length
13917 elsif Is_Entity_Length (Right_Opnd (N))
13918 and then Is_Optimizable (Left_Opnd (N))
13920 -- Flip comparison to opposite sense
13923 when N_Op_Lt => Op := N_Op_Gt;
13924 when N_Op_Le => Op := N_Op_Ge;
13925 when N_Op_Gt => Op := N_Op_Lt;
13926 when N_Op_Ge => Op := N_Op_Le;
13927 when others => null;
13930 -- Else optimization not possible
13936 -- Fall through if we will do the optimization
13938 -- Cases to handle:
13940 -- X'Length = 0 => X'First > X'Last
13941 -- X'Length = 1 => X'First = X'Last
13942 -- X'Length = n => X'First + (n - 1) = X'Last
13944 -- X'Length /= 0 => X'First <= X'Last
13945 -- X'Length /= 1 => X'First /= X'Last
13946 -- X'Length /= n => X'First + (n - 1) /= X'Last
13948 -- X'Length >= 0 => always true, warn
13949 -- X'Length >= 1 => X'First <= X'Last
13950 -- X'Length >= n => X'First + (n - 1) <= X'Last
13952 -- X'Length > 0 => X'First <= X'Last
13953 -- X'Length > 1 => X'First < X'Last
13954 -- X'Length > n => X'First + (n - 1) < X'Last
13956 -- X'Length <= 0 => X'First > X'Last (warn, could be =)
13957 -- X'Length <= 1 => X'First >= X'Last
13958 -- X'Length <= n => X'First + (n - 1) >= X'Last
13960 -- X'Length < 0 => always false (warn)
13961 -- X'Length < 1 => X'First > X'Last
13962 -- X'Length < n => X'First + (n - 1) > X'Last
13964 -- Note: for the cases of n (not constant 0,1), we require that the
13965 -- corresponding index type be integer or shorter (i.e. not 64-bit),
13966 -- and the same for the comparison value. Then we do the comparison
13967 -- using 64-bit arithmetic (actually long long integer), so that we
13968 -- cannot have overflow intefering with the result.
13970 -- First deal with warning cases
13979 Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
13980 Analyze_And_Resolve (N, Typ);
13981 Warn_On_Known_Condition (N);
13988 Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
13989 Analyze_And_Resolve (N, Typ);
13990 Warn_On_Known_Condition (N);
13994 if Constant_Condition_Warnings
13995 and then Comes_From_Source (Original_Node (N))
13997 Error_Msg_N ("could replace by ""'=""?c?", N);
14007 -- Build the First reference we will use
14010 Make_Attribute_Reference (Loc,
14011 Prefix => New_Occurrence_Of (Ent, Loc),
14012 Attribute_Name => Name_First);
14014 if Present (Index) then
14015 Set_Expressions (Left, New_List (New_Copy (Index)));
14018 -- If general value case, then do the addition of (n - 1), and
14019 -- also add the needed conversions to type Long_Long_Integer.
14021 if Present (Comp) then
14024 Left_Opnd => Prepare_64 (Left),
14026 Make_Op_Subtract (Loc,
14027 Left_Opnd => Prepare_64 (Comp),
14028 Right_Opnd => Make_Integer_Literal (Loc, 1)));
14031 -- Build the Last reference we will use
14034 Make_Attribute_Reference (Loc,
14035 Prefix => New_Occurrence_Of (Ent, Loc),
14036 Attribute_Name => Name_Last);
14038 if Present (Index) then
14039 Set_Expressions (Right, New_List (New_Copy (Index)));
14042 -- If general operand, convert Last reference to Long_Long_Integer
14044 if Present (Comp) then
14045 Right := Prepare_64 (Right);
14048 -- Check for cases to optimize
14050 -- X'Length = 0 => X'First > X'Last
14051 -- X'Length < 1 => X'First > X'Last
14052 -- X'Length < n => X'First + (n - 1) > X'Last
14054 if (Is_Zero and then Op = N_Op_Eq)
14055 or else (not Is_Zero and then Op = N_Op_Lt)
14060 Right_Opnd => Right);
14062 -- X'Length = 1 => X'First = X'Last
14063 -- X'Length = n => X'First + (n - 1) = X'Last
14065 elsif not Is_Zero and then Op = N_Op_Eq then
14069 Right_Opnd => Right);
14071 -- X'Length /= 0 => X'First <= X'Last
14072 -- X'Length > 0 => X'First <= X'Last
14074 elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
14078 Right_Opnd => Right);
14080 -- X'Length /= 1 => X'First /= X'Last
14081 -- X'Length /= n => X'First + (n - 1) /= X'Last
14083 elsif not Is_Zero and then Op = N_Op_Ne then
14087 Right_Opnd => Right);
14089 -- X'Length >= 1 => X'First <= X'Last
14090 -- X'Length >= n => X'First + (n - 1) <= X'Last
14092 elsif not Is_Zero and then Op = N_Op_Ge then
14096 Right_Opnd => Right);
14098 -- X'Length > 1 => X'First < X'Last
14099 -- X'Length > n => X'First + (n = 1) < X'Last
14101 elsif not Is_Zero and then Op = N_Op_Gt then
14105 Right_Opnd => Right);
14107 -- X'Length <= 1 => X'First >= X'Last
14108 -- X'Length <= n => X'First + (n - 1) >= X'Last
14110 elsif not Is_Zero and then Op = N_Op_Le then
14114 Right_Opnd => Right);
14116 -- Should not happen at this stage
14119 raise Program_Error;
14122 -- Rewrite and finish up
14124 Rewrite (N, Result);
14125 Analyze_And_Resolve (N, Typ);
14127 end Optimize_Length_Comparison;
14129 --------------------------------
14130 -- Process_If_Case_Statements --
14131 --------------------------------
14133 procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is
14137 Decl := First (Stmts);
14138 while Present (Decl) loop
14139 if Nkind (Decl) = N_Object_Declaration
14140 and then Is_Finalizable_Transient (Decl, N)
14142 Process_Transient_In_Expression (Decl, N, Stmts);
14147 end Process_If_Case_Statements;
14149 -------------------------------------
14150 -- Process_Transient_In_Expression --
14151 -------------------------------------
14153 procedure Process_Transient_In_Expression
14154 (Obj_Decl : Node_Id;
14158 Loc : constant Source_Ptr := Sloc (Obj_Decl);
14159 Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
14161 Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
14162 -- The node on which to insert the hook as an action. This is usually
14163 -- the innermost enclosing non-transient construct.
14165 Fin_Call : Node_Id;
14166 Hook_Assign : Node_Id;
14167 Hook_Clear : Node_Id;
14168 Hook_Decl : Node_Id;
14169 Hook_Insert : Node_Id;
14170 Ptr_Decl : Node_Id;
14172 Fin_Context : Node_Id;
14173 -- The node after which to insert the finalization actions of the
14174 -- transient object.
14177 pragma Assert (Nkind_In (Expr, N_Case_Expression,
14178 N_Expression_With_Actions,
14181 -- When the context is a Boolean evaluation, all three nodes capture the
14182 -- result of their computation in a local temporary:
14185 -- Trans_Id : Ctrl_Typ := ...;
14186 -- Result : constant Boolean := ... Trans_Id ...;
14187 -- <finalize Trans_Id>
14190 -- As a result, the finalization of any transient objects can safely
14191 -- take place after the result capture.
14193 -- ??? could this be extended to elementary types?
14195 if Is_Boolean_Type (Etype (Expr)) then
14196 Fin_Context := Last (Stmts);
14198 -- Otherwise the immediate context may not be safe enough to carry
14199 -- out transient object finalization due to aliasing and nesting of
14200 -- constructs. Insert calls to [Deep_]Finalize after the innermost
14201 -- enclosing non-transient construct.
14204 Fin_Context := Hook_Context;
14207 -- Mark the transient object as successfully processed to avoid double
14210 Set_Is_Finalized_Transient (Obj_Id);
14212 -- Construct all the pieces necessary to hook and finalize a transient
14215 Build_Transient_Object_Statements
14216 (Obj_Decl => Obj_Decl,
14217 Fin_Call => Fin_Call,
14218 Hook_Assign => Hook_Assign,
14219 Hook_Clear => Hook_Clear,
14220 Hook_Decl => Hook_Decl,
14221 Ptr_Decl => Ptr_Decl,
14222 Finalize_Obj => False);
14224 -- Add the access type which provides a reference to the transient
14225 -- object. Generate:
14227 -- type Ptr_Typ is access all Desig_Typ;
14229 Insert_Action (Hook_Context, Ptr_Decl);
14231 -- Add the temporary which acts as a hook to the transient object.
14234 -- Hook : Ptr_Id := null;
14236 Insert_Action (Hook_Context, Hook_Decl);
14238 -- When the transient object is initialized by an aggregate, the hook
14239 -- must capture the object after the last aggregate assignment takes
14240 -- place. Only then is the object considered initialized. Generate:
14242 -- Hook := Ptr_Typ (Obj_Id);
14244 -- Hook := Obj_Id'Unrestricted_Access;
14246 if Ekind_In (Obj_Id, E_Constant, E_Variable)
14247 and then Present (Last_Aggregate_Assignment (Obj_Id))
14249 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
14251 -- Otherwise the hook seizes the related object immediately
14254 Hook_Insert := Obj_Decl;
14257 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
14259 -- When the node is part of a return statement, there is no need to
14260 -- insert a finalization call, as the general finalization mechanism
14261 -- (see Build_Finalizer) would take care of the transient object on
14262 -- subprogram exit. Note that it would also be impossible to insert the
14263 -- finalization code after the return statement as this will render it
14266 if Nkind (Fin_Context) = N_Simple_Return_Statement then
14269 -- Finalize the hook after the context has been evaluated. Generate:
14271 -- if Hook /= null then
14272 -- [Deep_]Finalize (Hook.all);
14277 Insert_Action_After (Fin_Context,
14278 Make_Implicit_If_Statement (Obj_Decl,
14282 New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
14283 Right_Opnd => Make_Null (Loc)),
14285 Then_Statements => New_List (
14289 end Process_Transient_In_Expression;
14291 ------------------------
14292 -- Rewrite_Comparison --
14293 ------------------------
14295 procedure Rewrite_Comparison (N : Node_Id) is
14296 Typ : constant Entity_Id := Etype (N);
14298 False_Result : Boolean;
14299 True_Result : Boolean;
14302 if Nkind (N) = N_Type_Conversion then
14303 Rewrite_Comparison (Expression (N));
14306 elsif Nkind (N) not in N_Op_Compare then
14310 -- Determine the potential outcome of the comparison assuming that the
14311 -- operands are valid and emit a warning when the comparison evaluates
14312 -- to True or False only in the presence of invalid values.
14314 Warn_On_Constant_Valid_Condition (N);
14316 -- Determine the potential outcome of the comparison assuming that the
14317 -- operands are not valid.
14321 Assume_Valid => False,
14322 True_Result => True_Result,
14323 False_Result => False_Result);
14325 -- The outcome is a decisive False or True, rewrite the operator
14327 if False_Result or True_Result then
14330 New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N))));
14332 Analyze_And_Resolve (N, Typ);
14333 Warn_On_Known_Condition (N);
14335 end Rewrite_Comparison;
14337 ----------------------------
14338 -- Safe_In_Place_Array_Op --
14339 ----------------------------
14341 function Safe_In_Place_Array_Op
14344 Op2 : Node_Id) return Boolean
14346 Target : Entity_Id;
14348 function Is_Safe_Operand (Op : Node_Id) return Boolean;
14349 -- Operand is safe if it cannot overlap part of the target of the
14350 -- operation. If the operand and the target are identical, the operand
14351 -- is safe. The operand can be empty in the case of negation.
14353 function Is_Unaliased (N : Node_Id) return Boolean;
14354 -- Check that N is a stand-alone entity
14360 function Is_Unaliased (N : Node_Id) return Boolean is
14364 and then No (Address_Clause (Entity (N)))
14365 and then No (Renamed_Object (Entity (N)));
14368 ---------------------
14369 -- Is_Safe_Operand --
14370 ---------------------
14372 function Is_Safe_Operand (Op : Node_Id) return Boolean is
14377 elsif Is_Entity_Name (Op) then
14378 return Is_Unaliased (Op);
14380 elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
14381 return Is_Unaliased (Prefix (Op));
14383 elsif Nkind (Op) = N_Slice then
14385 Is_Unaliased (Prefix (Op))
14386 and then Entity (Prefix (Op)) /= Target;
14388 elsif Nkind (Op) = N_Op_Not then
14389 return Is_Safe_Operand (Right_Opnd (Op));
14394 end Is_Safe_Operand;
14396 -- Start of processing for Safe_In_Place_Array_Op
14399 -- Skip this processing if the component size is different from system
14400 -- storage unit (since at least for NOT this would cause problems).
14402 if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
14405 -- Cannot do in place stuff if non-standard Boolean representation
14407 elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
14410 elsif not Is_Unaliased (Lhs) then
14414 Target := Entity (Lhs);
14415 return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
14417 end Safe_In_Place_Array_Op;
14419 -----------------------
14420 -- Tagged_Membership --
14421 -----------------------
14423 -- There are two different cases to consider depending on whether the right
14424 -- operand is a class-wide type or not. If not we just compare the actual
14425 -- tag of the left expr to the target type tag:
14427 -- Left_Expr.Tag = Right_Type'Tag;
14429 -- If it is a class-wide type we use the RT function CW_Membership which is
14430 -- usually implemented by looking in the ancestor tables contained in the
14431 -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
14433 -- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
14434 -- function IW_Membership which is usually implemented by looking in the
14435 -- table of abstract interface types plus the ancestor table contained in
14436 -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
14438 procedure Tagged_Membership
14440 SCIL_Node : out Node_Id;
14441 Result : out Node_Id)
14443 Left : constant Node_Id := Left_Opnd (N);
14444 Right : constant Node_Id := Right_Opnd (N);
14445 Loc : constant Source_Ptr := Sloc (N);
14447 Full_R_Typ : Entity_Id;
14448 Left_Type : Entity_Id;
14449 New_Node : Node_Id;
14450 Right_Type : Entity_Id;
14454 SCIL_Node := Empty;
14456 -- Handle entities from the limited view
14458 Left_Type := Available_View (Etype (Left));
14459 Right_Type := Available_View (Etype (Right));
14461 -- In the case where the type is an access type, the test is applied
14462 -- using the designated types (needed in Ada 2012 for implicit anonymous
14463 -- access conversions, for AI05-0149).
14465 if Is_Access_Type (Right_Type) then
14466 Left_Type := Designated_Type (Left_Type);
14467 Right_Type := Designated_Type (Right_Type);
14470 if Is_Class_Wide_Type (Left_Type) then
14471 Left_Type := Root_Type (Left_Type);
14474 if Is_Class_Wide_Type (Right_Type) then
14475 Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
14477 Full_R_Typ := Underlying_Type (Right_Type);
14481 Make_Selected_Component (Loc,
14482 Prefix => Relocate_Node (Left),
14484 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
14486 if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then
14488 -- No need to issue a run-time check if we statically know that the
14489 -- result of this membership test is always true. For example,
14490 -- considering the following declarations:
14492 -- type Iface is interface;
14493 -- type T is tagged null record;
14494 -- type DT is new T and Iface with null record;
14499 -- These membership tests are always true:
14502 -- Obj2 in T'Class;
14503 -- Obj2 in Iface'Class;
14505 -- We do not need to handle cases where the membership is illegal.
14508 -- Obj1 in DT'Class; -- Compile time error
14509 -- Obj1 in Iface'Class; -- Compile time error
14511 if not Is_Interface (Left_Type)
14512 and then not Is_Class_Wide_Type (Left_Type)
14513 and then (Is_Ancestor (Etype (Right_Type), Left_Type,
14514 Use_Full_View => True)
14515 or else (Is_Interface (Etype (Right_Type))
14516 and then Interface_Present_In_Ancestor
14518 Iface => Etype (Right_Type))))
14520 Result := New_Occurrence_Of (Standard_True, Loc);
14524 -- Ada 2005 (AI-251): Class-wide applied to interfaces
14526 if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
14528 -- Support to: "Iface_CW_Typ in Typ'Class"
14530 or else Is_Interface (Left_Type)
14532 -- Issue error if IW_Membership operation not available in a
14533 -- configurable run time setting.
14535 if not RTE_Available (RE_IW_Membership) then
14537 ("dynamic membership test on interface types", N);
14543 Make_Function_Call (Loc,
14544 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
14545 Parameter_Associations => New_List (
14546 Make_Attribute_Reference (Loc,
14548 Attribute_Name => Name_Address),
14549 New_Occurrence_Of (
14550 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
14553 -- Ada 95: Normal case
14556 Build_CW_Membership (Loc,
14557 Obj_Tag_Node => Obj_Tag,
14559 New_Occurrence_Of (
14560 Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc),
14562 New_Node => New_Node);
14564 -- Generate the SCIL node for this class-wide membership test.
14565 -- Done here because the previous call to Build_CW_Membership
14566 -- relocates Obj_Tag.
14568 if Generate_SCIL then
14569 SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
14570 Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
14571 Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
14574 Result := New_Node;
14577 -- Right_Type is not a class-wide type
14580 -- No need to check the tag of the object if Right_Typ is abstract
14582 if Is_Abstract_Type (Right_Type) then
14583 Result := New_Occurrence_Of (Standard_False, Loc);
14588 Left_Opnd => Obj_Tag,
14591 (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
14594 end Tagged_Membership;
14596 ------------------------------
14597 -- Unary_Op_Validity_Checks --
14598 ------------------------------
14600 procedure Unary_Op_Validity_Checks (N : Node_Id) is
14602 if Validity_Checks_On and Validity_Check_Operands then
14603 Ensure_Valid (Right_Opnd (N));
14605 end Unary_Op_Validity_Checks;